scripts: Fix lazy chown syntax

[hcoop/domtool2.git] / src / tycheck.sml

diff --git a/src/tycheck.sml b/src/tycheck.sml
index f68100f..38ef822 100644 (file)
--- a/src/tycheck.sml
+++ b/src/tycheck.sml
@@ -1,5 +1,6 @@
 (* HCoop Domtool (http://hcoop.sourceforge.net/)
  * Copyright (c) 2006-2007, Adam Chlipala
+ * Copyright (c) 2014 Clinton Ebadi <clinton@unknownlamer.org>
  *
  * This program is free software; you can redistribute it and/or
  * modify it under the terms of the GNU General Public License
@@ -258,10 +259,7 @@ fun envVarSetFrom v (e, _) =
 
       | _ => NONE
 
-fun ununify (tAll as (t, _)) =
-    case t of
-       TUnif (_, ref (SOME t)) => ununify t
-      | _ => tAll
+val ununify = Describe.ununify
 
 fun checkExp G (eAll as (e, loc)) =
     let
@@ -446,14 +444,14 @@ fun checkExp G (eAll as (e, loc)) =
                             (TAction (p', d', r'), loc)
                         end
                       | (TError, _) => t2
-                      | _ => (dte (WrongForm ("Action to be sequenced",
+                      | _ => (dte (WrongForm ("First action to be sequenced",
                                               "action",
                                               e2,
                                               t2,
                                               NONE));
                               (TError, loc)))
                  | (TError, _) => t1
-                 | _ => (dte (WrongForm ("Action to be sequenced",
+                 | _ => (dte (WrongForm ("Second action to be sequenced",
                                          "action",
                                          e1,
                                          t1,
@@ -505,14 +503,14 @@ fun checkExp G (eAll as (e, loc)) =
                             (TAction (p', d', r2), loc)
                         end
                       | (TError, _) => t2
-                      | _ => (dte (WrongForm ("Action to be sequenced",
+                      | _ => (dte (WrongForm ("Body of local settings",
                                               "action",
                                               e2,
                                               t2,
                                               NONE));
                               (TError, loc)))
                  | (TError, _) => t1
-                 | _ => (dte (WrongForm ("Action to be sequenced",
+                 | _ => (dte (WrongForm ("Local settings",
                                          "action",
                                          e1,
                                          t1,
@@ -574,8 +572,6 @@ fun checkExp G (eAll as (e, loc)) =
 
          | EIf (e1, e2, e3) =>
            let
-               val t = (newUnif (), loc)
-
                val t1 = checkExp G e1
                val t2 = checkExp G e2
                val t3 = checkExp G e3
@@ -583,20 +579,21 @@ fun checkExp G (eAll as (e, loc)) =
            in
                (subTyp (t1, bool))
                handle Unify ue =>
-                      dte (WrongType ("\"If\" test",
+                      dte (WrongType ("\"if\" test",
                                       e1,
                                       t1,
                                       bool,
                                       SOME ue));
-               subTyp (t2, t);
-               (subTyp (t3, t))
-               handle Unify ue =>
-                      dte (WrongType ("\"Else\" case",
-                                      eAll,
-                                      t3,
-                                      t2,
-                                      SOME ue));
-               t
+               (subTyp (t2, t3); t3)
+                      handle Unify _ =>
+                             ((subTyp (t3, t2); t2)
+                              handle Unify ue =>
+                                     (dte (WrongType ("\"else\" case",
+                                                      eAll,
+                                                      t3,
+                                                      t2,
+                                                      SOME ue));
+                                      (TError, loc)))
            end
     end
 
@@ -675,6 +672,25 @@ fun checkDecl G (d, _, loc) =
                                                            SOME ue));
            bindVal G (name, to, SOME e)
        end
+      | DEnv (name, to, e) =>
+       let
+           val to =
+               case to of
+                   NONE => (newUnif (), loc)
+                 | SOME to => checkTyp G to
+
+           val t = checkExp G e
+       in
+           hasTyp (e, t, to)
+           handle Unify ue =>
+                  Describe.describe_type_error loc
+                                               (WrongType ("Dynamically bound value",
+                                                           e,
+                                                           t,
+                                                           to,
+                                                           SOME ue));
+           bindInitialDynEnvVal G (name, to, e)
+       end
       | DContext name => bindContext G name
 
 fun printActionDiffs {have, need} =
@@ -727,15 +743,42 @@ fun printActionDiffs {have, need} =
        
       | _ => false
 
-fun checkFile G tInit (_, ds, eo) =
+fun checkFile G (prog as (_, ds, eo)) =
     let
        val G' = foldl (fn (d, G) => checkDecl G d) G ds
+
+       fun tInitial prog env =
+           (* This should likely only take the dynamic env as an argument *)
+           let
+               fun allSets (e, _) =
+                   case e of
+                       ESkip => true
+                     | ESet _ => true
+                     | ESeq es => List.all allSets es
+                     | _ => false
+
+               val dmy = ErrorMsg.dummyLoc
+
+               fun bodyType (_, _, SOME e) =
+                   if allSets e then
+                       (CPrefix (CRoot, dmy), dmy)
+                   else
+                       (CRoot, dmy)
+                 | bodyType _ = (CRoot, dmy)
+           in
+               (TAction (bodyType prog,
+                         Env.initialDynEnvTypes env,
+                         StringMap.empty),
+                dmy)
+           end
+
     in
        case eo of
            NONE => ()
          | SOME (e as (_, loc)) =>
            let
                val t = checkExp G' e
+               val tInit = tInitial prog G'
            in
                hasTyp (e, t, tInit)
                handle Unify _ =>