Mercurial > urweb

annotate src/core_print.sml @ 194:df5fd8f6913a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
A multi-parameter datatype all the way through
author Adam Chlipala <adamc@hcoop.net>
date Sat, 09 Aug 2008 08:47:36 -0400
parents 8a70e2919e86
children 766b5475477f
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@16 28 (* Pretty-printing core Laconic/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@16 52
adamc@16 53 and p_kind k = p_kind' false k
adamc@16 54
adamc@16 55 fun p_con' par env (c, _) =
adamc@16 56 case c of
adamc@16 57 TFun (t1, t2) => parenIf par (box [p_con' true env t1,
adamc@16 58 space,
adamc@16 59 string "->",
adamc@16 60 space,
adamc@16 61 p_con env t2])
adamc@16 62 | TCFun (x, k, c) => parenIf par (box [string x,
adamc@16 63 space,
adamc@16 64 string "::",
adamc@16 65 space,
adamc@16 66 p_kind k,
adamc@16 67 space,
adamc@16 68 string "->",
adamc@16 69 space,
adamc@16 70 p_con (E.pushCRel env x k) c])
adamc@16 71 | TRecord (CRecord (_, xcs), _) => box [string "{",
adamc@16 72 p_list (fn (x, c) =>
adamc@20 73 box [p_name env x,
adamc@16 74 space,
adamc@16 75 string ":",
adamc@16 76 space,
adamc@16 77 p_con env c]) xcs,
adamc@16 78 string "}"]
adamc@16 79 | TRecord c => box [string "$",
adamc@16 80 p_con' true env c]
adamc@16 81
adamc@16 82 | CRel n =>
adamc@39 83 ((if !debug then
adamc@39 84 string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n)
adamc@39 85 else
adamc@39 86 string (#1 (E.lookupCRel env n)))
adamc@39 87 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
adamc@16 88 | CNamed n =>
adamc@39 89 ((if !debug then
adamc@39 90 string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n)
adamc@39 91 else
adamc@39 92 string (#1 (E.lookupCNamed env n)))
adamc@39 93 handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n))
adamc@48 94 | CFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@16 95
adamc@16 96 | CApp (c1, c2) => parenIf par (box [p_con env c1,
adamc@16 97 space,
adamc@16 98 p_con' true env c2])
adamc@16 99 | CAbs (x, k, c) => parenIf par (box [string "fn",
adamc@16 100 space,
adamc@16 101 string x,
adamc@16 102 space,
adamc@16 103 string "::",
adamc@16 104 space,
adamc@16 105 p_kind k,
adamc@16 106 space,
adamc@16 107 string "=>",
adamc@16 108 space,
adamc@16 109 p_con (E.pushCRel env x k) c])
adamc@16 110
adamc@16 111 | CName s => box [string "#", string s]
adamc@16 112
adamc@16 113 | CRecord (k, xcs) =>
adamc@16 114 if !debug then
adamc@16 115 parenIf par (box [string "[",
adamc@16 116 p_list (fn (x, c) =>
adamc@16 117 box [p_con env x,
adamc@16 118 space,
adamc@16 119 string "=",
adamc@16 120 space,
adamc@16 121 p_con env c]) xcs,
adamc@16 122 string "]::",
adamc@16 123 p_kind k])
adamc@16 124 else
adamc@16 125 parenIf par (box [string "[",
adamc@16 126 p_list (fn (x, c) =>
adamc@16 127 box [p_con env x,
adamc@16 128 space,
adamc@16 129 string "=",
adamc@16 130 space,
adamc@16 131 p_con env c]) xcs,
adamc@16 132 string "]"])
adamc@16 133 | CConcat (c1, c2) => parenIf par (box [p_con' true env c1,
adamc@16 134 space,
adamc@16 135 string "++",
adamc@16 136 space,
adamc@16 137 p_con env c2])
adamc@69 138 | CFold _ => string "fold"
adamc@87 139 | CUnit => string "()"
adamc@16 140
adamc@16 141 and p_con env = p_con' false env
adamc@16 142
adamc@20 143 and p_name env (all as (c, _)) =
adamc@20 144 case c of
adamc@20 145 CName s => string s
adamc@20 146 | _ => p_con env all
adamc@20 147
adamc@109 148 fun p_enamed env n =
adamc@109 149 (if !debug then
adamc@109 150 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@109 151 else
adamc@109 152 string (#1 (E.lookupENamed env n)))
adamc@109 153 handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)
adamc@109 154
adamc@177 155 fun p_con_named env n =
adamc@177 156 (if !debug then
adamc@177 157 string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n)
adamc@177 158 else
adamc@177 159 string (#1 (E.lookupConstructor env n)))
adamc@177 160 handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n)
adamc@177 161
adamc@177 162 fun p_patCon env pc =
adamc@177 163 case pc of
adamc@177 164 PConVar n => p_con_named env n
adamc@186 165 | PConFfi {mod = m, con, ...} => box [string "FFIC(",
adamc@185 166 string m,
adamc@185 167 string ".",
adamc@185 168 string con,
adamc@185 169 string ")"]
adamc@177 170
adamc@177 171 fun p_pat' par env (p, _) =
adamc@177 172 case p of
adamc@177 173 PWild => string "_"
adamc@182 174 | PVar (s, _) => string s
adamc@177 175 | PPrim p => Prim.p_t p
adamc@192 176 | PCon (_, n, _, NONE) => p_patCon env n
adamc@192 177 | PCon (_, n, _, SOME p) => parenIf par (box [p_patCon env n,
adamc@192 178 space,
adamc@192 179 p_pat' true env p])
adamc@177 180 | PRecord xps =>
adamc@177 181 box [string "{",
adamc@182 182 p_list_sep (box [string ",", space]) (fn (x, p, _) =>
adamc@177 183 box [string x,
adamc@177 184 space,
adamc@177 185 string "=",
adamc@177 186 space,
adamc@177 187 p_pat env p]) xps,
adamc@177 188 string "}"]
adamc@177 189
adamc@177 190 and p_pat x = p_pat' false x
adamc@177 191
adamc@16 192 fun p_exp' par env (e, _) =
adamc@16 193 case e of
adamc@16 194 EPrim p => Prim.p_t p
adamc@16 195 | ERel n =>
adamc@39 196 ((if !debug then
adamc@39 197 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@39 198 else
adamc@39 199 string (#1 (E.lookupERel env n)))
adamc@39 200 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
adamc@109 201 | ENamed n => p_enamed env n
adamc@194 202 | ECon (_, pc, ts, NONE) => box [string "[",
adamc@194 203 p_patCon env pc,
adamc@194 204 p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts,
adamc@194 205 string "]"]
adamc@194 206 | ECon (_, pc, ts, SOME e) => box [string "[",
adamc@193 207 p_patCon env pc,
adamc@193 208 space,
adamc@193 209 p_exp' true env e,
adamc@194 210 p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts,
adamc@193 211 string "]"]
adamc@48 212 | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@48 213 | EFfiApp (m, x, es) => box [string "FFI(",
adamc@48 214 string m,
adamc@48 215 string ".",
adamc@48 216 string x,
adamc@48 217 string "(",
adamc@48 218 p_list (p_exp env) es,
adamc@48 219 string "))"]
adamc@16 220 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
adamc@16 221 space,
adamc@16 222 p_exp' true env e2])
adamc@26 223 | EAbs (x, t, _, e) => parenIf par (box [string "fn",
adamc@26 224 space,
adamc@26 225 string x,
adamc@26 226 space,
adamc@26 227 string ":",
adamc@26 228 space,
adamc@26 229 p_con env t,
adamc@26 230 space,
adamc@26 231 string "=>",
adamc@26 232 space,
adamc@26 233 p_exp (E.pushERel env x t) e])
adamc@16 234 | ECApp (e, c) => parenIf par (box [p_exp env e,
adamc@16 235 space,
adamc@16 236 string "[",
adamc@16 237 p_con env c,
adamc@16 238 string "]"])
adamc@16 239 | ECAbs (x, k, e) => parenIf par (box [string "fn",
adamc@16 240 space,
adamc@16 241 string x,
adamc@16 242 space,
adamc@16 243 string "::",
adamc@16 244 space,
adamc@16 245 p_kind k,
adamc@16 246 space,
adamc@16 247 string "=>",
adamc@16 248 space,
adamc@16 249 p_exp (E.pushCRel env x k) e])
adamc@16 250
adamc@16 251 | ERecord xes => box [string "{",
adamc@29 252 p_list (fn (x, e, _) =>
adamc@21 253 box [p_name env x,
adamc@16 254 space,
adamc@16 255 string "=",
adamc@16 256 space,
adamc@16 257 p_exp env e]) xes,
adamc@16 258 string "}"]
adamc@16 259 | EField (e, c, {field, rest}) =>
adamc@16 260 if !debug then
adamc@16 261 box [p_exp' true env e,
adamc@16 262 string ".",
adamc@16 263 p_con' true env c,
adamc@16 264 space,
adamc@16 265 string "[",
adamc@16 266 p_con env field,
adamc@16 267 space,
adamc@16 268 string " in ",
adamc@16 269 space,
adamc@16 270 p_con env rest,
adamc@16 271 string "]"]
adamc@16 272 else
adamc@16 273 box [p_exp' true env e,
adamc@16 274 string ".",
adamc@16 275 p_con' true env c]
adamc@149 276 | ECut (e, c, {field, rest}) =>
adamc@149 277 parenIf par (if !debug then
adamc@149 278 box [p_exp' true env e,
adamc@149 279 space,
adamc@149 280 string "--",
adamc@149 281 space,
adamc@149 282 p_con' true env c,
adamc@149 283 space,
adamc@149 284 string "[",
adamc@149 285 p_con env field,
adamc@149 286 space,
adamc@149 287 string " in ",
adamc@149 288 space,
adamc@149 289 p_con env rest,
adamc@149 290 string "]"]
adamc@149 291 else
adamc@149 292 box [p_exp' true env e,
adamc@149 293 space,
adamc@149 294 string "--",
adamc@149 295 space,
adamc@149 296 p_con' true env c])
adamc@73 297 | EFold _ => string "fold"
adamc@16 298
adamc@177 299 | ECase (e, pes, _) => parenIf par (box [string "case",
adamc@177 300 space,
adamc@177 301 p_exp env e,
adamc@177 302 space,
adamc@177 303 string "of",
adamc@177 304 space,
adamc@177 305 p_list_sep (box [space, string "|", space])
adamc@177 306 (fn (p, e) => box [p_pat env p,
adamc@177 307 space,
adamc@177 308 string "=>",
adamc@177 309 space,
adamc@193 310 p_exp (E.patBinds env p) e]) pes])
adamc@177 311
adamc@102 312 | EWrite e => box [string "write(",
adamc@102 313 p_exp env e,
adamc@102 314 string ")"]
adamc@102 315
adamc@110 316 | EClosure (n, es) => box [string "CLOSURE(",
adamc@110 317 p_enamed env n,
adamc@110 318 p_list_sep (string "") (fn e => box [string ", ",
adamc@110 319 p_exp env e]) es,
adamc@110 320 string ")"]
adamc@110 321
adamc@16 322 and p_exp env = p_exp' false env
adamc@16 323
adamc@125 324 fun p_vali env (x, n, t, e, s) =
adamc@125 325 let
adamc@125 326 val xp = if !debug then
adamc@125 327 box [string x,
adamc@125 328 string "__",
adamc@125 329 string (Int.toString n)]
adamc@125 330 else
adamc@125 331 string x
adamc@125 332 in
adamc@125 333 box [xp,
adamc@125 334 space,
adamc@125 335 string "as",
adamc@125 336 space,
adamc@125 337 string s,
adamc@125 338 space,
adamc@125 339 string ":",
adamc@125 340 space,
adamc@125 341 p_con env t,
adamc@125 342 space,
adamc@125 343 string "=",
adamc@125 344 space,
adamc@125 345 p_exp env e]
adamc@125 346 end
adamc@125 347
adamc@144 348 fun p_export_kind ck =
adamc@144 349 case ck of
adamc@144 350 Link => string "link"
adamc@144 351 | Action => string "action"
adamc@144 352
adamc@192 353 fun p_datatype env (x, n, xs, cons) =
adamc@163 354 let
adamc@192 355 val k = (KType, ErrorMsg.dummySpan)
adamc@163 356 val env = E.pushCNamed env x n (KType, ErrorMsg.dummySpan) NONE
adamc@192 357 val env = foldl (fn (x, env) => E.pushCRel env x k) env xs
adamc@193 358
adamc@193 359 val xp = if !debug then
adamc@193 360 string (x ^ "__" ^ Int.toString n)
adamc@193 361 else
adamc@193 362 string x
adamc@163 363 in
adamc@163 364 box [string "datatype",
adamc@163 365 space,
adamc@193 366 xp,
adamc@192 367 p_list_sep (box []) (fn x => box [space, string x]) xs,
adamc@163 368 space,
adamc@163 369 string "=",
adamc@163 370 space,
adamc@163 371 p_list_sep (box [space, string "|", space])
adamc@163 372 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@163 373 else string x
adamc@193 374 | (x, n, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@163 375 else string x, space, string "of", space, p_con env t])
adamc@163 376 cons]
adamc@163 377 end
adamc@163 378
adamc@125 379 fun p_decl env (dAll as (d, _) : decl) =
adamc@16 380 case d of
adamc@16 381 DCon (x, n, k, c) =>
adamc@16 382 let
adamc@16 383 val xp = if !debug then
adamc@16 384 box [string x,
adamc@16 385 string "__",
adamc@16 386 string (Int.toString n)]
adamc@16 387 else
adamc@16 388 string x
adamc@16 389 in
adamc@16 390 box [string "con",
adamc@16 391 space,
adamc@16 392 xp,
adamc@16 393 space,
adamc@16 394 string "::",
adamc@16 395 space,
adamc@16 396 p_kind k,
adamc@16 397 space,
adamc@16 398 string "=",
adamc@16 399 space,
adamc@16 400 p_con env c]
adamc@16 401 end
adamc@163 402 | DDatatype x => p_datatype env x
adamc@125 403 | DVal vi => box [string "val",
adamc@125 404 space,
adamc@125 405 p_vali env vi]
adamc@125 406 | DValRec vis =>
adamc@16 407 let
adamc@125 408 val env = E.declBinds env dAll
adamc@16 409 in
adamc@16 410 box [string "val",
adamc@16 411 space,
adamc@125 412 string "rec",
adamc@16 413 space,
adamc@125 414 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@16 415 end
adamc@144 416 | DExport (ek, n) => box [string "export",
adamc@144 417 space,
adamc@144 418 p_export_kind ek,
adamc@144 419 space,
adamc@144 420 p_enamed env n,
adamc@144 421 space,
adamc@144 422 string "as",
adamc@144 423 space,
adamc@144 424 p_con env (#2 (E.lookupENamed env n))]
adamc@16 425
adamc@16 426 fun p_file env file =
adamc@16 427 let
adamc@31 428 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 429 (p_decl env d,
adamc@31 430 E.declBinds env d))
adamc@16 431 env file
adamc@16 432 in
adamc@16 433 p_list_sep newline (fn x => x) pds
adamc@16 434 end
adamc@16 435
adamc@16 436 end