Mercurial > urweb

annotate src/elab_print.sml @ 305:55eedecb6c50

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove need to mention table name in expressions for UPDATE and DELETE
author Adam Chlipala <adamc@hcoop.net>
date Sun, 07 Sep 2008 14:30:32 -0400
parents 42dfb0d61cf0
children 9601c717d2f3
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@3 41 fun p_kind' par (k, _) =
adamc@3 42 case k of
adamc@3 43 KType => string "Type"
adamc@3 44 | KArrow (k1, k2) => parenIf par (box [p_kind' true k1,
adamc@3 45 space,
adamc@3 46 string "->",
adamc@3 47 space,
adamc@3 48 p_kind k2])
adamc@3 49 | KName => string "Name"
adamc@3 50 | KRecord k => box [string "{", p_kind k, string "}"]
adamc@82 51 | KUnit => string "Unit"
adamc@207 52 | KTuple ks => box [string "(",
adamc@207 53 p_list_sep (box [space, string "*", space]) p_kind ks,
adamc@207 54 string ")"]
adamc@3 55
adamc@3 56 | KError => string "<ERROR>"
adamc@76 57 | KUnif (_, _, ref (SOME k)) => p_kind' par k
adamc@76 58 | KUnif (_, s, _) => string ("<UNIF:" ^ s ^ ">")
adamc@3 59
adamc@3 60 and p_kind k = p_kind' false k
adamc@3 61
adamc@3 62 fun p_explicitness e =
adamc@3 63 case e of
adamc@3 64 Explicit => string "::"
adamc@3 65 | Implicit => string ":::"
adamc@3 66
adamc@3 67 fun p_con' par env (c, _) =
adamc@3 68 case c of
adamc@3 69 TFun (t1, t2) => parenIf par (box [p_con' true env t1,
adamc@3 70 space,
adamc@3 71 string "->",
adamc@3 72 space,
adamc@3 73 p_con env t2])
adamc@3 74 | TCFun (e, x, k, c) => parenIf par (box [string x,
adamc@3 75 space,
adamc@3 76 p_explicitness e,
adamc@3 77 space,
adamc@3 78 p_kind k,
adamc@3 79 space,
adamc@3 80 string "->",
adamc@3 81 space,
adamc@3 82 p_con (E.pushCRel env x k) c])
adamc@85 83 | TDisjoint (c1, c2, c3) => parenIf par (box [p_con env c1,
adamc@85 84 space,
adamc@85 85 string "~",
adamc@85 86 space,
adamc@85 87 p_con env c2,
adamc@85 88 space,
adamc@85 89 string "->",
adamc@85 90 space,
adamc@85 91 p_con env c3])
adamc@3 92 | TRecord (CRecord (_, xcs), _) => box [string "{",
adamc@3 93 p_list (fn (x, c) =>
adamc@20 94 box [p_name env x,
adamc@3 95 space,
adamc@3 96 string ":",
adamc@3 97 space,
adamc@3 98 p_con env c]) xcs,
adamc@3 99 string "}"]
adamc@3 100 | TRecord c => box [string "$",
adamc@3 101 p_con' true env c]
adamc@3 102
adamc@11 103 | CRel n =>
adamc@71 104 ((if !debug then
adamc@71 105 string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n)
adamc@71 106 else
adamc@71 107 string (#1 (E.lookupCRel env n)))
adamc@71 108 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
adamc@11 109 | CNamed n =>
adamc@34 110 ((if !debug then
adamc@34 111 string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n)
adamc@34 112 else
adamc@34 113 string (#1 (E.lookupCNamed env n)))
adamc@34 114 handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
adamc@34 115 | CModProj (m1, ms, x) =>
adamc@34 116 let
adamc@88 117 val m1x = #1 (E.lookupStrNamed env m1)
adamc@88 118 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@88 119
adamc@34 120 val m1s = if !debug then
adamc@34 121 m1x ^ "__" ^ Int.toString m1
adamc@34 122 else
adamc@34 123 m1x
adamc@34 124 in
adamc@34 125 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@88 126 end
adamc@3 127
adamc@3 128 | CApp (c1, c2) => parenIf par (box [p_con env c1,
adamc@3 129 space,
adamc@3 130 p_con' true env c2])
adamc@147 131 | CAbs (x, k, c) => parenIf true (box [string "fn",
adamc@147 132 space,
adamc@147 133 string x,
adamc@147 134 space,
adamc@147 135 string "::",
adamc@147 136 space,
adamc@147 137 p_kind k,
adamc@147 138 space,
adamc@147 139 string "=>",
adamc@147 140 space,
adamc@147 141 p_con (E.pushCRel env x k) c])
adamc@84 142 | CDisjoint (c1, c2, c3) => parenIf par (box [p_con env c1,
adamc@84 143 space,
adamc@84 144 string "~",
adamc@84 145 space,
adamc@84 146 p_con env c2,
adamc@84 147 space,
adamc@84 148 string "=>",
adamc@84 149 space,
adamc@84 150 p_con env c3])
adamc@3 151
adamc@3 152 | CName s => box [string "#", string s]
adamc@3 153
adamc@12 154 | CRecord (k, xcs) =>
adamc@12 155 if !debug then
adamc@12 156 parenIf par (box [string "[",
adamc@12 157 p_list (fn (x, c) =>
adamc@12 158 box [p_con env x,
adamc@12 159 space,
adamc@12 160 string "=",
adamc@12 161 space,
adamc@12 162 p_con env c]) xcs,
adamc@12 163 string "]::",
adamc@12 164 p_kind k])
adamc@12 165 else
adamc@12 166 parenIf par (box [string "[",
adamc@12 167 p_list (fn (x, c) =>
adamc@12 168 box [p_con env x,
adamc@12 169 space,
adamc@12 170 string "=",
adamc@12 171 space,
adamc@12 172 p_con env c]) xcs,
adamc@12 173 string "]"])
adamc@3 174 | CConcat (c1, c2) => parenIf par (box [p_con' true env c1,
adamc@3 175 space,
adamc@3 176 string "++",
adamc@3 177 space,
adamc@3 178 p_con env c2])
adamc@67 179 | CFold _ => string "fold"
adamc@3 180
adamc@82 181 | CUnit => string "()"
adamc@82 182
adamc@207 183 | CTuple cs => box [string "(",
adamc@207 184 p_list (p_con env) cs,
adamc@207 185 string ")"]
adamc@207 186 | CProj (c, n) => box [p_con env c,
adamc@207 187 string ".",
adamc@207 188 string (Int.toString n)]
adamc@207 189
adamc@3 190 | CError => string "<ERROR>"
adamc@76 191 | CUnif (_, _, _, ref (SOME c)) => p_con' par env c
adamc@76 192 | CUnif (_, k, s, _) => box [string ("<UNIF:" ^ s ^ "::"),
adamc@76 193 p_kind k,
adamc@76 194 string ">"]
adamc@3 195
adamc@3 196 and p_con env = p_con' false env
adamc@3 197
adamc@20 198 and p_name env (all as (c, _)) =
adamc@20 199 case c of
adamc@20 200 CName s => string s
adamc@20 201 | _ => p_con env all
adamc@20 202
adamc@171 203 fun p_patCon env pc =
adamc@171 204 case pc of
adamc@171 205 PConVar n =>
adamc@171 206 ((if !debug then
adamc@171 207 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@171 208 else
adamc@171 209 string (#1 (E.lookupENamed env n)))
adamc@171 210 handle E.UnboundRel _ => string ("UNBOUND_NAMED" ^ Int.toString n))
adamc@171 211 | PConProj (m1, ms, x) =>
adamc@171 212 let
adamc@171 213 val m1x = #1 (E.lookupStrNamed env m1)
adamc@171 214 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@171 215
adamc@171 216 val m1s = if !debug then
adamc@171 217 m1x ^ "__" ^ Int.toString m1
adamc@171 218 else
adamc@171 219 m1x
adamc@171 220 in
adamc@171 221 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@171 222 end
adamc@171 223
adamc@171 224 fun p_pat' par env (p, _) =
adamc@171 225 case p of
adamc@171 226 PWild => string "_"
adamc@182 227 | PVar (s, _) => string s
adamc@173 228 | PPrim p => Prim.p_t p
adamc@191 229 | PCon (_, pc, _, NONE) => p_patCon env pc
adamc@191 230 | PCon (_, pc, _, SOME p) => parenIf par (box [p_patCon env pc,
adamc@188 231 space,
adamc@188 232 p_pat' true env p])
adamc@176 233 | PRecord xps =>
adamc@176 234 box [string "{",
adamc@182 235 p_list_sep (box [string ",", space]) (fn (x, p, _) =>
adamc@176 236 box [string x,
adamc@176 237 space,
adamc@176 238 string "=",
adamc@176 239 space,
adamc@176 240 p_pat env p]) xps,
adamc@176 241 string "}"]
adamc@171 242
adamc@175 243 and p_pat x = p_pat' false x
adamc@171 244
adamc@9 245 fun p_exp' par env (e, _) =
adamc@9 246 case e of
adamc@14 247 EPrim p => Prim.p_t p
adamc@14 248 | ERel n =>
adamc@88 249 ((if !debug then
adamc@88 250 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@88 251 else
adamc@88 252 string (#1 (E.lookupERel env n)))
adamc@88 253 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
adamc@11 254 | ENamed n =>
adamc@88 255 ((if !debug then
adamc@88 256 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@88 257 else
adamc@88 258 string (#1 (E.lookupENamed env n)))
adamc@88 259 handle E.UnboundRel _ => string ("UNBOUND_NAMED" ^ Int.toString n))
adamc@34 260 | EModProj (m1, ms, x) =>
adamc@34 261 let
adamc@88 262 val m1x = #1 (E.lookupStrNamed env m1)
adamc@88 263 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@88 264
adamc@34 265 val m1s = if !debug then
adamc@34 266 m1x ^ "__" ^ Int.toString m1
adamc@34 267 else
adamc@34 268 m1x
adamc@34 269 in
adamc@34 270 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@34 271 end
adamc@34 272
adamc@9 273 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
adamc@9 274 space,
adamc@9 275 p_exp' true env e2])
adamc@26 276 | EAbs (x, t, _, e) => parenIf par (box [string "fn",
adamc@26 277 space,
adamc@26 278 string x,
adamc@26 279 space,
adamc@26 280 string ":",
adamc@26 281 space,
adamc@26 282 p_con env t,
adamc@26 283 space,
adamc@26 284 string "=>",
adamc@26 285 space,
adamc@26 286 p_exp (E.pushERel env x t) e])
adamc@9 287 | ECApp (e, c) => parenIf par (box [p_exp env e,
adamc@9 288 space,
adamc@9 289 string "[",
adamc@9 290 p_con env c,
adamc@9 291 string "]"])
adamc@9 292 | ECAbs (exp, x, k, e) => parenIf par (box [string "fn",
adamc@9 293 space,
adamc@9 294 string x,
adamc@9 295 space,
adamc@9 296 p_explicitness exp,
adamc@9 297 space,
adamc@9 298 p_kind k,
adamc@9 299 space,
adamc@9 300 string "=>",
adamc@9 301 space,
adamc@9 302 p_exp (E.pushCRel env x k) e])
adamc@9 303
adamc@12 304 | ERecord xes => box [string "{",
adamc@29 305 p_list (fn (x, e, _) =>
adamc@21 306 box [p_name env x,
adamc@12 307 space,
adamc@12 308 string "=",
adamc@12 309 space,
adamc@12 310 p_exp env e]) xes,
adamc@12 311 string "}"]
adamc@12 312 | EField (e, c, {field, rest}) =>
adamc@12 313 if !debug then
adamc@12 314 box [p_exp' true env e,
adamc@12 315 string ".",
adamc@12 316 p_con' true env c,
adamc@12 317 space,
adamc@12 318 string "[",
adamc@12 319 p_con env field,
adamc@12 320 space,
adamc@12 321 string " in ",
adamc@12 322 space,
adamc@12 323 p_con env rest,
adamc@12 324 string "]"]
adamc@12 325 else
adamc@12 326 box [p_exp' true env e,
adamc@12 327 string ".",
adamc@12 328 p_con' true env c]
adamc@149 329 | ECut (e, c, {field, rest}) =>
adamc@149 330 parenIf par (if !debug then
adamc@149 331 box [p_exp' true env e,
adamc@149 332 space,
adamc@149 333 string "--",
adamc@149 334 space,
adamc@149 335 p_con' true env c,
adamc@149 336 space,
adamc@149 337 string "[",
adamc@149 338 p_con env field,
adamc@149 339 space,
adamc@149 340 string " in ",
adamc@149 341 space,
adamc@149 342 p_con env rest,
adamc@149 343 string "]"]
adamc@149 344 else
adamc@149 345 box [p_exp' true env e,
adamc@149 346 space,
adamc@149 347 string "--",
adamc@149 348 space,
adamc@149 349 p_con' true env c])
adamc@72 350 | EFold _ => string "fold"
adamc@71 351
adamc@171 352 | ECase (e, pes, _) => parenIf par (box [string "case",
adamc@171 353 space,
adamc@171 354 p_exp env e,
adamc@171 355 space,
adamc@171 356 string "of",
adamc@171 357 space,
adamc@171 358 p_list_sep (box [space, string "|", space])
adamc@171 359 (fn (p, e) => box [p_pat env p,
adamc@171 360 space,
adamc@171 361 string "=>",
adamc@171 362 space,
adamc@243 363 p_exp (E.patBinds env p) e]) pes])
adamc@171 364
adamc@9 365 | EError => string "<ERROR>"
adamc@228 366 | EUnif (ref (SOME e)) => p_exp env e
adamc@228 367 | EUnif _ => string "_"
adamc@9 368
adamc@9 369 and p_exp env = p_exp' false env
adamc@9 370
adamc@31 371 fun p_named x n =
adamc@31 372 if !debug then
adamc@31 373 box [string x,
adamc@31 374 string "__",
adamc@31 375 string (Int.toString n)]
adamc@31 376 else
adamc@31 377 string x
adamc@31 378
adamc@191 379 fun p_datatype env (x, n, xs, cons) =
adamc@156 380 let
adamc@191 381 val k = (KType, ErrorMsg.dummySpan)
adamc@191 382 val env = E.pushCNamedAs env x n k NONE
adamc@191 383 val env = foldl (fn (x, env) => E.pushCRel env x k) env xs
adamc@156 384 in
adamc@156 385 box [string "datatype",
adamc@156 386 space,
adamc@156 387 string x,
adamc@191 388 p_list_sep (box []) (fn x => box [space, string x]) xs,
adamc@156 389 space,
adamc@156 390 string "=",
adamc@156 391 space,
adamc@156 392 p_list_sep (box [space, string "|", space])
adamc@156 393 (fn (x, _, NONE) => string x
adamc@156 394 | (x, _, SOME t) => box [string x, space, string "of", space, p_con env t])
adamc@156 395 cons]
adamc@156 396 end
adamc@156 397
adamc@31 398 fun p_sgn_item env (sgi, _) =
adamc@31 399 case sgi of
adamc@31 400 SgiConAbs (x, n, k) => box [string "con",
adamc@31 401 space,
adamc@31 402 p_named x n,
adamc@31 403 space,
adamc@31 404 string "::",
adamc@31 405 space,
adamc@31 406 p_kind k]
adamc@31 407 | SgiCon (x, n, k, c) => box [string "con",
adamc@31 408 space,
adamc@31 409 p_named x n,
adamc@31 410 space,
adamc@31 411 string "::",
adamc@31 412 space,
adamc@31 413 p_kind k,
adamc@31 414 space,
adamc@31 415 string "=",
adamc@31 416 space,
adamc@31 417 p_con env c]
adamc@156 418 | SgiDatatype x => p_datatype env x
adamc@191 419 | SgiDatatypeImp (x, _, m1, ms, x', _, _) =>
adamc@156 420 let
adamc@156 421 val m1x = #1 (E.lookupStrNamed env m1)
adamc@156 422 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@156 423 in
adamc@156 424 box [string "datatype",
adamc@156 425 space,
adamc@156 426 string x,
adamc@156 427 space,
adamc@156 428 string "=",
adamc@156 429 space,
adamc@156 430 string "datatype",
adamc@156 431 space,
adamc@156 432 p_list_sep (string ".") string (m1x :: ms @ [x'])]
adamc@156 433 end
adamc@31 434 | SgiVal (x, n, c) => box [string "val",
adamc@31 435 space,
adamc@31 436 p_named x n,
adamc@31 437 space,
adamc@31 438 string ":",
adamc@31 439 space,
adamc@31 440 p_con env c]
adamc@31 441 | SgiStr (x, n, sgn) => box [string "structure",
adamc@31 442 space,
adamc@31 443 p_named x n,
adamc@31 444 space,
adamc@31 445 string ":",
adamc@31 446 space,
adamc@31 447 p_sgn env sgn]
adamc@59 448 | SgiSgn (x, n, sgn) => box [string "signature",
adamc@59 449 space,
adamc@59 450 p_named x n,
adamc@59 451 space,
adamc@59 452 string "=",
adamc@59 453 space,
adamc@59 454 p_sgn env sgn]
adamc@88 455 | SgiConstraint (c1, c2) => box [string "constraint",
adamc@88 456 space,
adamc@88 457 p_con env c1,
adamc@88 458 space,
adamc@88 459 string "~",
adamc@88 460 space,
adamc@88 461 p_con env c2]
adamc@205 462 | SgiTable (_, x, n, c) => box [string "table",
adamc@205 463 space,
adamc@205 464 p_named x n,
adamc@205 465 space,
adamc@205 466 string ":",
adamc@205 467 space,
adamc@205 468 p_con env c]
adamc@211 469 | SgiClassAbs (x, n) => box [string "class",
adamc@211 470 space,
adamc@211 471 p_named x n]
adamc@211 472 | SgiClass (x, n, c) => box [string "class",
adamc@211 473 space,
adamc@211 474 p_named x n,
adamc@211 475 space,
adamc@211 476 string "=",
adamc@211 477 space,
adamc@211 478 p_con env c]
adamc@31 479
adamc@31 480 and p_sgn env (sgn, _) =
adamc@31 481 case sgn of
adamc@31 482 SgnConst sgis => box [string "sig",
adamc@31 483 newline,
adamc@32 484 let
adamc@32 485 val (psgis, _) = ListUtil.foldlMap (fn (sgi, env) =>
adamc@32 486 (p_sgn_item env sgi,
adamc@32 487 E.sgiBinds env sgi))
adamc@32 488 env sgis
adamc@32 489 in
adamc@32 490 p_list_sep newline (fn x => x) psgis
adamc@32 491 end,
adamc@31 492 newline,
adamc@31 493 string "end"]
adamc@88 494 | SgnVar n => ((string (#1 (E.lookupSgnNamed env n)))
adamc@88 495 handle E.UnboundNamed _ => string ("UNBOUND_SGN_" ^ Int.toString n))
adamc@41 496 | SgnFun (x, n, sgn, sgn') => box [string "functor",
adamc@41 497 space,
adamc@41 498 string "(",
adamc@41 499 string x,
adamc@41 500 space,
adamc@41 501 string ":",
adamc@41 502 space,
adamc@41 503 p_sgn env sgn,
adamc@41 504 string ")",
adamc@41 505 space,
adamc@41 506 string ":",
adamc@41 507 space,
adamc@41 508 p_sgn (E.pushStrNamedAs env x n sgn) sgn']
adamc@42 509 | SgnWhere (sgn, x, c) => box [p_sgn env sgn,
adamc@42 510 space,
adamc@42 511 string "where",
adamc@42 512 space,
adamc@42 513 string "con",
adamc@42 514 space,
adamc@42 515 string x,
adamc@42 516 space,
adamc@42 517 string "=",
adamc@42 518 space,
adamc@42 519 p_con env c]
adamc@59 520 | SgnProj (m1, ms, x) =>
adamc@59 521 let
adamc@88 522 val m1x = #1 (E.lookupStrNamed env m1)
adamc@88 523 handle E.UnboundNamed _ => "UNBOUND_SGN_" ^ Int.toString m1
adamc@88 524
adamc@59 525 val m1s = if !debug then
adamc@59 526 m1x ^ "__" ^ Int.toString m1
adamc@59 527 else
adamc@59 528 m1x
adamc@88 529 in
adamc@59 530 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@59 531 end
adamc@31 532 | SgnError => string "<ERROR>"
adamc@31 533
adamc@123 534 fun p_vali env (x, n, t, e) = box [p_named x n,
adamc@123 535 space,
adamc@123 536 string ":",
adamc@123 537 space,
adamc@123 538 p_con env t,
adamc@123 539 space,
adamc@123 540 string "=",
adamc@123 541 space,
adamc@123 542 p_exp env e]
adamc@123 543
adamc@123 544 fun p_decl env (dAll as (d, _) : decl) =
adamc@3 545 case d of
adamc@31 546 DCon (x, n, k, c) => box [string "con",
adamc@31 547 space,
adamc@31 548 p_named x n,
adamc@31 549 space,
adamc@31 550 string "::",
adamc@31 551 space,
adamc@31 552 p_kind k,
adamc@31 553 space,
adamc@31 554 string "=",
adamc@31 555 space,
adamc@31 556 p_con env c]
adamc@156 557 | DDatatype x => p_datatype env x
adamc@191 558 | DDatatypeImp (x, _, m1, ms, x', _, _) =>
adamc@156 559 let
adamc@156 560 val m1x = #1 (E.lookupStrNamed env m1)
adamc@156 561 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@156 562 in
adamc@156 563 box [string "datatype",
adamc@156 564 space,
adamc@156 565 string x,
adamc@156 566 space,
adamc@156 567 string "=",
adamc@156 568 space,
adamc@156 569 string "datatype",
adamc@156 570 space,
adamc@156 571 p_list_sep (string ".") string (m1x :: ms @ [x'])]
adamc@156 572 end
adamc@123 573 | DVal vi => box [string "val",
adamc@123 574 space,
adamc@123 575 p_vali env vi]
adamc@123 576 | DValRec vis =>
adamc@123 577 let
adamc@123 578 val env = E.declBinds env dAll
adamc@123 579 in
adamc@123 580 box [string "val",
adamc@123 581 space,
adamc@123 582 string "rec",
adamc@123 583 space,
adamc@123 584 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@123 585 end
adamc@31 586
adamc@31 587 | DSgn (x, n, sgn) => box [string "signature",
adamc@31 588 space,
adamc@31 589 p_named x n,
adamc@31 590 space,
adamc@31 591 string "=",
adamc@31 592 space,
adamc@31 593 p_sgn env sgn]
adamc@31 594 | DStr (x, n, sgn, str) => box [string "structure",
adamc@31 595 space,
adamc@31 596 p_named x n,
adamc@31 597 space,
adamc@31 598 string ":",
adamc@31 599 space,
adamc@31 600 p_sgn env sgn,
adamc@31 601 space,
adamc@31 602 string "=",
adamc@31 603 space,
adamc@31 604 p_str env str]
adamc@48 605 | DFfiStr (x, n, sgn) => box [string "extern",
adamc@48 606 space,
adamc@48 607 string "structure",
adamc@48 608 space,
adamc@48 609 p_named x n,
adamc@48 610 space,
adamc@48 611 string ":",
adamc@48 612 space,
adamc@48 613 p_sgn env sgn]
adamc@88 614 | DConstraint (c1, c2) => box [string "constraint",
adamc@88 615 space,
adamc@88 616 p_con env c1,
adamc@88 617 space,
adamc@88 618 string "~",
adamc@88 619 space,
adamc@88 620 p_con env c2]
adamc@109 621 | DExport (_, sgn, str) => box [string "export",
adamc@110 622 space,
adamc@109 623 p_str env str,
adamc@109 624 space,
adamc@109 625 string ":",
adamc@109 626 space,
adamc@109 627 p_sgn env sgn]
adamc@205 628 | DTable (_, x, n, c) => box [string "table",
adamc@205 629 space,
adamc@205 630 p_named x n,
adamc@205 631 space,
adamc@205 632 string ":",
adamc@205 633 space,
adamc@205 634 p_con env c]
adamc@271 635 | DClass (x, n, c) => box [string "class",
adamc@271 636 space,
adamc@271 637 p_named x n,
adamc@271 638 space,
adamc@271 639 string "=",
adamc@271 640 space,
adamc@271 641 p_con env c]
adamc@271 642 | DDatabase s => box [string "database",
adamc@271 643 space,
adamc@271 644 string s]
adamc@31 645
adamc@31 646 and p_str env (str, _) =
adamc@31 647 case str of
adamc@31 648 StrConst ds => box [string "struct",
adamc@31 649 newline,
adamc@32 650 p_file env ds,
adamc@31 651 newline,
adamc@31 652 string "end"]
adamc@88 653 | StrVar n => ((string (#1 (E.lookupStrNamed env n)))
adamc@88 654 handle E.UnboundNamed _ => string ("UNBOUND_STR_" ^ Int.toString n))
adamc@34 655 | StrProj (str, s) => box [p_str env str,
adamc@34 656 string ".",
adamc@34 657 string s]
adamc@41 658 | StrFun (x, n, sgn, sgn', str) =>
adamc@41 659 let
adamc@41 660 val env' = E.pushStrNamedAs env x n sgn
adamc@41 661 in
adamc@41 662 box [string "functor",
adamc@41 663 space,
adamc@41 664 string "(",
adamc@41 665 string x,
adamc@41 666 space,
adamc@41 667 string ":",
adamc@41 668 space,
adamc@41 669 p_sgn env sgn,
adamc@41 670 string ")",
adamc@41 671 space,
adamc@41 672 string ":",
adamc@41 673 space,
adamc@41 674 p_sgn env' sgn',
adamc@41 675 space,
adamc@41 676 string "=>",
adamc@41 677 space,
adamc@41 678 p_str env' str]
adamc@41 679 end
adamc@44 680 | StrApp (str1, str2) => box [p_str env str1,
adamc@44 681 string "(",
adamc@44 682 p_str env str2,
adamc@44 683 string ")"]
adamc@31 684 | StrError => string "<ERROR>"
adamc@3 685
adamc@32 686 and p_file env file =
adamc@3 687 let
adamc@31 688 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 689 (p_decl env d,
adamc@31 690 E.declBinds env d))
adamc@31 691 env file
adamc@3 692 in
adamc@3 693 p_list_sep newline (fn x => x) pds
adamc@3 694 end
adamc@3 695
adamc@3 696 end