Mercurial > urweb

annotate src/elab_print.sml @ 1688:8c2e8d41a8f2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Correct an SQL grammar omission (thanks to Alexei Golovko for spotting the problem)
author Adam Chlipala <adam@chlipala.net>
date Sat, 25 Feb 2012 15:34:44 -0500
parents 6c00d8af6239
children 05ae68e019b6
rev   line source
adamc@3 1 (* Copyright (c) 2008, Adam Chlipala
adamc@3 2 * All rights reserved.
adamc@3 3 *
adamc@3 4 * Redistribution and use in source and binary forms, with or without
adamc@3 5 * modification, are permitted provided that the following conditions are met:
adamc@3 6 *
adamc@3 7 * - Redistributions of source code must retain the above copyright notice,
adamc@3 8 * this list of conditions and the following disclaimer.
adamc@3 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@3 10 * this list of conditions and the following disclaimer in the documentation
adamc@3 11 * and/or other materials provided with the distribution.
adamc@3 12 * - The names of contributors may not be used to endorse or promote products
adamc@3 13 * derived from this software without specific prior written permission.
adamc@3 14 *
adamc@3 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@3 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@3 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@3 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@3 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@3 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@3 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@3 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@3 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@3 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@3 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@3 26 *)
adamc@3 27
adamc@244 28 (* Pretty-printing elaborated Ur/Web *)
adamc@3 29
adamc@3 30 structure ElabPrint :> ELAB_PRINT = struct
adamc@3 31
adamc@3 32 open Print.PD
adamc@3 33 open Print
adamc@3 34
adamc@3 35 open Elab
adamc@3 36
adamc@3 37 structure E = ElabEnv
adamc@3 38
adamc@11 39 val debug = ref false
adamc@11 40
adamc@623 41 fun p_kind' par env (k, _) =
adamc@3 42 case k of
adamc@3 43 KType => string "Type"
adamc@623 44 | KArrow (k1, k2) => parenIf par (box [p_kind' true env k1,
adamc@3 45 space,
adamc@3 46 string "->",
adamc@3 47 space,
adamc@623 48 p_kind env k2])
adamc@3 49 | KName => string "Name"
adamc@623 50 | KRecord k => box [string "{", p_kind env k, string "}"]
adamc@82 51 | KUnit => string "Unit"
adamc@207 52 | KTuple ks => box [string "(",
adamc@623 53 p_list_sep (box [space, string "*", space]) (p_kind env) ks,
adamc@207 54 string ")"]
adamc@3 55
adamc@3 56 | KError => string "<ERROR>"
adam@1639 57 | KUnif (_, _, ref (KKnown k)) => p_kind' par env k
adamc@76 58 | KUnif (_, s, _) => string ("<UNIF:" ^ s ^ ">")
adam@1639 59 | KTupleUnif (_, _, ref (KKnown k)) => p_kind' par env k
adam@1302 60 | KTupleUnif (_, nks, _) => box [string "(",
adam@1302 61 p_list_sep (box [space, string "*", space])
adam@1302 62 (fn (n, k) => box [string (Int.toString n ^ ":"),
adam@1302 63 space,
adam@1302 64 p_kind env k]) nks,
adam@1302 65 space,
adam@1302 66 string "*",
adam@1302 67 space,
adam@1302 68 string "...)"]
adamc@3 69
adamc@623 70 | KRel n => ((if !debug then
adamc@623 71 string (E.lookupKRel env n ^ "_" ^ Int.toString n)
adamc@623 72 else
adamc@623 73 string (E.lookupKRel env n))
adamc@623 74 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
adamc@623 75 | KFun (x, k) => box [string x,
adamc@623 76 space,
adamc@623 77 string "-->",
adamc@623 78 space,
adamc@623 79 p_kind (E.pushKRel env x) k]
adamc@623 80
adamc@624 81 and p_kind env = p_kind' false env
adamc@3 82
adamc@3 83 fun p_explicitness e =
adamc@3 84 case e of
adamc@3 85 Explicit => string "::"
adamc@3 86 | Implicit => string ":::"
adamc@3 87
adamc@3 88 fun p_con' par env (c, _) =
adamc@3 89 case c of
adamc@623 90 TFun (t1, t2) => parenIf true (box [p_con' true env t1,
adamc@3 91 space,
adamc@3 92 string "->",
adamc@3 93 space,
adamc@3 94 p_con env t2])
adamc@3 95 | TCFun (e, x, k, c) => parenIf par (box [string x,
adamc@3 96 space,
adamc@3 97 p_explicitness e,
adamc@3 98 space,
adamc@623 99 p_kind env k,
adamc@3 100 space,
adamc@3 101 string "->",
adamc@3 102 space,
adamc@3 103 p_con (E.pushCRel env x k) c])
adamc@628 104 | TDisjoint (c1, c2, c3) => parenIf par (box [string "[",
adamc@628 105 p_con env c1,
adamc@628 106 space,
adamc@628 107 string "~",
adamc@628 108 space,
adamc@628 109 p_con env c2,
adamc@628 110 string "]",
adamc@628 111 space,
adamc@628 112 string "=>",
adamc@628 113 space,
adamc@628 114 p_con env c3])
adamc@3 115 | TRecord (CRecord (_, xcs), _) => box [string "{",
adamc@3 116 p_list (fn (x, c) =>
adamc@20 117 box [p_name env x,
adamc@3 118 space,
adamc@3 119 string ":",
adamc@3 120 space,
adamc@3 121 p_con env c]) xcs,
adamc@3 122 string "}"]
adamc@3 123 | TRecord c => box [string "$",
adamc@3 124 p_con' true env c]
adamc@3 125
adamc@11 126 | CRel n =>
adamc@71 127 ((if !debug then
adamc@71 128 string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n)
adamc@71 129 else
adamc@71 130 string (#1 (E.lookupCRel env n)))
adamc@71 131 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
adamc@11 132 | CNamed n =>
adamc@34 133 ((if !debug then
adamc@34 134 string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n)
adamc@34 135 else
adamc@34 136 string (#1 (E.lookupCNamed env n)))
adamc@34 137 handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
adamc@34 138 | CModProj (m1, ms, x) =>
adamc@34 139 let
adamc@88 140 val m1x = #1 (E.lookupStrNamed env m1)
adamc@88 141 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@88 142
adamc@34 143 val m1s = if !debug then
adamc@34 144 m1x ^ "__" ^ Int.toString m1
adamc@34 145 else
adamc@34 146 m1x
adamc@34 147 in
adamc@34 148 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@88 149 end
adamc@3 150
adamc@3 151 | CApp (c1, c2) => parenIf par (box [p_con env c1,
adamc@3 152 space,
adamc@3 153 p_con' true env c2])
adamc@147 154 | CAbs (x, k, c) => parenIf true (box [string "fn",
adamc@147 155 space,
adamc@147 156 string x,
adamc@147 157 space,
adamc@147 158 string "::",
adamc@147 159 space,
adamc@623 160 p_kind env k,
adamc@147 161 space,
adamc@147 162 string "=>",
adamc@147 163 space,
adamc@147 164 p_con (E.pushCRel env x k) c])
adamc@3 165
adamc@3 166 | CName s => box [string "#", string s]
adamc@3 167
adamc@12 168 | CRecord (k, xcs) =>
adamc@12 169 if !debug then
adamc@12 170 parenIf par (box [string "[",
adamc@12 171 p_list (fn (x, c) =>
adamc@12 172 box [p_con env x,
adamc@12 173 space,
adamc@12 174 string "=",
adamc@12 175 space,
adamc@12 176 p_con env c]) xcs,
adamc@12 177 string "]::",
adamc@623 178 p_kind env k])
adamc@12 179 else
adamc@12 180 parenIf par (box [string "[",
adamc@12 181 p_list (fn (x, c) =>
adamc@12 182 box [p_con env x,
adamc@12 183 space,
adamc@12 184 string "=",
adamc@12 185 space,
adamc@12 186 p_con env c]) xcs,
adamc@12 187 string "]"])
adamc@3 188 | CConcat (c1, c2) => parenIf par (box [p_con' true env c1,
adamc@3 189 space,
adamc@3 190 string "++",
adamc@3 191 space,
adamc@3 192 p_con env c2])
adamc@621 193 | CMap _ => string "map"
adamc@3 194
adamc@82 195 | CUnit => string "()"
adamc@82 196
adamc@207 197 | CTuple cs => box [string "(",
adamc@207 198 p_list (p_con env) cs,
adamc@207 199 string ")"]
adamc@207 200 | CProj (c, n) => box [p_con env c,
adamc@207 201 string ".",
adamc@207 202 string (Int.toString n)]
adamc@207 203
adamc@3 204 | CError => string "<ERROR>"
adam@1639 205 | CUnif (nl, _, _, _, ref (Known c)) => p_con' par env (E.mliftConInCon nl c)
adam@1303 206 | CUnif (nl, _, k, s, _) => box [string ("<UNIF:" ^ s ^ "::"),
adam@1303 207 p_kind env k,
adam@1303 208 case nl of
adam@1303 209 0 => box []
adam@1303 210 | _ => string ("+" ^ Int.toString nl),
adam@1303 211 string ">"]
adamc@623 212
adamc@623 213 | CKAbs (x, c) => box [string x,
adamc@623 214 space,
adamc@623 215 string "==>",
adamc@623 216 space,
adamc@623 217 p_con (E.pushKRel env x) c]
adamc@623 218 | CKApp (c, k) => box [p_con env c,
adamc@623 219 string "[[",
adamc@623 220 p_kind env k,
adamc@623 221 string "]]"]
adamc@623 222 | TKFun (x, c) => box [string x,
adamc@623 223 space,
adamc@623 224 string "-->",
adamc@623 225 space,
adamc@623 226 p_con (E.pushKRel env x) c]
adamc@623 227
adamc@3 228
adamc@3 229 and p_con env = p_con' false env
adamc@3 230
adamc@20 231 and p_name env (all as (c, _)) =
adamc@20 232 case c of
adamc@20 233 CName s => string s
adamc@20 234 | _ => p_con env all
adamc@20 235
adamc@171 236 fun p_patCon env pc =
adamc@171 237 case pc of
adamc@171 238 PConVar n =>
adamc@171 239 ((if !debug then
adamc@171 240 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@171 241 else
adamc@171 242 string (#1 (E.lookupENamed env n)))
adamc@448 243 handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
adamc@171 244 | PConProj (m1, ms, x) =>
adamc@171 245 let
adamc@171 246 val m1x = #1 (E.lookupStrNamed env m1)
adamc@171 247 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@171 248
adamc@171 249 val m1s = if !debug then
adamc@171 250 m1x ^ "__" ^ Int.toString m1
adamc@171 251 else
adamc@171 252 m1x
adamc@171 253 in
adamc@171 254 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@171 255 end
adamc@171 256
adamc@171 257 fun p_pat' par env (p, _) =
adamc@171 258 case p of
adamc@171 259 PWild => string "_"
adamc@182 260 | PVar (s, _) => string s
adamc@173 261 | PPrim p => Prim.p_t p
adamc@191 262 | PCon (_, pc, _, NONE) => p_patCon env pc
adamc@191 263 | PCon (_, pc, _, SOME p) => parenIf par (box [p_patCon env pc,
adamc@188 264 space,
adamc@188 265 p_pat' true env p])
adamc@176 266 | PRecord xps =>
adamc@176 267 box [string "{",
adamc@1272 268 p_list_sep (box [string ",", space]) (fn (x, p, t) =>
adamc@176 269 box [string x,
adamc@176 270 space,
adamc@176 271 string "=",
adamc@176 272 space,
adamc@1272 273 p_pat env p,
adamc@1272 274 if !debug then
adamc@1272 275 box [space,
adamc@1272 276 string ":",
adamc@1272 277 space,
adamc@1272 278 p_con env t]
adamc@1272 279 else
adamc@1272 280 box []]) xps,
adamc@176 281 string "}"]
adamc@171 282
adamc@175 283 and p_pat x = p_pat' false x
adamc@171 284
adamc@9 285 fun p_exp' par env (e, _) =
adamc@9 286 case e of
adamc@14 287 EPrim p => Prim.p_t p
adamc@14 288 | ERel n =>
adamc@88 289 ((if !debug then
adamc@88 290 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@88 291 else
adamc@88 292 string (#1 (E.lookupERel env n)))
adamc@88 293 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
adamc@11 294 | ENamed n =>
adamc@88 295 ((if !debug then
adamc@88 296 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@88 297 else
adamc@88 298 string (#1 (E.lookupENamed env n)))
adamc@448 299 handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
adamc@34 300 | EModProj (m1, ms, x) =>
adamc@34 301 let
adamc@88 302 val m1x = #1 (E.lookupStrNamed env m1)
adamc@88 303 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@88 304
adamc@34 305 val m1s = if !debug then
adamc@34 306 m1x ^ "__" ^ Int.toString m1
adamc@34 307 else
adamc@34 308 m1x
adamc@34 309 in
adamc@34 310 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@34 311 end
adamc@34 312
adamc@9 313 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
adamc@9 314 space,
adamc@9 315 p_exp' true env e2])
adamc@26 316 | EAbs (x, t, _, e) => parenIf par (box [string "fn",
adamc@26 317 space,
adamc@26 318 string x,
adamc@26 319 space,
adamc@26 320 string ":",
adamc@26 321 space,
adamc@26 322 p_con env t,
adamc@26 323 space,
adamc@26 324 string "=>",
adamc@26 325 space,
adamc@26 326 p_exp (E.pushERel env x t) e])
adamc@9 327 | ECApp (e, c) => parenIf par (box [p_exp env e,
adamc@9 328 space,
adamc@9 329 string "[",
adamc@9 330 p_con env c,
adamc@9 331 string "]"])
adamc@9 332 | ECAbs (exp, x, k, e) => parenIf par (box [string "fn",
adamc@9 333 space,
adamc@9 334 string x,
adamc@9 335 space,
adamc@9 336 p_explicitness exp,
adamc@9 337 space,
adamc@623 338 p_kind env k,
adamc@9 339 space,
adamc@9 340 string "=>",
adamc@9 341 space,
adamc@9 342 p_exp (E.pushCRel env x k) e])
adamc@9 343
adamc@12 344 | ERecord xes => box [string "{",
adamc@29 345 p_list (fn (x, e, _) =>
adamc@21 346 box [p_name env x,
adamc@12 347 space,
adamc@12 348 string "=",
adamc@12 349 space,
adamc@12 350 p_exp env e]) xes,
adamc@12 351 string "}"]
adamc@12 352 | EField (e, c, {field, rest}) =>
adamc@12 353 if !debug then
adamc@12 354 box [p_exp' true env e,
adamc@12 355 string ".",
adamc@12 356 p_con' true env c,
adamc@12 357 space,
adamc@12 358 string "[",
adamc@12 359 p_con env field,
adamc@12 360 space,
adamc@12 361 string " in ",
adamc@12 362 space,
adamc@12 363 p_con env rest,
adamc@12 364 string "]"]
adamc@12 365 else
adamc@12 366 box [p_exp' true env e,
adamc@12 367 string ".",
adamc@12 368 p_con' true env c]
adamc@445 369 | EConcat (e1, c1, e2, c2) =>
adamc@339 370 parenIf par (if !debug then
adamc@445 371 box [p_exp' true env e1,
adamc@445 372 space,
adamc@445 373 string ":",
adamc@445 374 space,
adamc@445 375 p_con env c1,
adamc@445 376 space,
adamc@445 377 string "++",
adamc@445 378 space,
adamc@445 379 p_exp' true env e2,
adamc@445 380 space,
adamc@445 381 string ":",
adamc@445 382 space,
adamc@445 383 p_con env c2]
adamc@445 384 else
adamc@445 385 box [p_exp' true env e1,
adamc@339 386 space,
adamc@494 387 string "++",
adamc@339 388 space,
adamc@339 389 p_exp' true env e2])
adamc@149 390 | ECut (e, c, {field, rest}) =>
adamc@149 391 parenIf par (if !debug then
adamc@149 392 box [p_exp' true env e,
adamc@149 393 space,
adamc@149 394 string "--",
adamc@149 395 space,
adamc@149 396 p_con' true env c,
adamc@149 397 space,
adamc@149 398 string "[",
adamc@149 399 p_con env field,
adamc@149 400 space,
adamc@149 401 string " in ",
adamc@149 402 space,
adamc@149 403 p_con env rest,
adamc@149 404 string "]"]
adamc@149 405 else
adamc@149 406 box [p_exp' true env e,
adamc@149 407 space,
adamc@149 408 string "--",
adamc@149 409 space,
adamc@149 410 p_con' true env c])
adamc@493 411 | ECutMulti (e, c, {rest}) =>
adamc@493 412 parenIf par (if !debug then
adamc@493 413 box [p_exp' true env e,
adamc@493 414 space,
adamc@493 415 string "---",
adamc@493 416 space,
adamc@493 417 p_con' true env c,
adamc@493 418 space,
adamc@493 419 string "[",
adamc@493 420 p_con env rest,
adamc@493 421 string "]"]
adamc@493 422 else
adamc@493 423 box [p_exp' true env e,
adamc@493 424 space,
adamc@493 425 string "---",
adamc@493 426 space,
adamc@493 427 p_con' true env c])
adamc@493 428
adamc@171 429 | ECase (e, pes, _) => parenIf par (box [string "case",
adamc@171 430 space,
adamc@171 431 p_exp env e,
adamc@171 432 space,
adamc@171 433 string "of",
adamc@171 434 space,
adamc@171 435 p_list_sep (box [space, string "|", space])
adamc@171 436 (fn (p, e) => box [p_pat env p,
adamc@171 437 space,
adamc@171 438 string "=>",
adamc@171 439 space,
adamc@243 440 p_exp (E.patBinds env p) e]) pes])
adamc@171 441
adamc@9 442 | EError => string "<ERROR>"
adamc@228 443 | EUnif (ref (SOME e)) => p_exp env e
adamc@228 444 | EUnif _ => string "_"
adamc@9 445
adamc@825 446 | ELet (ds, e, _) =>
adamc@447 447 let
adamc@447 448 val (dsp, env) = ListUtil.foldlMap
adamc@447 449 (fn (d, env) =>
adamc@447 450 (p_edecl env d,
adamc@447 451 E.edeclBinds env d))
adamc@447 452 env ds
adamc@447 453 in
adamc@447 454 box [string "let",
adamc@447 455 newline,
adamc@447 456 box [p_list_sep newline (fn x => x) dsp],
adamc@447 457 newline,
adamc@447 458 string "in",
adamc@447 459 newline,
adamc@447 460 box [p_exp env e],
adamc@447 461 newline,
adamc@447 462 string "end"]
adamc@447 463 end
adamc@447 464
adamc@623 465 | EKAbs (x, e) => box [string x,
adamc@623 466 space,
adamc@623 467 string "==>",
adamc@623 468 space,
adamc@623 469 p_exp (E.pushKRel env x) e]
adamc@623 470 | EKApp (e, k) => box [p_exp env e,
adamc@623 471 string "[[",
adamc@623 472 p_kind env k,
adamc@623 473 string "]]"]
adamc@623 474
adamc@9 475 and p_exp env = p_exp' false env
adamc@9 476
adamc@447 477 and p_edecl env (dAll as (d, _)) =
adamc@447 478 case d of
adamc@825 479 EDVal (p, t, e) => box [string "val",
adamc@825 480 space,
adamc@825 481 p_pat env p,
adamc@825 482 space,
adamc@825 483 string ":",
adamc@825 484 space,
adamc@825 485 p_con env t,
adamc@825 486 space,
adamc@825 487 string "=",
adamc@825 488 space,
adamc@825 489 p_exp env e]
adamc@447 490 | EDValRec vis =>
adamc@447 491 let
adamc@447 492 val env = E.edeclBinds env dAll
adamc@447 493 in
adamc@447 494 box [string "val",
adamc@447 495 space,
adamc@447 496 string "rec",
adamc@447 497 space,
adamc@447 498 p_list_sep (box [newline, string "and", space]) (p_evali env) vis]
adamc@447 499 end
adamc@447 500
adamc@447 501 and p_evali env (x, t, e) = box [string x,
adamc@447 502 space,
adamc@447 503 string ":",
adamc@447 504 space,
adamc@447 505 p_con env t,
adamc@447 506 space,
adamc@447 507 string "=",
adamc@447 508 space,
adamc@447 509 p_exp env e]
adamc@31 510
adamc@191 511 fun p_datatype env (x, n, xs, cons) =
adamc@156 512 let
adamc@191 513 val k = (KType, ErrorMsg.dummySpan)
adamc@191 514 val env = E.pushCNamedAs env x n k NONE
adamc@191 515 val env = foldl (fn (x, env) => E.pushCRel env x k) env xs
adamc@156 516 in
adamc@805 517 box [string x,
adamc@191 518 p_list_sep (box []) (fn x => box [space, string x]) xs,
adamc@156 519 space,
adamc@156 520 string "=",
adamc@156 521 space,
adamc@156 522 p_list_sep (box [space, string "|", space])
adamc@156 523 (fn (x, _, NONE) => string x
adamc@156 524 | (x, _, SOME t) => box [string x, space, string "of", space, p_con env t])
adamc@156 525 cons]
adamc@156 526 end
adamc@156 527
adamc@447 528 fun p_named x n =
adamc@447 529 if !debug then
adamc@447 530 box [string x,
adamc@447 531 string "__",
adamc@447 532 string (Int.toString n)]
adamc@447 533 else
adamc@447 534 string x
adamc@447 535
adamc@805 536 fun p_sgn_item env (sgiAll as (sgi, _)) =
adamc@31 537 case sgi of
adamc@31 538 SgiConAbs (x, n, k) => box [string "con",
adamc@31 539 space,
adamc@31 540 p_named x n,
adamc@31 541 space,
adamc@31 542 string "::",
adamc@31 543 space,
adamc@623 544 p_kind env k]
adamc@31 545 | SgiCon (x, n, k, c) => box [string "con",
adamc@31 546 space,
adamc@31 547 p_named x n,
adamc@31 548 space,
adamc@31 549 string "::",
adamc@31 550 space,
adamc@623 551 p_kind env k,
adamc@31 552 space,
adamc@31 553 string "=",
adamc@31 554 space,
adamc@31 555 p_con env c]
adamc@805 556 | SgiDatatype x => box [string "datatype",
adamc@805 557 space,
adamc@805 558 p_list_sep (box [space, string "and", space]) (p_datatype (E.sgiBinds env sgiAll)) x]
adamc@191 559 | SgiDatatypeImp (x, _, m1, ms, x', _, _) =>
adamc@156 560 let
adamc@156 561 val m1x = #1 (E.lookupStrNamed env m1)
adamc@156 562 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@156 563 in
adamc@156 564 box [string "datatype",
adamc@156 565 space,
adamc@156 566 string x,
adamc@156 567 space,
adamc@156 568 string "=",
adamc@156 569 space,
adamc@156 570 string "datatype",
adamc@156 571 space,
adamc@156 572 p_list_sep (string ".") string (m1x :: ms @ [x'])]
adamc@156 573 end
adamc@31 574 | SgiVal (x, n, c) => box [string "val",
adamc@31 575 space,
adamc@31 576 p_named x n,
adamc@31 577 space,
adamc@31 578 string ":",
adamc@31 579 space,
adamc@31 580 p_con env c]
adamc@31 581 | SgiStr (x, n, sgn) => box [string "structure",
adamc@31 582 space,
adamc@31 583 p_named x n,
adamc@31 584 space,
adamc@31 585 string ":",
adamc@31 586 space,
adamc@31 587 p_sgn env sgn]
adamc@59 588 | SgiSgn (x, n, sgn) => box [string "signature",
adamc@59 589 space,
adamc@59 590 p_named x n,
adamc@59 591 space,
adamc@59 592 string "=",
adamc@59 593 space,
adamc@59 594 p_sgn env sgn]
adamc@88 595 | SgiConstraint (c1, c2) => box [string "constraint",
adamc@88 596 space,
adamc@88 597 p_con env c1,
adamc@88 598 space,
adamc@88 599 string "~",
adamc@88 600 space,
adamc@88 601 p_con env c2]
adamc@563 602 | SgiClassAbs (x, n, k) => box [string "class",
adamc@563 603 space,
adamc@563 604 p_named x n,
adamc@563 605 space,
adamc@563 606 string "::",
adamc@563 607 space,
adamc@623 608 p_kind env k]
adamc@563 609 | SgiClass (x, n, k, c) => box [string "class",
adamc@563 610 space,
adamc@563 611 p_named x n,
adamc@563 612 space,
adamc@563 613 string "::",
adamc@563 614 space,
adamc@623 615 p_kind env k,
adamc@563 616 space,
adamc@563 617 string "=",
adamc@563 618 space,
adamc@563 619 p_con env c]
adamc@31 620
adamc@31 621 and p_sgn env (sgn, _) =
adamc@31 622 case sgn of
adamc@31 623 SgnConst sgis => box [string "sig",
adamc@31 624 newline,
adamc@32 625 let
adamc@32 626 val (psgis, _) = ListUtil.foldlMap (fn (sgi, env) =>
adamc@32 627 (p_sgn_item env sgi,
adamc@32 628 E.sgiBinds env sgi))
adamc@32 629 env sgis
adamc@32 630 in
adamc@32 631 p_list_sep newline (fn x => x) psgis
adamc@32 632 end,
adamc@31 633 newline,
adamc@31 634 string "end"]
adamc@88 635 | SgnVar n => ((string (#1 (E.lookupSgnNamed env n)))
adamc@88 636 handle E.UnboundNamed _ => string ("UNBOUND_SGN_" ^ Int.toString n))
adamc@41 637 | SgnFun (x, n, sgn, sgn') => box [string "functor",
adamc@41 638 space,
adamc@41 639 string "(",
adamc@41 640 string x,
adamc@41 641 space,
adamc@41 642 string ":",
adamc@41 643 space,
adamc@41 644 p_sgn env sgn,
adamc@41 645 string ")",
adamc@41 646 space,
adamc@41 647 string ":",
adamc@41 648 space,
adamc@41 649 p_sgn (E.pushStrNamedAs env x n sgn) sgn']
adamc@42 650 | SgnWhere (sgn, x, c) => box [p_sgn env sgn,
adamc@42 651 space,
adamc@42 652 string "where",
adamc@42 653 space,
adamc@42 654 string "con",
adamc@42 655 space,
adamc@42 656 string x,
adamc@42 657 space,
adamc@42 658 string "=",
adamc@42 659 space,
adamc@42 660 p_con env c]
adamc@59 661 | SgnProj (m1, ms, x) =>
adamc@59 662 let
adamc@88 663 val m1x = #1 (E.lookupStrNamed env m1)
adamc@88 664 handle E.UnboundNamed _ => "UNBOUND_SGN_" ^ Int.toString m1
adamc@88 665
adamc@59 666 val m1s = if !debug then
adamc@59 667 m1x ^ "__" ^ Int.toString m1
adamc@59 668 else
adamc@59 669 m1x
adamc@88 670 in
adamc@59 671 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@59 672 end
adamc@31 673 | SgnError => string "<ERROR>"
adamc@31 674
adamc@123 675 fun p_vali env (x, n, t, e) = box [p_named x n,
adamc@123 676 space,
adamc@123 677 string ":",
adamc@123 678 space,
adamc@123 679 p_con env t,
adamc@123 680 space,
adamc@123 681 string "=",
adamc@123 682 space,
adamc@123 683 p_exp env e]
adamc@123 684
adamc@447 685
adamc@447 686
adamc@123 687 fun p_decl env (dAll as (d, _) : decl) =
adamc@3 688 case d of
adamc@31 689 DCon (x, n, k, c) => box [string "con",
adamc@31 690 space,
adamc@31 691 p_named x n,
adamc@31 692 space,
adamc@31 693 string "::",
adamc@31 694 space,
adamc@623 695 p_kind env k,
adamc@31 696 space,
adamc@31 697 string "=",
adamc@31 698 space,
adamc@31 699 p_con env c]
adamc@805 700 | DDatatype x => box [string "datatype",
adamc@805 701 space,
adamc@805 702 p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x]
adamc@191 703 | DDatatypeImp (x, _, m1, ms, x', _, _) =>
adamc@156 704 let
adamc@156 705 val m1x = #1 (E.lookupStrNamed env m1)
adamc@156 706 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@156 707 in
adamc@156 708 box [string "datatype",
adamc@156 709 space,
adamc@156 710 string x,
adamc@156 711 space,
adamc@156 712 string "=",
adamc@156 713 space,
adamc@156 714 string "datatype",
adamc@156 715 space,
adamc@156 716 p_list_sep (string ".") string (m1x :: ms @ [x'])]
adamc@156 717 end
adamc@123 718 | DVal vi => box [string "val",
adamc@123 719 space,
adamc@123 720 p_vali env vi]
adamc@123 721 | DValRec vis =>
adamc@123 722 let
adamc@123 723 val env = E.declBinds env dAll
adamc@123 724 in
adamc@123 725 box [string "val",
adamc@123 726 space,
adamc@123 727 string "rec",
adamc@123 728 space,
adamc@123 729 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@123 730 end
adamc@31 731
adamc@31 732 | DSgn (x, n, sgn) => box [string "signature",
adamc@31 733 space,
adamc@31 734 p_named x n,
adamc@31 735 space,
adamc@31 736 string "=",
adamc@31 737 space,
adamc@31 738 p_sgn env sgn]
adamc@31 739 | DStr (x, n, sgn, str) => box [string "structure",
adamc@31 740 space,
adamc@31 741 p_named x n,
adamc@31 742 space,
adamc@31 743 string ":",
adamc@31 744 space,
adamc@31 745 p_sgn env sgn,
adamc@31 746 space,
adamc@31 747 string "=",
adamc@31 748 space,
adamc@31 749 p_str env str]
adamc@48 750 | DFfiStr (x, n, sgn) => box [string "extern",
adamc@48 751 space,
adamc@48 752 string "structure",
adamc@48 753 space,
adamc@48 754 p_named x n,
adamc@48 755 space,
adamc@48 756 string ":",
adamc@48 757 space,
adamc@48 758 p_sgn env sgn]
adamc@88 759 | DConstraint (c1, c2) => box [string "constraint",
adamc@88 760 space,
adamc@88 761 p_con env c1,
adamc@88 762 space,
adamc@88 763 string "~",
adamc@88 764 space,
adamc@88 765 p_con env c2]
adamc@109 766 | DExport (_, sgn, str) => box [string "export",
adamc@110 767 space,
adamc@109 768 p_str env str,
adamc@109 769 space,
adamc@109 770 string ":",
adamc@109 771 space,
adamc@109 772 p_sgn env sgn]
adamc@707 773 | DTable (_, x, n, c, pe, _, ce, _) => box [string "table",
adamc@707 774 space,
adamc@707 775 p_named x n,
adamc@707 776 space,
adamc@707 777 string ":",
adamc@707 778 space,
adamc@707 779 p_con env c,
adamc@707 780 space,
adamc@707 781 string "keys",
adamc@707 782 space,
adamc@707 783 p_exp env pe,
adamc@707 784 space,
adamc@707 785 string "constraints",
adamc@707 786 space,
adamc@707 787 p_exp env ce]
adamc@338 788 | DSequence (_, x, n) => box [string "sequence",
adamc@338 789 space,
adamc@338 790 p_named x n]
adamc@754 791 | DView (_, x, n, e, _) => box [string "view",
adamc@754 792 space,
adamc@754 793 p_named x n,
adamc@754 794 space,
adamc@754 795 string "as",
adamc@754 796 space,
adamc@754 797 p_exp env e]
adamc@563 798 | DClass (x, n, k, c) => box [string "class",
adamc@563 799 space,
adamc@563 800 p_named x n,
adamc@563 801 space,
adamc@563 802 string "::",
adamc@563 803 space,
adamc@623 804 p_kind env k,
adamc@563 805 space,
adamc@563 806 string "=",
adamc@563 807 space,
adamc@563 808 p_con env c]
adamc@271 809 | DDatabase s => box [string "database",
adamc@271 810 space,
adamc@271 811 string s]
adamc@459 812 | DCookie (_, x, n, c) => box [string "cookie",
adamc@459 813 space,
adamc@459 814 p_named x n,
adamc@459 815 space,
adamc@459 816 string ":",
adamc@459 817 space,
adamc@459 818 p_con env c]
adamc@720 819 | DStyle (_, x, n) => box [string "style",
adamc@720 820 space,
adamc@720 821 p_named x n]
adamc@1075 822 | DTask (e1, e2) => box [string "task",
adamc@1073 823 space,
adamc@1075 824 p_exp env e1,
adamc@1075 825 space,
adamc@1075 826 string "=",
adamc@1075 827 space,
adamc@1075 828 p_exp env e2]
adamc@1199 829 | DPolicy e1 => box [string "policy",
adamc@1199 830 space,
adamc@1199 831 p_exp env e1]
adam@1294 832 | DOnError _ => string "ONERROR"
adamc@31 833
adamc@31 834 and p_str env (str, _) =
adamc@31 835 case str of
adamc@31 836 StrConst ds => box [string "struct",
adamc@31 837 newline,
adamc@32 838 p_file env ds,
adamc@31 839 newline,
adamc@31 840 string "end"]
adamc@88 841 | StrVar n => ((string (#1 (E.lookupStrNamed env n)))
adamc@88 842 handle E.UnboundNamed _ => string ("UNBOUND_STR_" ^ Int.toString n))
adamc@34 843 | StrProj (str, s) => box [p_str env str,
adamc@34 844 string ".",
adamc@34 845 string s]
adamc@41 846 | StrFun (x, n, sgn, sgn', str) =>
adamc@41 847 let
adamc@41 848 val env' = E.pushStrNamedAs env x n sgn
adamc@41 849 in
adamc@41 850 box [string "functor",
adamc@41 851 space,
adamc@41 852 string "(",
adamc@41 853 string x,
adamc@41 854 space,
adamc@41 855 string ":",
adamc@41 856 space,
adamc@41 857 p_sgn env sgn,
adamc@41 858 string ")",
adamc@41 859 space,
adamc@41 860 string ":",
adamc@41 861 space,
adamc@41 862 p_sgn env' sgn',
adamc@41 863 space,
adamc@41 864 string "=>",
adamc@41 865 space,
adamc@41 866 p_str env' str]
adamc@41 867 end
adamc@44 868 | StrApp (str1, str2) => box [p_str env str1,
adamc@44 869 string "(",
adamc@44 870 p_str env str2,
adamc@44 871 string ")"]
adamc@31 872 | StrError => string "<ERROR>"
adamc@3 873
adamc@32 874 and p_file env file =
adamc@3 875 let
adamc@31 876 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 877 (p_decl env d,
adamc@31 878 E.declBinds env d))
adamc@31 879 env file
adamc@3 880 in
adamc@3 881 p_list_sep newline (fn x => x) pds
adamc@3 882 end
adamc@3 883
adamc@3 884 end