Mercurial > urweb

annotate src/expl_print.sml @ 2126:ec1614fb97bb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Change MonoReduce to do fixed-pointing, since it sometimes enables more optimizations for itself (e.g., yanking lambdas out of [case]s)
author Adam Chlipala <adam@chlipala.net>
date Fri, 06 Mar 2015 09:46:21 -0500
parents 403f0cc65b9c
children
rev   line source
adamc@1278 1 (* Copyright (c) 2008-2010, 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@796 222 | PCon (_, pc, cs, SOME p) =>
adamc@796 223 if !debug then
adamc@796 224 parenIf par (box [p_patCon env pc,
adamc@796 225 string "[",
adamc@796 226 p_list (p_con env) cs,
adamc@796 227 string "]",
adamc@796 228 space,
adamc@796 229 p_pat' true env p])
adamc@796 230 else
adamc@796 231 parenIf par (box [p_patCon env pc,
adamc@796 232 space,
adamc@796 233 p_pat' true env p])
adamc@796 234
adamc@176 235 | PRecord xps =>
adamc@176 236 box [string "{",
adamc@1272 237 p_list_sep (box [string ",", space]) (fn (x, p, t) =>
adamc@176 238 box [string x,
adamc@176 239 space,
adamc@176 240 string "=",
adamc@176 241 space,
adamc@1272 242 p_pat env p,
adamc@1272 243 if !debug then
adamc@1272 244 box [space,
adamc@1272 245 string ":",
adamc@1272 246 space,
adamc@1272 247 p_con env t]
adamc@1272 248 else
adamc@1272 249 box []]) xps,
adamc@176 250 string "}"]
adamc@176 251
adamc@176 252 and p_pat x = p_pat' false x
adamc@176 253
adamc@146 254 fun p_exp' par env (e, loc) =
adamc@38 255 case e of
adamc@38 256 EPrim p => Prim.p_t p
adamc@38 257 | ERel n =>
adamc@449 258 ((if !debug then
adamc@449 259 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@449 260 else
adamc@449 261 string (#1 (E.lookupERel env n)))
adamc@449 262 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
adamc@38 263 | ENamed n =>
adamc@449 264 ((if !debug then
adamc@449 265 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@449 266 else
adamc@449 267 string (#1 (E.lookupENamed env n)))
adamc@449 268 handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n))
adamc@38 269 | EModProj (m1, ms, x) =>
adamc@38 270 let
adamc@38 271 val (m1x, sgn) = E.lookupStrNamed env m1
adamc@480 272 handle E.UnboundNamed _ => ("UNBOUND" ^ Int.toString m1, (SgnConst [], loc))
adamc@38 273
adamc@38 274 val m1s = if !debug then
adamc@38 275 m1x ^ "__" ^ Int.toString m1
adamc@38 276 else
adamc@38 277 m1x
adamc@38 278 in
adamc@146 279 p_list_sep (string ".") string (m1s :: ms @ [x])
adamc@38 280 end
adamc@38 281
adamc@38 282 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
adamc@38 283 space,
adamc@38 284 p_exp' true env e2])
adamc@38 285 | EAbs (x, t, _, e) => parenIf par (box [string "fn",
adamc@38 286 space,
adamc@38 287 string x,
adamc@38 288 space,
adamc@38 289 string ":",
adamc@38 290 space,
adamc@38 291 p_con env t,
adamc@38 292 space,
adamc@38 293 string "=>",
adamc@38 294 space,
adamc@38 295 p_exp (E.pushERel env x t) e])
adamc@38 296 | ECApp (e, c) => parenIf par (box [p_exp env e,
adamc@38 297 space,
adamc@38 298 string "[",
adamc@38 299 p_con env c,
adamc@38 300 string "]"])
adamc@38 301 | ECAbs (x, k, e) => parenIf par (box [string "fn",
adamc@38 302 space,
adamc@38 303 string x,
adamc@38 304 space,
adamc@38 305 string "::",
adamc@38 306 space,
adamc@624 307 p_kind env k,
adamc@38 308 space,
adamc@38 309 string "=>",
adamc@38 310 space,
adamc@38 311 p_exp (E.pushCRel env x k) e])
adamc@38 312
adamc@38 313 | ERecord xes => box [string "{",
adamc@38 314 p_list (fn (x, e, _) =>
adamc@38 315 box [p_name env x,
adamc@38 316 space,
adamc@38 317 string "=",
adamc@38 318 space,
adamc@38 319 p_exp env e]) xes,
adamc@38 320 string "}"]
adamc@38 321 | EField (e, c, {field, rest}) =>
adamc@38 322 if !debug then
adamc@38 323 box [p_exp' true env e,
adamc@38 324 string ".",
adamc@38 325 p_con' true env c,
adamc@38 326 space,
adamc@38 327 string "[",
adamc@38 328 p_con env field,
adamc@38 329 space,
adamc@38 330 string " in ",
adamc@38 331 space,
adamc@38 332 p_con env rest,
adamc@38 333 string "]"]
adamc@38 334 else
adamc@38 335 box [p_exp' true env e,
adamc@38 336 string ".",
adamc@38 337 p_con' true env c]
adamc@445 338 | EConcat (e1, c1, e2, c2) =>
adamc@339 339 parenIf par (if !debug then
adamc@445 340 box [p_exp' true env e1,
adamc@445 341 space,
adamc@445 342 string ":",
adamc@445 343 space,
adamc@445 344 p_con env c1,
adamc@445 345 space,
adamc@445 346 string "++",
adamc@445 347 space,
adamc@445 348 p_exp' true env e2,
adamc@445 349 space,
adamc@445 350 string ":",
adamc@445 351 space,
adamc@445 352 p_con env c2]
adamc@445 353 else
adamc@445 354 box [p_exp' true env e1,
adamc@339 355 space,
adamc@339 356 string "with",
adamc@339 357 space,
adamc@339 358 p_exp' true env e2])
adamc@149 359 | ECut (e, c, {field, rest}) =>
adamc@149 360 parenIf par (if !debug then
adamc@149 361 box [p_exp' true env e,
adamc@149 362 space,
adamc@149 363 string "--",
adamc@149 364 space,
adamc@149 365 p_con' true env c,
adamc@149 366 space,
adamc@149 367 string "[",
adamc@149 368 p_con env field,
adamc@149 369 space,
adamc@149 370 string " in ",
adamc@149 371 space,
adamc@149 372 p_con env rest,
adamc@149 373 string "]"]
adamc@149 374 else
adamc@149 375 box [p_exp' true env e,
adamc@149 376 space,
adamc@149 377 string "--",
adamc@149 378 space,
adamc@149 379 p_con' true env c])
adamc@493 380 | ECutMulti (e, c, {rest}) =>
adamc@493 381 parenIf par (if !debug then
adamc@493 382 box [p_exp' true env e,
adamc@493 383 space,
adamc@493 384 string "---",
adamc@493 385 space,
adamc@493 386 p_con' true env c,
adamc@493 387 space,
adamc@493 388 string "[",
adamc@493 389 p_con env rest,
adamc@493 390 string "]"]
adamc@493 391 else
adamc@493 392 box [p_exp' true env e,
adamc@493 393 space,
adamc@493 394 string "---",
adamc@493 395 space,
adamc@493 396 p_con' true env c])
adamc@38 397
adamc@109 398 | EWrite e => box [string "write(",
adamc@109 399 p_exp env e,
adamc@109 400 string ")"]
adamc@109 401
adamc@288 402 | ECase (e, pes, {disc, result}) =>
adamc@288 403 parenIf par (box [string "case",
adamc@288 404 space,
adamc@288 405 p_exp env e,
adamc@288 406 space,
adamc@288 407 if !debug then
adamc@288 408 box [string "in",
adamc@288 409 space,
adamc@288 410 p_con env disc,
adamc@288 411 space,
adamc@288 412 string "return",
adamc@288 413 space,
adamc@288 414 p_con env result,
adamc@288 415 space]
adamc@288 416 else
adamc@288 417 box [],
adamc@288 418 string "of",
adamc@288 419 space,
adamc@288 420 p_list_sep (box [space, string "|", space])
adamc@288 421 (fn (p, e) => box [p_pat env p,
adamc@288 422 space,
adamc@288 423 string "=>",
adamc@288 424 space,
adamc@1278 425 p_exp (E.patBinds env p) e]) pes])
adamc@176 426
adamc@449 427 | ELet (x, t, e1, e2) => box [string "let",
adamc@449 428 space,
adamc@449 429 string x,
adamc@449 430 space,
adamc@449 431 string ":",
adamc@453 432 space,
adamc@449 433 p_con env t,
adamc@449 434 space,
adamc@449 435 string "=",
adamc@449 436 space,
adamc@449 437 p_exp env e1,
adamc@449 438 space,
adamc@449 439 string "in",
adamc@449 440 newline,
adamc@449 441 p_exp (E.pushERel env x t) e2]
adamc@449 442
adamc@624 443 | EKAbs (x, e) => box [string x,
adamc@624 444 space,
adamc@624 445 string "==>",
adamc@624 446 space,
adamc@624 447 p_exp (E.pushKRel env x) e]
adamc@624 448 | EKApp (e, k) => box [p_exp env e,
adamc@624 449 string "[[",
adamc@624 450 p_kind env k,
adamc@624 451 string "]]"]
adamc@449 452
adamc@449 453
adamc@38 454 and p_exp env = p_exp' false env
adamc@38 455
adamc@38 456 fun p_named x n =
adamc@38 457 if !debug then
adamc@38 458 box [string x,
adamc@38 459 string "__",
adamc@38 460 string (Int.toString n)]
adamc@38 461 else
adamc@38 462 string x
adamc@38 463
adamc@191 464 fun p_datatype env (x, n, xs, cons) =
adamc@162 465 let
adamc@191 466 val k = (KType, ErrorMsg.dummySpan)
adamc@191 467 val env = E.pushCNamed env x n k NONE
adamc@191 468 val env = foldl (fn (x, env) => E.pushCRel env x k) env xs
adamc@162 469 in
adamc@806 470 box [string x,
adamc@191 471 p_list_sep (box []) (fn x => box [space, string x]) xs,
adamc@162 472 space,
adamc@162 473 string "=",
adamc@162 474 space,
adamc@162 475 p_list_sep (box [space, string "|", space])
adamc@163 476 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@163 477 else string x
adamc@193 478 | (x, n, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@163 479 else string x, space, string "of", space, p_con env t])
adamc@162 480 cons]
adamc@162 481 end
adamc@162 482
adamc@806 483 fun p_sgn_item env (sgiAll as (sgi, _)) =
adamc@38 484 case sgi of
adamc@38 485 SgiConAbs (x, n, k) => box [string "con",
adamc@38 486 space,
adamc@38 487 p_named x n,
adamc@38 488 space,
adamc@38 489 string "::",
adamc@38 490 space,
adamc@624 491 p_kind env k]
adamc@38 492 | SgiCon (x, n, k, c) => box [string "con",
adamc@38 493 space,
adamc@38 494 p_named x n,
adamc@38 495 space,
adamc@38 496 string "::",
adamc@38 497 space,
adamc@624 498 p_kind env k,
adamc@38 499 space,
adamc@38 500 string "=",
adamc@38 501 space,
adamc@38 502 p_con env c]
adamc@806 503 | SgiDatatype x => box [string "datatype",
adamc@806 504 space,
adamc@806 505 p_list_sep (box [space, string "and", space]) (p_datatype (E.sgiBinds env sgiAll)) x]
adamc@191 506 | SgiDatatypeImp (x, _, m1, ms, x', _, _) =>
adamc@162 507 let
adamc@162 508 val m1x = #1 (E.lookupStrNamed env m1)
adamc@162 509 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@162 510 in
adamc@162 511 box [string "datatype",
adamc@162 512 space,
adamc@162 513 string x,
adamc@162 514 space,
adamc@162 515 string "=",
adamc@162 516 space,
adamc@162 517 string "datatype",
adamc@162 518 space,
adamc@162 519 p_list_sep (string ".") string (m1x :: ms @ [x'])]
adamc@162 520 end
adamc@38 521 | SgiVal (x, n, c) => box [string "val",
adamc@38 522 space,
adamc@38 523 p_named x n,
adamc@38 524 space,
adamc@38 525 string ":",
adamc@38 526 space,
adamc@38 527 p_con env c]
adamc@38 528 | SgiStr (x, n, sgn) => box [string "structure",
adamc@38 529 space,
adamc@38 530 p_named x n,
adamc@38 531 space,
adamc@38 532 string ":",
adamc@38 533 space,
adamc@38 534 p_sgn env sgn]
adamc@64 535 | SgiSgn (x, n, sgn) => box [string "signature",
adamc@64 536 space,
adamc@64 537 p_named x n,
adamc@64 538 space,
adamc@64 539 string "=",
adamc@64 540 space,
adamc@64 541 p_sgn env sgn]
adamc@38 542
adamc@146 543 and p_sgn env (sgn, loc) =
adamc@38 544 case sgn of
adamc@38 545 SgnConst sgis => box [string "sig",
adamc@38 546 newline,
adamc@38 547 let
adamc@38 548 val (psgis, _) = ListUtil.foldlMap (fn (sgi, env) =>
adamc@38 549 (p_sgn_item env sgi,
adamc@38 550 E.sgiBinds env sgi))
adamc@38 551 env sgis
adamc@38 552 in
adamc@38 553 p_list_sep newline (fn x => x) psgis
adamc@38 554 end,
adamc@38 555 newline,
adamc@38 556 string "end"]
adamc@146 557 | SgnVar n => string ((#1 (E.lookupSgnNamed env n))
adamc@480 558 handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString n)
adamc@45 559 | SgnFun (x, n, sgn, sgn') => box [string "functor",
adamc@45 560 space,
adamc@45 561 string "(",
adamc@480 562 p_named x n,
adamc@45 563 space,
adamc@45 564 string ":",
adamc@45 565 space,
adamc@45 566 p_sgn env sgn,
adamc@45 567 string ")",
adamc@45 568 space,
adamc@45 569 string ":",
adamc@45 570 space,
adamc@45 571 p_sgn (E.pushStrNamed env x n sgn) sgn']
adam@1864 572 | SgnWhere (sgn, ms, x, c) => box [p_sgn env sgn,
adamc@45 573 space,
adamc@45 574 string "where",
adamc@45 575 space,
adamc@45 576 string "con",
adamc@45 577 space,
adam@1864 578 p_list_sep (string ".") string (ms @ [x]),
adamc@45 579 space,
adamc@45 580 string "=",
adamc@45 581 space,
adamc@45 582 p_con env c]
adamc@64 583 | SgnProj (m1, ms, x) =>
adamc@64 584 let
adamc@64 585 val (m1x, sgn) = E.lookupStrNamed env m1
adamc@480 586 handle E.UnboundNamed _ => ("UNBOUND" ^ Int.toString m1, (SgnConst [], loc))
adamc@64 587
adamc@64 588 val m1s = if !debug then
adamc@64 589 m1x ^ "__" ^ Int.toString m1
adamc@64 590 else
adamc@64 591 m1x
adamc@64 592 in
adamc@64 593 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@64 594 end
adamc@38 595
adamc@124 596 fun p_vali env (x, n, t, e) = box [p_named x n,
adamc@124 597 space,
adamc@124 598 string ":",
adamc@124 599 space,
adamc@124 600 p_con env t,
adamc@124 601 space,
adamc@124 602 string "=",
adamc@124 603 space,
adamc@124 604 p_exp env e]
adamc@124 605
adamc@124 606 fun p_decl env (dAll as (d, _) : decl) =
adamc@38 607 case d of
adamc@38 608 DCon (x, n, k, c) => box [string "con",
adamc@38 609 space,
adamc@38 610 p_named x n,
adamc@38 611 space,
adamc@38 612 string "::",
adamc@38 613 space,
adamc@624 614 p_kind env k,
adamc@38 615 space,
adamc@38 616 string "=",
adamc@38 617 space,
adamc@38 618 p_con env c]
adamc@806 619 | DDatatype x => box [string "datatype",
adamc@806 620 space,
adamc@806 621 p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x]
adamc@191 622 | DDatatypeImp (x, _, m1, ms, x', _, _) =>
adamc@162 623 let
adamc@162 624 val m1x = #1 (E.lookupStrNamed env m1)
adamc@162 625 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@162 626 in
adamc@162 627 box [string "datatype",
adamc@162 628 space,
adamc@162 629 string x,
adamc@162 630 space,
adamc@162 631 string "=",
adamc@162 632 space,
adamc@162 633 string "datatype",
adamc@162 634 space,
adamc@162 635 p_list_sep (string ".") string (m1x :: ms @ [x'])]
adamc@162 636 end
adamc@124 637 | DVal vi => box [string "val",
adamc@124 638 space,
adamc@124 639 p_vali env vi]
adamc@124 640 | DValRec vis =>
adamc@124 641 let
adamc@124 642 val env = E.declBinds env dAll
adamc@124 643 in
adamc@124 644 box [string "val",
adamc@124 645 space,
adamc@124 646 string "rec",
adamc@124 647 space,
adamc@124 648 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@124 649 end
adamc@38 650
adamc@38 651 | DSgn (x, n, sgn) => box [string "signature",
adamc@38 652 space,
adamc@38 653 p_named x n,
adamc@38 654 space,
adamc@38 655 string "=",
adamc@38 656 space,
adamc@38 657 p_sgn env sgn]
adamc@38 658 | DStr (x, n, sgn, str) => box [string "structure",
adamc@38 659 space,
adamc@38 660 p_named x n,
adamc@38 661 space,
adamc@38 662 string ":",
adamc@38 663 space,
adamc@38 664 p_sgn env sgn,
adamc@38 665 space,
adamc@38 666 string "=",
adamc@38 667 space,
adamc@38 668 p_str env str]
adamc@48 669 | DFfiStr (x, n, sgn) => box [string "extern",
adamc@48 670 space,
adamc@48 671 string "structure",
adamc@48 672 space,
adamc@48 673 p_named x n,
adamc@48 674 space,
adamc@48 675 string ":",
adamc@48 676 space,
adamc@48 677 p_sgn env sgn]
adamc@109 678 | DExport (_, sgn, str) => box [string "export",
adamc@109 679 space,
adamc@109 680 p_str env str,
adamc@109 681 space,
adamc@109 682 string ":",
adamc@109 683 space,
adamc@109 684 p_sgn env sgn]
adamc@707 685 | DTable (_, x, n, c, pe, _, ce, _) => box [string "table",
adamc@707 686 space,
adamc@707 687 p_named x n,
adamc@707 688 space,
adamc@707 689 string ":",
adamc@707 690 space,
adamc@707 691 p_con env c,
adamc@707 692 space,
adamc@707 693 string "keys",
adamc@707 694 space,
adamc@707 695 p_exp env pe,
adamc@707 696 space,
adamc@707 697 string "constraints",
adamc@707 698 space,
adamc@707 699 p_exp env ce]
adamc@338 700 | DSequence (_, x, n) => box [string "sequence",
adamc@338 701 space,
adamc@338 702 p_named x n]
adamc@754 703 | DView (_, x, n, e, _) => box [string "view",
adamc@754 704 space,
adamc@754 705 p_named x n,
adamc@754 706 space,
adamc@754 707 string "as",
adamc@754 708 space,
adamc@754 709 p_exp env e]
adamc@271 710 | DDatabase s => box [string "database",
adamc@271 711 space,
adamc@271 712 string s]
adamc@460 713 | DCookie (_, x, n, c) => box [string "cookie",
adamc@460 714 space,
adamc@460 715 p_named x n,
adamc@460 716 space,
adamc@460 717 string ":",
adamc@460 718 space,
adamc@460 719 p_con env c]
adamc@720 720 | DStyle (_, x, n) => box [string "style",
adamc@720 721 space,
adamc@720 722 p_named x n]
adamc@1075 723 | DTask (e1, e2) => box [string "task",
adamc@1073 724 space,
adamc@1075 725 p_exp env e1,
adamc@1075 726 space,
adamc@1075 727 string "=",
adamc@1075 728 space,
adamc@1075 729 p_exp env e2]
adamc@1199 730 | DPolicy e1 => box [string "policy",
adamc@1199 731 space,
adamc@1199 732 p_exp env e1]
adam@1294 733 | DOnError _ => string "ONERROR"
adam@2010 734 | DFfi _ => string "FFI"
adamc@38 735
adamc@38 736 and p_str env (str, _) =
adamc@38 737 case str of
adamc@38 738 StrConst ds => box [string "struct",
adamc@38 739 newline,
adamc@38 740 p_file env ds,
adamc@38 741 newline,
adamc@38 742 string "end"]
adamc@146 743 | StrVar n =>
adamc@146 744 let
adamc@146 745 val x = #1 (E.lookupStrNamed env n)
adamc@480 746 handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString n
adamc@146 747
adamc@146 748 val s = if !debug then
adamc@146 749 x ^ "__" ^ Int.toString n
adamc@146 750 else
adamc@146 751 x
adamc@146 752 in
adamc@146 753 string s
adamc@146 754 end
adamc@38 755 | StrProj (str, s) => box [p_str env str,
adamc@38 756 string ".",
adamc@38 757 string s]
adamc@45 758 | StrFun (x, n, sgn, sgn', str) =>
adamc@45 759 let
adamc@45 760 val env' = E.pushStrNamed env x n sgn
adamc@45 761 in
adamc@45 762 box [string "functor",
adamc@45 763 space,
adamc@45 764 string "(",
adamc@480 765 p_named x n,
adamc@45 766 space,
adamc@45 767 string ":",
adamc@45 768 space,
adamc@45 769 p_sgn env sgn,
adamc@45 770 string ")",
adamc@45 771 space,
adamc@45 772 string ":",
adamc@45 773 space,
adamc@45 774 p_sgn env' sgn',
adamc@45 775 space,
adamc@45 776 string "=>",
adamc@45 777 space,
adamc@45 778 p_str env' str]
adamc@45 779 end
adamc@45 780 | StrApp (str1, str2) => box [p_str env str1,
adamc@45 781 string "(",
adamc@45 782 p_str env str2,
adamc@45 783 string ")"]
adamc@38 784
adamc@38 785 and p_file env file =
adamc@38 786 let
adamc@38 787 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@38 788 (p_decl env d,
adamc@38 789 E.declBinds env d))
adamc@38 790 env file
adamc@38 791 in
adamc@38 792 p_list_sep newline (fn x => x) pds
adamc@38 793 end
adamc@38 794
adamc@38 795 end