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 => (Print.preface ("Unexpected value for " ^ name ^ ":",
 174                                     Print.p_exp e);
 175                      raise Fail ("Bad format for environment variable " ^ name))
 176           | SOME v => v
 177
 178 fun type_one func arg f =
 179     registerType (func, fn e =>
 180                            case arg e of
 181                                NONE => false
 182                              | SOME v => f v)
 183
 184 fun action_none name f = registerAction (name, none name f)
 185 fun action_one name args f = registerAction (name, one name args f)
 186 fun action_two name args f = registerAction (name, two name args f)
 187 fun action_three name args f = registerAction (name, three name args f)
 188
 189 fun actionV_none name f = registerAction (name, fn (env, _) => (f env; env))
 190 fun actionV_one name args f = registerAction (name, oneV name args f)
 191 fun actionV_two name args f = registerAction (name, twoV name args f)
 192
 193 fun container_none name (f, g) = registerContainer (name, none name f, g)
 194 fun container_one name args (f, g) = registerContainer (name, one name args f, g)
 195
 196 fun containerV_one name args (f, g) = registerContainer (name, oneV name args f, g)
 197
 198 type env = SS.set * (typ * exp option) SM.map * SS.set
 199 val empty : env = (SS.empty, SM.empty, SS.empty)
 200
 201 fun lookupType (ts, _, _) name = SS.member (ts, name)
 202 fun lookupVal (_, vs, _) name =
 203     case SM.find (vs, name) of
 204         NONE => NONE
 205       | SOME (t, _) => SOME t
 206 fun lookupEquation (_, vs, _) name =
 207     case SM.find (vs, name) of
 208         NONE => NONE
 209       | SOME (_, eqo) => eqo
 210 fun lookupContext (_, _, cs) name = SS.member (cs, name)
 211
 212 fun bindType (ts, vs, cs) name = (SS.add (ts, name), vs, cs)
 213 fun bindVal (ts, vs, cs) (name, t, eqo) = (ts, SM.insert (vs, name, (t, eqo)), cs)
 214 fun bindContext (ts, vs, cs) name = (ts, vs, SS.add (cs, name))
 215
 216 fun types (ts, _, _) = ts
 217 fun vals (_, vs, _) = SM.foldli (fn (name, _, vs) => SS.add (vs, name)) SS.empty vs
 218 fun contexts (_, _, cs) = cs
 219
 220 end