Add listsHEADmain

34 files changed, 103 insertions, 17 deletions

diff --git a/Elab.sml b/Elab.sml
index ba436f5..13bc890 100644
--- a/Elab.sml
+++ b/Elab.sml
@@ -59,6 +59,8 @@ struct
   fun patternBindings (expr : Syntax.lexp) (Syntax.TPVar v, _ : Syntax.ty) : (string * Syntax.lexp) list = [(v, expr)]
     | patternBindings expr (Syntax.TPTuple t, _) =
         List.concat (map (fn (i, p) => patternBindings (Syntax.LSelect (i, expr)) p) (enumerate t))
+    | patternBindings _ (Syntax.TPList [], _) = []
+    | patternBindings expr (Syntax.TPList (x :: xs), t) = patternBindings (Syntax.LSelect (0, Syntax.LSelect (1, expr))) x @ patternBindings (Syntax.LSelect (1, Syntax.LSelect (1, expr))) (Syntax.TPList xs, t)
     | patternBindings expr (Syntax.TPCon (_, arg), _) = patternBindings (Syntax.LSelect (1, expr)) arg
     | patternBindings _ _ = []
 
@@ -117,11 +119,15 @@ struct
       val con1 =
         List.find
           (fn (Syntax.TPCon (name, _), Syntax.TDatatype cons) => lookupCon (List.last name) cons = n
+            | (Syntax.TPList [], _) => n = 0
+            | (_, Syntax.TList _) => n = 1
             | _ => false)
           (map hd patterns)
       val newTupleSize =
         case con1 of
           SOME (Syntax.TPCon (_, (Syntax.TPTuple t, _)), _) => length t
+        | SOME (Syntax.TPList [], _) => 0
+        | SOME (_, Syntax.TList _) => 2
         | _ => 0
       val occHead = hd occurrences
       val occRest = tl occurrences
@@ -130,10 +136,17 @@ struct
         then Syntax.LSelect (1, occHead) :: occRest
         else
           List.tabulate (newTupleSize, fn i => Syntax.LSelect (i, Syntax.LSelect (1, occHead))) @ occRest
+      val newTupleSize = if newTupleSize = 0 then 1 else newTupleSize
       fun specializeRow ((Syntax.TPInt i, ty):: rest) =
             if i = n then SOME ((Syntax.TPWild, ty) :: rest) else NONE
-        | specializeRow ((Syntax.TPWild, ty) :: rest) = SOME ((Syntax.TPWild, ty) :: rest)
-        | specializeRow ((Syntax.TPVar _, ty) :: rest) = SOME ((Syntax.TPWild, ty) :: rest)
+        | specializeRow ((Syntax.TPWild, ty) :: rest) = SOME (List.tabulate (newTupleSize, fn _ => (Syntax.TPWild, ty)) @ rest)
+        | specializeRow ((Syntax.TPVar _, ty) :: rest) = SOME (List.tabulate (newTupleSize, fn _ => (Syntax.TPWild, ty)) @ rest)
+        | specializeRow ((Syntax.TPList [], Syntax.TList ty) :: rest) =
+            if n = 0 then SOME ((Syntax.TPWild, ty) :: rest) else NONE
+        | specializeRow ((Syntax.TPList (pat :: pats), ty) :: rest) =
+            if n = 1 then SOME ([pat, (Syntax.TPList pats, ty)] @ rest) else NONE
+        | specializeRow ((Syntax.TPCon (_, (Syntax.TPTuple pats, _)), Syntax.TList _) :: rest) =
+            if n = 1 then SOME (pats @ rest) else NONE
         | specializeRow ((Syntax.TPCon (con, (Syntax.TPTuple [], tupleTy)), conTy) :: rest) =
             specializeRow ((Syntax.TPCon (con, (Syntax.TPTuple [(Syntax.TPWild, Syntax.TTuple [])], tupleTy)), conTy) :: rest)
         | specializeRow ((Syntax.TPCon (con, (Syntax.TPTuple args, _)), Syntax.TDatatype cons) :: rest) =
@@ -172,6 +185,7 @@ struct
           List.find
             (fn (_, (Syntax.TPInt _, _)) => true
               | (_, (Syntax.TPCon _, _)) => true
+              | (_, (Syntax.TPList _, _)) => true
               | _ => false)
             (enumerate firstRow)
         in
@@ -189,13 +203,16 @@ struct
                     (IntMap.toList
                       (foldl
                         (fn ((Syntax.TPInt i, _), acc) => IntMap.insert i true acc
+                          | ((Syntax.TPList [], _), acc) => IntMap.insert 0 true acc
+                          | ((_, Syntax.TList _), acc) => IntMap.insert 1 true acc
                           | ((Syntax.TPCon (c, _), Syntax.TDatatype cons), acc) => IntMap.insert (lookupCon (List.last c) cons) true acc
                           | (_, acc) => acc)
                         IntMap.empty
                         firstCol))
                 val nCons =
-                  case List.find (fn (Syntax.TPCon _, _) => true | _ => false) firstCol of
+                  case List.find (fn (Syntax.TPCon _, _) => true | (Syntax.TPList _, _) => true | _ => false) firstCol of
                     SOME (Syntax.TPCon _, Syntax.TDatatype cons) => length cons
+                  | SOME (_, Syntax.TList _) => 2
                   | _ => ~1
                 val defaultCase =
                   if length signatures = nCons
@@ -273,8 +290,8 @@ struct
     | Syntax.TEList exprs =>
         foldr
           (fn (x, acc) =>
-            Syntax.LRecord [elab env x, acc])
-          (Syntax.LInt 0)
+            Syntax.LRecord [Syntax.LInt 1, Syntax.LRecord [elab env x, acc]])
+          (Syntax.LRecord [Syntax.LInt 0])
           exprs
     | Syntax.TEApp (f, x) => Syntax.LApp (elab env f, elab env x)
     | Syntax.TEAndAlso (_, _) => raise Fail "unimplemented"
@@ -400,5 +417,12 @@ struct
         in Syntax.LApp (func, tuple) end
     | _ => raise Fail ("invalid expression " ^ ShowSyntax.typedExprToString p)
 
-  fun elaborate (p : Syntax.typedExpr * Syntax.ty) : Syntax.lexp = elab emptyEnv p
+  fun elaborate (p : Syntax.typedExpr * Syntax.ty) : Syntax.lexp =
+  let
+    val cons = GenSym.new ()
+    val alpha = GenSym.new ()
+    val env = IdentMap.insert (Syntax.ITVar, "::") cons emptyEnv
+  in
+    Syntax.LApp (Syntax.LFn (cons, elab env p), Syntax.LFn (alpha, Syntax.LRecord [Syntax.LInt 1, Syntax.LVar alpha]))
+  end
 end
diff --git a/Parser.sml b/Parser.sml
index 8f43352..9f31f8d 100644
--- a/Parser.sml
+++ b/Parser.sml
@@ -28,8 +28,18 @@ struct
     , "signature", "struct", "structure", "where", ":>"
     ]
 
-  val emptyInfixOperators : infixTable =
-    Vector.tabulate (10, fn _ => ([], []))
+  val defaultInfixOperators : infixTable = Vector.fromList
+    [ ([], [])
+    , ([], [])
+    , ([], [])
+    , ([], [])
+    , ([], [])
+    , ([], ["::"])
+    , ([], [])
+    , ([], [])
+    , ([], [])
+    , ([], [])
+    ]
 
   fun printSourceLoc ({file, row, column} : sourceLoc) : string =
     file ^ ":" ^ Int.toString row ^ "." ^ Int.toString column
@@ -69,7 +79,7 @@ struct
   fun newState (fileName : string) (fileStream : TextIO.instream) : state = {
     stream = TextIO.getInstream fileStream,
     loc = newLoc fileName,
-    userState = {infixTable = emptyInfixOperators}
+    userState = {infixTable = defaultInfixOperators}
   }
 
   fun updateUserState (f : userState -> userState) : userState parser =
@@ -414,6 +424,10 @@ struct
   val rec atpat : Syntax.pat parser = fn st =>
       (Syntax.PWild <$ reserved "_"
   <|> Syntax.PInt <$> integer
+  <|> (symbol "[" >>
+      bind (sepBy pat (symbol ",")) (fn pats =>
+      symbol "]" >>
+      const (Syntax.PList pats)))
   <|> bind (between (symbol "(") (symbol ")") (sepBy pat (symbol ","))) (fn pats =>
       const
         (case pats of
@@ -476,6 +490,10 @@ struct
            bind expr (fn e =>
            reserved "end" >>
            const (Syntax.ELet (List.mapPartial (fn x => x) decs, e)))))
+      <|> (symbol "[" >>
+          bind (sepBy expr (symbol ",")) (fn exprs =>
+          symbol "]" >>
+          const (Syntax.EList exprs)))
       <|> (symbol "(" >>
            bind (sepBy expr (symbol ",")) (fn exprs =>
            symbol ")" >>
diff --git a/ShowSyntax.sml b/ShowSyntax.sml
index 519fb2b..70f082b 100644
--- a/ShowSyntax.sml
+++ b/ShowSyntax.sml
@@ -44,6 +44,8 @@ and patToStringI (indent : string) (Syntax.PWild : Syntax.pat) : string =
       "PTuple " ^ listToString (patToStringI) indent x
   | patToStringI (indent : string) (Syntax.PCon x : Syntax.pat) : string =
       "PCon " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ "  " in "(\n" ^ indent' ^ listToString (stringToStringI) indent' x0 ^ ",\n" ^ indent' ^ patToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent x
+  | patToStringI (indent : string) (Syntax.PList x : Syntax.pat) : string =
+      "PList " ^ listToString (patToStringI) indent x
 and patToString (x : Syntax.pat) : string = patToStringI "" x
 
 and identTypeToStringI (indent : string) (Syntax.ITVar : Syntax.identType) : string =
@@ -140,6 +142,8 @@ and typedPatToStringI (indent : string) (Syntax.TPWild : Syntax.typedPat) : stri
       "TPTuple " ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ "  " in "(\n" ^ indent' ^ typedPatToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent x
   | typedPatToStringI (indent : string) (Syntax.TPCon x : Syntax.typedPat) : string =
       "TPCon " ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ "  " in "(\n" ^ indent' ^ listToString (stringToStringI) indent' x0 ^ ",\n" ^ indent' ^ (fn indent => fn (x0, x1) => let val indent' = indent ^ "  " in "(\n" ^ indent' ^ typedPatToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end) indent' x1 ^ "\n" ^ indent ^ ")" end) indent x
+  | typedPatToStringI (indent : string) (Syntax.TPList x : Syntax.typedPat) : string =
+      "TPList " ^ listToString ((fn indent => fn (x0, x1) => let val indent' = indent ^ "  " in "(\n" ^ indent' ^ typedPatToStringI indent' x0 ^ ",\n" ^ indent' ^ tyToStringI indent' x1 ^ "\n" ^ indent ^ ")" end)) indent x
 and typedPatToString (x : Syntax.typedPat) : string = typedPatToStringI "" x
 
 and typedExprToStringI (indent : string) (Syntax.TEIdent x : Syntax.typedExpr) : string =
diff --git a/Syntax.sml b/Syntax.sml
index 0eccd36..8145211 100644
--- a/Syntax.sml
+++ b/Syntax.sml
@@ -13,6 +13,7 @@ struct
   | PInt of int
   | PTuple of pat list
   | PCon of string list * pat
+  | PList of pat list
 
   datatype identType =
     ITVar
@@ -77,6 +78,7 @@ struct
   | TPInt of int
   | TPTuple of (typedPat * ty) list
   | TPCon of string list * (typedPat * ty)
+  | TPList of (typedPat * ty) list
 
   datatype typedExpr =
     TEIdent of identType * string
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
diff --git a/tests/01-simple.sml b/tests/010-simple.sml
index e41f9b4..e41f9b4 100644
--- a/tests/01-simple.sml
+++ b/tests/010-simple.sml
diff --git a/tests/02-lambda.sml b/tests/020-lambda.sml
index 41470a2..41470a2 100644
--- a/tests/02-lambda.sml
+++ b/tests/020-lambda.sml
diff --git a/tests/03-arg.sml b/tests/030-arg.sml
index 8d10139..8d10139 100644
--- a/tests/03-arg.sml
+++ b/tests/030-arg.sml
diff --git a/tests/04-val.sml b/tests/040-val.sml
index 20d07b4..20d07b4 100644
--- a/tests/04-val.sml
+++ b/tests/040-val.sml
diff --git a/tests/05-let.sml b/tests/050-let.sml
index d1c27f5..d1c27f5 100644
--- a/tests/05-let.sml
+++ b/tests/050-let.sml
diff --git a/tests/06-let-multiple.sml b/tests/060-let-multiple.sml
index 47441ac..47441ac 100644
--- a/tests/06-let-multiple.sml
+++ b/tests/060-let-multiple.sml
diff --git a/tests/07-add.sml b/tests/070-add.sml
index 9892b23..9892b23 100644
--- a/tests/07-add.sml
+++ b/tests/070-add.sml
diff --git a/tests/08-multiply.sml b/tests/080-multiply.sml
index d75c316..d75c316 100644
--- a/tests/08-multiply.sml
+++ b/tests/080-multiply.sml
diff --git a/tests/09-subtract.sml b/tests/090-subtract.sml
index 2374816..2374816 100644
--- a/tests/09-subtract.sml
+++ b/tests/090-subtract.sml
diff --git a/tests/10-divide.sml b/tests/100-divide.sml
index a701180..a701180 100644
--- a/tests/10-divide.sml
+++ b/tests/100-divide.sml
diff --git a/tests/11-case.sml b/tests/110-case.sml
index 297ae5b..297ae5b 100644
--- a/tests/11-case.sml
+++ b/tests/110-case.sml
diff --git a/tests/12-case-int.sml b/tests/120-case-int.sml
index 98967e4..98967e4 100644
--- a/tests/12-case-int.sml
+++ b/tests/120-case-int.sml
diff --git a/tests/13-fibonacci.sml b/tests/130-fibonacci.sml
index ec89f70..ec89f70 100644
--- a/tests/13-fibonacci.sml
+++ b/tests/130-fibonacci.sml
diff --git a/tests/14-fun.sml b/tests/140-fun.sml
index 210b30d..210b30d 100644
--- a/tests/14-fun.sml
+++ b/tests/140-fun.sml
diff --git a/tests/15-tuple.sml b/tests/150-tuple.sml
index 114fd25..114fd25 100644
--- a/tests/15-tuple.sml
+++ b/tests/150-tuple.sml
diff --git a/tests/155-case-tuple.sml b/tests/155-case-tuple.sml
new file mode 100644
index 0000000..774fb34
--- /dev/null
+++ b/tests/155-case-tuple.sml
@@ -0,0 +1,4 @@
+val _ = __builtin "exit"
+  (case (1, 2, 42) of
+    (_, 2, x) => x
+  | _ => 13)
diff --git a/tests/16-datatype.sml b/tests/160-datatype.sml
index 7514606..7514606 100644
--- a/tests/16-datatype.sml
+++ b/tests/160-datatype.sml
diff --git a/tests/17-case-datatype.sml b/tests/170-case-datatype.sml
index 974f263..974f263 100644
--- a/tests/17-case-datatype.sml
+++ b/tests/170-case-datatype.sml
diff --git a/tests/175-case-datatype-default.sml b/tests/175-case-datatype-default.sml
new file mode 100644
index 0000000..221bc13
--- /dev/null
+++ b/tests/175-case-datatype-default.sml
@@ -0,0 +1,6 @@
+datatype D = A of int * int | B
+
+val _ = __builtin "exit"
+  (case A (42, 13) of
+    A (x, 13) => x
+  | _ => 10)
diff --git a/tests/18-fun-case.sml b/tests/180-fun-case.sml
index d64b7d7..d64b7d7 100644
--- a/tests/18-fun-case.sml
+++ b/tests/180-fun-case.sml
diff --git a/tests/19-list.sml b/tests/190-list.sml
index 52404dc..de69c4a 100644
--- a/tests/19-list.sml
+++ b/tests/190-list.sml
@@ -1,5 +1,4 @@
 infix 6 +
-infixr 5 ::
 
 datatype 'a list = Nil | :: of 'a * 'a list
 
diff --git a/tests/20-structure.sml b/tests/200-structure.sml
index dfc7b9b..dfc7b9b 100644
--- a/tests/20-structure.sml
+++ b/tests/200-structure.sml
diff --git a/tests/21-struct-datatype.sml b/tests/210-struct-datatype.sml
index ab714ea..ab714ea 100644
--- a/tests/21-struct-datatype.sml
+++ b/tests/210-struct-datatype.sml
diff --git a/tests/22-nested-struct.sml b/tests/220-nested-struct.sml
index 1eaf6ab..1eaf6ab 100644
--- a/tests/22-nested-struct.sml
+++ b/tests/220-nested-struct.sml
diff --git a/tests/225-two-structs.sml b/tests/225-two-structs.sml
new file mode 100644
index 0000000..465840f
--- /dev/null
+++ b/tests/225-two-structs.sml
@@ -0,0 +1,9 @@
+structure A = struct
+  val fourtyTwo = 42
+end
+val B = 10
+structure X = struct
+  val Y = A.fourtyTwo
+end
+
+val _ = __builtin "exit" X.Y
diff --git a/tests/23-signature.sml b/tests/230-signature.sml
index 01a8494..01a8494 100644
--- a/tests/23-signature.sml
+++ b/tests/230-signature.sml
diff --git a/tests/24-functor.sml b/tests/240-functor.sml
index d18337e..d18337e 100644
--- a/tests/24-functor.sml
+++ b/tests/240-functor.sml
diff --git a/tests/250-list.sml b/tests/250-list.sml
new file mode 100644
index 0000000..4aeecf2
--- /dev/null
+++ b/tests/250-list.sml
@@ -0,0 +1,6 @@
+val _ = __builtin "exit"
+  (case [1, 2, 42] of
+    [] => 10
+  | [x] => x
+  | [_, _, x] => x
+  | _ => 13)
diff --git a/tests/260-cons.sml b/tests/260-cons.sml
new file mode 100644
index 0000000..f01cefe
--- /dev/null
+++ b/tests/260-cons.sml
@@ -0,0 +1,4 @@
+val _ = __builtin "exit"
+  (case 42 :: [] of
+    x :: _ => x
+  | _ => 13)