Mercurial > urweb

annotate src/mono_print.sml @ 25:0a762c73824d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Monoize
author Adam Chlipala <adamc@hcoop.net>
date Tue, 10 Jun 2008 13:14:45 -0400
parents
children 4ab19c19665f
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@25 61
adamc@25 62 and p_typ env = p_typ' false env
adamc@25 63
adamc@25 64 fun p_exp' par env (e, _) =
adamc@25 65 case e of
adamc@25 66 EPrim p => Prim.p_t p
adamc@25 67 | ERel n =>
adamc@25 68 if !debug then
adamc@25 69 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
adamc@25 70 else
adamc@25 71 string (#1 (E.lookupERel env n))
adamc@25 72 | ENamed n =>
adamc@25 73 if !debug then
adamc@25 74 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
adamc@25 75 else
adamc@25 76 string (#1 (E.lookupENamed env n))
adamc@25 77 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
adamc@25 78 space,
adamc@25 79 p_exp' true env e2])
adamc@25 80 | EAbs (x, t, e) => parenIf par (box [string "fn",
adamc@25 81 space,
adamc@25 82 string x,
adamc@25 83 space,
adamc@25 84 string ":",
adamc@25 85 space,
adamc@25 86 p_typ env t,
adamc@25 87 space,
adamc@25 88 string "=>",
adamc@25 89 space,
adamc@25 90 p_exp (E.pushERel env x t) e])
adamc@25 91
adamc@25 92 | ERecord xes => box [string "{",
adamc@25 93 p_list (fn (x, e) =>
adamc@25 94 box [string x,
adamc@25 95 space,
adamc@25 96 string "=",
adamc@25 97 space,
adamc@25 98 p_exp env e]) xes,
adamc@25 99 string "}"]
adamc@25 100 | EField (e, x) =>
adamc@25 101 box [p_exp' true env e,
adamc@25 102 string ".",
adamc@25 103 string x]
adamc@25 104
adamc@25 105 and p_exp env = p_exp' false env
adamc@25 106
adamc@25 107 fun p_decl env ((d, _) : decl) =
adamc@25 108 case d of
adamc@25 109 DVal (x, n, t, e) =>
adamc@25 110 let
adamc@25 111 val xp = if !debug then
adamc@25 112 box [string x,
adamc@25 113 string "__",
adamc@25 114 string (Int.toString n)]
adamc@25 115 else
adamc@25 116 string x
adamc@25 117 in
adamc@25 118 box [string "val",
adamc@25 119 space,
adamc@25 120 xp,
adamc@25 121 space,
adamc@25 122 string ":",
adamc@25 123 space,
adamc@25 124 p_typ env t,
adamc@25 125 space,
adamc@25 126 string "=",
adamc@25 127 space,
adamc@25 128 p_exp env e]
adamc@25 129 end
adamc@25 130
adamc@25 131 fun p_file env file =
adamc@25 132 let
adamc@25 133 val (_, pds) = ListUtil.mapfoldl (fn (d, env) =>
adamc@25 134 (E.declBinds env d,
adamc@25 135 p_decl env d))
adamc@25 136 env file
adamc@25 137 in
adamc@25 138 p_list_sep newline (fn x => x) pds
adamc@25 139 end
adamc@25 140
adamc@25 141 end