Mercurial > urweb

annotate src/core_print.sml @ 109:813e5a52063d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove closure conversion in favor of zany fun with modules, which also replaces 'page'
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 10:17:06 -0400
parents 5f04adf47f48
children 3739af9e727a
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@16 155 fun p_exp' par env (e, _) =
adamc@16 156 case e of
adamc@16 157 EPrim p => Prim.p_t p
adamc@16 158 | ERel n =>
adamc@39 159 ((if !debug then
adamc@39 160 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@39 161 else
adamc@39 162 string (#1 (E.lookupERel env n)))
adamc@39 163 handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
adamc@109 164 | ENamed n => p_enamed env n
adamc@48 165 | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@48 166 | EFfiApp (m, x, es) => box [string "FFI(",
adamc@48 167 string m,
adamc@48 168 string ".",
adamc@48 169 string x,
adamc@48 170 string "(",
adamc@48 171 p_list (p_exp env) es,
adamc@48 172 string "))"]
adamc@16 173 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
adamc@16 174 space,
adamc@16 175 p_exp' true env e2])
adamc@26 176 | EAbs (x, t, _, e) => parenIf par (box [string "fn",
adamc@26 177 space,
adamc@26 178 string x,
adamc@26 179 space,
adamc@26 180 string ":",
adamc@26 181 space,
adamc@26 182 p_con env t,
adamc@26 183 space,
adamc@26 184 string "=>",
adamc@26 185 space,
adamc@26 186 p_exp (E.pushERel env x t) e])
adamc@16 187 | ECApp (e, c) => parenIf par (box [p_exp env e,
adamc@16 188 space,
adamc@16 189 string "[",
adamc@16 190 p_con env c,
adamc@16 191 string "]"])
adamc@16 192 | ECAbs (x, k, e) => parenIf par (box [string "fn",
adamc@16 193 space,
adamc@16 194 string x,
adamc@16 195 space,
adamc@16 196 string "::",
adamc@16 197 space,
adamc@16 198 p_kind k,
adamc@16 199 space,
adamc@16 200 string "=>",
adamc@16 201 space,
adamc@16 202 p_exp (E.pushCRel env x k) e])
adamc@16 203
adamc@16 204 | ERecord xes => box [string "{",
adamc@29 205 p_list (fn (x, e, _) =>
adamc@21 206 box [p_name env x,
adamc@16 207 space,
adamc@16 208 string "=",
adamc@16 209 space,
adamc@16 210 p_exp env e]) xes,
adamc@16 211 string "}"]
adamc@16 212 | EField (e, c, {field, rest}) =>
adamc@16 213 if !debug then
adamc@16 214 box [p_exp' true env e,
adamc@16 215 string ".",
adamc@16 216 p_con' true env c,
adamc@16 217 space,
adamc@16 218 string "[",
adamc@16 219 p_con env field,
adamc@16 220 space,
adamc@16 221 string " in ",
adamc@16 222 space,
adamc@16 223 p_con env rest,
adamc@16 224 string "]"]
adamc@16 225 else
adamc@16 226 box [p_exp' true env e,
adamc@16 227 string ".",
adamc@16 228 p_con' true env c]
adamc@73 229 | EFold _ => string "fold"
adamc@16 230
adamc@102 231 | EWrite e => box [string "write(",
adamc@102 232 p_exp env e,
adamc@102 233 string ")"]
adamc@102 234
adamc@16 235 and p_exp env = p_exp' false env
adamc@16 236
adamc@16 237 fun p_decl env ((d, _) : decl) =
adamc@16 238 case d of
adamc@16 239 DCon (x, n, k, c) =>
adamc@16 240 let
adamc@16 241 val xp = if !debug then
adamc@16 242 box [string x,
adamc@16 243 string "__",
adamc@16 244 string (Int.toString n)]
adamc@16 245 else
adamc@16 246 string x
adamc@16 247 in
adamc@16 248 box [string "con",
adamc@16 249 space,
adamc@16 250 xp,
adamc@16 251 space,
adamc@16 252 string "::",
adamc@16 253 space,
adamc@16 254 p_kind k,
adamc@16 255 space,
adamc@16 256 string "=",
adamc@16 257 space,
adamc@16 258 p_con env c]
adamc@16 259 end
adamc@109 260 | DVal (x, n, t, e, s) =>
adamc@16 261 let
adamc@16 262 val xp = if !debug then
adamc@16 263 box [string x,
adamc@16 264 string "__",
adamc@16 265 string (Int.toString n)]
adamc@16 266 else
adamc@16 267 string x
adamc@16 268 in
adamc@16 269 box [string "val",
adamc@16 270 space,
adamc@16 271 xp,
adamc@16 272 space,
adamc@109 273 string "as",
adamc@109 274 space,
adamc@109 275 string s,
adamc@109 276 space,
adamc@16 277 string ":",
adamc@16 278 space,
adamc@16 279 p_con env t,
adamc@16 280 space,
adamc@16 281 string "=",
adamc@16 282 space,
adamc@16 283 p_exp env e]
adamc@16 284 end
adamc@109 285 | DExport n => box [string "export",
adamc@109 286 space,
adamc@109 287 p_enamed env n]
adamc@16 288
adamc@16 289 fun p_file env file =
adamc@16 290 let
adamc@31 291 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 292 (p_decl env d,
adamc@31 293 E.declBinds env d))
adamc@16 294 env file
adamc@16 295 in
adamc@16 296 p_list_sep newline (fn x => x) pds
adamc@16 297 end
adamc@16 298
adamc@16 299 end