Mercurial > urweb

annotate src/core_print.sml @ 1613:4973d31b5fff

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix server-side urlification of custom Option types
author Adam Chlipala <adam@chlipala.net>
date Fri, 25 Nov 2011 16:30:34 -0500
parents a99b743a3087
children 0577be31a435
rev   line source
adam@1544 1 (* Copyright (c) 2008-2011, 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 "(",
adamc@48 279 p_list (p_exp env) 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
adamc@1020 449 | EServerCall (n, es, _) => box [string "Server(",
adamc@1020 450 p_enamed env n,
adamc@1020 451 string ",",
adamc@1020 452 space,
adamc@1020 453 p_list (p_exp env) es,
adamc@1020 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