Mercurial > urweb

annotate src/core_print.sml @ 564:803b2f3bb86b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Monad type class seems to be working
author Adam Chlipala <adamc@hcoop.net>
date Fri, 19 Dec 2008 10:27:58 -0500
parents ae03d09043c1
children 0dd40b6bfdf3
rev   line source
adamc@16 1 (* Copyright (c) 2008, 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@16 41 fun p_kind' par (k, _) =
adamc@16 42 case k of
adamc@16 43 KType => string "Type"
adamc@16 44 | KArrow (k1, k2) => parenIf par (box [p_kind' true k1,
adamc@16 45 space,
adamc@16 46 string "->",
adamc@16 47 space,
adamc@16 48 p_kind k2])
adamc@16 49 | KName => string "Name"
adamc@16 50 | KRecord k => box [string "{", p_kind k, string "}"]
adamc@87 51 | KUnit => string "Unit"
adamc@214 52 | KTuple ks => box [string "(",
adamc@214 53 p_list_sep (box [space, string "*", space]) p_kind ks,
adamc@214 54 string ")"]
adamc@16 55
adamc@16 56 and p_kind k = p_kind' false k
adamc@16 57
adamc@16 58 fun p_con' par env (c, _) =
adamc@16 59 case c of
adamc@16 60 TFun (t1, t2) => parenIf par (box [p_con' true env t1,
adamc@16 61 space,
adamc@16 62 string "->",
adamc@16 63 space,
adamc@16 64 p_con env t2])
adamc@16 65 | TCFun (x, k, c) => parenIf par (box [string x,
adamc@16 66 space,
adamc@16 67 string "::",
adamc@16 68 space,
adamc@16 69 p_kind k,
adamc@16 70 space,
adamc@16 71 string "->",
adamc@16 72 space,
adamc@16 73 p_con (E.pushCRel env x k) c])
adamc@16 74 | TRecord (CRecord (_, xcs), _) => box [string "{",
adamc@16 75 p_list (fn (x, c) =>
adamc@20 76 box [p_name env x,
adamc@16 77 space,
adamc@16 78 string ":",
adamc@16 79 space,
adamc@16 80 p_con env c]) xcs,
adamc@16 81 string "}"]
adamc@16 82 | TRecord c => box [string "$",
adamc@16 83 p_con' true env c]
adamc@16 84
adamc@16 85 | CRel n =>
adamc@39 86 ((if !debug then
adamc@39 87 string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n)
adamc@39 88 else
adamc@39 89 string (#1 (E.lookupCRel env n)))
adamc@39 90 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
adamc@16 91 | CNamed n =>
adamc@39 92 ((if !debug then
adamc@39 93 string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n)
adamc@39 94 else
adamc@39 95 string (#1 (E.lookupCNamed env n)))
adamc@480 96 handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n))
adamc@48 97 | CFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@16 98
adamc@16 99 | CApp (c1, c2) => parenIf par (box [p_con env c1,
adamc@16 100 space,
adamc@16 101 p_con' true env c2])
adamc@16 102 | CAbs (x, k, c) => parenIf par (box [string "fn",
adamc@16 103 space,
adamc@16 104 string x,
adamc@16 105 space,
adamc@16 106 string "::",
adamc@16 107 space,
adamc@16 108 p_kind k,
adamc@16 109 space,
adamc@16 110 string "=>",
adamc@16 111 space,
adamc@16 112 p_con (E.pushCRel env x k) c])
adamc@16 113
adamc@16 114 | CName s => box [string "#", string s]
adamc@16 115
adamc@16 116 | CRecord (k, xcs) =>
adamc@16 117 if !debug then
adamc@16 118 parenIf par (box [string "[",
adamc@16 119 p_list (fn (x, c) =>
adamc@16 120 box [p_con env x,
adamc@16 121 space,
adamc@16 122 string "=",
adamc@16 123 space,
adamc@16 124 p_con env c]) xcs,
adamc@16 125 string "]::",
adamc@16 126 p_kind k])
adamc@16 127 else
adamc@16 128 parenIf par (box [string "[",
adamc@16 129 p_list (fn (x, c) =>
adamc@16 130 box [p_con env x,
adamc@16 131 space,
adamc@16 132 string "=",
adamc@16 133 space,
adamc@16 134 p_con env c]) xcs,
adamc@16 135 string "]"])
adamc@16 136 | CConcat (c1, c2) => parenIf par (box [p_con' true env c1,
adamc@16 137 space,
adamc@16 138 string "++",
adamc@16 139 space,
adamc@16 140 p_con env c2])
adamc@69 141 | CFold _ => string "fold"
adamc@87 142 | CUnit => string "()"
adamc@214 143
adamc@214 144 | CTuple cs => box [string "(",
adamc@214 145 p_list (p_con env) cs,
adamc@214 146 string ")"]
adamc@214 147 | CProj (c, n) => box [p_con env c,
adamc@214 148 string ".",
adamc@214 149 string (Int.toString n)]
adamc@16 150
adamc@16 151 and p_con env = p_con' false env
adamc@16 152
adamc@20 153 and p_name env (all as (c, _)) =
adamc@20 154 case c of
adamc@20 155 CName s => string s
adamc@20 156 | _ => p_con env all
adamc@20 157
adamc@109 158 fun p_enamed env n =
adamc@109 159 (if !debug then
adamc@109 160 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@109 161 else
adamc@109 162 string (#1 (E.lookupENamed env n)))
adamc@109 163 handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)
adamc@109 164
adamc@177 165 fun p_con_named env n =
adamc@177 166 (if !debug then
adamc@177 167 string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n)
adamc@177 168 else
adamc@177 169 string (#1 (E.lookupConstructor env n)))
adamc@177 170 handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n)
adamc@177 171
adamc@177 172 fun p_patCon env pc =
adamc@177 173 case pc of
adamc@177 174 PConVar n => p_con_named env n
adamc@186 175 | PConFfi {mod = m, con, ...} => box [string "FFIC(",
adamc@185 176 string m,
adamc@185 177 string ".",
adamc@185 178 string con,
adamc@185 179 string ")"]
adamc@177 180
adamc@177 181 fun p_pat' par env (p, _) =
adamc@177 182 case p of
adamc@177 183 PWild => string "_"
adamc@182 184 | PVar (s, _) => string s
adamc@177 185 | PPrim p => Prim.p_t p
adamc@192 186 | PCon (_, n, _, NONE) => p_patCon env n
adamc@192 187 | PCon (_, n, _, SOME p) => parenIf par (box [p_patCon env n,
adamc@192 188 space,
adamc@192 189 p_pat' true env p])
adamc@177 190 | PRecord xps =>
adamc@177 191 box [string "{",
adamc@182 192 p_list_sep (box [string ",", space]) (fn (x, p, _) =>
adamc@177 193 box [string x,
adamc@177 194 space,
adamc@177 195 string "=",
adamc@177 196 space,
adamc@177 197 p_pat env p]) xps,
adamc@177 198 string "}"]
adamc@177 199
adamc@177 200 and p_pat x = p_pat' false x
adamc@177 201
adamc@16 202 fun p_exp' par env (e, _) =
adamc@16 203 case e of
adamc@16 204 EPrim p => Prim.p_t p
adamc@16 205 | ERel n =>
adamc@39 206 ((if !debug then
adamc@39 207 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@39 208 else
adamc@39 209 string (#1 (E.lookupERel env n)))
adamc@39 210 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
adamc@109 211 | ENamed n => p_enamed env n
adamc@194 212 | ECon (_, pc, ts, NONE) => box [string "[",
adamc@194 213 p_patCon env pc,
adamc@194 214 p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts,
adamc@194 215 string "]"]
adamc@194 216 | ECon (_, pc, ts, SOME e) => box [string "[",
adamc@193 217 p_patCon env pc,
adamc@193 218 space,
adamc@193 219 p_exp' true env e,
adamc@194 220 p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts,
adamc@193 221 string "]"]
adamc@48 222 | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@48 223 | EFfiApp (m, x, es) => box [string "FFI(",
adamc@48 224 string m,
adamc@48 225 string ".",
adamc@48 226 string x,
adamc@48 227 string "(",
adamc@48 228 p_list (p_exp env) es,
adamc@48 229 string "))"]
adamc@487 230 | EApp (e1, e2) => parenIf par (box [p_exp' true env e1,
adamc@16 231 space,
adamc@16 232 p_exp' true env e2])
adamc@26 233 | EAbs (x, t, _, e) => parenIf par (box [string "fn",
adamc@26 234 space,
adamc@26 235 string x,
adamc@26 236 space,
adamc@26 237 string ":",
adamc@26 238 space,
adamc@26 239 p_con env t,
adamc@26 240 space,
adamc@26 241 string "=>",
adamc@26 242 space,
adamc@26 243 p_exp (E.pushERel env x t) e])
adamc@16 244 | ECApp (e, c) => parenIf par (box [p_exp env e,
adamc@16 245 space,
adamc@16 246 string "[",
adamc@16 247 p_con env c,
adamc@16 248 string "]"])
adamc@16 249 | ECAbs (x, k, e) => parenIf par (box [string "fn",
adamc@16 250 space,
adamc@16 251 string x,
adamc@16 252 space,
adamc@16 253 string "::",
adamc@16 254 space,
adamc@16 255 p_kind k,
adamc@16 256 space,
adamc@16 257 string "=>",
adamc@16 258 space,
adamc@16 259 p_exp (E.pushCRel env x k) e])
adamc@16 260
adamc@16 261 | ERecord xes => box [string "{",
adamc@29 262 p_list (fn (x, e, _) =>
adamc@21 263 box [p_name env x,
adamc@16 264 space,
adamc@16 265 string "=",
adamc@16 266 space,
adamc@16 267 p_exp env e]) xes,
adamc@16 268 string "}"]
adamc@16 269 | EField (e, c, {field, rest}) =>
adamc@16 270 if !debug then
adamc@16 271 box [p_exp' true env e,
adamc@16 272 string ".",
adamc@16 273 p_con' true env c,
adamc@16 274 space,
adamc@16 275 string "[",
adamc@16 276 p_con env field,
adamc@16 277 space,
adamc@16 278 string " in ",
adamc@16 279 space,
adamc@16 280 p_con env rest,
adamc@16 281 string "]"]
adamc@16 282 else
adamc@16 283 box [p_exp' true env e,
adamc@16 284 string ".",
adamc@16 285 p_con' true env c]
adamc@445 286 | EConcat (e1, c1, e2, c2) =>
adamc@339 287 parenIf par (if !debug then
adamc@445 288 box [p_exp' true env e1,
adamc@445 289 space,
adamc@445 290 string ":",
adamc@445 291 space,
adamc@445 292 p_con env c1,
adamc@445 293 space,
adamc@445 294 string "++",
adamc@445 295 space,
adamc@445 296 p_exp' true env e2,
adamc@445 297 space,
adamc@445 298 string ":",
adamc@445 299 space,
adamc@445 300 p_con env c2]
adamc@445 301 else
adamc@445 302 box [p_exp' true env e1,
adamc@339 303 space,
adamc@339 304 string "with",
adamc@339 305 space,
adamc@339 306 p_exp' true env e2])
adamc@149 307 | ECut (e, c, {field, rest}) =>
adamc@149 308 parenIf par (if !debug then
adamc@149 309 box [p_exp' true env e,
adamc@149 310 space,
adamc@149 311 string "--",
adamc@149 312 space,
adamc@149 313 p_con' true env c,
adamc@149 314 space,
adamc@149 315 string "[",
adamc@149 316 p_con env field,
adamc@149 317 space,
adamc@149 318 string " in ",
adamc@149 319 space,
adamc@149 320 p_con env rest,
adamc@149 321 string "]"]
adamc@149 322 else
adamc@149 323 box [p_exp' true env e,
adamc@149 324 space,
adamc@149 325 string "--",
adamc@149 326 space,
adamc@149 327 p_con' true env c])
adamc@493 328 | ECutMulti (e, c, {rest}) =>
adamc@493 329 parenIf par (if !debug then
adamc@493 330 box [p_exp' true env e,
adamc@493 331 space,
adamc@493 332 string "---",
adamc@493 333 space,
adamc@493 334 p_con' true env c,
adamc@493 335 space,
adamc@493 336 string "[",
adamc@493 337 p_con env rest,
adamc@493 338 string "]"]
adamc@493 339 else
adamc@493 340 box [p_exp' true env e,
adamc@493 341 space,
adamc@493 342 string "---",
adamc@493 343 space,
adamc@493 344 p_con' true env c])
adamc@73 345 | EFold _ => string "fold"
adamc@16 346
adamc@288 347 | ECase (e, pes, {disc, result}) =>
adamc@288 348 parenIf par (box [string "case",
adamc@288 349 space,
adamc@288 350 p_exp env e,
adamc@288 351 space,
adamc@288 352 if !debug then
adamc@288 353 box [string "in",
adamc@288 354 space,
adamc@288 355 p_con env disc,
adamc@288 356 space,
adamc@288 357 string "return",
adamc@288 358 space,
adamc@288 359 p_con env result,
adamc@288 360 space]
adamc@288 361 else
adamc@288 362 box [],
adamc@288 363 string "of",
adamc@288 364 space,
adamc@288 365 p_list_sep (box [space, string "|", space])
adamc@288 366 (fn (p, e) => box [p_pat env p,
adamc@288 367 space,
adamc@288 368 string "=>",
adamc@288 369 space,
adamc@288 370 p_exp (E.patBinds env p) e]) pes])
adamc@177 371
adamc@102 372 | EWrite e => box [string "write(",
adamc@102 373 p_exp env e,
adamc@102 374 string ")"]
adamc@102 375
adamc@110 376 | EClosure (n, es) => box [string "CLOSURE(",
adamc@110 377 p_enamed env n,
adamc@110 378 p_list_sep (string "") (fn e => box [string ", ",
adamc@110 379 p_exp env e]) es,
adamc@110 380 string ")"]
adamc@110 381
adamc@450 382 | ELet (x, t, e1, e2) => box [string "let",
adamc@450 383 space,
adamc@450 384 string x,
adamc@450 385 space,
adamc@450 386 string ":",
adamc@450 387 p_con env t,
adamc@450 388 space,
adamc@450 389 string "=",
adamc@450 390 space,
adamc@450 391 p_exp env e1,
adamc@450 392 space,
adamc@450 393 string "in",
adamc@450 394 newline,
adamc@450 395 p_exp (E.pushERel env x t) e2]
adamc@450 396
adamc@16 397 and p_exp env = p_exp' false env
adamc@16 398
adamc@247 399 fun p_named x n =
adamc@247 400 if !debug then
adamc@247 401 box [string x,
adamc@247 402 string "__",
adamc@247 403 string (Int.toString n)]
adamc@247 404 else
adamc@247 405 string x
adamc@247 406
adamc@125 407 fun p_vali env (x, n, t, e, s) =
adamc@125 408 let
adamc@247 409 val xp = p_named x n
adamc@125 410 in
adamc@125 411 box [xp,
adamc@125 412 space,
adamc@125 413 string "as",
adamc@125 414 space,
adamc@125 415 string s,
adamc@125 416 space,
adamc@125 417 string ":",
adamc@125 418 space,
adamc@125 419 p_con env t,
adamc@125 420 space,
adamc@125 421 string "=",
adamc@125 422 space,
adamc@125 423 p_exp env e]
adamc@125 424 end
adamc@125 425
adamc@144 426 fun p_export_kind ck =
adamc@144 427 case ck of
adamc@144 428 Link => string "link"
adamc@144 429 | Action => string "action"
adamc@144 430
adamc@192 431 fun p_datatype env (x, n, xs, cons) =
adamc@163 432 let
adamc@192 433 val k = (KType, ErrorMsg.dummySpan)
adamc@163 434 val env = E.pushCNamed env x n (KType, ErrorMsg.dummySpan) NONE
adamc@192 435 val env = foldl (fn (x, env) => E.pushCRel env x k) env xs
adamc@193 436
adamc@193 437 val xp = if !debug then
adamc@193 438 string (x ^ "__" ^ Int.toString n)
adamc@193 439 else
adamc@193 440 string x
adamc@163 441 in
adamc@163 442 box [string "datatype",
adamc@163 443 space,
adamc@193 444 xp,
adamc@192 445 p_list_sep (box []) (fn x => box [space, string x]) xs,
adamc@163 446 space,
adamc@163 447 string "=",
adamc@163 448 space,
adamc@163 449 p_list_sep (box [space, string "|", space])
adamc@163 450 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@163 451 else string x
adamc@193 452 | (x, n, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@163 453 else string x, space, string "of", space, p_con env t])
adamc@163 454 cons]
adamc@163 455 end
adamc@163 456
adamc@125 457 fun p_decl env (dAll as (d, _) : decl) =
adamc@16 458 case d of
adamc@16 459 DCon (x, n, k, c) =>
adamc@16 460 let
adamc@16 461 val xp = if !debug then
adamc@16 462 box [string x,
adamc@16 463 string "__",
adamc@16 464 string (Int.toString n)]
adamc@16 465 else
adamc@16 466 string x
adamc@16 467 in
adamc@16 468 box [string "con",
adamc@16 469 space,
adamc@16 470 xp,
adamc@16 471 space,
adamc@16 472 string "::",
adamc@16 473 space,
adamc@16 474 p_kind k,
adamc@16 475 space,
adamc@16 476 string "=",
adamc@16 477 space,
adamc@16 478 p_con env c]
adamc@16 479 end
adamc@163 480 | DDatatype x => p_datatype env x
adamc@125 481 | DVal vi => box [string "val",
adamc@125 482 space,
adamc@125 483 p_vali env vi]
adamc@125 484 | DValRec vis =>
adamc@16 485 let
adamc@125 486 val env = E.declBinds env dAll
adamc@16 487 in
adamc@16 488 box [string "val",
adamc@16 489 space,
adamc@125 490 string "rec",
adamc@16 491 space,
adamc@125 492 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@16 493 end
adamc@144 494 | DExport (ek, n) => box [string "export",
adamc@144 495 space,
adamc@144 496 p_export_kind ek,
adamc@144 497 space,
adamc@144 498 p_enamed env n,
adamc@144 499 space,
adamc@144 500 string "as",
adamc@144 501 space,
adamc@482 502 (p_con env (#2 (E.lookupENamed env n))
adamc@482 503 handle E.UnboundNamed _ => string "UNBOUND")]
adamc@247 504 | DTable (x, n, c, s) => box [string "table",
adamc@247 505 space,
adamc@247 506 p_named x n,
adamc@247 507 space,
adamc@247 508 string "as",
adamc@247 509 space,
adamc@247 510 string s,
adamc@247 511 space,
adamc@247 512 string ":",
adamc@247 513 space,
adamc@247 514 p_con env c]
adamc@338 515 | DSequence (x, n, s) => box [string "sequence",
adamc@338 516 space,
adamc@338 517 p_named x n,
adamc@338 518 space,
adamc@338 519 string "as",
adamc@338 520 space,
adamc@338 521 string s]
adamc@271 522 | DDatabase s => box [string "database",
adamc@271 523 space,
adamc@271 524 string s]
adamc@461 525 | DCookie (x, n, c, s) => box [string "cookie",
adamc@461 526 space,
adamc@461 527 p_named x n,
adamc@461 528 space,
adamc@461 529 string "as",
adamc@461 530 space,
adamc@461 531 string s,
adamc@461 532 space,
adamc@461 533 string ":",
adamc@461 534 space,
adamc@461 535 p_con env c]
adamc@16 536
adamc@16 537 fun p_file env file =
adamc@16 538 let
adamc@31 539 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 540 (p_decl env d,
adamc@31 541 E.declBinds env d))
adamc@16 542 env file
adamc@16 543 in
adamc@16 544 p_list_sep newline (fn x => x) pds
adamc@16 545 end
adamc@16 546
adamc@16 547 end