Mercurial > urweb

annotate src/expl_print.sml @ 1512:dcc8abbc6dfd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Change cookie signature comparison to resist timing attacks (based on code suggested by Robin Green and Austin Seipp)
author Adam Chlipala <adam@chlipala.net>
date Tue, 19 Jul 2011 09:18:50 -0400
parents b4480a56cab7
children 1aa9629e3a4c
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']
adamc@45 572 | SgnWhere (sgn, 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,
adamc@45 578 string 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"
adamc@38 734
adamc@38 735 and p_str env (str, _) =
adamc@38 736 case str of
adamc@38 737 StrConst ds => box [string "struct",
adamc@38 738 newline,
adamc@38 739 p_file env ds,
adamc@38 740 newline,
adamc@38 741 string "end"]
adamc@146 742 | StrVar n =>
adamc@146 743 let
adamc@146 744 val x = #1 (E.lookupStrNamed env n)
adamc@480 745 handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString n
adamc@146 746
adamc@146 747 val s = if !debug then
adamc@146 748 x ^ "__" ^ Int.toString n
adamc@146 749 else
adamc@146 750 x
adamc@146 751 in
adamc@146 752 string s
adamc@146 753 end
adamc@38 754 | StrProj (str, s) => box [p_str env str,
adamc@38 755 string ".",
adamc@38 756 string s]
adamc@45 757 | StrFun (x, n, sgn, sgn', str) =>
adamc@45 758 let
adamc@45 759 val env' = E.pushStrNamed env x n sgn
adamc@45 760 in
adamc@45 761 box [string "functor",
adamc@45 762 space,
adamc@45 763 string "(",
adamc@480 764 p_named x n,
adamc@45 765 space,
adamc@45 766 string ":",
adamc@45 767 space,
adamc@45 768 p_sgn env sgn,
adamc@45 769 string ")",
adamc@45 770 space,
adamc@45 771 string ":",
adamc@45 772 space,
adamc@45 773 p_sgn env' sgn',
adamc@45 774 space,
adamc@45 775 string "=>",
adamc@45 776 space,
adamc@45 777 p_str env' str]
adamc@45 778 end
adamc@45 779 | StrApp (str1, str2) => box [p_str env str1,
adamc@45 780 string "(",
adamc@45 781 p_str env str2,
adamc@45 782 string ")"]
adamc@38 783
adamc@38 784 and p_file env file =
adamc@38 785 let
adamc@38 786 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@38 787 (p_decl env d,
adamc@38 788 E.declBinds env d))
adamc@38 789 env file
adamc@38 790 in
adamc@38 791 p_list_sep newline (fn x => x) pds
adamc@38 792 end
adamc@38 793
adamc@38 794 end