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 local
  45     val pr = ref (fn () => ())
  46 in
  47
  48 fun registerPre f =
  49     let
  50         val old = !pr
  51     in
  52         pr := (fn () => (old (); f ()))
  53     end
  54 fun pre () = !pr ()
  55
  56 end
  57
  58 local
  59     val pst = ref (fn () => ())
  60 in
  61
  62 fun registerPost f =
  63     let
  64         val old = !pst
  65     in
  66         pst := (fn () => (old (); f ()))
  67     end
  68 fun post () = !pst ()
  69
  70 end
  71
  72 fun badArgs (name, args) =
  73     (print ("Invalid arguments to " ^ name ^ "\n");
  74      app (fn arg => Print.preface ("Argument: ", Print.p_exp arg)) args;
  75      raise Domain)
  76 fun badArg (func, arg, v) =
  77     (print ("Invalid " ^ arg ^ " argument to " ^ func ^ "\n");
  78      Print.preface ("Argument: ", Print.p_exp v);
  79      raise Domain)
  80
  81 type 'a arg = exp -> 'a option
  82
  83 fun int (EInt n, _) = SOME n
  84   | int _ = NONE
  85
  86 fun string (EString s, _) = SOME s
  87   | string _ = NONE
  88
  89 fun mapFail f [] = SOME []
  90   | mapFail f (h :: t) =
  91     case f h of
  92         NONE => NONE
  93       | SOME h' =>
  94         case mapFail f t of
  95             NONE => NONE
  96           | SOME t' => SOME (h' :: t')
  97
  98 fun list f (EList ls, _) = mapFail f ls
  99   | list _ _ = NONE
 100
 101 fun none func f (_, []) = (f ();
 102                            SM.empty)
 103   | none func _ (_, es) = badArgs (func, es)
 104
 105 fun one func (name, arg) f (_, [e]) =
 106     (case arg e of
 107          NONE => badArg (func, name, e)
 108        | SOME v => (f v;
 109                     SM.empty))
 110   | one func _ _ (_, es) = badArgs (func, es)
 111
 112 fun two func (name1, arg1, name2, arg2) f (_, [e1, e2]) =
 113     (case (arg1 e1, arg2 e2) of
 114          (NONE, _) => badArg (func, name1, e1)
 115        | (_, NONE) => badArg (func, name2, e2)
 116        | (SOME v1, SOME v2) => (f (v1, v2);
 117                                 SM.empty))
 118   | two func _ _ (_, es) = badArgs (func, es)
 119
 120
 121 fun oneV func (name, arg) f (evs, [e]) =
 122     (case arg e of
 123          NONE => badArg (func, name, e)
 124        | SOME v => (f (evs, v);
 125                     SM.empty))
 126   | oneV func _ _ (_, es) = badArgs (func, es)
 127
 128 fun twoV func (name1, arg1, name2, arg2) f (evs, [e1, e2]) =
 129     (case (arg1 e1, arg2 e2) of
 130          (NONE, _) => badArg (func, name1, e1)
 131        | (_, NONE) => badArg (func, name2, e2)
 132        | (SOME v1, SOME v2) => (f (evs, v1, v2);
 133                                 SM.empty))
 134   | twoV func _ _ (_, es) = badArgs (func, es)
 135
 136
 137 fun env arg (evs, name) =
 138     case SM.find (evs, name) of
 139         NONE => raise Fail ("Unavailable environment variable " ^ name)
 140       | SOME e =>
 141         case arg e of
 142             NONE => raise Fail ("Bad format for environment variable " ^ name)
 143           | SOME v => v
 144
 145 fun type_one func arg f =
 146     registerType (func, fn e =>
 147                            case arg e of
 148                                NONE => false
 149                              | SOME v => f v)
 150
 151 fun action_none name f = registerAction (name, none name f)
 152 fun action_one name args f = registerAction (name, one name args f)
 153 fun action_two name args f = registerAction (name, two name args f)
 154
 155 fun actionV_none name f = registerAction (name, fn (env, _) => (f env; env))
 156 fun actionV_one name args f = registerAction (name, oneV name args f)
 157 fun actionV_two name args f = registerAction (name, twoV name args f)
 158
 159 fun container_none name (f, g) = registerContainer (name, none name f, g)
 160 fun container_one name args (f, g) = registerContainer (name, one name args f, g)
 161
 162 fun containerV_one name args (f, g) = registerContainer (name, oneV name args f, g)
 163
 164 type env = SS.set * (typ * exp option) SM.map * SS.set
 165 val empty : env = (SS.empty, SM.empty, SS.empty)
 166
 167 fun lookupType (ts, _, _) name = SS.member (ts, name)
 168 fun lookupVal (_, vs, _) name =
 169     case SM.find (vs, name) of
 170         NONE => NONE
 171       | SOME (t, _) => SOME t
 172 fun lookupEquation (_, vs, _) name =
 173     case SM.find (vs, name) of
 174         NONE => NONE
 175       | SOME (_, eqo) => eqo
 176 fun lookupContext (_, _, cs) name = SS.member (cs, name)
 177
 178 fun bindType (ts, vs, cs) name = (SS.add (ts, name), vs, cs)
 179 fun bindVal (ts, vs, cs) (name, t, eqo) = (ts, SM.insert (vs, name, (t, eqo)), cs)
 180 fun bindContext (ts, vs, cs) name = (ts, vs, SS.add (cs, name))
 181
 182 fun types (ts, _, _) = ts
 183 fun vals (_, vs, _) = SM.foldli (fn (name, _, vs) => SS.add (vs, name)) SS.empty vs
 184 fun contexts (_, _, cs) = cs
 185
 186 end