Mercurial > urweb

annotate src/mono_print.sml @ 251:326fb4686f60

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Monoize transaction identifiers; improve disjointness prover on irreducible folds; change 'query' type
author Adam Chlipala <adamc@hcoop.net>
date Sun, 31 Aug 2008 10:36:54 -0400
parents 71bafe66dbe1
children 7e9bd70ad3ce
rev   line source
adamc@25 1 (* Copyright (c) 2008, Adam Chlipala
adamc@25 2 * All rights reserved.
adamc@25 3 *
adamc@25 4 * Redistribution and use in source and binary forms, with or without
adamc@25 5 * modification, are permitted provided that the following conditions are met:
adamc@25 6 *
adamc@25 7 * - Redistributions of source code must retain the above copyright notice,
adamc@25 8 * this list of conditions and the following disclaimer.
adamc@25 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@25 10 * this list of conditions and the following disclaimer in the documentation
adamc@25 11 * and/or other materials provided with the distribution.
adamc@25 12 * - The names of contributors may not be used to endorse or promote products
adamc@25 13 * derived from this software without specific prior written permission.
adamc@25 14 *
adamc@25 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@25 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@25 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@25 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@25 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@25 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@25 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@25 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@25 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@25 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@25 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@25 26 *)
adamc@25 27
adamc@244 28 (* Pretty-printing monomorphic Ur/Web *)
adamc@25 29
adamc@25 30 structure MonoPrint :> MONO_PRINT = struct
adamc@25 31
adamc@25 32 open Print.PD
adamc@25 33 open Print
adamc@25 34
adamc@25 35 open Mono
adamc@25 36
adamc@25 37 structure E = MonoEnv
adamc@25 38
adamc@25 39 val debug = ref false
adamc@25 40
adamc@25 41 fun p_typ' par env (t, _) =
adamc@25 42 case t of
adamc@25 43 TFun (t1, t2) => parenIf par (box [p_typ' true env t1,
adamc@25 44 space,
adamc@25 45 string "->",
adamc@25 46 space,
adamc@25 47 p_typ env t2])
adamc@25 48 | TRecord xcs => box [string "{",
adamc@25 49 p_list (fn (x, t) =>
adamc@25 50 box [string x,
adamc@25 51 space,
adamc@25 52 string ":",
adamc@25 53 space,
adamc@25 54 p_typ env t]) xcs,
adamc@25 55 string "}"]
adamc@196 56 | TDatatype (n, _) =>
adamc@178 57 ((if !debug then
adamc@178 58 string (#1 (E.lookupDatatype env n) ^ "__" ^ Int.toString n)
adamc@178 59 else
adamc@178 60 string (#1 (E.lookupDatatype env n)))
adamc@178 61 handle E.UnboundNamed _ => string ("UNBOUND_DATATYPE_" ^ Int.toString n))
adamc@51 62 | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@25 63
adamc@25 64 and p_typ env = p_typ' false env
adamc@25 65
adamc@109 66 fun p_enamed env n =
adamc@178 67 (if !debug then
adamc@178 68 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@178 69 else
adamc@178 70 string (#1 (E.lookupENamed env n)))
adamc@178 71 handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)
adamc@178 72
adamc@178 73 fun p_con_named env n =
adamc@178 74 (if !debug then
adamc@178 75 string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n)
adamc@178 76 else
adamc@178 77 string (#1 (E.lookupConstructor env n)))
adamc@178 78 handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n)
adamc@178 79
adamc@178 80 fun p_patCon env pc =
adamc@178 81 case pc of
adamc@178 82 PConVar n => p_con_named env n
adamc@186 83 | PConFfi {mod = m, con, ...} => box [string "FFIC(",
adamc@185 84 string m,
adamc@185 85 string ".",
adamc@185 86 string con,
adamc@185 87 string ")"]
adamc@178 88
adamc@178 89 fun p_pat' par env (p, _) =
adamc@178 90 case p of
adamc@178 91 PWild => string "_"
adamc@182 92 | PVar (s, _) => string s
adamc@178 93 | PPrim p => Prim.p_t p
adamc@188 94 | PCon (_, n, NONE) => p_patCon env n
adamc@188 95 | PCon (_, n, SOME p) => parenIf par (box [p_patCon env n,
adamc@178 96 space,
adamc@178 97 p_pat' true env p])
adamc@178 98 | PRecord xps =>
adamc@178 99 box [string "{",
adamc@182 100 p_list_sep (box [string ",", space]) (fn (x, p, _) =>
adamc@178 101 box [string x,
adamc@178 102 space,
adamc@178 103 string "=",
adamc@178 104 space,
adamc@178 105 p_pat env p]) xps,
adamc@178 106 string "}"]
adamc@178 107
adamc@178 108 and p_pat x = p_pat' false x
adamc@109 109
adamc@25 110 fun p_exp' par env (e, _) =
adamc@25 111 case e of
adamc@25 112 EPrim p => Prim.p_t p
adamc@25 113 | ERel n =>
adamc@178 114 ((if !debug then
adamc@178 115 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@178 116 else
adamc@178 117 string (#1 (E.lookupERel env n)))
adamc@178 118 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
adamc@109 119 | ENamed n => p_enamed env n
adamc@188 120 | ECon (_, pc, NONE) => p_patCon env pc
adamc@188 121 | ECon (_, pc, SOME e) => parenIf par (box [p_patCon env pc,
adamc@188 122 space,
adamc@188 123 p_exp' true env e])
adamc@109 124
adamc@51 125 | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@51 126 | EFfiApp (m, x, es) => box [string "FFI(",
adamc@51 127 string m,
adamc@51 128 string ".",
adamc@51 129 string x,
adamc@51 130 string "(",
adamc@51 131 p_list (p_exp env) es,
adamc@51 132 string "))"]
adamc@25 133 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
adamc@25 134 space,
adamc@25 135 p_exp' true env e2])
adamc@26 136 | EAbs (x, t, _, e) => parenIf par (box [string "fn",
adamc@26 137 space,
adamc@26 138 string x,
adamc@26 139 space,
adamc@26 140 string ":",
adamc@26 141 space,
adamc@26 142 p_typ env t,
adamc@26 143 space,
adamc@26 144 string "=>",
adamc@26 145 space,
adamc@183 146 p_exp (E.pushERel env x t NONE) e])
adamc@25 147
adamc@25 148 | ERecord xes => box [string "{",
adamc@29 149 p_list (fn (x, e, _) =>
adamc@25 150 box [string x,
adamc@25 151 space,
adamc@25 152 string "=",
adamc@25 153 space,
adamc@25 154 p_exp env e]) xes,
adamc@25 155 string "}"]
adamc@25 156 | EField (e, x) =>
adamc@25 157 box [p_exp' true env e,
adamc@25 158 string ".",
adamc@25 159 string x]
adamc@25 160
adamc@178 161 | ECase (e, pes, _) => parenIf par (box [string "case",
adamc@178 162 space,
adamc@178 163 p_exp env e,
adamc@178 164 space,
adamc@178 165 string "of",
adamc@178 166 space,
adamc@178 167 p_list_sep (box [space, string "|", space])
adamc@178 168 (fn (p, e) => box [p_pat env p,
adamc@178 169 space,
adamc@178 170 string "=>",
adamc@178 171 space,
adamc@179 172 p_exp (E.patBinds env p) e]) pes])
adamc@94 173
adamc@94 174 | EStrcat (e1, e2) => box [p_exp' true env e1,
adamc@94 175 space,
adamc@102 176 string "^",
adamc@94 177 space,
adamc@94 178 p_exp' true env e2]
adamc@94 179
adamc@102 180 | EWrite e => box [string "write(",
adamc@102 181 p_exp env e,
adamc@102 182 string ")"]
adamc@102 183
adamc@106 184 | ESeq (e1, e2) => box [p_exp env e1,
adamc@106 185 string ";",
adamc@106 186 space,
adamc@106 187 p_exp env e2]
adamc@251 188 | ELet (x, t, e1, e2) => box [string "let",
adamc@251 189 space,
adamc@251 190 string x,
adamc@251 191 space,
adamc@251 192 string ":",
adamc@251 193 space,
adamc@251 194 p_typ env t,
adamc@251 195 space,
adamc@251 196 string "=",
adamc@251 197 space,
adamc@251 198 p_exp env e1,
adamc@251 199 space,
adamc@251 200 string "in",
adamc@251 201 space,
adamc@251 202 p_exp (E.pushERel env x t NONE) e2]
adamc@106 203
adamc@111 204 | EClosure (n, es) => box [string "CLOSURE(",
adamc@111 205 p_enamed env n,
adamc@111 206 p_list_sep (string "") (fn e => box [string ", ",
adamc@111 207 p_exp env e]) es,
adamc@111 208 string ")"]
adamc@111 209
adamc@25 210 and p_exp env = p_exp' false env
adamc@25 211
adamc@126 212 fun p_vali env (x, n, t, e, s) =
adamc@126 213 let
adamc@126 214 val xp = if !debug then
adamc@126 215 box [string x,
adamc@126 216 string "__",
adamc@126 217 string (Int.toString n)]
adamc@126 218 else
adamc@126 219 string x
adamc@126 220 in
adamc@126 221 box [xp,
adamc@126 222 space,
adamc@126 223 string "as",
adamc@126 224 space,
adamc@126 225 string s,
adamc@126 226 space,
adamc@126 227 string ":",
adamc@126 228 space,
adamc@126 229 p_typ env t,
adamc@126 230 space,
adamc@126 231 string "=",
adamc@126 232 space,
adamc@126 233 p_exp env e]
adamc@126 234 end
adamc@126 235
adamc@164 236 fun p_datatype env (x, n, cons) =
adamc@164 237 let
adamc@168 238 val env = E.pushDatatype env x n cons
adamc@164 239 in
adamc@164 240 box [string "datatype",
adamc@164 241 space,
adamc@164 242 string x,
adamc@164 243 space,
adamc@164 244 string "=",
adamc@164 245 space,
adamc@164 246 p_list_sep (box [space, string "|", space])
adamc@164 247 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@164 248 else string x
adamc@164 249 | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@164 250 else string x, space, string "of", space, p_typ env t])
adamc@164 251 cons]
adamc@164 252 end
adamc@164 253
adamc@126 254 fun p_decl env (dAll as (d, _) : decl) =
adamc@25 255 case d of
adamc@164 256 DDatatype x => p_datatype env x
adamc@164 257 | DVal vi => box [string "val",
adamc@126 258 space,
adamc@126 259 p_vali env vi]
adamc@126 260 | DValRec vis =>
adamc@25 261 let
adamc@126 262 val env = E.declBinds env dAll
adamc@25 263 in
adamc@25 264 box [string "val",
adamc@25 265 space,
adamc@126 266 string "rec",
adamc@25 267 space,
adamc@126 268 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@25 269 end
adamc@109 270
adamc@144 271 | DExport (ek, s, n, ts) => box [string "export",
adamc@144 272 space,
adamc@144 273 CorePrint.p_export_kind ek,
adamc@144 274 space,
adamc@144 275 p_enamed env n,
adamc@144 276 space,
adamc@144 277 string "as",
adamc@144 278 space,
adamc@144 279 string s,
adamc@144 280 p_list_sep (string "") (fn t => box [space,
adamc@144 281 string "(",
adamc@144 282 p_typ env t,
adamc@144 283 string ")"]) ts]
adamc@100 284
adamc@25 285 fun p_file env file =
adamc@25 286 let
adamc@31 287 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 288 (p_decl env d,
adamc@31 289 E.declBinds env d))
adamc@25 290 env file
adamc@25 291 in
adamc@25 292 p_list_sep newline (fn x => x) pds
adamc@25 293 end
adamc@25 294
adamc@25 295 end