Mercurial > urweb

annotate src/mono_print.sml @ 169:2232ab355f66

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Took more advantage of new ability to exit with an error message
author Adam Chlipala <adamc@hcoop.net>
date Tue, 29 Jul 2008 16:02:02 -0400
parents 25b169416ea8
children eb3f9913bf31
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@168 56 | TDatatype (n, _) =>
adamc@25 57 if !debug then
adamc@168 58 string (#1 (E.lookupDatatype env n) ^ "__" ^ Int.toString n)
adamc@25 59 else
adamc@168 60 string (#1 (E.lookupDatatype env n))
adamc@51 61 | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@25 62
adamc@25 63 and p_typ env = p_typ' false env
adamc@25 64
adamc@109 65 fun p_enamed env n =
adamc@109 66 if !debug then
adamc@109 67 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@109 68 else
adamc@109 69 string (#1 (E.lookupENamed env n))
adamc@109 70
adamc@25 71 fun p_exp' par env (e, _) =
adamc@25 72 case e of
adamc@25 73 EPrim p => Prim.p_t p
adamc@25 74 | ERel n =>
adamc@25 75 if !debug then
adamc@25 76 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@25 77 else
adamc@25 78 string (#1 (E.lookupERel env n))
adamc@109 79 | ENamed n => p_enamed env n
adamc@109 80
adamc@51 81 | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
adamc@51 82 | EFfiApp (m, x, es) => box [string "FFI(",
adamc@51 83 string m,
adamc@51 84 string ".",
adamc@51 85 string x,
adamc@51 86 string "(",
adamc@51 87 p_list (p_exp env) es,
adamc@51 88 string "))"]
adamc@25 89 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
adamc@25 90 space,
adamc@25 91 p_exp' true env e2])
adamc@26 92 | EAbs (x, t, _, e) => parenIf par (box [string "fn",
adamc@26 93 space,
adamc@26 94 string x,
adamc@26 95 space,
adamc@26 96 string ":",
adamc@26 97 space,
adamc@26 98 p_typ env t,
adamc@26 99 space,
adamc@26 100 string "=>",
adamc@26 101 space,
adamc@26 102 p_exp (E.pushERel env x t) e])
adamc@25 103
adamc@25 104 | ERecord xes => box [string "{",
adamc@29 105 p_list (fn (x, e, _) =>
adamc@25 106 box [string x,
adamc@25 107 space,
adamc@25 108 string "=",
adamc@25 109 space,
adamc@25 110 p_exp env e]) xes,
adamc@25 111 string "}"]
adamc@25 112 | EField (e, x) =>
adamc@25 113 box [p_exp' true env e,
adamc@25 114 string ".",
adamc@25 115 string x]
adamc@25 116
adamc@94 117
adamc@94 118 | EStrcat (e1, e2) => box [p_exp' true env e1,
adamc@94 119 space,
adamc@102 120 string "^",
adamc@94 121 space,
adamc@94 122 p_exp' true env e2]
adamc@94 123
adamc@102 124 | EWrite e => box [string "write(",
adamc@102 125 p_exp env e,
adamc@102 126 string ")"]
adamc@102 127
adamc@106 128 | ESeq (e1, e2) => box [p_exp env e1,
adamc@106 129 string ";",
adamc@106 130 space,
adamc@106 131 p_exp env e2]
adamc@106 132
adamc@111 133 | EClosure (n, es) => box [string "CLOSURE(",
adamc@111 134 p_enamed env n,
adamc@111 135 p_list_sep (string "") (fn e => box [string ", ",
adamc@111 136 p_exp env e]) es,
adamc@111 137 string ")"]
adamc@111 138
adamc@25 139 and p_exp env = p_exp' false env
adamc@25 140
adamc@126 141 fun p_vali env (x, n, t, e, s) =
adamc@126 142 let
adamc@126 143 val xp = if !debug then
adamc@126 144 box [string x,
adamc@126 145 string "__",
adamc@126 146 string (Int.toString n)]
adamc@126 147 else
adamc@126 148 string x
adamc@126 149 in
adamc@126 150 box [xp,
adamc@126 151 space,
adamc@126 152 string "as",
adamc@126 153 space,
adamc@126 154 string s,
adamc@126 155 space,
adamc@126 156 string ":",
adamc@126 157 space,
adamc@126 158 p_typ env t,
adamc@126 159 space,
adamc@126 160 string "=",
adamc@126 161 space,
adamc@126 162 p_exp env e]
adamc@126 163 end
adamc@126 164
adamc@164 165 fun p_datatype env (x, n, cons) =
adamc@164 166 let
adamc@168 167 val env = E.pushDatatype env x n cons
adamc@164 168 in
adamc@164 169 box [string "datatype",
adamc@164 170 space,
adamc@164 171 string x,
adamc@164 172 space,
adamc@164 173 string "=",
adamc@164 174 space,
adamc@164 175 p_list_sep (box [space, string "|", space])
adamc@164 176 (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@164 177 else string x
adamc@164 178 | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
adamc@164 179 else string x, space, string "of", space, p_typ env t])
adamc@164 180 cons]
adamc@164 181 end
adamc@164 182
adamc@126 183 fun p_decl env (dAll as (d, _) : decl) =
adamc@25 184 case d of
adamc@164 185 DDatatype x => p_datatype env x
adamc@164 186 | DVal vi => box [string "val",
adamc@126 187 space,
adamc@126 188 p_vali env vi]
adamc@126 189 | DValRec vis =>
adamc@25 190 let
adamc@126 191 val env = E.declBinds env dAll
adamc@25 192 in
adamc@25 193 box [string "val",
adamc@25 194 space,
adamc@126 195 string "rec",
adamc@25 196 space,
adamc@126 197 p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
adamc@25 198 end
adamc@109 199
adamc@144 200 | DExport (ek, s, n, ts) => box [string "export",
adamc@144 201 space,
adamc@144 202 CorePrint.p_export_kind ek,
adamc@144 203 space,
adamc@144 204 p_enamed env n,
adamc@144 205 space,
adamc@144 206 string "as",
adamc@144 207 space,
adamc@144 208 string s,
adamc@144 209 p_list_sep (string "") (fn t => box [space,
adamc@144 210 string "(",
adamc@144 211 p_typ env t,
adamc@144 212 string ")"]) ts]
adamc@100 213
adamc@25 214 fun p_file env file =
adamc@25 215 let
adamc@31 216 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 217 (p_decl env d,
adamc@31 218 E.declBinds env d))
adamc@25 219 env file
adamc@25 220 in
adamc@25 221 p_list_sep newline (fn x => x) pds
adamc@25 222 end
adamc@25 223
adamc@25 224 end