Mercurial > urweb

annotate src/core_print.sml @ 20:1ab48e37d0ef

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Some con reducing
author Adam Chlipala <adamc@hcoop.net>
date Sun, 08 Jun 2008 15:47:44 -0400
parents bc7b76ca57e0
children 067029c748e9
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@16 51
adamc@16 52 and p_kind k = p_kind' false k
adamc@16 53
adamc@16 54 fun p_con' par env (c, _) =
adamc@16 55 case c of
adamc@16 56 TFun (t1, t2) => parenIf par (box [p_con' true env t1,
adamc@16 57 space,
adamc@16 58 string "->",
adamc@16 59 space,
adamc@16 60 p_con env t2])
adamc@16 61 | TCFun (x, k, c) => parenIf par (box [string x,
adamc@16 62 space,
adamc@16 63 string "::",
adamc@16 64 space,
adamc@16 65 p_kind k,
adamc@16 66 space,
adamc@16 67 string "->",
adamc@16 68 space,
adamc@16 69 p_con (E.pushCRel env x k) c])
adamc@16 70 | TRecord (CRecord (_, xcs), _) => box [string "{",
adamc@16 71 p_list (fn (x, c) =>
adamc@20 72 box [p_name env x,
adamc@16 73 space,
adamc@16 74 string ":",
adamc@16 75 space,
adamc@16 76 p_con env c]) xcs,
adamc@16 77 string "}"]
adamc@16 78 | TRecord c => box [string "$",
adamc@16 79 p_con' true env c]
adamc@16 80
adamc@16 81 | CRel n =>
adamc@16 82 if !debug then
adamc@16 83 string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n)
adamc@16 84 else
adamc@16 85 string (#1 (E.lookupCRel env n))
adamc@16 86 | CNamed n =>
adamc@16 87 if !debug then
adamc@16 88 string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n)
adamc@16 89 else
adamc@16 90 string (#1 (E.lookupCNamed env n))
adamc@16 91
adamc@16 92 | CApp (c1, c2) => parenIf par (box [p_con env c1,
adamc@16 93 space,
adamc@16 94 p_con' true env c2])
adamc@16 95 | CAbs (x, k, c) => parenIf par (box [string "fn",
adamc@16 96 space,
adamc@16 97 string x,
adamc@16 98 space,
adamc@16 99 string "::",
adamc@16 100 space,
adamc@16 101 p_kind k,
adamc@16 102 space,
adamc@16 103 string "=>",
adamc@16 104 space,
adamc@16 105 p_con (E.pushCRel env x k) c])
adamc@16 106
adamc@16 107 | CName s => box [string "#", string s]
adamc@16 108
adamc@16 109 | CRecord (k, xcs) =>
adamc@16 110 if !debug then
adamc@16 111 parenIf par (box [string "[",
adamc@16 112 p_list (fn (x, c) =>
adamc@16 113 box [p_con env x,
adamc@16 114 space,
adamc@16 115 string "=",
adamc@16 116 space,
adamc@16 117 p_con env c]) xcs,
adamc@16 118 string "]::",
adamc@16 119 p_kind k])
adamc@16 120 else
adamc@16 121 parenIf par (box [string "[",
adamc@16 122 p_list (fn (x, c) =>
adamc@16 123 box [p_con env x,
adamc@16 124 space,
adamc@16 125 string "=",
adamc@16 126 space,
adamc@16 127 p_con env c]) xcs,
adamc@16 128 string "]"])
adamc@16 129 | CConcat (c1, c2) => parenIf par (box [p_con' true env c1,
adamc@16 130 space,
adamc@16 131 string "++",
adamc@16 132 space,
adamc@16 133 p_con env c2])
adamc@16 134
adamc@16 135 and p_con env = p_con' false env
adamc@16 136
adamc@20 137 and p_name env (all as (c, _)) =
adamc@20 138 case c of
adamc@20 139 CName s => string s
adamc@20 140 | _ => p_con env all
adamc@20 141
adamc@16 142 fun p_exp' par env (e, _) =
adamc@16 143 case e of
adamc@16 144 EPrim p => Prim.p_t p
adamc@16 145 | ERel n =>
adamc@16 146 if !debug then
adamc@16 147 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@16 148 else
adamc@16 149 string (#1 (E.lookupERel env n))
adamc@16 150 | ENamed n =>
adamc@16 151 if !debug then
adamc@16 152 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@16 153 else
adamc@16 154 string (#1 (E.lookupENamed env n))
adamc@16 155 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
adamc@16 156 space,
adamc@16 157 p_exp' true env e2])
adamc@16 158 | EAbs (x, t, e) => parenIf par (box [string "fn",
adamc@16 159 space,
adamc@16 160 string x,
adamc@16 161 space,
adamc@16 162 string ":",
adamc@16 163 space,
adamc@16 164 p_con env t,
adamc@16 165 space,
adamc@16 166 string "=>",
adamc@16 167 space,
adamc@16 168 p_exp (E.pushERel env x t) e])
adamc@16 169 | ECApp (e, c) => parenIf par (box [p_exp env e,
adamc@16 170 space,
adamc@16 171 string "[",
adamc@16 172 p_con env c,
adamc@16 173 string "]"])
adamc@16 174 | ECAbs (x, k, e) => parenIf par (box [string "fn",
adamc@16 175 space,
adamc@16 176 string x,
adamc@16 177 space,
adamc@16 178 string "::",
adamc@16 179 space,
adamc@16 180 p_kind k,
adamc@16 181 space,
adamc@16 182 string "=>",
adamc@16 183 space,
adamc@16 184 p_exp (E.pushCRel env x k) e])
adamc@16 185
adamc@16 186 | ERecord xes => box [string "{",
adamc@16 187 p_list (fn (x, e) =>
adamc@16 188 box [p_con env x,
adamc@16 189 space,
adamc@16 190 string "=",
adamc@16 191 space,
adamc@16 192 p_exp env e]) xes,
adamc@16 193 string "}"]
adamc@16 194 | EField (e, c, {field, rest}) =>
adamc@16 195 if !debug then
adamc@16 196 box [p_exp' true env e,
adamc@16 197 string ".",
adamc@16 198 p_con' true env c,
adamc@16 199 space,
adamc@16 200 string "[",
adamc@16 201 p_con env field,
adamc@16 202 space,
adamc@16 203 string " in ",
adamc@16 204 space,
adamc@16 205 p_con env rest,
adamc@16 206 string "]"]
adamc@16 207 else
adamc@16 208 box [p_exp' true env e,
adamc@16 209 string ".",
adamc@16 210 p_con' true env c]
adamc@16 211
adamc@16 212 and p_exp env = p_exp' false env
adamc@16 213
adamc@16 214 fun p_decl env ((d, _) : decl) =
adamc@16 215 case d of
adamc@16 216 DCon (x, n, k, c) =>
adamc@16 217 let
adamc@16 218 val xp = if !debug then
adamc@16 219 box [string x,
adamc@16 220 string "__",
adamc@16 221 string (Int.toString n)]
adamc@16 222 else
adamc@16 223 string x
adamc@16 224 in
adamc@16 225 box [string "con",
adamc@16 226 space,
adamc@16 227 xp,
adamc@16 228 space,
adamc@16 229 string "::",
adamc@16 230 space,
adamc@16 231 p_kind k,
adamc@16 232 space,
adamc@16 233 string "=",
adamc@16 234 space,
adamc@16 235 p_con env c]
adamc@16 236 end
adamc@16 237 | DVal (x, n, t, e) =>
adamc@16 238 let
adamc@16 239 val xp = if !debug then
adamc@16 240 box [string x,
adamc@16 241 string "__",
adamc@16 242 string (Int.toString n)]
adamc@16 243 else
adamc@16 244 string x
adamc@16 245 in
adamc@16 246 box [string "val",
adamc@16 247 space,
adamc@16 248 xp,
adamc@16 249 space,
adamc@16 250 string ":",
adamc@16 251 space,
adamc@16 252 p_con env t,
adamc@16 253 space,
adamc@16 254 string "=",
adamc@16 255 space,
adamc@16 256 p_exp env e]
adamc@16 257 end
adamc@16 258
adamc@16 259 fun p_file env file =
adamc@16 260 let
adamc@16 261 val (_, pds) = ListUtil.mapfoldl (fn (d, env) =>
adamc@16 262 (E.declBinds env d,
adamc@16 263 p_decl env d))
adamc@16 264 env file
adamc@16 265 in
adamc@16 266 p_list_sep newline (fn x => x) pds
adamc@16 267 end
adamc@16 268
adamc@16 269 end