Mercurial > urweb

annotate src/mono_print.sml @ 720:acb8537f58f0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Stop tracking CSS classes in XML types
author Adam Chlipala <adamc@hcoop.net>
date Sun, 12 Apr 2009 12:31:54 -0400
parents f152f215a02c
children 4c5796512edc
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@577 68 | TSource => string "source"
adamc@568 69 | TSignal t => box [string "signal(",
adamc@568 70 p_typ env t,
adamc@568 71 string ")"]
adamc@25 72
adamc@25 73 and p_typ env = p_typ' false env
adamc@25 74
adamc@109 75 fun p_enamed env n =
adamc@178 76 (if !debug then
adamc@178 77 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@178 78 else
adamc@178 79 string (#1 (E.lookupENamed env n)))
adamc@178 80 handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)
adamc@178 81
adamc@178 82 fun p_con_named env n =
adamc@178 83 (if !debug then
adamc@178 84 string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n)
adamc@178 85 else
adamc@178 86 string (#1 (E.lookupConstructor env n)))
adamc@178 87 handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n)
adamc@178 88
adamc@178 89 fun p_patCon env pc =
adamc@178 90 case pc of
adamc@178 91 PConVar n => p_con_named env n
adamc@186 92 | PConFfi {mod = m, con, ...} => box [string "FFIC(",
adamc@185 93 string m,
adamc@185 94 string ".",
adamc@185 95 string con,
adamc@185 96 string ")"]
adamc@178 97
adamc@178 98 fun p_pat' par env (p, _) =
adamc@178 99 case p of
adamc@178 100 PWild => string "_"
adamc@182 101 | PVar (s, _) => string s
adamc@178 102 | PPrim p => Prim.p_t p
adamc@188 103 | PCon (_, n, NONE) => p_patCon env n
adamc@188 104 | PCon (_, n, SOME p) => parenIf par (box [p_patCon env n,
adamc@288 105 space,
adamc@288 106 p_pat' true env p])
adamc@178 107 | PRecord xps =>
adamc@178 108 box [string "{",
adamc@182 109 p_list_sep (box [string ",", space]) (fn (x, p, _) =>
adamc@178 110 box [string x,
adamc@178 111 space,
adamc@178 112 string "=",
adamc@178 113 space,
adamc@178 114 p_pat env p]) xps,
adamc@178 115 string "}"]
adamc@288 116 | PNone _ => string "None"
adamc@288 117 | PSome (_, p) => box [string "Some",
adamc@288 118 space,
adamc@288 119 p_pat' true env p]
adamc@178 120
adamc@178 121 and p_pat x = p_pat' false x
adamc@109 122
adamc@591 123 fun p_mode env m =
adamc@591 124 case m of
adamc@591 125 Attribute => string "Attribute"
adamc@591 126 | Script => string "Script"
adamc@591 127 | Source t => box [string "Source", space, p_typ env t]
adamc@591 128
adamc@25 129 fun p_exp' par env (e, _) =
adamc@25 130 case e of
adamc@25 131 EPrim p => Prim.p_t p
adamc@25 132 | ERel n =>
adamc@178 133 ((if !debug then
adamc@178 134 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@178 135 else
adamc@178 136 string (#1 (E.lookupERel env n)))
adamc@178 137 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
adamc@109 138 | ENamed n => p_enamed env n
adamc@188 139 | ECon (_, pc, NONE) => p_patCon env pc
adamc@188 140 | ECon (_, pc, SOME e) => parenIf par (box [p_patCon env pc,
adamc@188 141 space,
adamc@188 142 p_exp' true env e])
adamc@297 143 | ENone _ => string "None"
adamc@290 144 | ESome (_, e) => parenIf par (box [string "Some",
adamc@290 145 space,
adamc@290 146 p_exp' true env e])
adamc@109 147
adamc@51 148 | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@51 149 | EFfiApp (m, x, es) => box [string "FFI(",
adamc@51 150 string m,
adamc@51 151 string ".",
adamc@51 152 string x,
adamc@51 153 string "(",
adamc@51 154 p_list (p_exp env) es,
adamc@51 155 string "))"]
adamc@25 156 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
adamc@25 157 space,
adamc@25 158 p_exp' true env e2])
adamc@252 159 | EAbs (x, t, _, e) => parenIf true (box [string "fn",
adamc@252 160 space,
adamc@252 161 string x,
adamc@252 162 space,
adamc@252 163 string ":",
adamc@252 164 space,
adamc@252 165 p_typ env t,
adamc@252 166 space,
adamc@252 167 string "=>",
adamc@252 168 space,
adamc@252 169 p_exp (E.pushERel env x t NONE) e])
adamc@25 170
adamc@387 171 | EUnop (s, e) => parenIf true (box [string s,
adamc@387 172 space,
adamc@387 173 p_exp' true env e])
adamc@387 174 | EBinop (s, e1, e2) => parenIf true (box [p_exp' true env e1,
adamc@387 175 space,
adamc@387 176 string s,
adamc@387 177 space,
adamc@387 178 p_exp' true env e2])
adamc@387 179
adamc@25 180 | ERecord xes => box [string "{",
adamc@29 181 p_list (fn (x, e, _) =>
adamc@25 182 box [string x,
adamc@25 183 space,
adamc@25 184 string "=",
adamc@25 185 space,
adamc@25 186 p_exp env e]) xes,
adamc@25 187 string "}"]
adamc@25 188 | EField (e, x) =>
adamc@25 189 box [p_exp' true env e,
adamc@25 190 string ".",
adamc@25 191 string x]
adamc@25 192
adamc@252 193 | ECase (e, pes, _) => parenIf true (box [string "case",
adamc@252 194 space,
adamc@252 195 p_exp env e,
adamc@252 196 space,
adamc@252 197 string "of",
adamc@252 198 space,
adamc@252 199 p_list_sep (box [space, string "|", space])
adamc@252 200 (fn (p, e) => box [p_pat env p,
adamc@252 201 space,
adamc@252 202 string "=>",
adamc@252 203 space,
adamc@252 204 p_exp (E.patBinds env p) e]) pes])
adamc@94 205
adamc@283 206 | EError (e, t) => box [string "(error",
adamc@283 207 space,
adamc@283 208 p_exp env e,
adamc@283 209 space,
adamc@283 210 string ":",
adamc@283 211 space,
adamc@283 212 p_typ env t,
adamc@283 213 string ")"]
adamc@283 214
adamc@331 215 | EStrcat (e1, e2) => parenIf par (box [p_exp' true env e1,
adamc@331 216 space,
adamc@331 217 string "^",
adamc@331 218 space,
adamc@331 219 p_exp env e2])
adamc@94 220
adamc@102 221 | EWrite e => box [string "write(",
adamc@102 222 p_exp env e,
adamc@102 223 string ")"]
adamc@102 224
adamc@578 225 | ESeq (e1, e2) => box [string "(",
adamc@578 226 p_exp env e1,
adamc@106 227 string ";",
adamc@106 228 space,
adamc@578 229 p_exp env e2,
adamc@578 230 string ")"]
adamc@252 231 | ELet (x, t, e1, e2) => box [string "(let",
adamc@251 232 space,
adamc@251 233 string x,
adamc@251 234 space,
adamc@251 235 string ":",
adamc@251 236 space,
adamc@251 237 p_typ env t,
adamc@251 238 space,
adamc@251 239 string "=",
adamc@251 240 space,
adamc@252 241 string "(",
adamc@251 242 p_exp env e1,
adamc@252 243 string ")",
adamc@251 244 space,
adamc@251 245 string "in",
adamc@251 246 space,
adamc@252 247 string "(",
adamc@252 248 p_exp (E.pushERel env x t NONE) e2,
adamc@252 249 string "))"]
adamc@106 250
adamc@111 251 | EClosure (n, es) => box [string "CLOSURE(",
adamc@111 252 p_enamed env n,
adamc@111 253 p_list_sep (string "") (fn e => box [string ", ",
adamc@111 254 p_exp env e]) es,
adamc@111 255 string ")"]
adamc@111 256
adamc@252 257 | EQuery {exps, tables, state, query, body, initial} =>
adamc@252 258 box [string "query[",
adamc@252 259 p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) exps,
adamc@252 260 string "] [",
adamc@252 261 p_list (fn (x, xts) => box [string x,
adamc@252 262 space,
adamc@252 263 string ":",
adamc@252 264 space,
adamc@252 265 string "{",
adamc@252 266 p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) xts,
adamc@252 267 string "}"]) tables,
adamc@252 268 string "] [",
adamc@252 269 p_typ env state,
adamc@252 270 string "]",
adamc@252 271 space,
adamc@252 272 p_exp env query,
adamc@252 273 space,
adamc@252 274 string "initial",
adamc@252 275 space,
adamc@252 276 p_exp env initial,
adamc@252 277 space,
adamc@252 278 string "in",
adamc@252 279 space,
adamc@252 280 p_exp (E.pushERel (E.pushERel env "r" dummyt NONE) "acc" dummyt NONE) body]
adamc@307 281 | EDml e => box [string "dml(",
adamc@307 282 p_exp env e,
adamc@307 283 string ")"]
adamc@338 284 | ENextval e => box [string "nextval(",
adamc@338 285 p_exp env e,
adamc@338 286 string ")"]
adamc@463 287 | EUnurlify (e, _) => box [string "unurlify(",
adamc@463 288 p_exp env e,
adamc@463 289 string ")"]
adamc@591 290 | EJavaScript (m, e, NONE) => box [string "JavaScript(",
adamc@591 291 p_mode env m,
adamc@591 292 string ",",
adamc@591 293 space,
adamc@578 294 p_exp env e,
adamc@578 295 string ")"]
adamc@578 296 | EJavaScript (_, _, SOME e) => p_exp env e
adamc@568 297
adamc@568 298 | ESignalReturn e => box [string "Return(",
adamc@568 299 p_exp env e,
adamc@568 300 string ")"]
adamc@574 301 | ESignalBind (e1, e2) => box [string "Bind(",
adamc@572 302 p_exp env e1,
adamc@572 303 string ",",
adamc@572 304 space,
adamc@572 305 p_exp env e2,
adamc@572 306 string ")"]
adamc@574 307 | ESignalSource e => box [string "Source(",
adamc@574 308 p_exp env e,
adamc@574 309 string ")"]
adamc@252 310
adamc@614 311 | EServerCall (n, e, _) => box [string "Server(",
adamc@614 312 p_exp env n,
adamc@609 313 string ")[",
adamc@609 314 p_exp env e,
adamc@609 315 string "]"]
adamc@670 316 | ERecv (n, e, _) => box [string "Recv(",
adamc@670 317 p_exp env n,
adamc@670 318 string ")[",
adamc@670 319 p_exp env e,
adamc@670 320 string "]"]
adamc@695 321 | ESleep (n, e) => box [string "Sleep(",
adamc@695 322 p_exp env n,
adamc@695 323 string ")[",
adamc@695 324 p_exp env e,
adamc@695 325 string "]"]
adamc@608 326
adamc@25 327 and p_exp env = p_exp' false env
adamc@25 328
adamc@126 329 fun p_vali env (x, n, t, e, s) =
adamc@126 330 let
adamc@126 331 val xp = if !debug then
adamc@126 332 box [string x,
adamc@126 333 string "__",
adamc@126 334 string (Int.toString n)]
adamc@126 335 else
adamc@126 336 string x
adamc@126 337 in
adamc@126 338 box [xp,
adamc@126 339 space,
adamc@126 340 string "as",
adamc@126 341 space,
adamc@126 342 string s,
adamc@126 343 space,
adamc@126 344 string ":",
adamc@126 345 space,
adamc@126 346 p_typ env t,
adamc@126 347 space,
adamc@126 348 string "=",
adamc@126 349 space,
adamc@126 350 p_exp env e]
adamc@126 351 end
adamc@126 352
adamc@164 353 fun p_datatype env (x, n, cons) =
adamc@164 354 let
adamc@168 355 val env = E.pushDatatype env x n cons
adamc@164 356 in
adamc@164 357 box [string "datatype",
adamc@164 358 space,
adamc@164 359 string x,
adamc@164 360 space,
adamc@164 361 string "=",
adamc@164 362 space,
adamc@164 363 p_list_sep (box [space, string "|", space])
adamc@164 364 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@164 365 else string x
adamc@164 366 | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@164 367 else string x, space, string "of", space, p_typ env t])
adamc@164 368 cons]
adamc@164 369 end
adamc@164 370
adamc@126 371 fun p_decl env (dAll as (d, _) : decl) =
adamc@25 372 case d of
adamc@164 373 DDatatype x => p_datatype env x
adamc@164 374 | DVal vi => box [string "val",
adamc@126 375 space,
adamc@126 376 p_vali env vi]
adamc@126 377 | DValRec vis =>
adamc@25 378 let
adamc@126 379 val env = E.declBinds env dAll
adamc@25 380 in
adamc@25 381 box [string "val",
adamc@25 382 space,
adamc@126 383 string "rec",
adamc@25 384 space,
adamc@126 385 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@25 386 end
adamc@109 387
adamc@609 388 | DExport (ek, s, n, ts, t) => box [string "export",
adamc@609 389 space,
adamc@609 390 CorePrint.p_export_kind ek,
adamc@609 391 space,
adamc@609 392 p_enamed env n,
adamc@609 393 space,
adamc@609 394 string "as",
adamc@609 395 space,
adamc@609 396 string s,
adamc@609 397 p_list_sep (string "") (fn t => box [space,
adamc@609 398 string "(",
adamc@609 399 p_typ env t,
adamc@609 400 string ")"]) ts,
adamc@609 401 space,
adamc@609 402 string "->",
adamc@609 403 space,
adamc@609 404 p_typ env t]
adamc@271 405
adamc@707 406 | DTable (s, xts, pe, ce) => box [string "(* SQL table ",
adamc@707 407 string s,
adamc@707 408 space,
adamc@707 409 string ":",
adamc@707 410 space,
adamc@707 411 p_list (fn (x, t) => box [string x,
adamc@707 412 space,
adamc@707 413 string ":",
adamc@707 414 space,
adamc@707 415 p_typ env t]) xts,
adamc@707 416 space,
adamc@707 417 string "keys",
adamc@707 418 space,
adamc@707 419 p_exp env pe,
adamc@707 420 space,
adamc@707 421 string "constraints",
adamc@707 422 space,
adamc@707 423 p_exp env ce,
adamc@707 424 space,
adamc@707 425 string "*)"]
adamc@338 426 | DSequence s => box [string "(* SQL sequence ",
adamc@338 427 string s,
adamc@338 428 string "*)"]
adamc@687 429 | DDatabase {name, expunge, initialize} => box [string "database",
adamc@687 430 space,
adamc@687 431 string name,
adamc@687 432 space,
adamc@687 433 string "(",
adamc@687 434 p_enamed env expunge,
adamc@687 435 string ",",
adamc@687 436 space,
adamc@687 437 p_enamed env initialize,
adamc@687 438 string ")"]
adamc@569 439 | DJavaScript s => box [string "JavaScript(",
adamc@569 440 string s,
adamc@569 441 string ")"]
adamc@569 442
adamc@720 443 | DStyle s => box [string "style",
adamc@720 444 space,
adamc@720 445 string s]
adamc@718 446
adamc@100 447
adamc@25 448 fun p_file env file =
adamc@25 449 let
adamc@31 450 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 451 (p_decl env d,
adamc@31 452 E.declBinds env d))
adamc@25 453 env file
adamc@25 454 in
adamc@25 455 p_list_sep newline (fn x => x) pds
adamc@25 456 end
adamc@25 457
adamc@25 458 end