Mercurial > urweb

annotate src/mono_print.sml @ 574:ac947e2f29ff

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