Mercurial > urweb

annotate src/expl_print.sml @ 305:55eedecb6c50

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove need to mention table name in expressions for UPDATE and DELETE
author Adam Chlipala <adamc@hcoop.net>
date Sun, 07 Sep 2008 14:30:32 -0400
parents 4260ad920c36
children e976b187d73a
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@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@288 319 | ECase (e, pes, {disc, result}) =>
adamc@288 320 parenIf par (box [string "case",
adamc@288 321 space,
adamc@288 322 p_exp env e,
adamc@288 323 space,
adamc@288 324 if !debug then
adamc@288 325 box [string "in",
adamc@288 326 space,
adamc@288 327 p_con env disc,
adamc@288 328 space,
adamc@288 329 string "return",
adamc@288 330 space,
adamc@288 331 p_con env result,
adamc@288 332 space]
adamc@288 333 else
adamc@288 334 box [],
adamc@288 335 string "of",
adamc@288 336 space,
adamc@288 337 p_list_sep (box [space, string "|", space])
adamc@288 338 (fn (p, e) => box [p_pat env p,
adamc@288 339 space,
adamc@288 340 string "=>",
adamc@288 341 space,
adamc@288 342 p_exp env e]) pes])
adamc@176 343
adamc@38 344 and p_exp env = p_exp' false env
adamc@38 345
adamc@38 346 fun p_named x n =
adamc@38 347 if !debug then
adamc@38 348 box [string x,
adamc@38 349 string "__",
adamc@38 350 string (Int.toString n)]
adamc@38 351 else
adamc@38 352 string x
adamc@38 353
adamc@191 354 fun p_datatype env (x, n, xs, cons) =
adamc@162 355 let
adamc@191 356 val k = (KType, ErrorMsg.dummySpan)
adamc@191 357 val env = E.pushCNamed env x n k NONE
adamc@191 358 val env = foldl (fn (x, env) => E.pushCRel env x k) env xs
adamc@162 359 in
adamc@162 360 box [string "datatype",
adamc@162 361 space,
adamc@162 362 string x,
adamc@191 363 p_list_sep (box []) (fn x => box [space, string x]) xs,
adamc@162 364 space,
adamc@162 365 string "=",
adamc@162 366 space,
adamc@162 367 p_list_sep (box [space, string "|", space])
adamc@163 368 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@163 369 else string x
adamc@193 370 | (x, n, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@163 371 else string x, space, string "of", space, p_con env t])
adamc@162 372 cons]
adamc@162 373 end
adamc@162 374
adamc@38 375 fun p_sgn_item env (sgi, _) =
adamc@38 376 case sgi of
adamc@38 377 SgiConAbs (x, n, k) => box [string "con",
adamc@38 378 space,
adamc@38 379 p_named x n,
adamc@38 380 space,
adamc@38 381 string "::",
adamc@38 382 space,
adamc@38 383 p_kind k]
adamc@38 384 | SgiCon (x, n, k, c) => box [string "con",
adamc@38 385 space,
adamc@38 386 p_named x n,
adamc@38 387 space,
adamc@38 388 string "::",
adamc@38 389 space,
adamc@38 390 p_kind k,
adamc@38 391 space,
adamc@38 392 string "=",
adamc@38 393 space,
adamc@38 394 p_con env c]
adamc@162 395 | SgiDatatype x => p_datatype env x
adamc@191 396 | SgiDatatypeImp (x, _, m1, ms, x', _, _) =>
adamc@162 397 let
adamc@162 398 val m1x = #1 (E.lookupStrNamed env m1)
adamc@162 399 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@162 400 in
adamc@162 401 box [string "datatype",
adamc@162 402 space,
adamc@162 403 string x,
adamc@162 404 space,
adamc@162 405 string "=",
adamc@162 406 space,
adamc@162 407 string "datatype",
adamc@162 408 space,
adamc@162 409 p_list_sep (string ".") string (m1x :: ms @ [x'])]
adamc@162 410 end
adamc@38 411 | SgiVal (x, n, c) => box [string "val",
adamc@38 412 space,
adamc@38 413 p_named x n,
adamc@38 414 space,
adamc@38 415 string ":",
adamc@38 416 space,
adamc@38 417 p_con env c]
adamc@38 418 | SgiStr (x, n, sgn) => box [string "structure",
adamc@38 419 space,
adamc@38 420 p_named x n,
adamc@38 421 space,
adamc@38 422 string ":",
adamc@38 423 space,
adamc@38 424 p_sgn env sgn]
adamc@64 425 | SgiSgn (x, n, sgn) => box [string "signature",
adamc@64 426 space,
adamc@64 427 p_named x n,
adamc@64 428 space,
adamc@64 429 string "=",
adamc@64 430 space,
adamc@64 431 p_sgn env sgn]
adamc@246 432 | SgiTable (_, x, n, c) => box [string "table",
adamc@246 433 space,
adamc@246 434 p_named x n,
adamc@246 435 space,
adamc@246 436 string ":",
adamc@246 437 space,
adamc@246 438 p_con env c]
adamc@38 439
adamc@146 440 and p_sgn env (sgn, loc) =
adamc@38 441 case sgn of
adamc@38 442 SgnConst sgis => box [string "sig",
adamc@38 443 newline,
adamc@38 444 let
adamc@38 445 val (psgis, _) = ListUtil.foldlMap (fn (sgi, env) =>
adamc@38 446 (p_sgn_item env sgi,
adamc@38 447 E.sgiBinds env sgi))
adamc@38 448 env sgis
adamc@38 449 in
adamc@38 450 p_list_sep newline (fn x => x) psgis
adamc@38 451 end,
adamc@38 452 newline,
adamc@38 453 string "end"]
adamc@146 454 | SgnVar n => string ((#1 (E.lookupSgnNamed env n))
adamc@146 455 handle E.UnboundNamed _ => "UNBOUND")
adamc@45 456 | SgnFun (x, n, sgn, sgn') => box [string "functor",
adamc@45 457 space,
adamc@45 458 string "(",
adamc@45 459 string x,
adamc@45 460 space,
adamc@45 461 string ":",
adamc@45 462 space,
adamc@45 463 p_sgn env sgn,
adamc@45 464 string ")",
adamc@45 465 space,
adamc@45 466 string ":",
adamc@45 467 space,
adamc@45 468 p_sgn (E.pushStrNamed env x n sgn) sgn']
adamc@45 469 | SgnWhere (sgn, x, c) => box [p_sgn env sgn,
adamc@45 470 space,
adamc@45 471 string "where",
adamc@45 472 space,
adamc@45 473 string "con",
adamc@45 474 space,
adamc@45 475 string x,
adamc@45 476 space,
adamc@45 477 string "=",
adamc@45 478 space,
adamc@45 479 p_con env c]
adamc@64 480 | SgnProj (m1, ms, x) =>
adamc@64 481 let
adamc@64 482 val (m1x, sgn) = E.lookupStrNamed env m1
adamc@146 483 handle E.UnboundNamed _ => ("UNBOUND", (SgnConst [], loc))
adamc@64 484
adamc@64 485 val m1s = if !debug then
adamc@64 486 m1x ^ "__" ^ Int.toString m1
adamc@64 487 else
adamc@64 488 m1x
adamc@64 489 in
adamc@64 490 p_list_sep (string ".") string (m1x :: ms @ [x])
adamc@64 491 end
adamc@38 492
adamc@124 493 fun p_vali env (x, n, t, e) = box [p_named x n,
adamc@124 494 space,
adamc@124 495 string ":",
adamc@124 496 space,
adamc@124 497 p_con env t,
adamc@124 498 space,
adamc@124 499 string "=",
adamc@124 500 space,
adamc@124 501 p_exp env e]
adamc@124 502
adamc@124 503 fun p_decl env (dAll as (d, _) : decl) =
adamc@38 504 case d of
adamc@38 505 DCon (x, n, k, c) => box [string "con",
adamc@38 506 space,
adamc@38 507 p_named x n,
adamc@38 508 space,
adamc@38 509 string "::",
adamc@38 510 space,
adamc@38 511 p_kind k,
adamc@38 512 space,
adamc@38 513 string "=",
adamc@38 514 space,
adamc@38 515 p_con env c]
adamc@162 516 | DDatatype x => p_datatype env x
adamc@191 517 | DDatatypeImp (x, _, m1, ms, x', _, _) =>
adamc@162 518 let
adamc@162 519 val m1x = #1 (E.lookupStrNamed env m1)
adamc@162 520 handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
adamc@162 521 in
adamc@162 522 box [string "datatype",
adamc@162 523 space,
adamc@162 524 string x,
adamc@162 525 space,
adamc@162 526 string "=",
adamc@162 527 space,
adamc@162 528 string "datatype",
adamc@162 529 space,
adamc@162 530 p_list_sep (string ".") string (m1x :: ms @ [x'])]
adamc@162 531 end
adamc@124 532 | DVal vi => box [string "val",
adamc@124 533 space,
adamc@124 534 p_vali env vi]
adamc@124 535 | DValRec vis =>
adamc@124 536 let
adamc@124 537 val env = E.declBinds env dAll
adamc@124 538 in
adamc@124 539 box [string "val",
adamc@124 540 space,
adamc@124 541 string "rec",
adamc@124 542 space,
adamc@124 543 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@124 544 end
adamc@38 545
adamc@38 546 | DSgn (x, n, sgn) => box [string "signature",
adamc@38 547 space,
adamc@38 548 p_named x n,
adamc@38 549 space,
adamc@38 550 string "=",
adamc@38 551 space,
adamc@38 552 p_sgn env sgn]
adamc@38 553 | DStr (x, n, sgn, str) => box [string "structure",
adamc@38 554 space,
adamc@38 555 p_named x n,
adamc@38 556 space,
adamc@38 557 string ":",
adamc@38 558 space,
adamc@38 559 p_sgn env sgn,
adamc@38 560 space,
adamc@38 561 string "=",
adamc@38 562 space,
adamc@38 563 p_str env str]
adamc@48 564 | DFfiStr (x, n, sgn) => box [string "extern",
adamc@48 565 space,
adamc@48 566 string "structure",
adamc@48 567 space,
adamc@48 568 p_named x n,
adamc@48 569 space,
adamc@48 570 string ":",
adamc@48 571 space,
adamc@48 572 p_sgn env sgn]
adamc@109 573 | DExport (_, sgn, str) => box [string "export",
adamc@109 574 space,
adamc@109 575 p_str env str,
adamc@109 576 space,
adamc@109 577 string ":",
adamc@109 578 space,
adamc@109 579 p_sgn env sgn]
adamc@246 580 | DTable (_, x, n, c) => box [string "table",
adamc@246 581 space,
adamc@246 582 p_named x n,
adamc@246 583 space,
adamc@246 584 string ":",
adamc@246 585 space,
adamc@246 586 p_con env c]
adamc@271 587 | DDatabase s => box [string "database",
adamc@271 588 space,
adamc@271 589 string s]
adamc@38 590
adamc@38 591 and p_str env (str, _) =
adamc@38 592 case str of
adamc@38 593 StrConst ds => box [string "struct",
adamc@38 594 newline,
adamc@38 595 p_file env ds,
adamc@38 596 newline,
adamc@38 597 string "end"]
adamc@146 598 | StrVar n =>
adamc@146 599 let
adamc@146 600 val x = #1 (E.lookupStrNamed env n)
adamc@146 601 handle E.UnboundNamed _ => "UNBOUND"
adamc@146 602
adamc@146 603 val s = if !debug then
adamc@146 604 x ^ "__" ^ Int.toString n
adamc@146 605 else
adamc@146 606 x
adamc@146 607 in
adamc@146 608 string s
adamc@146 609 end
adamc@38 610 | StrProj (str, s) => box [p_str env str,
adamc@38 611 string ".",
adamc@38 612 string s]
adamc@45 613 | StrFun (x, n, sgn, sgn', str) =>
adamc@45 614 let
adamc@45 615 val env' = E.pushStrNamed env x n sgn
adamc@45 616 in
adamc@45 617 box [string "functor",
adamc@45 618 space,
adamc@45 619 string "(",
adamc@45 620 string x,
adamc@45 621 space,
adamc@45 622 string ":",
adamc@45 623 space,
adamc@45 624 p_sgn env sgn,
adamc@45 625 string ")",
adamc@45 626 space,
adamc@45 627 string ":",
adamc@45 628 space,
adamc@45 629 p_sgn env' sgn',
adamc@45 630 space,
adamc@45 631 string "=>",
adamc@45 632 space,
adamc@45 633 p_str env' str]
adamc@45 634 end
adamc@45 635 | StrApp (str1, str2) => box [p_str env str1,
adamc@45 636 string "(",
adamc@45 637 p_str env str2,
adamc@45 638 string ")"]
adamc@38 639
adamc@38 640 and p_file env file =
adamc@38 641 let
adamc@38 642 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@38 643 (p_decl env d,
adamc@38 644 E.declBinds env d))
adamc@38 645 env file
adamc@38 646 in
adamc@38 647 p_list_sep newline (fn x => x) pds
adamc@38 648 end
adamc@38 649
adamc@38 650 end