Fix file paths for recursive rmdom
[hcoop/domtool2.git] / src / env.sml
CommitLineData
492c1cff
AC
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.
dac62e84 17 *)
492c1cff
AC
18
19(* Domtool type-checking and reduction environments *)
20
21structure Env :> ENV = struct
22
23open Ast
24
25structure SS = StringSet
26structure SM = StringMap
27
a3698041
AC
28type typeRule = exp -> bool
29val typeRules : typeRule SM.map ref = ref SM.empty
6be996d4
AC
30fun registerType (name, rule) = typeRules := SM.insert (!typeRules, name, rule)
31fun typeRule name = SM.find (!typeRules, name)
32
a3698041
AC
33type env_vars = exp SM.map
34type action = env_vars * Ast.exp list -> env_vars
35val actions : action SM.map ref = ref SM.empty
36fun registerAction (name, action) = actions := SM.insert (!actions, name, action)
37fun action name = SM.find (!actions, name)
38
39val containers : (action * (unit -> unit)) SM.map ref = ref SM.empty
40fun registerContainer (name, befor, after) =
41 containers := SM.insert (!containers, name, (befor, after))
42fun container name = SM.find (!containers, name)
43
cf879b4f
AC
44val functions : (exp list -> exp option) SM.map ref = ref SM.empty
45fun registerFunction (name, f) =
46 functions := SM.insert (!functions, name, f)
47fun function name = SM.find (!functions, name)
48
e0b0abd2
AC
49local
50 val pr = ref (fn () => ())
51in
52
53fun registerPre f =
54 let
55 val old = !pr
56 in
57 pr := (fn () => (old (); f ()))
58 end
59fun pre () = !pr ()
60
61end
62
63local
64 val pst = ref (fn () => ())
65in
66
67fun registerPost f =
68 let
69 val old = !pst
70 in
71 pst := (fn () => (old (); f ()))
72 end
73fun post () = !pst ()
74
75end
76
12adf55a
AC
77local
78 val pr = ref (fn () => ())
79in
80
81fun registerPreTycheck f =
82 let
83 val old = !pr
84 in
85 pr := (fn () => (old (); f ()))
86 end
87fun preTycheck () = !pr ()
88
89end
90
629a34f6
AC
91fun 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)
95fun badArg (func, arg, v) =
96 (print ("Invalid " ^ arg ^ " argument to " ^ func ^ "\n");
97 Print.preface ("Argument: ", Print.p_exp v);
98 raise Domain)
99
100type 'a arg = exp -> 'a option
101
102fun int (EInt n, _) = SOME n
103 | int _ = NONE
104
105fun string (EString s, _) = SOME s
106 | string _ = NONE
107
8a7c40fa
AC
108fun bool (EVar "false", _) = SOME false
109 | bool (EVar "true", _) = SOME true
110 | bool _ = NONE
111
629a34f6
AC
112fun 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
121fun list f (EList ls, _) = mapFail f ls
122 | list _ _ = NONE
123
ed9fda3a
AC
124fun none func f (_, []) = (f ();
125 SM.empty)
126 | none func _ (_, es) = badArgs (func, es)
127
629a34f6
AC
128fun 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
135fun 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
f8dfbbcc
AC
143fun 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)
6ae327f8
AC
151
152fun 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
e0b0abd2
AC
159fun 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
6ae327f8
AC
167
168fun 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
629a34f6
AC
176fun type_one func arg f =
177 registerType (func, fn e =>
178 case arg e of
179 NONE => false
180 | SOME v => f v)
181
ed9fda3a 182fun action_none name f = registerAction (name, none name f)
629a34f6
AC
183fun action_one name args f = registerAction (name, one name args f)
184fun action_two name args f = registerAction (name, two name args f)
f8dfbbcc 185fun action_three name args f = registerAction (name, three name args f)
629a34f6 186
e0b0abd2 187fun actionV_none name f = registerAction (name, fn (env, _) => (f env; env))
6ae327f8 188fun actionV_one name args f = registerAction (name, oneV name args f)
e0b0abd2 189fun actionV_two name args f = registerAction (name, twoV name args f)
6ae327f8
AC
190
191fun container_none name (f, g) = registerContainer (name, none name f, g)
629a34f6 192fun container_one name args (f, g) = registerContainer (name, one name args f, g)
a3698041 193
6ae327f8
AC
194fun containerV_one name args (f, g) = registerContainer (name, oneV name args f, g)
195
095de39e
AC
196type env = SS.set * (typ * exp option) SM.map * SS.set
197val empty : env = (SS.empty, SM.empty, SS.empty)
492c1cff 198
095de39e
AC
199fun lookupType (ts, _, _) name = SS.member (ts, name)
200fun lookupVal (_, vs, _) name =
492c1cff
AC
201 case SM.find (vs, name) of
202 NONE => NONE
203 | SOME (t, _) => SOME t
095de39e 204fun lookupEquation (_, vs, _) name =
492c1cff
AC
205 case SM.find (vs, name) of
206 NONE => NONE
207 | SOME (_, eqo) => eqo
095de39e 208fun lookupContext (_, _, cs) name = SS.member (cs, name)
492c1cff 209
095de39e
AC
210fun bindType (ts, vs, cs) name = (SS.add (ts, name), vs, cs)
211fun bindVal (ts, vs, cs) (name, t, eqo) = (ts, SM.insert (vs, name, (t, eqo)), cs)
212fun bindContext (ts, vs, cs) name = (ts, vs, SS.add (cs, name))
213
214fun types (ts, _, _) = ts
215fun vals (_, vs, _) = SM.foldli (fn (name, _, vs) => SS.add (vs, name)) SS.empty vs
216fun contexts (_, _, cs) = cs
492c1cff
AC
217
218end