Combine structs and expressions

1 files changed, 110 insertions, 108 deletions

diff --git a/Types.sml b/Types.sml
index 5b0e1a8..6b945f9 100644
--- a/Types.sml
+++ b/Types.sml
@@ -1,30 +1,34 @@
 structure Types = struct
   structure StringMap = Map(type k = string val cmp = String.compare)
   structure IntMap = Map(type k = int val cmp = Int.compare)
+  structure IdentMap = Map(type k = Syntax.identType * string val cmp = Syntax.compareIdentifiers)
 
   type tyvar = int
-  datatype tycon = Bool | Int | Str | Fun | Tuple | List | Datatype of int
-  and ty =
+  datatype tycon = Bool | Int | Str | Fun | Tuple | List | Datatype of int | Functor
+  datatype ty =
     TyVar of tyvar
   | TyCon of tycon * ty list
-  | TyStruct of structTy
-  and structTy = Struct of {
-    structs : structTy StringMap.map,
-    vals : ty StringMap.map
-  }
+  | TyStruct of ty IdentMap.map
 
   structure TyVarMap = IntMap
 
   fun listToString (show : 'a -> string) (l : 'a list) : string =
     "[" ^ String.concatWith ", " (map show l) ^ "]"
 
+  fun printIdent (ty : Syntax.identType, name : string) : string = "(" ^ ShowSyntax.identTypeToString ty ^ ", \"" ^ name ^ "\")"
+
   fun printTyCon Int : string = "Int"
+    | printTyCon Bool = "Bool"
+    | printTyCon Str = "Str"
     | printTyCon Fun = "Fun"
     | printTyCon Tuple = "Tuple"
+    | printTyCon List = "List"
     | printTyCon (Datatype tag) = "Datatype " ^ Int.toString tag
+    | printTyCon Functor = "Functor"
 
   and printTy (TyVar a) : string = "TyVar " ^ Int.toString a
     | printTy (TyCon (n, tys)) = "TyCon (" ^ printTyCon n ^ ", " ^ listToString printTy tys ^ ")"
+    | printTy (TyStruct decls) = "TyStruct " ^ listToString (fn (id, ty) => "(" ^ printIdent id ^ ", " ^ printTy ty ^ ")") (IdentMap.toList decls)
 
   (* map of type variables to types *)
   val substitution : ty TyVarMap.map ref = ref TyVarMap.empty
@@ -55,19 +59,17 @@ structure Types = struct
 
   datatype binding = Let of tyvar | Arg of tyvar
 
-  type env = {
-    bindings : binding StringMap.map,
-    boundVars : unit TyVarMap.map,
-    typesByName : tycon StringMap.map,
-    structs : structTy StringMap.map
-  }
+  type env =
+    { bindings : binding IdentMap.map
+    , boundVars : unit TyVarMap.map
+    , typesByName : tycon StringMap.map
+    }
 
-  fun bind (makeBinding : tyvar -> binding) (s : string) (v : tyvar) ({bindings, boundVars, typesByName, structs} : env) : env = {
-    bindings = StringMap.insert s (makeBinding v) bindings,
-    boundVars = TyVarMap.insert v () boundVars,
-    typesByName = typesByName,
-    structs = structs
-  }
+  fun bind (makeBinding : tyvar -> binding) (s : Syntax.identType * string) (v : tyvar) (env : env) : env =
+    { bindings = IdentMap.insert s (makeBinding v) (#bindings env)
+    , boundVars = TyVarMap.insert v () (#boundVars env)
+    , typesByName = (#typesByName env)
+    }
 
   fun genericVars (env : env) (TyVar a) : unit TyVarMap.map =
         if isSome (TyVarMap.lookup a (#boundVars env))
@@ -115,15 +117,14 @@ structure Types = struct
         | go (Syntax.Tyfun (arg, result)) = TyCon (Fun, [go arg, go result])
     in instantiate env (go t) end
 
-  fun bindType ((vars, name, constructors) : string list * string * (string * Syntax.etype option) list) (env as {bindings, boundVars, typesByName, structs} : env) : env =
+  fun bindType ((vars, name, constructors) : string list * string * (string * Syntax.etype option) list) (env : env) : env =
     let
       val tag = GenSym.new ()
-      val env = {
-        bindings = bindings,
-        boundVars = boundVars,
-        typesByName = StringMap.insert name (Datatype tag) typesByName,
-        structs = structs
-      }
+      val env =
+        { bindings = #bindings env
+        , boundVars = #boundVars env
+        , typesByName = StringMap.insert name (Datatype tag) (#typesByName env)
+        }
     in
       datatypes := IntMap.insert tag (map (fn (x, _) => x) constructors) (!datatypes) ;
       foldl
@@ -137,31 +138,24 @@ structure Types = struct
               | SOME t => TyCon (Fun, [etypeToTy env t, resType])
           in
             unify (TyVar g) conType;
-            bind Let x g env
+            bind Let (Syntax.ITVar, x) g env
           end)
         env
         constructors
     end
 
-  fun bindStruct (name : string) (str : structTy) ({bindings, boundVars, typesByName, structs} : env) : env = {
-    bindings = bindings,
-    boundVars = boundVars,
-    typesByName = typesByName,
-    structs = StringMap.insert name str structs
-  }
-
   fun bindPat (makeBinding : tyvar -> binding) (Syntax.PVar v) (env : env) : env =
-        bind makeBinding v (GenSym.new ()) env
+        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.PCon (_, pat)) env = bindPat makeBinding pat env
     | bindPat _ _ env = env
 
-  fun lookupBinding (name : string) (env : env) : ty =
-    case StringMap.lookup name (#bindings env) of
+  fun lookupBinding (name: Syntax.identType * string) (env : env) : ty =
+    case IdentMap.lookup name (#bindings env) of
       SOME (Let t) => instantiate env (find (TyVar t))
     | SOME (Arg t) => TyVar t
-    | NONE => raise Fail ("unbound var " ^ name)
+    | NONE => raise Fail ("unbound var " ^ printIdent name)
 
   fun patBindings (Syntax.PVar v) : string list = [v]
     | patBindings (Syntax.PTuple pats) = List.concat (map patBindings pats)
@@ -179,17 +173,12 @@ structure Types = struct
         (case (IntMap.lookup tag (!datatypes)) of
           SOME cases => Syntax.TDatatype cases
         | NONE => raise Fail ("unknown datatype tag " ^ Int.toString tag))
+    | tyToSyntaxTy (TyCon (Functor, [f, x])) = Syntax.TFunctor (tyToSyntaxTy f, tyToSyntaxTy x)
+    | tyToSyntaxTy (TyStruct decls) = Syntax.TStruct (map (fn (id, ty) => (id, tyToSyntaxTy ty)) (IdentMap.toList decls))
     | tyToSyntaxTy t = raise Fail ("invalid ty " ^ printTy t)
 
-  fun structTypeToSyntaxStructType (Struct s) =
-    Syntax.TStruct
-      ( map (fn (name, ty) => (name, structTypeToSyntaxStructType ty)) (StringMap.toList (#structs s))
-      , map (fn (name, ty) => (name, tyToSyntaxTy ty)) (StringMap.toList (#vals s))
-      )
-    (* | structTypeToSyntaxStructType _ = raise Fail "we really need to combine structs and expressions" *)
-
   fun tagPat (_ : env) Syntax.PWild : Syntax.typedPat * ty = (Syntax.TPWild, TyVar (GenSym.new ()))
-    | tagPat env (Syntax.PVar v) = (Syntax.TPVar v, TyVar (case (StringMap.lookup v (#bindings env)) of SOME (Let t) => t | SOME (Arg t) => t | NONE => raise Fail "unknown pattern variable"))
+    | tagPat env (Syntax.PVar v) = (Syntax.TPVar v, TyVar (case (IdentMap.lookup (Syntax.ITVar, v) (#bindings env)) of SOME (Let t) => t | SOME (Arg t) => t | NONE => raise Fail "unknown pattern variable"))
     | tagPat _ (Syntax.PInt i) = (Syntax.TPInt i, TyCon (Int, []))
     | tagPat env (Syntax.PTuple pats) =
         let
@@ -201,21 +190,23 @@ structure Types = struct
         let
           val conBinding =
             case con of
-              [ident] => lookupBinding ident env
+              [ident] => lookupBinding (Syntax.ITVar, ident) env
+            | [] => raise Fail "invalid constructor"
             | str :: fields =>
-                case StringMap.lookup str (#structs env) of
-                  SOME (Struct structTy) =>
+                case lookupBinding (Syntax.ITStruct, str) env of
+                  TyStruct structTy =>
                     let
                       fun go structTy [field] =
-                            (case StringMap.lookup field (#vals structTy) of
+                            (case IdentMap.lookup (Syntax.ITVar, field) structTy of
                               SOME t => instantiate env (find t)
                             | NONE => raise Fail "unbound something or other")
                         | go structTy (str :: fields) =
-                            case StringMap.lookup str (#structs structTy) of
-                              SOME (Struct structTy) => go structTy fields
-                            | NONE => raise Fail ("unbound field " ^ str)
+                            (case IdentMap.lookup (Syntax.ITStruct, str) structTy of
+                              SOME (TyStruct structTy) => go structTy fields
+                            | _ => raise Fail ("unbound field " ^ str))
+                        | go _ _ = raise (Fail "a constructor should have at least one field")
                     in go structTy fields end
-                | NONE => raise Fail ("unbound struct " ^ str)
+                | _ => raise Fail ("that's a weird struct " ^ str)
         in
           case conBinding of
             TyCon (Fun, [argType, resType]) =>
@@ -230,13 +221,15 @@ structure Types = struct
               | _ => raise Fail ("non-function " ^ (String.concatWith "." con) ^ " applied to argument in pattern")
         end
 
-  fun F (env : env) (Syntax.EIdent i : Syntax.expr) : Syntax.typedExpr * ty =
+  fun F (env : env) (Syntax.EIdent i) : Syntax.typedExpr * ty =
         (Syntax.TEIdent i, lookupBinding i env)
     | F env (Syntax.EDot (expr, field)) =
-        let
-          val (str, Struct structType) = tagStructExpr env expr
-          val fieldType = instantiate env (find (valOf (StringMap.lookup field (#vals structType))))
-        in (Syntax.TEDot ((str, structTypeToSyntaxStructType (Struct structType)), field), fieldType) end
+        (case F env expr of
+          (str, TyStruct structType) =>
+            let
+              val fieldType = instantiate env (find (valOf (IdentMap.lookup field structType)))
+            in (Syntax.TEDot ((str, tyToSyntaxTy (TyStruct structType)), field), fieldType) end
+        | (_, ty) => raise Fail ("wrong struct type " ^ printTy ty))
     | F _ (Syntax.EBuiltin "exit") = (Syntax.TEBuiltin "exit", TyCon (Fun, [TyCon (Int, []), TyVar (GenSym.new ())]))
     | F _ (Syntax.EBuiltin "add") = (Syntax.TEBuiltin "add", TyCon (Fun, [TyCon (Tuple, [TyCon (Int, []), TyCon (Int, [])]), TyCon (Int, [])]))
     | F _ (Syntax.EBuiltin "sub") = (Syntax.TEBuiltin "sub", TyCon (Fun, [TyCon (Tuple, [TyCon (Int, []), TyCon (Int, [])]), TyCon (Int, [])]))
@@ -312,6 +305,26 @@ structure Types = struct
                 end)
               arms
         in (Syntax.TECase ((arg, tyToSyntaxTy argType), arms), resultType) end
+    | F env (Syntax.EStruct decls) =
+        let val (env, decls) = tagDecs env decls
+        in
+          ( Syntax.TEStruct decls
+          , TyStruct
+              (IdentMap.fromList
+                (map
+                  (fn (name, Let v) => (name, TyVar v)
+                    | (name, Arg v) => (name, TyVar v))
+                  (IdentMap.toList (#bindings env))))
+          )
+        end
+    | F env (Syntax.EFunctorApp (func, arg)) =
+        case F env func of
+          (func, funcType as TyCon (Functor, [_, result])) =>
+            let
+              val (arg, argType) = F env arg
+            in (Syntax.TEFunctorApp ((func, tyToSyntaxTy funcType), (arg, tyToSyntaxTy argType)), result) end
+        | _ => raise Fail "invalid functor"
+    (* | F _ expr = raise Fail ("invalid expression " ^ ShowSyntax.exprToString expr) *)
 
   and tagDec (env : env) (Syntax.DVal (pat, expr)) : env * Syntax.typedDec option =
         let
@@ -337,7 +350,7 @@ structure Types = struct
           val args1Env =
             foldl
               (fn (arg, env) => bindPat Arg arg env)
-              (bind Arg name fnType env)
+              (bind Arg (Syntax.ITVar, name) fnType env)
               args
           val args = map (tagPat args1Env) args
           val argTypes = map (fn (_, ty) => ty) args
@@ -350,7 +363,7 @@ structure Types = struct
                   val env =
                     foldl
                       (fn (arg, env) => bindPat Arg arg env)
-                      (bind Arg name fnType env)
+                      (bind Arg (Syntax.ITVar, name) fnType env)
                       args
                   val args = map (tagPat env) args
                   val (body, bt) = F env body
@@ -362,16 +375,40 @@ structure Types = struct
                   (map (fn (arg, ty) => (arg, tyToSyntaxTy ty)) args, (body, tyToSyntaxTy bt))
                 end)
               cases
-        in (bind Let name fnType env, SOME (Syntax.TDFun (name, cases)))
+        in (bind Let (Syntax.ITVar, name) fnType env, SOME (Syntax.TDFun (name, cases)))
         end
     | tagDec env (Syntax.DDatatype (vars, name, data)) =
         let val env = bindType (vars, name, data) env
         in (env, SOME (Syntax.TDDatatype (name, map (fn (name, ty) => (name, Option.map (tyToSyntaxTy o (etypeToTy env)) ty)) data))) end
     | tagDec _ (Syntax.DType _) = raise Fail "TODO"
     | tagDec env (Syntax.DStruct (name, _, str)) =
-        let val (str, strType) = tagStructExpr env str
-        in (bindStruct name strType env, SOME (Syntax.TDStruct (name, (str, structTypeToSyntaxStructType strType)))) end
-    | tagDec env (Syntax.DSig (s, decls)) = (env, NONE)
+        let
+          val v = GenSym.new ()
+          val (str, strType) = F env str
+          val _ = unify (TyVar v) strType
+        in (bind Let (Syntax.ITStruct, name) v env, SOME (Syntax.TDStruct (name, (str, tyToSyntaxTy strType)))) end
+    | tagDec env (Syntax.DSig (s, decls)) =
+        let
+          val signType = TyStruct
+            (IdentMap.fromList
+              (map
+                (fn (name, ty) => ((Syntax.ITVar, name), etypeToTy env ty))
+                decls))
+          val v = GenSym.new ()
+          val _ = unify (TyVar v) signType
+          val env = bind Let (Syntax.ITSignature, s) v env
+        in (env, NONE) end
+    | tagDec env (Syntax.DFunctor (functorName, arg, sign, body)) =
+        let
+          val (_, signType) = F env (Syntax.EIdent (Syntax.ITSignature, sign))
+          val a = GenSym.new ()
+          val _ = unify (TyVar a) signType
+          val bodyEnv = bind Let (Syntax.ITStruct, arg) a env
+          val (body, bodyType) = F bodyEnv body
+          val f = GenSym.new ()
+          val _ = unify (TyVar f) (TyCon (Functor, [signType, bodyType]))
+          val env = bind Let (Syntax.ITFunctor, functorName) f env
+        in (env, SOME (Syntax.TDFunctor (functorName, arg, tyToSyntaxTy signType, (body, tyToSyntaxTy bodyType)))) end
     | tagDec _ _ = raise Fail "invalid expr"
 
   and tagDecs env [] = (env, [])
@@ -386,32 +423,6 @@ structure Types = struct
         in (env, decs)
         end
 
-  and tagStructExpr (env : env) (Syntax.SIdent s) : Syntax.typedStructExpr * structTy =
-        (case StringMap.lookup s (#structs env) of
-          SOME t => (Syntax.TSIdent s, t)
-        | NONE => raise Fail ("unknown struct type " ^ s))
-    | tagStructExpr env (Syntax.SDot (sExpr, field)) =
-        let
-          val (parent, Struct parentType) = tagStructExpr env sExpr
-          val fieldType =
-            case StringMap.lookup field (#structs parentType) of
-              SOME x => x
-            | NONE => raise Fail ("unknown struct field " ^ field)
-        in (Syntax.TSDot ((parent, structTypeToSyntaxStructType (Struct parentType)), field), fieldType) end
-    | tagStructExpr env (Syntax.SStruct decls) =
-        let val (env, decls) = tagDecs env decls
-        in
-          (Syntax.TSStruct decls, Struct {
-            structs = #structs env,
-            vals =
-              StringMap.fromList
-                (map
-                  (fn (name, Let v) => (name, TyVar v)
-                    | (name, Arg v) => (name, TyVar v))
-                  (StringMap.toList (#bindings env)))
-          })
-        end
-
   fun reexpandType (Syntax.TVar i) : Syntax.ty = tyToSyntaxTy (find (TyVar i))
     | reexpandType ty = ty
 
@@ -428,7 +439,7 @@ structure Types = struct
     let
       val expr =
         case expr of
-          Syntax.TEDot (str, field) => Syntax.TEDot (reexpandStructExpr str, field)
+          Syntax.TEDot (str, field) => Syntax.TEDot (reexpand str, field)
         | Syntax.TETuple exprs => Syntax.TETuple (map reexpand exprs)
         | Syntax.TEList exprs => Syntax.TEList (map reexpand exprs)
         | Syntax.TEApp (f, arg) => Syntax.TEApp (reexpand f, reexpand arg)
@@ -444,25 +455,16 @@ structure Types = struct
     | reexpandDecl (Syntax.TDValRec (pat, expr)) = Syntax.TDValRec (reexpandPat pat, reexpand expr)
     | reexpandDecl (Syntax.TDFun (name, arms)) = Syntax.TDFun (name, map (fn (pats, body) => (map reexpandPat pats, reexpand body)) arms)
     | reexpandDecl (decl as Syntax.TDDatatype _) = decl
-    | reexpandDecl (Syntax.TDStruct (name, str)) = Syntax.TDStruct (name, reexpandStructExpr str)
-
-  and reexpandStructExpr (str : Syntax.typedStructExpr, structType : Syntax.structType) : Syntax.typedStructExpr * Syntax.structType =
-    let
-      val str =
-        case str of
-          Syntax.TSIdent _ => str
-        | Syntax.TSDot (str, field) => Syntax.TSDot (reexpandStructExpr str, field)
-        | Syntax.TSStruct decls => Syntax.TSStruct (map reexpandDecl decls)
-    in (str, structType) end
+    | reexpandDecl (Syntax.TDStruct (name, str)) = Syntax.TDStruct (name, reexpand str)
+    | reexpandDecl (Syntax.TDFunctor (name, arg, argType, body)) = Syntax.TDFunctor (name, arg, reexpandType argType, reexpand body)
 
   fun tag (expr : Syntax.expr) : Syntax.typedExpr * Syntax.ty =
     let
-      val env = {
-        bindings = StringMap.empty,
-        boundVars = TyVarMap.empty,
-        typesByName = StringMap.empty,
-        structs = StringMap.empty
-      }
+      val env =
+        { bindings = IdentMap.empty
+        , boundVars = TyVarMap.empty
+        , typesByName = StringMap.empty
+        }
       val (expr, ty) = F env expr
     in reexpand (expr, tyToSyntaxTy ty) end
 end