Mercurial > urweb

annotate src/elab_print.sml @ 709:0406e9cccb72

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
FOREIGN KEY, without ability to link NULL to NOT NULL (and with some lingering problems in row inference)
author Adam Chlipala <adamc@hcoop.net>
date Tue, 07 Apr 2009 18:47:47 -0400
parents d8217b4cb617
children f152f215a02c
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>"
adamc@623 57 | KUnif (_, _, ref (SOME k)) => p_kind' par env k
adamc@76 58 | KUnif (_, s, _) => string ("<UNIF:" ^ s ^ ">")
adamc@3 59
adamc@623 60 | KRel n => ((if !debug then
adamc@623 61 string (E.lookupKRel env n ^ "_" ^ Int.toString n)
adamc@623 62 else
adamc@623 63 string (E.lookupKRel env n))
adamc@623 64 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
adamc@623 65 | KFun (x, k) => box [string x,
adamc@623 66 space,
adamc@623 67 string "-->",
adamc@623 68 space,
adamc@623 69 p_kind (E.pushKRel env x) k]
adamc@623 70
adamc@624 71 and p_kind env = p_kind' false env
adamc@3 72
adamc@3 73 fun p_explicitness e =
adamc@3 74 case e of
adamc@3 75 Explicit => string "::"
adamc@3 76 | Implicit => string ":::"
adamc@3 77
adamc@3 78 fun p_con' par env (c, _) =
adamc@3 79 case c of
adamc@623 80 TFun (t1, t2) => parenIf true (box [p_con' true env t1,
adamc@3 81 space,
adamc@3 82 string "->",
adamc@3 83 space,
adamc@3 84 p_con env t2])
adamc@3 85 | TCFun (e, x, k, c) => parenIf par (box [string x,
adamc@3 86 space,
adamc@3 87 p_explicitness e,
adamc@3 88 space,
adamc@623 89 p_kind env k,
adamc@3 90 space,
adamc@3 91 string "->",
adamc@3 92 space,
adamc@3 93 p_con (E.pushCRel env x k) c])
adamc@628 94 | TDisjoint (c1, c2, c3) => parenIf par (box [string "[",
adamc@628 95 p_con env c1,
adamc@628 96 space,
adamc@628 97 string "~",
adamc@628 98 space,
adamc@628 99 p_con env c2,
adamc@628 100 string "]",
adamc@628 101 space,
adamc@628 102 string "=>",
adamc@628 103 space,
adamc@628 104 p_con env c3])
adamc@3 105 | TRecord (CRecord (_, xcs), _) => box [string "{",
adamc@3 106 p_list (fn (x, c) =>
adamc@20 107 box [p_name env x,
adamc@3 108 space,
adamc@3 109 string ":",
adamc@3 110 space,
adamc@3 111 p_con env c]) xcs,
adamc@3 112 string "}"]
adamc@3 113 | TRecord c => box [string "$",
adamc@3 114 p_con' true env c]
adamc@3 115
adamc@11 116 | CRel n =>
adamc@71 117 ((if !debug then
adamc@71 118 string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n)
adamc@71 119 else
adamc@71 120 string (#1 (E.lookupCRel env n)))
adamc@71 121 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
adamc@11 122 | CNamed n =>
adamc@34 123 ((if !debug then
adamc@34 124 string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n)
adamc@34 125 else
adamc@34 126 string (#1 (E.lookupCNamed env n)))
adamc@34 127 handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
adamc@34 128 | CModProj (m1, ms, x) =>
adamc@34 129 let
adamc@88 130 val m1x = #1 (E.lookupStrNamed env m1)
adamc@88 131 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@88 132
adamc@34 133 val m1s = if !debug then
adamc@34 134 m1x ^ "__" ^ Int.toString m1
adamc@34 135 else
adamc@34 136 m1x
adamc@34 137 in
adamc@34 138 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@88 139 end
adamc@3 140
adamc@3 141 | CApp (c1, c2) => parenIf par (box [p_con env c1,
adamc@3 142 space,
adamc@3 143 p_con' true env c2])
adamc@147 144 | CAbs (x, k, c) => parenIf true (box [string "fn",
adamc@147 145 space,
adamc@147 146 string x,
adamc@147 147 space,
adamc@147 148 string "::",
adamc@147 149 space,
adamc@623 150 p_kind env k,
adamc@147 151 space,
adamc@147 152 string "=>",
adamc@147 153 space,
adamc@147 154 p_con (E.pushCRel env x k) c])
adamc@3 155
adamc@3 156 | CName s => box [string "#", string s]
adamc@3 157
adamc@12 158 | CRecord (k, xcs) =>
adamc@12 159 if !debug then
adamc@12 160 parenIf par (box [string "[",
adamc@12 161 p_list (fn (x, c) =>
adamc@12 162 box [p_con env x,
adamc@12 163 space,
adamc@12 164 string "=",
adamc@12 165 space,
adamc@12 166 p_con env c]) xcs,
adamc@12 167 string "]::",
adamc@623 168 p_kind env k])
adamc@12 169 else
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@3 178 | CConcat (c1, c2) => parenIf par (box [p_con' true env c1,
adamc@3 179 space,
adamc@3 180 string "++",
adamc@3 181 space,
adamc@3 182 p_con env c2])
adamc@621 183 | CMap _ => string "map"
adamc@3 184
adamc@82 185 | CUnit => string "()"
adamc@82 186
adamc@207 187 | CTuple cs => box [string "(",
adamc@207 188 p_list (p_con env) cs,
adamc@207 189 string ")"]
adamc@207 190 | CProj (c, n) => box [p_con env c,
adamc@207 191 string ".",
adamc@207 192 string (Int.toString n)]
adamc@207 193
adamc@3 194 | CError => string "<ERROR>"
adamc@76 195 | CUnif (_, _, _, ref (SOME c)) => p_con' par env c
adamc@76 196 | CUnif (_, k, s, _) => box [string ("<UNIF:" ^ s ^ "::"),
adamc@623 197 p_kind env k,
adamc@76 198 string ">"]
adamc@623 199
adamc@623 200 | CKAbs (x, c) => box [string x,
adamc@623 201 space,
adamc@623 202 string "==>",
adamc@623 203 space,
adamc@623 204 p_con (E.pushKRel env x) c]
adamc@623 205 | CKApp (c, k) => box [p_con env c,
adamc@623 206 string "[[",
adamc@623 207 p_kind env k,
adamc@623 208 string "]]"]
adamc@623 209 | TKFun (x, c) => box [string x,
adamc@623 210 space,
adamc@623 211 string "-->",
adamc@623 212 space,
adamc@623 213 p_con (E.pushKRel env x) c]
adamc@623 214
adamc@3 215
adamc@3 216 and p_con env = p_con' false env
adamc@3 217
adamc@20 218 and p_name env (all as (c, _)) =
adamc@20 219 case c of
adamc@20 220 CName s => string s
adamc@20 221 | _ => p_con env all
adamc@20 222
adamc@171 223 fun p_patCon env pc =
adamc@171 224 case pc of
adamc@171 225 PConVar n =>
adamc@171 226 ((if !debug then
adamc@171 227 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@171 228 else
adamc@171 229 string (#1 (E.lookupENamed env n)))
adamc@448 230 handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
adamc@171 231 | PConProj (m1, ms, x) =>
adamc@171 232 let
adamc@171 233 val m1x = #1 (E.lookupStrNamed env m1)
adamc@171 234 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@171 235
adamc@171 236 val m1s = if !debug then
adamc@171 237 m1x ^ "__" ^ Int.toString m1
adamc@171 238 else
adamc@171 239 m1x
adamc@171 240 in
adamc@171 241 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@171 242 end
adamc@171 243
adamc@171 244 fun p_pat' par env (p, _) =
adamc@171 245 case p of
adamc@171 246 PWild => string "_"
adamc@182 247 | PVar (s, _) => string s
adamc@173 248 | PPrim p => Prim.p_t p
adamc@191 249 | PCon (_, pc, _, NONE) => p_patCon env pc
adamc@191 250 | PCon (_, pc, _, SOME p) => parenIf par (box [p_patCon env pc,
adamc@188 251 space,
adamc@188 252 p_pat' true env p])
adamc@176 253 | PRecord xps =>
adamc@176 254 box [string "{",
adamc@182 255 p_list_sep (box [string ",", space]) (fn (x, p, _) =>
adamc@176 256 box [string x,
adamc@176 257 space,
adamc@176 258 string "=",
adamc@176 259 space,
adamc@176 260 p_pat env p]) xps,
adamc@176 261 string "}"]
adamc@171 262
adamc@175 263 and p_pat x = p_pat' false x
adamc@171 264
adamc@9 265 fun p_exp' par env (e, _) =
adamc@9 266 case e of
adamc@14 267 EPrim p => Prim.p_t p
adamc@14 268 | ERel n =>
adamc@88 269 ((if !debug then
adamc@88 270 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@88 271 else
adamc@88 272 string (#1 (E.lookupERel env n)))
adamc@88 273 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
adamc@11 274 | ENamed n =>
adamc@88 275 ((if !debug then
adamc@88 276 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@88 277 else
adamc@88 278 string (#1 (E.lookupENamed env n)))
adamc@448 279 handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
adamc@34 280 | EModProj (m1, ms, x) =>
adamc@34 281 let
adamc@88 282 val m1x = #1 (E.lookupStrNamed env m1)
adamc@88 283 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@88 284
adamc@34 285 val m1s = if !debug then
adamc@34 286 m1x ^ "__" ^ Int.toString m1
adamc@34 287 else
adamc@34 288 m1x
adamc@34 289 in
adamc@34 290 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@34 291 end
adamc@34 292
adamc@9 293 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
adamc@9 294 space,
adamc@9 295 p_exp' true env e2])
adamc@26 296 | EAbs (x, t, _, e) => parenIf par (box [string "fn",
adamc@26 297 space,
adamc@26 298 string x,
adamc@26 299 space,
adamc@26 300 string ":",
adamc@26 301 space,
adamc@26 302 p_con env t,
adamc@26 303 space,
adamc@26 304 string "=>",
adamc@26 305 space,
adamc@26 306 p_exp (E.pushERel env x t) e])
adamc@9 307 | ECApp (e, c) => parenIf par (box [p_exp env e,
adamc@9 308 space,
adamc@9 309 string "[",
adamc@9 310 p_con env c,
adamc@9 311 string "]"])
adamc@9 312 | ECAbs (exp, x, k, e) => parenIf par (box [string "fn",
adamc@9 313 space,
adamc@9 314 string x,
adamc@9 315 space,
adamc@9 316 p_explicitness exp,
adamc@9 317 space,
adamc@623 318 p_kind env k,
adamc@9 319 space,
adamc@9 320 string "=>",
adamc@9 321 space,
adamc@9 322 p_exp (E.pushCRel env x k) e])
adamc@9 323
adamc@12 324 | ERecord xes => box [string "{",
adamc@29 325 p_list (fn (x, e, _) =>
adamc@21 326 box [p_name env x,
adamc@12 327 space,
adamc@12 328 string "=",
adamc@12 329 space,
adamc@12 330 p_exp env e]) xes,
adamc@12 331 string "}"]
adamc@12 332 | EField (e, c, {field, rest}) =>
adamc@12 333 if !debug then
adamc@12 334 box [p_exp' true env e,
adamc@12 335 string ".",
adamc@12 336 p_con' true env c,
adamc@12 337 space,
adamc@12 338 string "[",
adamc@12 339 p_con env field,
adamc@12 340 space,
adamc@12 341 string " in ",
adamc@12 342 space,
adamc@12 343 p_con env rest,
adamc@12 344 string "]"]
adamc@12 345 else
adamc@12 346 box [p_exp' true env e,
adamc@12 347 string ".",
adamc@12 348 p_con' true env c]
adamc@445 349 | EConcat (e1, c1, e2, c2) =>
adamc@339 350 parenIf par (if !debug then
adamc@445 351 box [p_exp' true env e1,
adamc@445 352 space,
adamc@445 353 string ":",
adamc@445 354 space,
adamc@445 355 p_con env c1,
adamc@445 356 space,
adamc@445 357 string "++",
adamc@445 358 space,
adamc@445 359 p_exp' true env e2,
adamc@445 360 space,
adamc@445 361 string ":",
adamc@445 362 space,
adamc@445 363 p_con env c2]
adamc@445 364 else
adamc@445 365 box [p_exp' true env e1,
adamc@339 366 space,
adamc@494 367 string "++",
adamc@339 368 space,
adamc@339 369 p_exp' true env e2])
adamc@149 370 | ECut (e, c, {field, rest}) =>
adamc@149 371 parenIf par (if !debug then
adamc@149 372 box [p_exp' true env e,
adamc@149 373 space,
adamc@149 374 string "--",
adamc@149 375 space,
adamc@149 376 p_con' true env c,
adamc@149 377 space,
adamc@149 378 string "[",
adamc@149 379 p_con env field,
adamc@149 380 space,
adamc@149 381 string " in ",
adamc@149 382 space,
adamc@149 383 p_con env rest,
adamc@149 384 string "]"]
adamc@149 385 else
adamc@149 386 box [p_exp' true env e,
adamc@149 387 space,
adamc@149 388 string "--",
adamc@149 389 space,
adamc@149 390 p_con' true env c])
adamc@493 391 | ECutMulti (e, c, {rest}) =>
adamc@493 392 parenIf par (if !debug then
adamc@493 393 box [p_exp' true env e,
adamc@493 394 space,
adamc@493 395 string "---",
adamc@493 396 space,
adamc@493 397 p_con' true env c,
adamc@493 398 space,
adamc@493 399 string "[",
adamc@493 400 p_con env rest,
adamc@493 401 string "]"]
adamc@493 402 else
adamc@493 403 box [p_exp' true env e,
adamc@493 404 space,
adamc@493 405 string "---",
adamc@493 406 space,
adamc@493 407 p_con' true env c])
adamc@493 408
adamc@171 409 | ECase (e, pes, _) => parenIf par (box [string "case",
adamc@171 410 space,
adamc@171 411 p_exp env e,
adamc@171 412 space,
adamc@171 413 string "of",
adamc@171 414 space,
adamc@171 415 p_list_sep (box [space, string "|", space])
adamc@171 416 (fn (p, e) => box [p_pat env p,
adamc@171 417 space,
adamc@171 418 string "=>",
adamc@171 419 space,
adamc@243 420 p_exp (E.patBinds env p) e]) pes])
adamc@171 421
adamc@9 422 | EError => string "<ERROR>"
adamc@228 423 | EUnif (ref (SOME e)) => p_exp env e
adamc@228 424 | EUnif _ => string "_"
adamc@9 425
adamc@447 426 | ELet (ds, e) =>
adamc@447 427 let
adamc@447 428 val (dsp, env) = ListUtil.foldlMap
adamc@447 429 (fn (d, env) =>
adamc@447 430 (p_edecl env d,
adamc@447 431 E.edeclBinds env d))
adamc@447 432 env ds
adamc@447 433 in
adamc@447 434 box [string "let",
adamc@447 435 newline,
adamc@447 436 box [p_list_sep newline (fn x => x) dsp],
adamc@447 437 newline,
adamc@447 438 string "in",
adamc@447 439 newline,
adamc@447 440 box [p_exp env e],
adamc@447 441 newline,
adamc@447 442 string "end"]
adamc@447 443 end
adamc@447 444
adamc@623 445 | EKAbs (x, e) => box [string x,
adamc@623 446 space,
adamc@623 447 string "==>",
adamc@623 448 space,
adamc@623 449 p_exp (E.pushKRel env x) e]
adamc@623 450 | EKApp (e, k) => box [p_exp env e,
adamc@623 451 string "[[",
adamc@623 452 p_kind env k,
adamc@623 453 string "]]"]
adamc@623 454
adamc@9 455 and p_exp env = p_exp' false env
adamc@9 456
adamc@447 457 and p_edecl env (dAll as (d, _)) =
adamc@447 458 case d of
adamc@447 459 EDVal vi => box [string "val",
adamc@447 460 space,
adamc@447 461 p_evali env vi]
adamc@447 462 | EDValRec vis =>
adamc@447 463 let
adamc@447 464 val env = E.edeclBinds env dAll
adamc@447 465 in
adamc@447 466 box [string "val",
adamc@447 467 space,
adamc@447 468 string "rec",
adamc@447 469 space,
adamc@447 470 p_list_sep (box [newline, string "and", space]) (p_evali env) vis]
adamc@447 471 end
adamc@447 472
adamc@447 473 and p_evali env (x, t, e) = box [string x,
adamc@447 474 space,
adamc@447 475 string ":",
adamc@447 476 space,
adamc@447 477 p_con env t,
adamc@447 478 space,
adamc@447 479 string "=",
adamc@447 480 space,
adamc@447 481 p_exp env e]
adamc@31 482
adamc@191 483 fun p_datatype env (x, n, xs, cons) =
adamc@156 484 let
adamc@191 485 val k = (KType, ErrorMsg.dummySpan)
adamc@191 486 val env = E.pushCNamedAs env x n k NONE
adamc@191 487 val env = foldl (fn (x, env) => E.pushCRel env x k) env xs
adamc@156 488 in
adamc@156 489 box [string "datatype",
adamc@156 490 space,
adamc@156 491 string x,
adamc@191 492 p_list_sep (box []) (fn x => box [space, string x]) xs,
adamc@156 493 space,
adamc@156 494 string "=",
adamc@156 495 space,
adamc@156 496 p_list_sep (box [space, string "|", space])
adamc@156 497 (fn (x, _, NONE) => string x
adamc@156 498 | (x, _, SOME t) => box [string x, space, string "of", space, p_con env t])
adamc@156 499 cons]
adamc@156 500 end
adamc@156 501
adamc@447 502 fun p_named x n =
adamc@447 503 if !debug then
adamc@447 504 box [string x,
adamc@447 505 string "__",
adamc@447 506 string (Int.toString n)]
adamc@447 507 else
adamc@447 508 string x
adamc@447 509
adamc@31 510 fun p_sgn_item env (sgi, _) =
adamc@31 511 case sgi of
adamc@31 512 SgiConAbs (x, n, k) => box [string "con",
adamc@31 513 space,
adamc@31 514 p_named x n,
adamc@31 515 space,
adamc@31 516 string "::",
adamc@31 517 space,
adamc@623 518 p_kind env k]
adamc@31 519 | SgiCon (x, n, k, c) => box [string "con",
adamc@31 520 space,
adamc@31 521 p_named x n,
adamc@31 522 space,
adamc@31 523 string "::",
adamc@31 524 space,
adamc@623 525 p_kind env k,
adamc@31 526 space,
adamc@31 527 string "=",
adamc@31 528 space,
adamc@31 529 p_con env c]
adamc@156 530 | SgiDatatype x => p_datatype env x
adamc@191 531 | SgiDatatypeImp (x, _, m1, ms, x', _, _) =>
adamc@156 532 let
adamc@156 533 val m1x = #1 (E.lookupStrNamed env m1)
adamc@156 534 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@156 535 in
adamc@156 536 box [string "datatype",
adamc@156 537 space,
adamc@156 538 string x,
adamc@156 539 space,
adamc@156 540 string "=",
adamc@156 541 space,
adamc@156 542 string "datatype",
adamc@156 543 space,
adamc@156 544 p_list_sep (string ".") string (m1x :: ms @ [x'])]
adamc@156 545 end
adamc@31 546 | SgiVal (x, n, c) => box [string "val",
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_con env c]
adamc@31 553 | SgiStr (x, n, sgn) => box [string "structure",
adamc@31 554 space,
adamc@31 555 p_named x n,
adamc@31 556 space,
adamc@31 557 string ":",
adamc@31 558 space,
adamc@31 559 p_sgn env sgn]
adamc@59 560 | SgiSgn (x, n, sgn) => box [string "signature",
adamc@59 561 space,
adamc@59 562 p_named x n,
adamc@59 563 space,
adamc@59 564 string "=",
adamc@59 565 space,
adamc@59 566 p_sgn env sgn]
adamc@88 567 | SgiConstraint (c1, c2) => box [string "constraint",
adamc@88 568 space,
adamc@88 569 p_con env c1,
adamc@88 570 space,
adamc@88 571 string "~",
adamc@88 572 space,
adamc@88 573 p_con env c2]
adamc@563 574 | SgiClassAbs (x, n, k) => box [string "class",
adamc@563 575 space,
adamc@563 576 p_named x n,
adamc@563 577 space,
adamc@563 578 string "::",
adamc@563 579 space,
adamc@623 580 p_kind env k]
adamc@563 581 | SgiClass (x, n, k, c) => box [string "class",
adamc@563 582 space,
adamc@563 583 p_named x n,
adamc@563 584 space,
adamc@563 585 string "::",
adamc@563 586 space,
adamc@623 587 p_kind env k,
adamc@563 588 space,
adamc@563 589 string "=",
adamc@563 590 space,
adamc@563 591 p_con env c]
adamc@31 592
adamc@31 593 and p_sgn env (sgn, _) =
adamc@31 594 case sgn of
adamc@31 595 SgnConst sgis => box [string "sig",
adamc@31 596 newline,
adamc@32 597 let
adamc@32 598 val (psgis, _) = ListUtil.foldlMap (fn (sgi, env) =>
adamc@32 599 (p_sgn_item env sgi,
adamc@32 600 E.sgiBinds env sgi))
adamc@32 601 env sgis
adamc@32 602 in
adamc@32 603 p_list_sep newline (fn x => x) psgis
adamc@32 604 end,
adamc@31 605 newline,
adamc@31 606 string "end"]
adamc@88 607 | SgnVar n => ((string (#1 (E.lookupSgnNamed env n)))
adamc@88 608 handle E.UnboundNamed _ => string ("UNBOUND_SGN_" ^ Int.toString n))
adamc@41 609 | SgnFun (x, n, sgn, sgn') => box [string "functor",
adamc@41 610 space,
adamc@41 611 string "(",
adamc@41 612 string x,
adamc@41 613 space,
adamc@41 614 string ":",
adamc@41 615 space,
adamc@41 616 p_sgn env sgn,
adamc@41 617 string ")",
adamc@41 618 space,
adamc@41 619 string ":",
adamc@41 620 space,
adamc@41 621 p_sgn (E.pushStrNamedAs env x n sgn) sgn']
adamc@42 622 | SgnWhere (sgn, x, c) => box [p_sgn env sgn,
adamc@42 623 space,
adamc@42 624 string "where",
adamc@42 625 space,
adamc@42 626 string "con",
adamc@42 627 space,
adamc@42 628 string x,
adamc@42 629 space,
adamc@42 630 string "=",
adamc@42 631 space,
adamc@42 632 p_con env c]
adamc@59 633 | SgnProj (m1, ms, x) =>
adamc@59 634 let
adamc@88 635 val m1x = #1 (E.lookupStrNamed env m1)
adamc@88 636 handle E.UnboundNamed _ => "UNBOUND_SGN_" ^ Int.toString m1
adamc@88 637
adamc@59 638 val m1s = if !debug then
adamc@59 639 m1x ^ "__" ^ Int.toString m1
adamc@59 640 else
adamc@59 641 m1x
adamc@88 642 in
adamc@59 643 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@59 644 end
adamc@31 645 | SgnError => string "<ERROR>"
adamc@31 646
adamc@123 647 fun p_vali env (x, n, t, e) = box [p_named x n,
adamc@123 648 space,
adamc@123 649 string ":",
adamc@123 650 space,
adamc@123 651 p_con env t,
adamc@123 652 space,
adamc@123 653 string "=",
adamc@123 654 space,
adamc@123 655 p_exp env e]
adamc@123 656
adamc@447 657
adamc@447 658
adamc@123 659 fun p_decl env (dAll as (d, _) : decl) =
adamc@3 660 case d of
adamc@31 661 DCon (x, n, k, c) => box [string "con",
adamc@31 662 space,
adamc@31 663 p_named x n,
adamc@31 664 space,
adamc@31 665 string "::",
adamc@31 666 space,
adamc@623 667 p_kind env k,
adamc@31 668 space,
adamc@31 669 string "=",
adamc@31 670 space,
adamc@31 671 p_con env c]
adamc@156 672 | DDatatype x => p_datatype env x
adamc@191 673 | DDatatypeImp (x, _, m1, ms, x', _, _) =>
adamc@156 674 let
adamc@156 675 val m1x = #1 (E.lookupStrNamed env m1)
adamc@156 676 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@156 677 in
adamc@156 678 box [string "datatype",
adamc@156 679 space,
adamc@156 680 string x,
adamc@156 681 space,
adamc@156 682 string "=",
adamc@156 683 space,
adamc@156 684 string "datatype",
adamc@156 685 space,
adamc@156 686 p_list_sep (string ".") string (m1x :: ms @ [x'])]
adamc@156 687 end
adamc@123 688 | DVal vi => box [string "val",
adamc@123 689 space,
adamc@123 690 p_vali env vi]
adamc@123 691 | DValRec vis =>
adamc@123 692 let
adamc@123 693 val env = E.declBinds env dAll
adamc@123 694 in
adamc@123 695 box [string "val",
adamc@123 696 space,
adamc@123 697 string "rec",
adamc@123 698 space,
adamc@123 699 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@123 700 end
adamc@31 701
adamc@31 702 | DSgn (x, n, sgn) => box [string "signature",
adamc@31 703 space,
adamc@31 704 p_named x n,
adamc@31 705 space,
adamc@31 706 string "=",
adamc@31 707 space,
adamc@31 708 p_sgn env sgn]
adamc@31 709 | DStr (x, n, sgn, str) => box [string "structure",
adamc@31 710 space,
adamc@31 711 p_named x n,
adamc@31 712 space,
adamc@31 713 string ":",
adamc@31 714 space,
adamc@31 715 p_sgn env sgn,
adamc@31 716 space,
adamc@31 717 string "=",
adamc@31 718 space,
adamc@31 719 p_str env str]
adamc@48 720 | DFfiStr (x, n, sgn) => box [string "extern",
adamc@48 721 space,
adamc@48 722 string "structure",
adamc@48 723 space,
adamc@48 724 p_named x n,
adamc@48 725 space,
adamc@48 726 string ":",
adamc@48 727 space,
adamc@48 728 p_sgn env sgn]
adamc@88 729 | DConstraint (c1, c2) => box [string "constraint",
adamc@88 730 space,
adamc@88 731 p_con env c1,
adamc@88 732 space,
adamc@88 733 string "~",
adamc@88 734 space,
adamc@88 735 p_con env c2]
adamc@109 736 | DExport (_, sgn, str) => box [string "export",
adamc@110 737 space,
adamc@109 738 p_str env str,
adamc@109 739 space,
adamc@109 740 string ":",
adamc@109 741 space,
adamc@109 742 p_sgn env sgn]
adamc@707 743 | DTable (_, x, n, c, pe, _, ce, _) => box [string "table",
adamc@707 744 space,
adamc@707 745 p_named x n,
adamc@707 746 space,
adamc@707 747 string ":",
adamc@707 748 space,
adamc@707 749 p_con env c,
adamc@707 750 space,
adamc@707 751 string "keys",
adamc@707 752 space,
adamc@707 753 p_exp env pe,
adamc@707 754 space,
adamc@707 755 string "constraints",
adamc@707 756 space,
adamc@707 757 p_exp env ce]
adamc@338 758 | DSequence (_, x, n) => box [string "sequence",
adamc@338 759 space,
adamc@338 760 p_named x n]
adamc@563 761 | DClass (x, n, k, c) => box [string "class",
adamc@563 762 space,
adamc@563 763 p_named x n,
adamc@563 764 space,
adamc@563 765 string "::",
adamc@563 766 space,
adamc@623 767 p_kind env k,
adamc@563 768 space,
adamc@563 769 string "=",
adamc@563 770 space,
adamc@563 771 p_con env c]
adamc@271 772 | DDatabase s => box [string "database",
adamc@271 773 space,
adamc@271 774 string s]
adamc@459 775 | DCookie (_, x, n, c) => box [string "cookie",
adamc@459 776 space,
adamc@459 777 p_named x n,
adamc@459 778 space,
adamc@459 779 string ":",
adamc@459 780 space,
adamc@459 781 p_con env c]
adamc@31 782
adamc@31 783 and p_str env (str, _) =
adamc@31 784 case str of
adamc@31 785 StrConst ds => box [string "struct",
adamc@31 786 newline,
adamc@32 787 p_file env ds,
adamc@31 788 newline,
adamc@31 789 string "end"]
adamc@88 790 | StrVar n => ((string (#1 (E.lookupStrNamed env n)))
adamc@88 791 handle E.UnboundNamed _ => string ("UNBOUND_STR_" ^ Int.toString n))
adamc@34 792 | StrProj (str, s) => box [p_str env str,
adamc@34 793 string ".",
adamc@34 794 string s]
adamc@41 795 | StrFun (x, n, sgn, sgn', str) =>
adamc@41 796 let
adamc@41 797 val env' = E.pushStrNamedAs env x n sgn
adamc@41 798 in
adamc@41 799 box [string "functor",
adamc@41 800 space,
adamc@41 801 string "(",
adamc@41 802 string x,
adamc@41 803 space,
adamc@41 804 string ":",
adamc@41 805 space,
adamc@41 806 p_sgn env sgn,
adamc@41 807 string ")",
adamc@41 808 space,
adamc@41 809 string ":",
adamc@41 810 space,
adamc@41 811 p_sgn env' sgn',
adamc@41 812 space,
adamc@41 813 string "=>",
adamc@41 814 space,
adamc@41 815 p_str env' str]
adamc@41 816 end
adamc@44 817 | StrApp (str1, str2) => box [p_str env str1,
adamc@44 818 string "(",
adamc@44 819 p_str env str2,
adamc@44 820 string ")"]
adamc@31 821 | StrError => string "<ERROR>"
adamc@3 822
adamc@32 823 and p_file env file =
adamc@3 824 let
adamc@31 825 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 826 (p_decl env d,
adamc@31 827 E.declBinds env d))
adamc@31 828 env file
adamc@3 829 in
adamc@3 830 p_list_sep newline (fn x => x) pds
adamc@3 831 end
adamc@3 832
adamc@3 833 end