Mercurial > urweb

annotate src/elab_print.sml @ 853:19fdeef40ada

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Factor out common request functionality, in preparation for supporting different protocols
author Adam Chlipala <adamc@hcoop.net>
date Tue, 23 Jun 2009 14:05:12 -0400
parents 7f871c03e3a1
children b2311dfb3158
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@825 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@825 459 EDVal (p, t, e) => box [string "val",
adamc@825 460 space,
adamc@825 461 p_pat env p,
adamc@825 462 space,
adamc@825 463 string ":",
adamc@825 464 space,
adamc@825 465 p_con env t,
adamc@825 466 space,
adamc@825 467 string "=",
adamc@825 468 space,
adamc@825 469 p_exp env e]
adamc@447 470 | EDValRec vis =>
adamc@447 471 let
adamc@447 472 val env = E.edeclBinds env dAll
adamc@447 473 in
adamc@447 474 box [string "val",
adamc@447 475 space,
adamc@447 476 string "rec",
adamc@447 477 space,
adamc@447 478 p_list_sep (box [newline, string "and", space]) (p_evali env) vis]
adamc@447 479 end
adamc@447 480
adamc@447 481 and p_evali env (x, t, e) = box [string x,
adamc@447 482 space,
adamc@447 483 string ":",
adamc@447 484 space,
adamc@447 485 p_con env t,
adamc@447 486 space,
adamc@447 487 string "=",
adamc@447 488 space,
adamc@447 489 p_exp env e]
adamc@31 490
adamc@191 491 fun p_datatype env (x, n, xs, cons) =
adamc@156 492 let
adamc@191 493 val k = (KType, ErrorMsg.dummySpan)
adamc@191 494 val env = E.pushCNamedAs env x n k NONE
adamc@191 495 val env = foldl (fn (x, env) => E.pushCRel env x k) env xs
adamc@156 496 in
adamc@805 497 box [string x,
adamc@191 498 p_list_sep (box []) (fn x => box [space, string x]) xs,
adamc@156 499 space,
adamc@156 500 string "=",
adamc@156 501 space,
adamc@156 502 p_list_sep (box [space, string "|", space])
adamc@156 503 (fn (x, _, NONE) => string x
adamc@156 504 | (x, _, SOME t) => box [string x, space, string "of", space, p_con env t])
adamc@156 505 cons]
adamc@156 506 end
adamc@156 507
adamc@447 508 fun p_named x n =
adamc@447 509 if !debug then
adamc@447 510 box [string x,
adamc@447 511 string "__",
adamc@447 512 string (Int.toString n)]
adamc@447 513 else
adamc@447 514 string x
adamc@447 515
adamc@805 516 fun p_sgn_item env (sgiAll as (sgi, _)) =
adamc@31 517 case sgi of
adamc@31 518 SgiConAbs (x, n, k) => box [string "con",
adamc@31 519 space,
adamc@31 520 p_named x n,
adamc@31 521 space,
adamc@31 522 string "::",
adamc@31 523 space,
adamc@623 524 p_kind env k]
adamc@31 525 | SgiCon (x, n, k, c) => box [string "con",
adamc@31 526 space,
adamc@31 527 p_named x n,
adamc@31 528 space,
adamc@31 529 string "::",
adamc@31 530 space,
adamc@623 531 p_kind env k,
adamc@31 532 space,
adamc@31 533 string "=",
adamc@31 534 space,
adamc@31 535 p_con env c]
adamc@805 536 | SgiDatatype x => box [string "datatype",
adamc@805 537 space,
adamc@805 538 p_list_sep (box [space, string "and", space]) (p_datatype (E.sgiBinds env sgiAll)) x]
adamc@191 539 | SgiDatatypeImp (x, _, m1, ms, x', _, _) =>
adamc@156 540 let
adamc@156 541 val m1x = #1 (E.lookupStrNamed env m1)
adamc@156 542 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@156 543 in
adamc@156 544 box [string "datatype",
adamc@156 545 space,
adamc@156 546 string x,
adamc@156 547 space,
adamc@156 548 string "=",
adamc@156 549 space,
adamc@156 550 string "datatype",
adamc@156 551 space,
adamc@156 552 p_list_sep (string ".") string (m1x :: ms @ [x'])]
adamc@156 553 end
adamc@31 554 | SgiVal (x, n, c) => box [string "val",
adamc@31 555 space,
adamc@31 556 p_named x n,
adamc@31 557 space,
adamc@31 558 string ":",
adamc@31 559 space,
adamc@31 560 p_con env c]
adamc@31 561 | SgiStr (x, n, sgn) => box [string "structure",
adamc@31 562 space,
adamc@31 563 p_named x n,
adamc@31 564 space,
adamc@31 565 string ":",
adamc@31 566 space,
adamc@31 567 p_sgn env sgn]
adamc@59 568 | SgiSgn (x, n, sgn) => box [string "signature",
adamc@59 569 space,
adamc@59 570 p_named x n,
adamc@59 571 space,
adamc@59 572 string "=",
adamc@59 573 space,
adamc@59 574 p_sgn env sgn]
adamc@88 575 | SgiConstraint (c1, c2) => box [string "constraint",
adamc@88 576 space,
adamc@88 577 p_con env c1,
adamc@88 578 space,
adamc@88 579 string "~",
adamc@88 580 space,
adamc@88 581 p_con env c2]
adamc@563 582 | SgiClassAbs (x, n, k) => box [string "class",
adamc@563 583 space,
adamc@563 584 p_named x n,
adamc@563 585 space,
adamc@563 586 string "::",
adamc@563 587 space,
adamc@623 588 p_kind env k]
adamc@563 589 | SgiClass (x, n, k, c) => box [string "class",
adamc@563 590 space,
adamc@563 591 p_named x n,
adamc@563 592 space,
adamc@563 593 string "::",
adamc@563 594 space,
adamc@623 595 p_kind env k,
adamc@563 596 space,
adamc@563 597 string "=",
adamc@563 598 space,
adamc@563 599 p_con env c]
adamc@31 600
adamc@31 601 and p_sgn env (sgn, _) =
adamc@31 602 case sgn of
adamc@31 603 SgnConst sgis => box [string "sig",
adamc@31 604 newline,
adamc@32 605 let
adamc@32 606 val (psgis, _) = ListUtil.foldlMap (fn (sgi, env) =>
adamc@32 607 (p_sgn_item env sgi,
adamc@32 608 E.sgiBinds env sgi))
adamc@32 609 env sgis
adamc@32 610 in
adamc@32 611 p_list_sep newline (fn x => x) psgis
adamc@32 612 end,
adamc@31 613 newline,
adamc@31 614 string "end"]
adamc@88 615 | SgnVar n => ((string (#1 (E.lookupSgnNamed env n)))
adamc@88 616 handle E.UnboundNamed _ => string ("UNBOUND_SGN_" ^ Int.toString n))
adamc@41 617 | SgnFun (x, n, sgn, sgn') => box [string "functor",
adamc@41 618 space,
adamc@41 619 string "(",
adamc@41 620 string x,
adamc@41 621 space,
adamc@41 622 string ":",
adamc@41 623 space,
adamc@41 624 p_sgn env sgn,
adamc@41 625 string ")",
adamc@41 626 space,
adamc@41 627 string ":",
adamc@41 628 space,
adamc@41 629 p_sgn (E.pushStrNamedAs env x n sgn) sgn']
adamc@42 630 | SgnWhere (sgn, x, c) => box [p_sgn env sgn,
adamc@42 631 space,
adamc@42 632 string "where",
adamc@42 633 space,
adamc@42 634 string "con",
adamc@42 635 space,
adamc@42 636 string x,
adamc@42 637 space,
adamc@42 638 string "=",
adamc@42 639 space,
adamc@42 640 p_con env c]
adamc@59 641 | SgnProj (m1, ms, x) =>
adamc@59 642 let
adamc@88 643 val m1x = #1 (E.lookupStrNamed env m1)
adamc@88 644 handle E.UnboundNamed _ => "UNBOUND_SGN_" ^ Int.toString m1
adamc@88 645
adamc@59 646 val m1s = if !debug then
adamc@59 647 m1x ^ "__" ^ Int.toString m1
adamc@59 648 else
adamc@59 649 m1x
adamc@88 650 in
adamc@59 651 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@59 652 end
adamc@31 653 | SgnError => string "<ERROR>"
adamc@31 654
adamc@123 655 fun p_vali env (x, n, t, e) = box [p_named x n,
adamc@123 656 space,
adamc@123 657 string ":",
adamc@123 658 space,
adamc@123 659 p_con env t,
adamc@123 660 space,
adamc@123 661 string "=",
adamc@123 662 space,
adamc@123 663 p_exp env e]
adamc@123 664
adamc@447 665
adamc@447 666
adamc@123 667 fun p_decl env (dAll as (d, _) : decl) =
adamc@3 668 case d of
adamc@31 669 DCon (x, n, k, c) => box [string "con",
adamc@31 670 space,
adamc@31 671 p_named x n,
adamc@31 672 space,
adamc@31 673 string "::",
adamc@31 674 space,
adamc@623 675 p_kind env k,
adamc@31 676 space,
adamc@31 677 string "=",
adamc@31 678 space,
adamc@31 679 p_con env c]
adamc@805 680 | DDatatype x => box [string "datatype",
adamc@805 681 space,
adamc@805 682 p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x]
adamc@191 683 | DDatatypeImp (x, _, m1, ms, x', _, _) =>
adamc@156 684 let
adamc@156 685 val m1x = #1 (E.lookupStrNamed env m1)
adamc@156 686 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@156 687 in
adamc@156 688 box [string "datatype",
adamc@156 689 space,
adamc@156 690 string x,
adamc@156 691 space,
adamc@156 692 string "=",
adamc@156 693 space,
adamc@156 694 string "datatype",
adamc@156 695 space,
adamc@156 696 p_list_sep (string ".") string (m1x :: ms @ [x'])]
adamc@156 697 end
adamc@123 698 | DVal vi => box [string "val",
adamc@123 699 space,
adamc@123 700 p_vali env vi]
adamc@123 701 | DValRec vis =>
adamc@123 702 let
adamc@123 703 val env = E.declBinds env dAll
adamc@123 704 in
adamc@123 705 box [string "val",
adamc@123 706 space,
adamc@123 707 string "rec",
adamc@123 708 space,
adamc@123 709 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@123 710 end
adamc@31 711
adamc@31 712 | DSgn (x, n, sgn) => box [string "signature",
adamc@31 713 space,
adamc@31 714 p_named x n,
adamc@31 715 space,
adamc@31 716 string "=",
adamc@31 717 space,
adamc@31 718 p_sgn env sgn]
adamc@31 719 | DStr (x, n, sgn, str) => box [string "structure",
adamc@31 720 space,
adamc@31 721 p_named x n,
adamc@31 722 space,
adamc@31 723 string ":",
adamc@31 724 space,
adamc@31 725 p_sgn env sgn,
adamc@31 726 space,
adamc@31 727 string "=",
adamc@31 728 space,
adamc@31 729 p_str env str]
adamc@48 730 | DFfiStr (x, n, sgn) => box [string "extern",
adamc@48 731 space,
adamc@48 732 string "structure",
adamc@48 733 space,
adamc@48 734 p_named x n,
adamc@48 735 space,
adamc@48 736 string ":",
adamc@48 737 space,
adamc@48 738 p_sgn env sgn]
adamc@88 739 | DConstraint (c1, c2) => box [string "constraint",
adamc@88 740 space,
adamc@88 741 p_con env c1,
adamc@88 742 space,
adamc@88 743 string "~",
adamc@88 744 space,
adamc@88 745 p_con env c2]
adamc@109 746 | DExport (_, sgn, str) => box [string "export",
adamc@110 747 space,
adamc@109 748 p_str env str,
adamc@109 749 space,
adamc@109 750 string ":",
adamc@109 751 space,
adamc@109 752 p_sgn env sgn]
adamc@707 753 | DTable (_, x, n, c, pe, _, ce, _) => box [string "table",
adamc@707 754 space,
adamc@707 755 p_named x n,
adamc@707 756 space,
adamc@707 757 string ":",
adamc@707 758 space,
adamc@707 759 p_con env c,
adamc@707 760 space,
adamc@707 761 string "keys",
adamc@707 762 space,
adamc@707 763 p_exp env pe,
adamc@707 764 space,
adamc@707 765 string "constraints",
adamc@707 766 space,
adamc@707 767 p_exp env ce]
adamc@338 768 | DSequence (_, x, n) => box [string "sequence",
adamc@338 769 space,
adamc@338 770 p_named x n]
adamc@754 771 | DView (_, x, n, e, _) => box [string "view",
adamc@754 772 space,
adamc@754 773 p_named x n,
adamc@754 774 space,
adamc@754 775 string "as",
adamc@754 776 space,
adamc@754 777 p_exp env e]
adamc@563 778 | DClass (x, n, k, c) => box [string "class",
adamc@563 779 space,
adamc@563 780 p_named x n,
adamc@563 781 space,
adamc@563 782 string "::",
adamc@563 783 space,
adamc@623 784 p_kind env k,
adamc@563 785 space,
adamc@563 786 string "=",
adamc@563 787 space,
adamc@563 788 p_con env c]
adamc@271 789 | DDatabase s => box [string "database",
adamc@271 790 space,
adamc@271 791 string s]
adamc@459 792 | DCookie (_, x, n, c) => box [string "cookie",
adamc@459 793 space,
adamc@459 794 p_named x n,
adamc@459 795 space,
adamc@459 796 string ":",
adamc@459 797 space,
adamc@459 798 p_con env c]
adamc@720 799 | DStyle (_, x, n) => box [string "style",
adamc@720 800 space,
adamc@720 801 p_named x n]
adamc@31 802
adamc@31 803 and p_str env (str, _) =
adamc@31 804 case str of
adamc@31 805 StrConst ds => box [string "struct",
adamc@31 806 newline,
adamc@32 807 p_file env ds,
adamc@31 808 newline,
adamc@31 809 string "end"]
adamc@88 810 | StrVar n => ((string (#1 (E.lookupStrNamed env n)))
adamc@88 811 handle E.UnboundNamed _ => string ("UNBOUND_STR_" ^ Int.toString n))
adamc@34 812 | StrProj (str, s) => box [p_str env str,
adamc@34 813 string ".",
adamc@34 814 string s]
adamc@41 815 | StrFun (x, n, sgn, sgn', str) =>
adamc@41 816 let
adamc@41 817 val env' = E.pushStrNamedAs env x n sgn
adamc@41 818 in
adamc@41 819 box [string "functor",
adamc@41 820 space,
adamc@41 821 string "(",
adamc@41 822 string x,
adamc@41 823 space,
adamc@41 824 string ":",
adamc@41 825 space,
adamc@41 826 p_sgn env sgn,
adamc@41 827 string ")",
adamc@41 828 space,
adamc@41 829 string ":",
adamc@41 830 space,
adamc@41 831 p_sgn env' sgn',
adamc@41 832 space,
adamc@41 833 string "=>",
adamc@41 834 space,
adamc@41 835 p_str env' str]
adamc@41 836 end
adamc@44 837 | StrApp (str1, str2) => box [p_str env str1,
adamc@44 838 string "(",
adamc@44 839 p_str env str2,
adamc@44 840 string ")"]
adamc@31 841 | StrError => string "<ERROR>"
adamc@3 842
adamc@32 843 and p_file env file =
adamc@3 844 let
adamc@31 845 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 846 (p_decl env d,
adamc@31 847 E.declBinds env d))
adamc@31 848 env file
adamc@3 849 in
adamc@3 850 p_list_sep newline (fn x => x) pds
adamc@3 851 end
adamc@3 852
adamc@3 853 end