Add listsHEADmain

1 files changed, 17 insertions, 7 deletions

diff --git a/Types.sml b/Types.sml
index 6b945f9..6cf419f 100644
--- a/Types.sml
+++ b/Types.sml
@@ -148,6 +148,8 @@ structure Types = struct
         bind makeBinding (Syntax.ITVar, v) (GenSym.new ()) env
     | bindPat makeBinding (Syntax.PTuple pats) env =
         foldl (fn (pat, env) => bindPat makeBinding pat env) env pats
+    | bindPat makeBinding (Syntax.PList pats) env =
+        foldl (fn (pat, env) => bindPat makeBinding pat env) env pats
     | bindPat makeBinding (Syntax.PCon (_, pat)) env = bindPat makeBinding pat env
     | bindPat _ _ env = env
 
@@ -157,11 +159,6 @@ structure Types = struct
     | SOME (Arg t) => TyVar t
     | NONE => raise Fail ("unbound var " ^ printIdent name)
 
-  fun patBindings (Syntax.PVar v) : string list = [v]
-    | patBindings (Syntax.PTuple pats) = List.concat (map patBindings pats)
-    | patBindings (Syntax.PCon (_, pat)) = patBindings pat
-    | patBindings _ = []
-
   fun tyToSyntaxTy (TyVar v) = Syntax.TVar v
     | tyToSyntaxTy (TyCon (Bool, [])) = Syntax.TBool
     | tyToSyntaxTy (TyCon (Int, [])) = Syntax.TInt
@@ -220,6 +217,13 @@ structure Types = struct
                 Syntax.PTuple [] => (Syntax.TPCon (con, (Syntax.TPTuple [], Syntax.TTuple [])), conType)
               | _ => raise Fail ("non-function " ^ (String.concatWith "." con) ^ " applied to argument in pattern")
         end
+    | tagPat env (Syntax.PList pats) =
+        let
+          val taggedPats = map (tagPat env) pats
+          val elemType = TyVar (GenSym.new ())
+          val _ = app (fn (_, t) => unify elemType t) taggedPats
+        in (Syntax.TPList (map (fn (x, t) => (x, tyToSyntaxTy t)) taggedPats), TyCon (List, [elemType]))
+        end
 
   fun F (env : env) (Syntax.EIdent i) : Syntax.typedExpr * ty =
         (Syntax.TEIdent i, lookupBinding i env)
@@ -306,7 +310,7 @@ structure Types = struct
               arms
         in (Syntax.TECase ((arg, tyToSyntaxTy argType), arms), resultType) end
     | F env (Syntax.EStruct decls) =
-        let val (env, decls) = tagDecs env decls
+        let val (env', decls) = tagDecs env decls
         in
           ( Syntax.TEStruct decls
           , TyStruct
@@ -314,7 +318,9 @@ structure Types = struct
                 (map
                   (fn (name, Let v) => (name, TyVar v)
                     | (name, Arg v) => (name, TyVar v))
-                  (IdentMap.toList (#bindings env))))
+                  (List.filter
+                    (fn (id, _) => not (isSome (IdentMap.lookup id (#bindings env))))
+                    (IdentMap.toList (#bindings env')))))
           )
         end
     | F env (Syntax.EFunctorApp (func, arg)) =
@@ -465,6 +471,10 @@ structure Types = struct
         , boundVars = TyVarMap.empty
         , typesByName = StringMap.empty
         }
+      val alpha = TyVar (GenSym.new ())
+      val cons = GenSym.new ()
+      val _ = unify (TyVar cons) (TyCon (Fun, [TyCon (Tuple, [alpha, TyCon (List, [alpha])]), TyCon (List, [alpha])]))
+      val env = bind Let (Syntax.ITVar, "::") cons env
       val (expr, ty) = F env expr
     in reexpand (expr, tyToSyntaxTy ty) end
 end