Mercurial > urweb

annotate src/mono_print.sml @ 223:bbe5899a9585

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Queries back to working as well as before, after start of refactoring to support grouping
author Adam Chlipala <adamc@hcoop.net>
date Thu, 21 Aug 2008 12:49:29 -0400
parents 890a61991263
children 71bafe66dbe1
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@25 28 (* Pretty-printing monomorphic Laconic/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@106 188
adamc@111 189 | EClosure (n, es) => box [string "CLOSURE(",
adamc@111 190 p_enamed env n,
adamc@111 191 p_list_sep (string "") (fn e => box [string ", ",
adamc@111 192 p_exp env e]) es,
adamc@111 193 string ")"]
adamc@111 194
adamc@25 195 and p_exp env = p_exp' false env
adamc@25 196
adamc@126 197 fun p_vali env (x, n, t, e, s) =
adamc@126 198 let
adamc@126 199 val xp = if !debug then
adamc@126 200 box [string x,
adamc@126 201 string "__",
adamc@126 202 string (Int.toString n)]
adamc@126 203 else
adamc@126 204 string x
adamc@126 205 in
adamc@126 206 box [xp,
adamc@126 207 space,
adamc@126 208 string "as",
adamc@126 209 space,
adamc@126 210 string s,
adamc@126 211 space,
adamc@126 212 string ":",
adamc@126 213 space,
adamc@126 214 p_typ env t,
adamc@126 215 space,
adamc@126 216 string "=",
adamc@126 217 space,
adamc@126 218 p_exp env e]
adamc@126 219 end
adamc@126 220
adamc@164 221 fun p_datatype env (x, n, cons) =
adamc@164 222 let
adamc@168 223 val env = E.pushDatatype env x n cons
adamc@164 224 in
adamc@164 225 box [string "datatype",
adamc@164 226 space,
adamc@164 227 string x,
adamc@164 228 space,
adamc@164 229 string "=",
adamc@164 230 space,
adamc@164 231 p_list_sep (box [space, string "|", space])
adamc@164 232 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@164 233 else string x
adamc@164 234 | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@164 235 else string x, space, string "of", space, p_typ env t])
adamc@164 236 cons]
adamc@164 237 end
adamc@164 238
adamc@126 239 fun p_decl env (dAll as (d, _) : decl) =
adamc@25 240 case d of
adamc@164 241 DDatatype x => p_datatype env x
adamc@164 242 | DVal vi => box [string "val",
adamc@126 243 space,
adamc@126 244 p_vali env vi]
adamc@126 245 | DValRec vis =>
adamc@25 246 let
adamc@126 247 val env = E.declBinds env dAll
adamc@25 248 in
adamc@25 249 box [string "val",
adamc@25 250 space,
adamc@126 251 string "rec",
adamc@25 252 space,
adamc@126 253 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@25 254 end
adamc@109 255
adamc@144 256 | DExport (ek, s, n, ts) => box [string "export",
adamc@144 257 space,
adamc@144 258 CorePrint.p_export_kind ek,
adamc@144 259 space,
adamc@144 260 p_enamed env n,
adamc@144 261 space,
adamc@144 262 string "as",
adamc@144 263 space,
adamc@144 264 string s,
adamc@144 265 p_list_sep (string "") (fn t => box [space,
adamc@144 266 string "(",
adamc@144 267 p_typ env t,
adamc@144 268 string ")"]) ts]
adamc@100 269
adamc@25 270 fun p_file env file =
adamc@25 271 let
adamc@31 272 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 273 (p_decl env d,
adamc@31 274 E.declBinds env d))
adamc@25 275 env file
adamc@25 276 in
adamc@25 277 p_list_sep newline (fn x => x) pds
adamc@25 278 end
adamc@25 279
adamc@25 280 end