Mercurial > urweb

annotate src/expl_print.sml @ 708:1a317a707d71

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