Mercurial > urweb

annotate src/core_print.sml @ 2258:b1ba35ce2613

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix bug where pure caching didn't treat FFI applications as effectful.
author Ziv Scully <ziv@mit.edu>
date Sun, 27 Sep 2015 17:02:14 -0400
parents e15234fbb163
children
rev   line source
adam@1848 1 (* Copyright (c) 2008-2011, 2013, Adam Chlipala
adamc@16 2 * All rights reserved.
adamc@16 3 *
adamc@16 4 * Redistribution and use in source and binary forms, with or without
adamc@16 5 * modification, are permitted provided that the following conditions are met:
adamc@16 6 *
adamc@16 7 * - Redistributions of source code must retain the above copyright notice,
adamc@16 8 * this list of conditions and the following disclaimer.
adamc@16 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@16 10 * this list of conditions and the following disclaimer in the documentation
adamc@16 11 * and/or other materials provided with the distribution.
adamc@16 12 * - The names of contributors may not be used to endorse or promote products
adamc@16 13 * derived from this software without specific prior written permission.
adamc@16 14 *
adamc@16 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@16 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@16 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@16 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@16 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@16 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@16 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@16 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@16 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@16 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@16 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@16 26 *)
adamc@16 27
adamc@244 28 (* Pretty-printing core Ur/Web *)
adamc@16 29
adamc@16 30 structure CorePrint :> CORE_PRINT = struct
adamc@16 31
adamc@16 32 open Print.PD
adamc@16 33 open Print
adamc@16 34
adamc@16 35 open Core
adamc@16 36
adamc@16 37 structure E = CoreEnv
adamc@16 38
adamc@16 39 val debug = ref false
adamc@16 40
adamc@626 41 fun p_kind' par env (k, _) =
adamc@16 42 case k of
adamc@16 43 KType => string "Type"
adamc@626 44 | KArrow (k1, k2) => parenIf par (box [p_kind' true env k1,
adamc@16 45 space,
adamc@16 46 string "->",
adamc@16 47 space,
adamc@626 48 p_kind env k2])
adamc@16 49 | KName => string "Name"
adamc@626 50 | KRecord k => box [string "{", p_kind env k, string "}"]
adamc@87 51 | KUnit => string "Unit"
adamc@214 52 | KTuple ks => box [string "(",
adamc@626 53 p_list_sep (box [space, string "*", space]) (p_kind env) ks,
adamc@214 54 string ")"]
adamc@16 55
adamc@626 56 | KRel n => ((if !debug then
adamc@626 57 string (E.lookupKRel env n ^ "_" ^ Int.toString n)
adamc@626 58 else
adamc@626 59 string (E.lookupKRel env n))
adamc@626 60 handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
adamc@626 61 | KFun (x, k) => box [string x,
adamc@626 62 space,
adamc@626 63 string "-->",
adamc@626 64 space,
adamc@626 65 p_kind (E.pushKRel env x) k]
adamc@626 66
adamc@626 67 and p_kind env = p_kind' false env
adamc@16 68
adamc@16 69 fun p_con' par env (c, _) =
adamc@16 70 case c of
adamc@16 71 TFun (t1, t2) => parenIf par (box [p_con' true env t1,
adamc@16 72 space,
adamc@16 73 string "->",
adamc@16 74 space,
adamc@16 75 p_con env t2])
adamc@16 76 | TCFun (x, k, c) => parenIf par (box [string x,
adamc@16 77 space,
adamc@16 78 string "::",
adamc@16 79 space,
adamc@626 80 p_kind env k,
adamc@16 81 space,
adamc@16 82 string "->",
adamc@16 83 space,
adamc@16 84 p_con (E.pushCRel env x k) c])
adamc@16 85 | TRecord (CRecord (_, xcs), _) => box [string "{",
adamc@16 86 p_list (fn (x, c) =>
adamc@20 87 box [p_name env x,
adamc@16 88 space,
adamc@16 89 string ":",
adamc@16 90 space,
adamc@16 91 p_con env c]) xcs,
adamc@16 92 string "}"]
adamc@16 93 | TRecord c => box [string "$",
adamc@16 94 p_con' true env c]
adamc@16 95
adamc@16 96 | CRel n =>
adamc@39 97 ((if !debug then
adamc@39 98 string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n)
adamc@39 99 else
adamc@39 100 string (#1 (E.lookupCRel env n)))
adamc@39 101 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
adamc@16 102 | CNamed n =>
adamc@39 103 ((if !debug then
adamc@39 104 string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n)
adamc@39 105 else
adamc@39 106 string (#1 (E.lookupCNamed env n)))
adamc@480 107 handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n))
adamc@48 108 | CFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@16 109
adamc@16 110 | CApp (c1, c2) => parenIf par (box [p_con env c1,
adamc@16 111 space,
adamc@16 112 p_con' true env c2])
adamc@16 113 | CAbs (x, k, c) => parenIf par (box [string "fn",
adamc@16 114 space,
adamc@16 115 string x,
adamc@16 116 space,
adamc@16 117 string "::",
adamc@16 118 space,
adamc@626 119 p_kind env k,
adamc@16 120 space,
adamc@16 121 string "=>",
adamc@16 122 space,
adamc@16 123 p_con (E.pushCRel env x k) c])
adamc@16 124
adamc@16 125 | CName s => box [string "#", string s]
adamc@16 126
adamc@16 127 | CRecord (k, xcs) =>
adamc@16 128 if !debug then
adamc@16 129 parenIf par (box [string "[",
adamc@16 130 p_list (fn (x, c) =>
adamc@16 131 box [p_con env x,
adamc@16 132 space,
adamc@16 133 string "=",
adamc@16 134 space,
adamc@16 135 p_con env c]) xcs,
adamc@16 136 string "]::",
adamc@626 137 p_kind env k])
adamc@16 138 else
adamc@16 139 parenIf par (box [string "[",
adamc@16 140 p_list (fn (x, c) =>
adamc@16 141 box [p_con env x,
adamc@16 142 space,
adamc@16 143 string "=",
adamc@16 144 space,
adamc@16 145 p_con env c]) xcs,
adamc@16 146 string "]"])
adamc@16 147 | CConcat (c1, c2) => parenIf par (box [p_con' true env c1,
adamc@16 148 space,
adamc@16 149 string "++",
adamc@16 150 space,
adamc@16 151 p_con env c2])
adamc@621 152 | CMap _ => string "map"
adamc@87 153 | CUnit => string "()"
adamc@214 154
adamc@214 155 | CTuple cs => box [string "(",
adamc@214 156 p_list (p_con env) cs,
adamc@214 157 string ")"]
adamc@214 158 | CProj (c, n) => box [p_con env c,
adamc@214 159 string ".",
adamc@214 160 string (Int.toString n)]
adamc@626 161
adamc@626 162 | CKAbs (x, c) => box [string x,
adamc@626 163 space,
adamc@626 164 string "==>",
adamc@626 165 space,
adamc@626 166 p_con (E.pushKRel env x) c]
adamc@626 167 | CKApp (c, k) => box [p_con env c,
adamc@626 168 string "[[",
adamc@626 169 p_kind env k,
adamc@626 170 string "]]"]
adamc@626 171 | TKFun (x, c) => box [string x,
adamc@626 172 space,
adamc@626 173 string "-->",
adamc@626 174 space,
adamc@626 175 p_con (E.pushKRel env x) c]
adamc@16 176
adamc@16 177 and p_con env = p_con' false env
adamc@16 178
adamc@20 179 and p_name env (all as (c, _)) =
adamc@20 180 case c of
adamc@20 181 CName s => string s
adamc@20 182 | _ => p_con env all
adamc@20 183
adamc@109 184 fun p_enamed env n =
adamc@109 185 (if !debug then
adamc@109 186 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@109 187 else
adamc@109 188 string (#1 (E.lookupENamed env n)))
adamc@109 189 handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)
adamc@109 190
adamc@177 191 fun p_con_named env n =
adamc@177 192 (if !debug then
adamc@177 193 string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n)
adamc@177 194 else
adamc@177 195 string (#1 (E.lookupConstructor env n)))
adamc@177 196 handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n)
adamc@177 197
adamc@177 198 fun p_patCon env pc =
adamc@177 199 case pc of
adamc@177 200 PConVar n => p_con_named env n
adamc@796 201 | PConFfi {mod = m, con, arg, params, ...} =>
adamc@757 202 if !debug then
adamc@757 203 box [string "FFIC[",
adamc@757 204 case arg of
adamc@757 205 NONE => box []
adamc@796 206 | SOME t =>
adamc@796 207 let
adamc@796 208 val k = (KType, ErrorMsg.dummySpan)
adamc@796 209 val env' = foldl (fn (x, env) => E.pushCRel env x k) env params
adamc@796 210 in
adamc@796 211 p_con env' t
adamc@796 212 end,
adamc@757 213 string "](",
adamc@757 214 string m,
adamc@757 215 string ".",
adamc@757 216 string con,
adamc@757 217 string ")"]
adamc@757 218 else
adamc@757 219 box [string "FFIC(",
adamc@757 220 string m,
adamc@757 221 string ".",
adamc@757 222 string con,
adamc@757 223 string ")"]
adamc@177 224
adamc@177 225 fun p_pat' par env (p, _) =
adamc@177 226 case p of
adamc@177 227 PWild => string "_"
adamc@182 228 | PVar (s, _) => string s
adamc@177 229 | PPrim p => Prim.p_t p
adamc@192 230 | PCon (_, n, _, NONE) => p_patCon env n
adamc@192 231 | PCon (_, n, _, SOME p) => parenIf par (box [p_patCon env n,
adamc@192 232 space,
adamc@192 233 p_pat' true env p])
adamc@177 234 | PRecord xps =>
adamc@177 235 box [string "{",
adamc@1272 236 p_list_sep (box [string ",", space]) (fn (x, p, t) =>
adamc@177 237 box [string x,
adamc@177 238 space,
adamc@177 239 string "=",
adamc@177 240 space,
adamc@1272 241 p_pat env p,
adamc@1272 242 if !debug then
adamc@1272 243 box [space,
adamc@1272 244 string ":",
adamc@1272 245 space,
adamc@1272 246 p_con env t]
adamc@1272 247 else
adamc@1272 248 box []]) xps,
adamc@177 249 string "}"]
adamc@177 250
adamc@177 251 and p_pat x = p_pat' false x
adamc@177 252
adamc@16 253 fun p_exp' par env (e, _) =
adamc@16 254 case e of
adamc@16 255 EPrim p => Prim.p_t p
adamc@16 256 | ERel n =>
adamc@39 257 ((if !debug then
adamc@39 258 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@39 259 else
adamc@39 260 string (#1 (E.lookupERel env n)))
adamc@39 261 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
adamc@109 262 | ENamed n => p_enamed env n
adamc@194 263 | ECon (_, pc, ts, NONE) => box [string "[",
adamc@194 264 p_patCon env pc,
adamc@194 265 p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts,
adamc@194 266 string "]"]
adamc@194 267 | ECon (_, pc, ts, SOME e) => box [string "[",
adamc@193 268 p_patCon env pc,
adamc@193 269 space,
adamc@193 270 p_exp' true env e,
adamc@194 271 p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts,
adamc@193 272 string "]"]
adamc@48 273 | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@48 274 | EFfiApp (m, x, es) => box [string "FFI(",
adamc@48 275 string m,
adamc@48 276 string ".",
adamc@48 277 string x,
adamc@48 278 string "(",
adam@1663 279 p_list (p_exp env o #1) es,
adamc@48 280 string "))"]
adamc@487 281 | EApp (e1, e2) => parenIf par (box [p_exp' true env e1,
adamc@16 282 space,
adamc@16 283 p_exp' true env e2])
adam@1544 284 | EAbs (x, t, _, e) => parenIf par (box [string "(fn",
adamc@26 285 space,
adamc@26 286 string x,
adamc@26 287 space,
adamc@26 288 string ":",
adamc@26 289 space,
adamc@26 290 p_con env t,
adamc@26 291 space,
adamc@26 292 string "=>",
adamc@26 293 space,
adam@1544 294 p_exp (E.pushERel env x t) e,
adam@1544 295 string ")"])
adamc@16 296 | ECApp (e, c) => parenIf par (box [p_exp env e,
adamc@16 297 space,
adamc@16 298 string "[",
adamc@16 299 p_con env c,
adamc@16 300 string "]"])
adamc@16 301 | ECAbs (x, k, e) => parenIf par (box [string "fn",
adamc@16 302 space,
adamc@16 303 string x,
adamc@16 304 space,
adamc@16 305 string "::",
adamc@16 306 space,
adamc@626 307 p_kind env k,
adamc@16 308 space,
adamc@16 309 string "=>",
adamc@16 310 space,
adamc@16 311 p_exp (E.pushCRel env x k) e])
adamc@16 312
adamc@16 313 | ERecord xes => box [string "{",
adamc@29 314 p_list (fn (x, e, _) =>
adamc@21 315 box [p_name env x,
adamc@16 316 space,
adamc@16 317 string "=",
adamc@16 318 space,
adamc@16 319 p_exp env e]) xes,
adamc@16 320 string "}"]
adamc@16 321 | EField (e, c, {field, rest}) =>
adamc@16 322 if !debug then
adamc@16 323 box [p_exp' true env e,
adamc@16 324 string ".",
adamc@16 325 p_con' true env c,
adamc@16 326 space,
adamc@16 327 string "[",
adamc@16 328 p_con env field,
adamc@16 329 space,
adamc@16 330 string " in ",
adamc@16 331 space,
adamc@16 332 p_con env rest,
adamc@16 333 string "]"]
adamc@16 334 else
adamc@16 335 box [p_exp' true env e,
adamc@16 336 string ".",
adamc@16 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@16 397
adamc@288 398 | ECase (e, pes, {disc, result}) =>
adamc@288 399 parenIf par (box [string "case",
adamc@288 400 space,
adamc@288 401 p_exp env e,
adamc@288 402 space,
adamc@288 403 if !debug then
adamc@288 404 box [string "in",
adamc@288 405 space,
adamc@288 406 p_con env disc,
adamc@288 407 space,
adamc@288 408 string "return",
adamc@288 409 space,
adamc@288 410 p_con env result,
adamc@288 411 space]
adamc@288 412 else
adamc@288 413 box [],
adamc@288 414 string "of",
adamc@288 415 space,
adamc@288 416 p_list_sep (box [space, string "|", space])
adamc@288 417 (fn (p, e) => box [p_pat env p,
adamc@288 418 space,
adamc@288 419 string "=>",
adamc@288 420 space,
adamc@288 421 p_exp (E.patBinds env p) e]) pes])
adamc@177 422
adamc@102 423 | EWrite e => box [string "write(",
adamc@102 424 p_exp env e,
adamc@102 425 string ")"]
adamc@102 426
adamc@110 427 | EClosure (n, es) => box [string "CLOSURE(",
adamc@110 428 p_enamed env n,
adamc@110 429 p_list_sep (string "") (fn e => box [string ", ",
adamc@110 430 p_exp env e]) es,
adamc@110 431 string ")"]
adamc@110 432
adamc@450 433 | ELet (x, t, e1, e2) => box [string "let",
adamc@450 434 space,
adamc@450 435 string x,
adamc@450 436 space,
adamc@450 437 string ":",
adamc@910 438 space,
adamc@450 439 p_con env t,
adamc@450 440 space,
adamc@450 441 string "=",
adamc@450 442 space,
adamc@450 443 p_exp env e1,
adamc@450 444 space,
adamc@450 445 string "in",
adamc@450 446 newline,
adamc@450 447 p_exp (E.pushERel env x t) e2]
adamc@450 448
adam@1848 449 | EServerCall (n, es, _, _) => box [string "Server(",
adam@1848 450 p_enamed env n,
adam@1848 451 string ",",
adam@1848 452 space,
adam@1848 453 p_list (p_exp env) es,
adam@1848 454 string ")"]
adamc@607 455
adamc@626 456 | EKAbs (x, e) => box [string x,
adamc@626 457 space,
adamc@626 458 string "==>",
adamc@626 459 space,
adamc@626 460 p_exp (E.pushKRel env x) e]
adamc@626 461 | EKApp (e, k) => box [p_exp env e,
adamc@626 462 string "[[",
adamc@626 463 p_kind env k,
adamc@626 464 string "]]"]
adamc@626 465
adamc@16 466 and p_exp env = p_exp' false env
adamc@16 467
adamc@247 468 fun p_named x n =
adamc@247 469 if !debug then
adamc@247 470 box [string x,
adamc@247 471 string "__",
adamc@247 472 string (Int.toString n)]
adamc@247 473 else
adamc@247 474 string x
adamc@247 475
adamc@125 476 fun p_vali env (x, n, t, e, s) =
adamc@125 477 let
adamc@247 478 val xp = p_named x n
adamc@125 479 in
adamc@125 480 box [xp,
adamc@125 481 space,
adamc@125 482 string "as",
adamc@125 483 space,
adamc@125 484 string s,
adamc@125 485 space,
adamc@125 486 string ":",
adamc@125 487 space,
adamc@125 488 p_con env t,
adamc@125 489 space,
adamc@125 490 string "=",
adamc@125 491 space,
adamc@125 492 p_exp env e]
adamc@125 493 end
adamc@125 494
adamc@192 495 fun p_datatype env (x, n, xs, cons) =
adamc@163 496 let
adamc@192 497 val k = (KType, ErrorMsg.dummySpan)
adamc@163 498 val env = E.pushCNamed env x n (KType, ErrorMsg.dummySpan) NONE
adamc@192 499 val env = foldl (fn (x, env) => E.pushCRel env x k) env xs
adamc@193 500
adamc@193 501 val xp = if !debug then
adamc@193 502 string (x ^ "__" ^ Int.toString n)
adamc@193 503 else
adamc@193 504 string x
adamc@163 505 in
adamc@807 506 box [xp,
adamc@192 507 p_list_sep (box []) (fn x => box [space, string x]) xs,
adamc@163 508 space,
adamc@163 509 string "=",
adamc@163 510 space,
adamc@163 511 p_list_sep (box [space, string "|", space])
adamc@163 512 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@163 513 else string x
adamc@193 514 | (x, n, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@163 515 else string x, space, string "of", space, p_con env t])
adamc@163 516 cons]
adamc@163 517 end
adamc@163 518
adamc@125 519 fun p_decl env (dAll as (d, _) : decl) =
adamc@16 520 case d of
adamc@16 521 DCon (x, n, k, c) =>
adamc@16 522 let
adamc@16 523 val xp = if !debug then
adamc@16 524 box [string x,
adamc@16 525 string "__",
adamc@16 526 string (Int.toString n)]
adamc@16 527 else
adamc@16 528 string x
adamc@16 529 in
adamc@16 530 box [string "con",
adamc@16 531 space,
adamc@16 532 xp,
adamc@16 533 space,
adamc@16 534 string "::",
adamc@16 535 space,
adamc@626 536 p_kind env k,
adamc@16 537 space,
adamc@16 538 string "=",
adamc@16 539 space,
adamc@16 540 p_con env c]
adamc@16 541 end
adamc@807 542 | DDatatype x => box [string "datatype",
adamc@807 543 space,
adamc@807 544 p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x]
adamc@125 545 | DVal vi => box [string "val",
adamc@125 546 space,
adamc@125 547 p_vali env vi]
adamc@125 548 | DValRec vis =>
adamc@16 549 let
adamc@125 550 val env = E.declBinds env dAll
adamc@16 551 in
adamc@16 552 box [string "val",
adamc@16 553 space,
adamc@125 554 string "rec",
adamc@16 555 space,
adamc@125 556 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@16 557 end
adamc@1104 558 | DExport (ek, n, _) => box [string "export",
adamc@1104 559 space,
adamc@1104 560 Export.p_export_kind ek,
adamc@1104 561 space,
adamc@1104 562 p_enamed env n,
adamc@1104 563 space,
adamc@1104 564 string "as",
adamc@1104 565 space,
adamc@1104 566 (p_con env (#2 (E.lookupENamed env n))
adamc@1104 567 handle E.UnboundNamed _ => string "UNBOUND")]
adamc@707 568 | DTable (x, n, c, s, pe, _, ce, _) => box [string "table",
adamc@707 569 space,
adamc@707 570 p_named x n,
adamc@707 571 space,
adamc@707 572 string "as",
adamc@707 573 space,
adamc@707 574 string s,
adamc@707 575 space,
adamc@707 576 string ":",
adamc@707 577 space,
adamc@707 578 p_con env c,
adamc@707 579 space,
adamc@707 580 string "keys",
adamc@707 581 space,
adamc@707 582 p_exp env pe,
adamc@707 583 space,
adamc@707 584 string "constraints",
adamc@707 585 space,
adamc@802 586 p_exp (E.declBinds env dAll) ce]
adamc@338 587 | DSequence (x, n, s) => box [string "sequence",
adamc@338 588 space,
adamc@338 589 p_named x n,
adamc@338 590 space,
adamc@338 591 string "as",
adamc@338 592 space,
adamc@338 593 string s]
adamc@754 594 | DView (x, n, s, e, _) => box [string "view",
adamc@754 595 space,
adamc@754 596 p_named x n,
adamc@754 597 space,
adamc@754 598 string "as",
adamc@754 599 space,
adamc@754 600 p_exp env e]
adamc@271 601 | DDatabase s => box [string "database",
adamc@271 602 space,
adamc@271 603 string s]
adamc@461 604 | DCookie (x, n, c, s) => box [string "cookie",
adamc@461 605 space,
adamc@461 606 p_named x n,
adamc@461 607 space,
adamc@461 608 string "as",
adamc@461 609 space,
adamc@461 610 string s,
adamc@461 611 space,
adamc@461 612 string ":",
adamc@461 613 space,
adamc@461 614 p_con env c]
adamc@720 615 | DStyle (x, n, s) => box [string "style",
adamc@720 616 space,
adamc@720 617 p_named x n,
adamc@720 618 space,
adamc@720 619 string "as",
adamc@720 620 space,
adamc@720 621 string s]
adamc@1075 622 | DTask (e1, e2) => box [string "task",
adamc@1073 623 space,
adamc@1075 624 p_exp env e1,
adamc@1075 625 space,
adamc@1075 626 string "=",
adamc@1075 627 space,
adamc@1075 628 p_exp env e2]
adamc@1199 629 | DPolicy e1 => box [string "policy",
adamc@1199 630 space,
adamc@1199 631 p_exp env e1]
adam@1294 632 | DOnError _ => string "ONERROR"
adamc@16 633
adamc@16 634 fun p_file env file =
adamc@16 635 let
adamc@31 636 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 637 (p_decl env d,
adamc@31 638 E.declBinds env d))
adamc@16 639 env file
adamc@16 640 in
adamc@16 641 p_list_sep newline (fn x => x) pds
adamc@16 642 end
adamc@16 643
adamc@16 644 end