Mercurial > urweb

annotate src/mono_print.sml @ 793:3e5d1c6ae30c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Stop potential buffer overrun of path_copy
author Adam Chlipala <adamc@hcoop.net>
date Tue, 12 May 2009 20:15:11 -0400
parents fa2019a63ea4
children d8f58d488cfb
rev   line source
adamc@25 1 (* Copyright (c) 2008, Adam Chlipala
adamc@25 2 * All rights reserved.
adamc@25 3 *
adamc@25 4 * Redistribution and use in source and binary forms, with or without
adamc@25 5 * modification, are permitted provided that the following conditions are met:
adamc@25 6 *
adamc@25 7 * - Redistributions of source code must retain the above copyright notice,
adamc@25 8 * this list of conditions and the following disclaimer.
adamc@25 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@25 10 * this list of conditions and the following disclaimer in the documentation
adamc@25 11 * and/or other materials provided with the distribution.
adamc@25 12 * - The names of contributors may not be used to endorse or promote products
adamc@25 13 * derived from this software without specific prior written permission.
adamc@25 14 *
adamc@25 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@25 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@25 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@25 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@25 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@25 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@25 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@25 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@25 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@25 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@25 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@25 26 *)
adamc@25 27
adamc@244 28 (* Pretty-printing monomorphic Ur/Web *)
adamc@25 29
adamc@25 30 structure MonoPrint :> MONO_PRINT = struct
adamc@25 31
adamc@25 32 open Print.PD
adamc@25 33 open Print
adamc@25 34
adamc@25 35 open Mono
adamc@25 36
adamc@25 37 structure E = MonoEnv
adamc@25 38
adamc@25 39 val debug = ref false
adamc@25 40
adamc@252 41 val dummyt = (TRecord [], ErrorMsg.dummySpan)
adamc@252 42
adamc@25 43 fun p_typ' par env (t, _) =
adamc@25 44 case t of
adamc@25 45 TFun (t1, t2) => parenIf par (box [p_typ' true env t1,
adamc@25 46 space,
adamc@25 47 string "->",
adamc@25 48 space,
adamc@25 49 p_typ env t2])
adamc@25 50 | TRecord xcs => box [string "{",
adamc@25 51 p_list (fn (x, t) =>
adamc@25 52 box [string x,
adamc@25 53 space,
adamc@25 54 string ":",
adamc@25 55 space,
adamc@25 56 p_typ env t]) xcs,
adamc@25 57 string "}"]
adamc@196 58 | TDatatype (n, _) =>
adamc@178 59 ((if !debug then
adamc@178 60 string (#1 (E.lookupDatatype env n) ^ "__" ^ Int.toString n)
adamc@178 61 else
adamc@178 62 string (#1 (E.lookupDatatype env n)))
adamc@178 63 handle E.UnboundNamed _ => string ("UNBOUND_DATATYPE_" ^ Int.toString n))
adamc@51 64 | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@292 65 | TOption t => box [string "option(",
adamc@292 66 p_typ env t,
adamc@292 67 string ")"]
adamc@757 68 | TList t => box [string "list(",
adamc@757 69 p_typ env t,
adamc@757 70 string ")"]
adamc@577 71 | TSource => string "source"
adamc@568 72 | TSignal t => box [string "signal(",
adamc@568 73 p_typ env t,
adamc@568 74 string ")"]
adamc@25 75
adamc@25 76 and p_typ env = p_typ' false env
adamc@25 77
adamc@109 78 fun p_enamed env n =
adamc@178 79 (if !debug then
adamc@178 80 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@178 81 else
adamc@178 82 string (#1 (E.lookupENamed env n)))
adamc@178 83 handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)
adamc@178 84
adamc@178 85 fun p_con_named env n =
adamc@178 86 (if !debug then
adamc@178 87 string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n)
adamc@178 88 else
adamc@178 89 string (#1 (E.lookupConstructor env n)))
adamc@178 90 handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n)
adamc@178 91
adamc@178 92 fun p_patCon env pc =
adamc@178 93 case pc of
adamc@178 94 PConVar n => p_con_named env n
adamc@186 95 | PConFfi {mod = m, con, ...} => box [string "FFIC(",
adamc@185 96 string m,
adamc@185 97 string ".",
adamc@185 98 string con,
adamc@185 99 string ")"]
adamc@178 100
adamc@178 101 fun p_pat' par env (p, _) =
adamc@178 102 case p of
adamc@178 103 PWild => string "_"
adamc@182 104 | PVar (s, _) => string s
adamc@178 105 | PPrim p => Prim.p_t p
adamc@188 106 | PCon (_, n, NONE) => p_patCon env n
adamc@188 107 | PCon (_, n, SOME p) => parenIf par (box [p_patCon env n,
adamc@288 108 space,
adamc@288 109 p_pat' true env p])
adamc@178 110 | PRecord xps =>
adamc@178 111 box [string "{",
adamc@182 112 p_list_sep (box [string ",", space]) (fn (x, p, _) =>
adamc@178 113 box [string x,
adamc@178 114 space,
adamc@178 115 string "=",
adamc@178 116 space,
adamc@178 117 p_pat env p]) xps,
adamc@178 118 string "}"]
adamc@288 119 | PNone _ => string "None"
adamc@757 120 | PSome (t, p) =>
adamc@757 121 if !debug then
adamc@757 122 box [string "Some[",
adamc@757 123 p_typ env t,
adamc@757 124 string "]",
adamc@757 125 space,
adamc@757 126 p_pat' true env p]
adamc@757 127 else
adamc@757 128 box [string "Some",
adamc@757 129 space,
adamc@757 130 p_pat' true env p]
adamc@178 131
adamc@178 132 and p_pat x = p_pat' false x
adamc@109 133
adamc@591 134 fun p_mode env m =
adamc@591 135 case m of
adamc@591 136 Attribute => string "Attribute"
adamc@591 137 | Script => string "Script"
adamc@591 138 | Source t => box [string "Source", space, p_typ env t]
adamc@591 139
adamc@25 140 fun p_exp' par env (e, _) =
adamc@25 141 case e of
adamc@25 142 EPrim p => Prim.p_t p
adamc@25 143 | ERel n =>
adamc@178 144 ((if !debug then
adamc@178 145 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@178 146 else
adamc@178 147 string (#1 (E.lookupERel env n)))
adamc@178 148 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
adamc@109 149 | ENamed n => p_enamed env n
adamc@188 150 | ECon (_, pc, NONE) => p_patCon env pc
adamc@188 151 | ECon (_, pc, SOME e) => parenIf par (box [p_patCon env pc,
adamc@188 152 space,
adamc@188 153 p_exp' true env e])
adamc@297 154 | ENone _ => string "None"
adamc@290 155 | ESome (_, e) => parenIf par (box [string "Some",
adamc@290 156 space,
adamc@290 157 p_exp' true env e])
adamc@109 158
adamc@51 159 | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@51 160 | EFfiApp (m, x, es) => box [string "FFI(",
adamc@51 161 string m,
adamc@51 162 string ".",
adamc@51 163 string x,
adamc@51 164 string "(",
adamc@51 165 p_list (p_exp env) es,
adamc@51 166 string "))"]
adamc@25 167 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
adamc@25 168 space,
adamc@25 169 p_exp' true env e2])
adamc@252 170 | EAbs (x, t, _, e) => parenIf true (box [string "fn",
adamc@252 171 space,
adamc@252 172 string x,
adamc@252 173 space,
adamc@252 174 string ":",
adamc@252 175 space,
adamc@252 176 p_typ env t,
adamc@252 177 space,
adamc@252 178 string "=>",
adamc@252 179 space,
adamc@252 180 p_exp (E.pushERel env x t NONE) e])
adamc@25 181
adamc@387 182 | EUnop (s, e) => parenIf true (box [string s,
adamc@387 183 space,
adamc@387 184 p_exp' true env e])
adamc@387 185 | EBinop (s, e1, e2) => parenIf true (box [p_exp' true env e1,
adamc@387 186 space,
adamc@387 187 string s,
adamc@387 188 space,
adamc@387 189 p_exp' true env e2])
adamc@387 190
adamc@25 191 | ERecord xes => box [string "{",
adamc@29 192 p_list (fn (x, e, _) =>
adamc@25 193 box [string x,
adamc@25 194 space,
adamc@25 195 string "=",
adamc@25 196 space,
adamc@25 197 p_exp env e]) xes,
adamc@25 198 string "}"]
adamc@25 199 | EField (e, x) =>
adamc@25 200 box [p_exp' true env e,
adamc@25 201 string ".",
adamc@25 202 string x]
adamc@25 203
adamc@252 204 | ECase (e, pes, _) => parenIf true (box [string "case",
adamc@252 205 space,
adamc@252 206 p_exp env e,
adamc@252 207 space,
adamc@252 208 string "of",
adamc@252 209 space,
adamc@252 210 p_list_sep (box [space, string "|", space])
adamc@252 211 (fn (p, e) => box [p_pat env p,
adamc@252 212 space,
adamc@252 213 string "=>",
adamc@252 214 space,
adamc@252 215 p_exp (E.patBinds env p) e]) pes])
adamc@94 216
adamc@283 217 | EError (e, t) => box [string "(error",
adamc@283 218 space,
adamc@283 219 p_exp env e,
adamc@283 220 space,
adamc@283 221 string ":",
adamc@283 222 space,
adamc@283 223 p_typ env t,
adamc@283 224 string ")"]
adamc@741 225 | EReturnBlob {blob, mimeType, t} => box [string "(blob",
adamc@741 226 space,
adamc@741 227 p_exp env blob,
adamc@741 228 space,
adamc@741 229 string "in",
adamc@741 230 space,
adamc@741 231 p_exp env mimeType,
adamc@741 232 space,
adamc@741 233 string ":",
adamc@741 234 space,
adamc@741 235 p_typ env t,
adamc@741 236 string ")"]
adamc@283 237
adamc@331 238 | EStrcat (e1, e2) => parenIf par (box [p_exp' true env e1,
adamc@331 239 space,
adamc@331 240 string "^",
adamc@331 241 space,
adamc@331 242 p_exp env e2])
adamc@94 243
adamc@102 244 | EWrite e => box [string "write(",
adamc@102 245 p_exp env e,
adamc@102 246 string ")"]
adamc@102 247
adamc@578 248 | ESeq (e1, e2) => box [string "(",
adamc@578 249 p_exp env e1,
adamc@106 250 string ";",
adamc@106 251 space,
adamc@578 252 p_exp env e2,
adamc@578 253 string ")"]
adamc@252 254 | ELet (x, t, e1, e2) => box [string "(let",
adamc@251 255 space,
adamc@251 256 string x,
adamc@251 257 space,
adamc@251 258 string ":",
adamc@251 259 space,
adamc@251 260 p_typ env t,
adamc@251 261 space,
adamc@251 262 string "=",
adamc@251 263 space,
adamc@252 264 string "(",
adamc@251 265 p_exp env e1,
adamc@252 266 string ")",
adamc@251 267 space,
adamc@251 268 string "in",
adamc@251 269 space,
adamc@252 270 string "(",
adamc@252 271 p_exp (E.pushERel env x t NONE) e2,
adamc@252 272 string "))"]
adamc@106 273
adamc@111 274 | EClosure (n, es) => box [string "CLOSURE(",
adamc@111 275 p_enamed env n,
adamc@111 276 p_list_sep (string "") (fn e => box [string ", ",
adamc@111 277 p_exp env e]) es,
adamc@111 278 string ")"]
adamc@111 279
adamc@252 280 | EQuery {exps, tables, state, query, body, initial} =>
adamc@252 281 box [string "query[",
adamc@252 282 p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) exps,
adamc@252 283 string "] [",
adamc@252 284 p_list (fn (x, xts) => box [string x,
adamc@252 285 space,
adamc@252 286 string ":",
adamc@252 287 space,
adamc@252 288 string "{",
adamc@252 289 p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) xts,
adamc@252 290 string "}"]) tables,
adamc@252 291 string "] [",
adamc@252 292 p_typ env state,
adamc@252 293 string "]",
adamc@252 294 space,
adamc@252 295 p_exp env query,
adamc@252 296 space,
adamc@252 297 string "initial",
adamc@252 298 space,
adamc@252 299 p_exp env initial,
adamc@252 300 space,
adamc@252 301 string "in",
adamc@252 302 space,
adamc@252 303 p_exp (E.pushERel (E.pushERel env "r" dummyt NONE) "acc" dummyt NONE) body]
adamc@307 304 | EDml e => box [string "dml(",
adamc@307 305 p_exp env e,
adamc@307 306 string ")"]
adamc@338 307 | ENextval e => box [string "nextval(",
adamc@338 308 p_exp env e,
adamc@338 309 string ")"]
adamc@463 310 | EUnurlify (e, _) => box [string "unurlify(",
adamc@463 311 p_exp env e,
adamc@463 312 string ")"]
adamc@591 313 | EJavaScript (m, e, NONE) => box [string "JavaScript(",
adamc@591 314 p_mode env m,
adamc@591 315 string ",",
adamc@591 316 space,
adamc@578 317 p_exp env e,
adamc@578 318 string ")"]
adamc@578 319 | EJavaScript (_, _, SOME e) => p_exp env e
adamc@568 320
adamc@568 321 | ESignalReturn e => box [string "Return(",
adamc@568 322 p_exp env e,
adamc@568 323 string ")"]
adamc@574 324 | ESignalBind (e1, e2) => box [string "Bind(",
adamc@572 325 p_exp env e1,
adamc@572 326 string ",",
adamc@572 327 space,
adamc@572 328 p_exp env e2,
adamc@572 329 string ")"]
adamc@574 330 | ESignalSource e => box [string "Source(",
adamc@574 331 p_exp env e,
adamc@574 332 string ")"]
adamc@252 333
adamc@736 334 | EServerCall (n, e, _, _) => box [string "Server(",
adamc@736 335 p_exp env n,
adamc@736 336 string ")[",
adamc@736 337 p_exp env e,
adamc@736 338 string "]"]
adamc@670 339 | ERecv (n, e, _) => box [string "Recv(",
adamc@670 340 p_exp env n,
adamc@670 341 string ")[",
adamc@670 342 p_exp env e,
adamc@670 343 string "]"]
adamc@695 344 | ESleep (n, e) => box [string "Sleep(",
adamc@695 345 p_exp env n,
adamc@695 346 string ")[",
adamc@695 347 p_exp env e,
adamc@695 348 string "]"]
adamc@608 349
adamc@25 350 and p_exp env = p_exp' false env
adamc@25 351
adamc@126 352 fun p_vali env (x, n, t, e, s) =
adamc@126 353 let
adamc@126 354 val xp = if !debug then
adamc@126 355 box [string x,
adamc@126 356 string "__",
adamc@126 357 string (Int.toString n)]
adamc@126 358 else
adamc@126 359 string x
adamc@126 360 in
adamc@126 361 box [xp,
adamc@126 362 space,
adamc@126 363 string "as",
adamc@126 364 space,
adamc@126 365 string s,
adamc@126 366 space,
adamc@126 367 string ":",
adamc@126 368 space,
adamc@126 369 p_typ env t,
adamc@126 370 space,
adamc@126 371 string "=",
adamc@126 372 space,
adamc@126 373 p_exp env e]
adamc@126 374 end
adamc@126 375
adamc@164 376 fun p_datatype env (x, n, cons) =
adamc@164 377 let
adamc@168 378 val env = E.pushDatatype env x n cons
adamc@164 379 in
adamc@164 380 box [string "datatype",
adamc@164 381 space,
adamc@164 382 string x,
adamc@164 383 space,
adamc@164 384 string "=",
adamc@164 385 space,
adamc@164 386 p_list_sep (box [space, string "|", space])
adamc@164 387 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@164 388 else string x
adamc@164 389 | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@164 390 else string x, space, string "of", space, p_typ env t])
adamc@164 391 cons]
adamc@164 392 end
adamc@164 393
adamc@126 394 fun p_decl env (dAll as (d, _) : decl) =
adamc@25 395 case d of
adamc@164 396 DDatatype x => p_datatype env x
adamc@164 397 | DVal vi => box [string "val",
adamc@126 398 space,
adamc@126 399 p_vali env vi]
adamc@126 400 | DValRec vis =>
adamc@25 401 let
adamc@126 402 val env = E.declBinds env dAll
adamc@25 403 in
adamc@25 404 box [string "val",
adamc@25 405 space,
adamc@126 406 string "rec",
adamc@25 407 space,
adamc@126 408 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@25 409 end
adamc@109 410
adamc@609 411 | DExport (ek, s, n, ts, t) => box [string "export",
adamc@609 412 space,
adamc@732 413 Export.p_export_kind ek,
adamc@609 414 space,
adamc@609 415 p_enamed env n,
adamc@609 416 space,
adamc@609 417 string "as",
adamc@609 418 space,
adamc@609 419 string s,
adamc@609 420 p_list_sep (string "") (fn t => box [space,
adamc@609 421 string "(",
adamc@609 422 p_typ env t,
adamc@609 423 string ")"]) ts,
adamc@609 424 space,
adamc@609 425 string "->",
adamc@609 426 space,
adamc@609 427 p_typ env t]
adamc@271 428
adamc@707 429 | DTable (s, xts, pe, ce) => box [string "(* SQL table ",
adamc@707 430 string s,
adamc@707 431 space,
adamc@707 432 string ":",
adamc@707 433 space,
adamc@707 434 p_list (fn (x, t) => box [string x,
adamc@707 435 space,
adamc@707 436 string ":",
adamc@707 437 space,
adamc@707 438 p_typ env t]) xts,
adamc@707 439 space,
adamc@707 440 string "keys",
adamc@707 441 space,
adamc@707 442 p_exp env pe,
adamc@707 443 space,
adamc@707 444 string "constraints",
adamc@707 445 space,
adamc@707 446 p_exp env ce,
adamc@707 447 space,
adamc@707 448 string "*)"]
adamc@338 449 | DSequence s => box [string "(* SQL sequence ",
adamc@338 450 string s,
adamc@338 451 string "*)"]
adamc@754 452 | DView (s, _, e) => box [string "(* SQL view ",
adamc@754 453 string s,
adamc@754 454 space,
adamc@754 455 string "as",
adamc@754 456 space,
adamc@754 457 p_exp env e,
adamc@754 458 string "*)"]
adamc@687 459 | DDatabase {name, expunge, initialize} => box [string "database",
adamc@687 460 space,
adamc@687 461 string name,
adamc@687 462 space,
adamc@687 463 string "(",
adamc@687 464 p_enamed env expunge,
adamc@687 465 string ",",
adamc@687 466 space,
adamc@687 467 p_enamed env initialize,
adamc@687 468 string ")"]
adamc@569 469 | DJavaScript s => box [string "JavaScript(",
adamc@569 470 string s,
adamc@569 471 string ")"]
adamc@569 472
adamc@725 473 | DCookie s => box [string "cookie",
adamc@725 474 space,
adamc@725 475 string s]
adamc@720 476 | DStyle s => box [string "style",
adamc@720 477 space,
adamc@720 478 string s]
adamc@718 479
adamc@100 480
adamc@25 481 fun p_file env file =
adamc@25 482 let
adamc@31 483 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 484 (p_decl env d,
adamc@31 485 E.declBinds env d))
adamc@25 486 env file
adamc@25 487 in
adamc@25 488 p_list_sep newline (fn x => x) pds
adamc@25 489 end
adamc@25 490
adamc@25 491 end