Mercurial > urweb

annotate src/expl_print.sml @ 224:cb8a68964ebb

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