Mercurial > urweb

annotate src/flat_print.sml @ 106:d101cb1efe55

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
More with attributes and efficient serialization
author Adam Chlipala <adamc@hcoop.net>
date Thu, 10 Jul 2008 15:49:14 -0400
parents 5f04adf47f48
children
rev   line source
adamc@26 1 (* Copyright (c) 2008, Adam Chlipala
adamc@26 2 * All rights reserved.
adamc@26 3 *
adamc@26 4 * Redistribution and use in source and binary forms, with or without
adamc@26 5 * modification, are permitted provided that the following conditions are met:
adamc@26 6 *
adamc@26 7 * - Redistributions of source code must retain the above copyright notice,
adamc@26 8 * this list of conditions and the following disclaimer.
adamc@26 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@26 10 * this list of conditions and the following disclaimer in the documentation
adamc@26 11 * and/or other materials provided with the distribution.
adamc@26 12 * - The names of contributors may not be used to endorse or promote products
adamc@26 13 * derived from this software without specific prior written permission.
adamc@26 14 *
adamc@26 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@26 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@26 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@26 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@26 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@26 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@26 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@26 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@26 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@26 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@26 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@26 26 *)
adamc@26 27
adamc@26 28 (* Pretty-printing flat-code Laconic/Web *)
adamc@26 29
adamc@26 30 structure FlatPrint :> FLAT_PRINT = struct
adamc@26 31
adamc@26 32 open Print.PD
adamc@26 33 open Print
adamc@26 34
adamc@26 35 open Flat
adamc@26 36
adamc@26 37 structure E = FlatEnv
adamc@26 38
adamc@26 39 val debug = ref false
adamc@26 40
adamc@26 41 val dummyTyp = (TNamed 0, ErrorMsg.dummySpan)
adamc@26 42
adamc@26 43 fun p_typ' par env (t, _) =
adamc@26 44 case t of
adamc@29 45 TTop => string "?"
adamc@29 46 | TFun (t1, t2) => parenIf par (box [p_typ' true env t1,
adamc@26 47 space,
adamc@26 48 string "->",
adamc@26 49 space,
adamc@26 50 p_typ env t2])
adamc@26 51 | TCode (t1, t2) => parenIf par (box [p_typ' true env t1,
adamc@26 52 space,
adamc@26 53 string "-->",
adamc@26 54 space,
adamc@26 55 p_typ env t2])
adamc@26 56 | TRecord xcs => box [string "{",
adamc@26 57 p_list (fn (x, t) =>
adamc@26 58 box [string x,
adamc@26 59 space,
adamc@26 60 string ":",
adamc@26 61 space,
adamc@26 62 p_typ env t]) xcs,
adamc@26 63 string "}"]
adamc@26 64 | TNamed n =>
adamc@26 65 if !debug then
adamc@26 66 string (#1 (E.lookupTNamed env n) ^ "__" ^ Int.toString n)
adamc@26 67 else
adamc@26 68 string (#1 (E.lookupTNamed env n))
adamc@52 69 | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@26 70
adamc@26 71 and p_typ env = p_typ' false env
adamc@26 72
adamc@26 73 fun p_exp' par env (e, _) =
adamc@26 74 case e of
adamc@26 75 EPrim p => Prim.p_t p
adamc@26 76 | ERel n =>
adamc@26 77 ((if !debug then
adamc@26 78 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@26 79 else
adamc@26 80 string (#1 (E.lookupERel env n)))
adamc@26 81 handle E.UnboundRel _ => string ("UNBOUND" ^ Int.toString n))
adamc@26 82 | ENamed n =>
adamc@26 83 if !debug then
adamc@26 84 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@26 85 else
adamc@26 86 string (#1 (E.lookupENamed env n))
adamc@52 87 | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@52 88 | EFfiApp (m, x, es) => box [string "FFI(",
adamc@52 89 string m,
adamc@52 90 string ".",
adamc@52 91 string x,
adamc@52 92 string "(",
adamc@52 93 p_list (p_exp env) es,
adamc@52 94 string "))"]
adamc@26 95 | ECode n => string ("code$" ^ Int.toString n)
adamc@26 96 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
adamc@26 97 space,
adamc@26 98 p_exp' true env e2])
adamc@26 99
adamc@26 100 | ERecord xes => box [string "{",
adamc@29 101 p_list (fn (x, e, _) =>
adamc@26 102 box [string x,
adamc@26 103 space,
adamc@26 104 string "=",
adamc@26 105 space,
adamc@26 106 p_exp env e]) xes,
adamc@26 107 string "}"]
adamc@26 108 | EField (e, x) =>
adamc@26 109 box [p_exp' true env e,
adamc@26 110 string ".",
adamc@26 111 string x]
adamc@26 112
adamc@26 113 | ELet (xes, e) =>
adamc@26 114 let
adamc@29 115 val (env, pps) = foldl (fn ((x, _, e), (env, pps)) =>
adamc@26 116 (E.pushERel env x dummyTyp,
adamc@26 117 List.revAppend ([space,
adamc@26 118 string "val",
adamc@26 119 space,
adamc@26 120 string x,
adamc@26 121 space,
adamc@26 122 string "=",
adamc@26 123 space,
adamc@26 124 p_exp env e],
adamc@26 125 pps)))
adamc@26 126 (env, []) xes
adamc@26 127 in
adamc@26 128 box [string "let",
adamc@26 129 space,
adamc@26 130 box (rev pps),
adamc@26 131 space,
adamc@26 132 string "in",
adamc@26 133 space,
adamc@26 134 p_exp env e,
adamc@26 135 space,
adamc@26 136 string "end"]
adamc@26 137 end
adamc@26 138
adamc@102 139 | EStrcat (e1, e2) => box [p_exp' true env e1,
adamc@102 140 space,
adamc@102 141 string "^",
adamc@102 142 space,
adamc@102 143 p_exp' true env e2]
adamc@102 144
adamc@102 145 | EWrite e => box [string "write(",
adamc@102 146 p_exp env e,
adamc@102 147 string ")"]
adamc@102 148
adamc@106 149 | ESeq (e1, e2) => box [p_exp env e1,
adamc@106 150 string ";",
adamc@106 151 space,
adamc@106 152 p_exp env e2]
adamc@106 153
adamc@26 154 and p_exp env = p_exp' false env
adamc@26 155
adamc@26 156 fun p_decl env ((d, _) : decl) =
adamc@26 157 case d of
adamc@26 158 DVal (x, n, t, e) =>
adamc@26 159 let
adamc@26 160 val xp = if !debug then
adamc@26 161 box [string x,
adamc@26 162 string "__",
adamc@26 163 string (Int.toString n)]
adamc@26 164 else
adamc@26 165 string x
adamc@26 166 in
adamc@26 167 box [string "val",
adamc@26 168 space,
adamc@26 169 xp,
adamc@26 170 space,
adamc@26 171 string ":",
adamc@26 172 space,
adamc@26 173 p_typ env t,
adamc@26 174 space,
adamc@26 175 string "=",
adamc@26 176 space,
adamc@26 177 p_exp env e]
adamc@26 178
adamc@26 179 end
adamc@26 180 | DFun (n, x, dom, ran, e) =>
adamc@26 181 let
adamc@26 182 val xp = if !debug then
adamc@26 183 box [string x,
adamc@26 184 string "__",
adamc@26 185 string (Int.toString n)]
adamc@26 186 else
adamc@26 187 string x
adamc@26 188 in
adamc@26 189 box [string "fun",
adamc@26 190 space,
adamc@26 191 string "code$",
adamc@26 192 string (Int.toString n),
adamc@26 193 space,
adamc@26 194 string "(",
adamc@26 195 xp,
adamc@26 196 space,
adamc@26 197 string ":",
adamc@26 198 space,
adamc@26 199 p_typ env dom,
adamc@26 200 string ")",
adamc@26 201 space,
adamc@26 202 string ":",
adamc@26 203 space,
adamc@26 204 p_typ env ran,
adamc@26 205 space,
adamc@26 206 string "=",
adamc@26 207 space,
adamc@26 208 p_exp (E.pushERel env x dom) e]
adamc@26 209
adamc@26 210 end
adamc@26 211
adamc@101 212 | DPage (xcs, e) => box [string "page",
adamc@101 213 string "[",
adamc@101 214 p_list (fn (x, t) =>
adamc@101 215 box [string x,
adamc@101 216 space,
adamc@101 217 string ":",
adamc@101 218 space,
adamc@101 219 p_typ env t]) xcs,
adamc@101 220 string "]",
adamc@101 221 space,
adamc@101 222 string "=",
adamc@101 223 space,
adamc@101 224 p_exp env e]
adamc@101 225
adamc@26 226 fun p_file env file =
adamc@26 227 let
adamc@31 228 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 229 (p_decl env d,
adamc@31 230 E.declBinds env d))
adamc@26 231 env file
adamc@26 232 in
adamc@26 233 p_list_sep newline (fn x => x) pds
adamc@26 234 end
adamc@26 235
adamc@26 236 end