Mercurial > urweb

comparison 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
comparison
equal deleted inserted replaced
24:ea15905e598d 25:0a762c73824d
1 (* Copyright (c) 2008, Adam Chlipala
2 * All rights reserved.
3 *
4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met:
6 *
7 * - Redistributions of source code must retain the above copyright notice,
8 * this list of conditions and the following disclaimer.
9 * - Redistributions in binary form must reproduce the above copyright notice,
10 * this list of conditions and the following disclaimer in the documentation
11 * and/or other materials provided with the distribution.
12 * - The names of contributors may not be used to endorse or promote products
13 * derived from this software without specific prior written permission.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE.
26 *)
27
28 (* Pretty-printing monomorphic Laconic/Web *)
29
30 structure MonoPrint :> MONO_PRINT = struct
31
32 open Print.PD
33 open Print
34
35 open Mono
36
37 structure E = MonoEnv
38
39 val debug = ref false
40
41 fun p_typ' par env (t, _) =
42 case t of
43 TFun (t1, t2) => parenIf par (box [p_typ' true env t1,
44 space,
45 string "->",
46 space,
47 p_typ env t2])
48 | TRecord xcs => box [string "{",
49 p_list (fn (x, t) =>
50 box [string x,
51 space,
52 string ":",
53 space,
54 p_typ env t]) xcs,
55 string "}"]
56 | TNamed n =>
57 if !debug then
58 string (#1 (E.lookupTNamed env n) ^ "__" ^ Int.toString n)
59 else
60 string (#1 (E.lookupTNamed env n))
61
62 and p_typ env = p_typ' false env
63
64 fun p_exp' par env (e, _) =
65 case e of
66 EPrim p => Prim.p_t p
67 | ERel n =>
68 if !debug then
69 string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n)
70 else
71 string (#1 (E.lookupERel env n))
72 | ENamed n =>
73 if !debug then
74 string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n)
75 else
76 string (#1 (E.lookupENamed env n))
77 | EApp (e1, e2) => parenIf par (box [p_exp env e1,
78 space,
79 p_exp' true env e2])
80 | EAbs (x, t, e) => parenIf par (box [string "fn",
81 space,
82 string x,
83 space,
84 string ":",
85 space,
86 p_typ env t,
87 space,
88 string "=>",
89 space,
90 p_exp (E.pushERel env x t) e])
91
92 | ERecord xes => box [string "{",
93 p_list (fn (x, e) =>
94 box [string x,
95 space,
96 string "=",
97 space,
98 p_exp env e]) xes,
99 string "}"]
100 | EField (e, x) =>
101 box [p_exp' true env e,
102 string ".",
103 string x]
104
105 and p_exp env = p_exp' false env
106
107 fun p_decl env ((d, _) : decl) =
108 case d of
109 DVal (x, n, t, e) =>
110 let
111 val xp = if !debug then
112 box [string x,
113 string "__",
114 string (Int.toString n)]
115 else
116 string x
117 in
118 box [string "val",
119 space,
120 xp,
121 space,
122 string ":",
123 space,
124 p_typ env t,
125 space,
126 string "=",
127 space,
128 p_exp env e]
129 end
130
131 fun p_file env file =
132 let
133 val (_, pds) = ListUtil.mapfoldl (fn (d, env) =>
134 (E.declBinds env d,
135 p_decl env d))
136 env file
137 in
138 p_list_sep newline (fn x => x) pds
139 end
140
141 end