Add structures.

5 files changed, 109 insertions, 25 deletions

diff --git a/elab.sml b/elab.sml
index a99758a..33f1a10 100644
--- a/elab.sml
+++ b/elab.sml
@@ -35,34 +35,47 @@ struct
         NONE => []
       | SOME (heads, tails) => heads :: transpose tails
 
-  type env = int StringMap.map * (int * int) StringMap.map
+  datatype env = Env of { vars: int StringMap.map, types: (int * int) StringMap.map, structTypes: env StringMap.map }
 
-  fun bindVar (name : string) (sym : int) ((vars, types) : env) : env = (StringMap.insert name sym vars, types)
+  val emptyEnv = Env { vars = StringMap.empty, types = StringMap.empty, structTypes = StringMap.empty }
 
-  fun lookupVar (name : string) ((vars, _) : env) : int =
-    case StringMap.lookup name vars of
+  fun bindVar (name : string) (sym : int) (Env env) : env = Env { vars = StringMap.insert name sym (#vars env), types = #types env, structTypes = #structTypes env }
+
+  fun lookupVar (name : string) (Env env) : int =
+    case StringMap.lookup name (#vars env) of
       SOME x => x
     | NONE => raise Fail ("unbound identifier " ^ name)
 
-  fun bindDataCons (cons : (string * Syntax.etype option) list) ((vars, types) : env) : env =
+  fun bindDataCons (cons : (string * Syntax.etype option) list) (Env env) : env =
   let
     val nCons = length cons
     val (_, vars, types) =
       foldl
         (fn ((name, _), (i, vars, types)) =>
           (i + 1, StringMap.insert name (Gensym.new ()) vars, StringMap.insert name (i, nCons) types))
-        (0, vars, types)
+        (0, #vars env, #types env)
         cons
-  in (vars, types)
+  in Env { vars = vars, types = types, structTypes = #structTypes env }
   end
 
-  fun lookupCon (name : string) ((_, types) : env) : int option =
-    Option.map (fn (i, _) => i) (StringMap.lookup name types)
+  fun lookupStructType (name : string) (Env env) : env =
+    case StringMap.lookup name (#structTypes env) of
+      SOME x => x
+    | NONE => raise Fail ("unbound structure " ^ name)
+
+  fun lookupCon ([name] : string list) (Env env) : int option =
+        Option.map (fn (i, _) => i) (StringMap.lookup name (#types env))
+    | lookupCon (structName :: names) env =
+        lookupCon names (lookupStructType structName env)
+    | lookupCon [] _ = raise Fail "lookupCon empty"
 
-  fun nConstructors (name : string) ((_, types) : env) : int =
-    let val (_, n) = valOf (StringMap.lookup name types)
-    in n
-    end
+  fun nConstructors ([name] : string list) (Env env) : int =
+        let val (_, n) = valOf (StringMap.lookup name (#types env))
+        in n
+        end
+    | nConstructors (structName :: names) env =
+        nConstructors names (lookupStructType structName env)
+    | nConstructors [] _ = raise Fail "nConstructors empty"
 
   fun patternMatrix (arms : Syntax.pat list) : Syntax.pat list list =
   let val ts =
@@ -179,8 +192,8 @@ struct
     case expr of
       Syntax.PTuple t => Syntax.PTuple (map (fixConstructors env) t)
     | Syntax.PVar v =>
-        if isSome (lookupCon v env)
-        then Syntax.PCon (v, Syntax.PTuple [])
+        if isSome (lookupCon [v] env)
+        then Syntax.PCon ([v], Syntax.PTuple [])
         else Syntax.PVar v
     | Syntax.PCon (s, p) => Syntax.PCon (s, fixConstructors env p)
     | _ => expr
@@ -236,6 +249,32 @@ struct
               end
         end
 
+  fun declBoundVars (Syntax.DVal (p, _)) : string list = map (fn (x, _) => x) (patternBindings (Syntax.LInt 0) p)
+    | declBoundVars (Syntax.DValRec (p, _)) = map (fn (x, _) => x) (patternBindings (Syntax.LInt 0) p)
+    | declBoundVars (Syntax.DFun (name, _)) = [name]
+    | declBoundVars (Syntax.DDatatype (_, cons)) = map (fn (x, _) => x) cons
+    | declBoundVars (Syntax.DStruct (name, _)) = [name]
+
+  fun structBoundVars (decls : Syntax.dec list) : string list = List.concatMap declBoundVars decls
+
+  fun bindStructType (name : string) (decls : Syntax.dec list) (Env env) : env =
+    let
+      val structEnv =
+        foldl
+          (fn (Syntax.DDatatype (_, cons), env) => bindDataCons cons env
+            | (Syntax.DStruct (name, decls), env) => bindStructType name decls env
+            | (_, env) => env)
+          emptyEnv
+          decls
+      val structEnv =
+        foldl
+          (fn ((i, n), env) => bindVar n i env)
+          structEnv
+          (enumerate (structBoundVars decls))
+    in
+      Env { vars = #vars env, types = #types env, structTypes = StringMap.insert name structEnv (#structTypes env) }
+    end
+
   fun actionVector (env : env) (expr : Syntax.lexp) (arms : (Syntax.pat * Syntax.expr) list) : Syntax.lexp list =
     map
       (fn (p, body) =>
@@ -280,7 +319,18 @@ struct
   and elab (env : env) (p : Syntax.expr) : Syntax.lexp =
     case p of
       Syntax.EIdent [i] => Syntax.LVar (lookupVar i env)
-    | Syntax.EIdent _ => raise Fail "long identifiers are not supported"
+    | Syntax.EIdent (structName :: accessors) =>
+        let
+          val s = Syntax.LVar (lookupVar structName env)
+          val env = lookupStructType structName env
+          fun go env [i] acc = Syntax.LSelect (lookupVar i env, acc)
+            | go env (accessor :: accessors) acc =
+                let val env = lookupStructType accessor env
+                in go env accessors (Syntax.LSelect (lookupVar accessor env, acc))
+                end
+            | go _ [] _ = raise Fail "go empty"
+        in go env accessors s
+        end
     | Syntax.EBuiltin builtin => Syntax.LPrim (primop builtin)
     | Syntax.EInt i => Syntax.LInt i
     | Syntax.EStr s => Syntax.LString s
@@ -359,6 +409,15 @@ struct
             )
         end
         end
+    | Syntax.ELet (Syntax.DStruct (name, structDecls) :: decls, body) =>
+        let
+          val names = structBoundVars structDecls
+          val tuple = elab env (Syntax.ELet (structDecls, Syntax.ETuple (map (fn n => Syntax.EIdent [n]) names)))
+          val v = Gensym.new ()
+          val env = bindStructType name structDecls env
+          val env = bindVar name v env
+        in Syntax.LApp (Syntax.LFn (v, elab env (Syntax.ELet (decls, body))), tuple)
+        end
     | Syntax.ELambda body =>
         let val v = Gensym.new ()
         in Syntax.LFn (v, elabCase env (Syntax.LVar v) [body])
@@ -368,5 +427,5 @@ struct
         in Syntax.LApp (Syntax.LFn (v, elabCase env (Syntax.LVar v) arms), elab env expr)
         end
 
-  fun elaborate (p : Syntax.expr) : Syntax.lexp = elab (StringMap.empty, StringMap.empty) p
+  fun elaborate (p : Syntax.expr) : Syntax.lexp = elab emptyEnv p
 end
diff --git a/parser.sml b/parser.sml
index 6e82e19..ea68412 100644
--- a/parser.sml
+++ b/parser.sml
@@ -390,12 +390,14 @@ struct
         (case pats of
           [p] => p
         | _ => Syntax.PTuple pats))
-  <|> Syntax.PVar <$> identifier) st
+  <|> bind longIdentifier (fn [i] => const (Syntax.PVar i) | is => const (Syntax.PCon (is, Syntax.PTuple [])))) st
   and appPat : Syntax.pat parser = fn st =>
-      (bind identifier (fn ident =>
+      (bind longIdentifier (fn ident =>
           bind atpat (fn arg =>
           const (Syntax.PCon (ident, arg)))
-      <|> const (Syntax.PVar ident))
+      <|> const (case ident of
+                  [i] => Syntax.PVar i
+                | _ => Syntax.PCon (ident, Syntax.PTuple [])))
   <|> atpat) st
   and pat : Syntax.pat parser = fn st =>
     foldl
@@ -404,14 +406,14 @@ struct
           fun patLeft pat1 =
             bind (leftOp i) (fn opEx =>
             bind patLower (fn pat2 =>
-            let val app = Syntax.PCon (opEx, Syntax.PTuple [pat1, pat2])
+            let val app = Syntax.PCon ([opEx], Syntax.PTuple [pat1, pat2])
             in patLeft app <|> const app
             end))
           fun patRight pat1 =
             bind (rightOp i) (fn opEx =>
             bind patLower (fn pat2 =>
             bind (patRight pat2 <|> const pat2) (fn rest =>
-            const (Syntax.PCon (opEx, Syntax.PTuple [pat1, rest])))))
+            const (Syntax.PCon ([opEx], Syntax.PTuple [pat1, rest])))))
         in
           bind patLower (fn pat1 =>
           patLeft pat1 <|> patRight pat1 <|> const pat1)
@@ -565,8 +567,18 @@ struct
         else const (SOME (Syntax.DFun (name, map (fn (_, x, y) => (x, y)) cases)))
       end))) st
 
+  val rec strdec : Syntax.dec option parser = fn st =>
+      ((reserved "structure" >>
+      bind identifier (fn strID =>
+      reserved "=" >>
+      reserved "struct" >>
+      bind (many strdec) (fn bindings =>
+      reserved "end" >>
+      const (SOME (Syntax.DStruct (strID, List.mapPartial (fn x => x) bindings))))))
+  <|> dec) st
+
   val program : Syntax.expr parser =
-    bind (many dec) (fn decs =>
+    bind (many strdec) (fn decs =>
     const (Syntax.ELet (List.mapPartial (fn x => x) decs, Syntax.EInt 0)))
   fun parse (f : string) : (string, Syntax.expr) Result.either = runParser program f
 end
diff --git a/syntax.sml b/syntax.sml
index e05beee..2f7a96e 100644
--- a/syntax.sml
+++ b/syntax.sml
@@ -12,7 +12,7 @@ struct
   | PVar of string
   | PInt of int
   | PTuple of pat list
-  | PCon of string * pat
+  | PCon of string list * pat
 
   datatype expr =
     EIdent of string list
@@ -34,6 +34,7 @@ struct
   | DValRec of pat * expr
   | DFun of string * (pat list * expr) list
   | DDatatype of string * (string * etype option) list
+  | DStruct of string * dec list
 
   (* Lambda language *)
   type var = int
@@ -127,7 +128,7 @@ struct
     | PVar v => "PVar " ^ quote v
     | PInt i => "PInt " ^ Int.toString i
     | PTuple pats => "PTuple " ^ listToString patToString pats
-    | PCon (con, v) => "PCon " ^ "(" ^ quote con ^ ", " ^ patToString v ^ ")"
+    | PCon (con, v) => "PCon " ^ "(" ^ listToString quote con ^ ", " ^ patToString v ^ ")"
 
   fun exprToStringI (indent : string) (x : expr) : string =
     let val self = exprToStringI indent
@@ -153,6 +154,7 @@ struct
     | DValRec (p, e) => "DValRec (" ^ patToString p ^ ", " ^ exprToStringI indent e ^ ")"
     | DFun (name, cases) => "DFun (" ^ quote name ^ ", " ^ multilineListToString (fn indent => fn (ps, b) => "(" ^ listToString patToString ps ^ ", " ^ exprToStringI indent b ^ ")") indent cases ^ ")"
     | DDatatype (name, arms) => "DDatatype (" ^ quote name ^ ", " ^ listToString (fn (con, v) => "(" ^ quote con ^ ", " ^ optionToString etypeToString v ^ ")") arms ^ ")"
+    | DStruct (name, decls) => "DStruct (" ^ quote name ^ ",\n" ^ indent ^ "\t" ^ multilineListToString decToStringI (indent ^ "\t") decls ^ ")"
 
   val exprToString : expr -> string = exprToStringI ""
 
diff --git a/tests/20-structure.sml b/tests/20-structure.sml
new file mode 100644
index 0000000..dfc7b9b
--- /dev/null
+++ b/tests/20-structure.sml
@@ -0,0 +1,5 @@
+structure S = struct
+  val fourtyTwo = 42
+end
+
+val _ = __builtin "exit" S.fourtyTwo
diff --git a/tests/21-struct-datatype.sml b/tests/21-struct-datatype.sml
new file mode 100644
index 0000000..ab714ea
--- /dev/null
+++ b/tests/21-struct-datatype.sml
@@ -0,0 +1,6 @@
+structure S = struct
+  datatype D = D of int
+end
+
+val S.D x = S.D 42
+val _ = __builtin "exit" x