Mercurial > urweb

annotate src/mono_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 d101cb1efe55
children 2d6116de9cca
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@25 133 and p_exp env = p_exp' false env
adamc@25 134
adamc@25 135 fun p_decl env ((d, _) : decl) =
adamc@25 136 case d of
adamc@109 137 DVal (x, n, t, e, s) =>
adamc@25 138 let
adamc@25 139 val xp = if !debug then
adamc@25 140 box [string x,
adamc@25 141 string "__",
adamc@25 142 string (Int.toString n)]
adamc@25 143 else
adamc@25 144 string x
adamc@25 145 in
adamc@25 146 box [string "val",
adamc@25 147 space,
adamc@25 148 xp,
adamc@25 149 space,
adamc@109 150 string "as",
adamc@109 151 space,
adamc@109 152 string s,
adamc@109 153 space,
adamc@25 154 string ":",
adamc@25 155 space,
adamc@25 156 p_typ env t,
adamc@25 157 space,
adamc@25 158 string "=",
adamc@25 159 space,
adamc@25 160 p_exp env e]
adamc@25 161 end
adamc@109 162
adamc@109 163 | DExport n => box [string "export",
adamc@109 164 space,
adamc@109 165 p_enamed env n]
adamc@100 166
adamc@25 167 fun p_file env file =
adamc@25 168 let
adamc@31 169 val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
adamc@31 170 (p_decl env d,
adamc@31 171 E.declBinds env d))
adamc@25 172 env file
adamc@25 173 in
adamc@25 174 p_list_sep newline (fn x => x) pds
adamc@25 175 end
adamc@25 176
adamc@25 177 end