Mercurial > urweb

annotate src/mono_print.sml @ 164:6847741e1f5f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Datatypes through monoize
author Adam Chlipala <adamc@hcoop.net>
date Tue, 29 Jul 2008 13:32:07 -0400
parents f0d3402184d1
children 25b169416ea8
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@25 56 | TNamed n =>
adamc@25 57 if !debug then
adamc@25 58 string (#1 (E.lookupTNamed env n) ^ "__" ^ Int.toString n)
adamc@25 59 else
adamc@25 60 string (#1 (E.lookupTNamed 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@164 167 val env = E.pushTNamed env x n NONE
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