f87278fcf1431e36ad341fbb41d3dead5c61c3c1
[hcoop/domtool2.git] / src / env.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006, Adam Chlipala
3 *
4 * This program is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU General Public License
6 * as published by the Free Software Foundation; either version 2
7 * of the License, or (at your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
13 *
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
17 *)
18
19 (* Domtool type-checking and reduction environments *)
20
21 structure Env :> ENV = struct
22
23 open Ast
24
25 structure SS = StringSet
26 structure SM = StringMap
27
28 type typeRule = exp -> bool
29 val typeRules : typeRule SM.map ref = ref SM.empty
30 fun registerType (name, rule) = typeRules := SM.insert (!typeRules, name, rule)
31 fun typeRule name = SM.find (!typeRules, name)
32
33 type env_vars = exp SM.map
34 type action = env_vars * Ast.exp list -> env_vars
35 val actions : action SM.map ref = ref SM.empty
36 fun registerAction (name, action) = actions := SM.insert (!actions, name, action)
37 fun action name = SM.find (!actions, name)
38
39 val containers : (action * (unit -> unit)) SM.map ref = ref SM.empty
40 fun registerContainer (name, befor, after) =
41 containers := SM.insert (!containers, name, (befor, after))
42 fun container name = SM.find (!containers, name)
43
44 val functions : (exp list -> exp option) SM.map ref = ref SM.empty
45 fun registerFunction (name, f) =
46 functions := SM.insert (!functions, name, f)
47 fun function name = SM.find (!functions, name)
48
49 local
50 val pr = ref (fn () => ())
51 in
52
53 fun registerPre f =
54 let
55 val old = !pr
56 in
57 pr := (fn () => (old (); f ()))
58 end
59 fun pre () = !pr ()
60
61 end
62
63 local
64 val pst = ref (fn () => ())
65 in
66
67 fun registerPost f =
68 let
69 val old = !pst
70 in
71 pst := (fn () => (old (); f ()))
72 end
73 fun post () = !pst ()
74
75 end
76
77 local
78 val pr = ref (fn () => ())
79 in
80
81 fun registerPreTycheck f =
82 let
83 val old = !pr
84 in
85 pr := (fn () => (old (); f ()))
86 end
87 fun preTycheck () = !pr ()
88
89 end
90
91 fun badArgs (name, args) =
92 (print ("Invalid arguments to " ^ name ^ "\n");
93 app (fn arg => Print.preface ("Argument: ", Print.p_exp arg)) args;
94 raise Domain)
95 fun badArg (func, arg, v) =
96 (print ("Invalid " ^ arg ^ " argument to " ^ func ^ "\n");
97 Print.preface ("Argument: ", Print.p_exp v);
98 raise Domain)
99
100 type 'a arg = exp -> 'a option
101
102 fun int (EInt n, _) = SOME n
103 | int _ = NONE
104
105 fun string (EString s, _) = SOME s
106 | string _ = NONE
107
108 fun bool (EVar "false", _) = SOME false
109 | bool (EVar "true", _) = SOME true
110 | bool _ = NONE
111
112 fun mapFail f [] = SOME []
113 | mapFail f (h :: t) =
114 case f h of
115 NONE => NONE
116 | SOME h' =>
117 case mapFail f t of
118 NONE => NONE
119 | SOME t' => SOME (h' :: t')
120
121 fun list f (EList ls, _) = mapFail f ls
122 | list _ _ = NONE
123
124 fun none func f (_, []) = (f ();
125 SM.empty)
126 | none func _ (_, es) = badArgs (func, es)
127
128 fun one func (name, arg) f (_, [e]) =
129 (case arg e of
130 NONE => badArg (func, name, e)
131 | SOME v => (f v;
132 SM.empty))
133 | one func _ _ (_, es) = badArgs (func, es)
134
135 fun two func (name1, arg1, name2, arg2) f (_, [e1, e2]) =
136 (case (arg1 e1, arg2 e2) of
137 (NONE, _) => badArg (func, name1, e1)
138 | (_, NONE) => badArg (func, name2, e2)
139 | (SOME v1, SOME v2) => (f (v1, v2);
140 SM.empty))
141 | two func _ _ (_, es) = badArgs (func, es)
142
143 fun three func (name1, arg1, name2, arg2, name3, arg3) f (_, [e1, e2, e3]) =
144 (case (arg1 e1, arg2 e2, arg3 e3) of
145 (NONE, _, _) => badArg (func, name1, e1)
146 | (_, NONE, _) => badArg (func, name2, e2)
147 | (_, _, NONE) => badArg (func, name3, e3)
148 | (SOME v1, SOME v2, SOME v3) => (f (v1, v2, v3);
149 SM.empty))
150 | three func _ _ (_, es) = badArgs (func, es)
151
152 fun oneV func (name, arg) f (evs, [e]) =
153 (case arg e of
154 NONE => badArg (func, name, e)
155 | SOME v => (f (evs, v);
156 SM.empty))
157 | oneV func _ _ (_, es) = badArgs (func, es)
158
159 fun twoV func (name1, arg1, name2, arg2) f (evs, [e1, e2]) =
160 (case (arg1 e1, arg2 e2) of
161 (NONE, _) => badArg (func, name1, e1)
162 | (_, NONE) => badArg (func, name2, e2)
163 | (SOME v1, SOME v2) => (f (evs, v1, v2);
164 SM.empty))
165 | twoV func _ _ (_, es) = badArgs (func, es)
166
167
168 fun env arg (evs, name) =
169 case SM.find (evs, name) of
170 NONE => raise Fail ("Unavailable environment variable " ^ name)
171 | SOME e =>
172 case arg e of
173 NONE => raise Fail ("Bad format for environment variable " ^ name)
174 | SOME v => v
175
176 fun type_one func arg f =
177 registerType (func, fn e =>
178 case arg e of
179 NONE => false
180 | SOME v => f v)
181
182 fun action_none name f = registerAction (name, none name f)
183 fun action_one name args f = registerAction (name, one name args f)
184 fun action_two name args f = registerAction (name, two name args f)
185 fun action_three name args f = registerAction (name, three name args f)
186
187 fun actionV_none name f = registerAction (name, fn (env, _) => (f env; env))
188 fun actionV_one name args f = registerAction (name, oneV name args f)
189 fun actionV_two name args f = registerAction (name, twoV name args f)
190
191 fun container_none name (f, g) = registerContainer (name, none name f, g)
192 fun container_one name args (f, g) = registerContainer (name, one name args f, g)
193
194 fun containerV_one name args (f, g) = registerContainer (name, oneV name args f, g)
195
196 type env = SS.set * (typ * exp option) SM.map * SS.set
197 val empty : env = (SS.empty, SM.empty, SS.empty)
198
199 fun lookupType (ts, _, _) name = SS.member (ts, name)
200 fun lookupVal (_, vs, _) name =
201 case SM.find (vs, name) of
202 NONE => NONE
203 | SOME (t, _) => SOME t
204 fun lookupEquation (_, vs, _) name =
205 case SM.find (vs, name) of
206 NONE => NONE
207 | SOME (_, eqo) => eqo
208 fun lookupContext (_, _, cs) name = SS.member (cs, name)
209
210 fun bindType (ts, vs, cs) name = (SS.add (ts, name), vs, cs)
211 fun bindVal (ts, vs, cs) (name, t, eqo) = (ts, SM.insert (vs, name, (t, eqo)), cs)
212 fun bindContext (ts, vs, cs) name = (ts, vs, SS.add (cs, name))
213
214 fun types (ts, _, _) = ts
215 fun vals (_, vs, _) = SM.foldli (fn (name, _, vs) => SS.add (vs, name)) SS.empty vs
216 fun contexts (_, _, cs) = cs
217
218 end