# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1216926123 14400
# Node ID 34ccd7d2bea869d695f805adf834d1c7d93ea121
# Parent  4334bb734187e70c1b42049331fe219f3bfc2840
Start of datatype support

diff -r 4334bb734187 -r 34ccd7d2bea8 src/elab.sml
--- a/src/elab.sml	Thu Jul 24 11:32:01 2008 -0400
+++ b/src/elab.sml	Thu Jul 24 15:02:03 2008 -0400
@@ -93,6 +93,8 @@
 datatype sgn_item' =
          SgiConAbs of string * int * kind
        | SgiCon of string * int * kind * con
+       | SgiDatatype of string * int * (string * int * con option) list
+       | SgiDatatypeImp of string * int * int * string list * string
        | SgiVal of string * int * con
        | SgiStr of string * int * sgn
        | SgiSgn of string * int * sgn
@@ -111,6 +113,8 @@
 
 datatype decl' =
          DCon of string * int * kind * con
+       | DDatatype of string * int * (string * int * con option) list
+       | DDatatypeImp of string * int * int * string list * string
        | DVal of string * int * con * exp
        | DValRec of (string * int * con * exp) list
        | DSgn of string * int * sgn
diff -r 4334bb734187 -r 34ccd7d2bea8 src/elab_env.sml
--- a/src/elab_env.sml	Thu Jul 24 11:32:01 2008 -0400
+++ b/src/elab_env.sml	Thu Jul 24 15:02:03 2008 -0400
@@ -292,9 +292,18 @@
 
 fun lookupStr (env : env) x = SM.find (#renameStr env, x)
 
-fun declBinds env (d, _) =
+fun declBinds env (d, loc) =
     case d of
         DCon (x, n, k, c) => pushCNamedAs env x n k (SOME c)
+      | DDatatype (x, n, xncs) =>
+        let
+            val env = pushCNamedAs env x n (KType, loc) NONE
+        in
+            foldl (fn ((x', n', NONE), env) => pushENamedAs env x' n' (CNamed n, loc)
+                    | ((x', n', SOME t), env) => pushENamedAs env x' n' (TFun (t, (CNamed n, loc)), loc))
+            env xncs
+        end
+      | DDatatypeImp (x, n, m, ms, x') => pushCNamedAs env x n (KType, loc) (SOME (CModProj (m, ms, x'), loc))
       | DVal (x, n, t, _) => pushENamedAs env x n t
       | DValRec vis => foldl (fn ((x, n, t, _), env) => pushENamedAs env x n t) env vis
       | DSgn (x, n, sgn) => pushSgnNamedAs env x n sgn
@@ -303,10 +312,19 @@
       | DConstraint _ => env
       | DExport _ => env
 
-fun sgiBinds env (sgi, _) =
+fun sgiBinds env (sgi, loc) =
     case sgi of
         SgiConAbs (x, n, k) => pushCNamedAs env x n k NONE
       | SgiCon (x, n, k, c) => pushCNamedAs env x n k (SOME c)
+      | SgiDatatype (x, n, xncs) =>
+        let
+            val env = pushCNamedAs env x n (KType, loc) NONE
+        in
+            foldl (fn ((x', n', NONE), env) => pushENamedAs env x' n' (CNamed n, loc)
+                    | ((x', n', SOME t), env) => pushENamedAs env x' n' (TFun (t, (CNamed n, loc)), loc))
+            env xncs
+        end
+      | SgiDatatypeImp (x, n, m1, ms, x') => pushCNamedAs env x n (KType, loc) (SOME (CModProj (m1, ms, x'), loc))
       | SgiVal (x, n, t) => pushENamedAs env x n t
       | SgiStr (x, n, sgn) => pushStrNamedAs env x n sgn
       | SgiSgn (x, n, sgn) => pushSgnNamedAs env x n sgn
@@ -324,6 +342,8 @@
                     case sgi of
                         SgiConAbs (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x))
                       | SgiCon (x, n, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x))
+                      | SgiDatatype (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x))
+                      | SgiDatatypeImp (x, n, _, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x))
                       | SgiVal _ => seek (sgis, sgns, strs, cons)
                       | SgiSgn (x, n, _) => seek (sgis, IM.insert (sgns, n, x), strs, cons)
                       | SgiStr (x, n, _) => seek (sgis, sgns, IM.insert (strs, n, x), cons)
@@ -489,6 +509,8 @@
                     end
                   | SgiConAbs (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc)
                   | SgiCon (x, n, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc)
+                  | SgiDatatype (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc)
+                  | SgiDatatypeImp (x, n, _, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc)
                   | SgiVal _ => seek (sgis, sgns, strs, cons, acc)
                   | SgiSgn (x, n, _) => seek (sgis, IM.insert (sgns, n, x), strs, cons, acc)
                   | SgiStr (x, n, _) => seek (sgis, sgns, IM.insert (strs, n, x), cons, acc)
diff -r 4334bb734187 -r 34ccd7d2bea8 src/elab_print.sml
--- a/src/elab_print.sml	Thu Jul 24 11:32:01 2008 -0400
+++ b/src/elab_print.sml	Thu Jul 24 15:02:03 2008 -0400
@@ -309,6 +309,22 @@
     else
         string x
 
+fun p_datatype env (x, n, cons) =
+    let
+        val env = E.pushCNamedAs env x n (KType, ErrorMsg.dummySpan) NONE
+    in
+        box [string "datatype",
+             space,
+             string x,
+             space,
+             string "=",
+             space,
+             p_list_sep (box [space, string "|", space])
+                        (fn (x, _, NONE) => string x
+                          | (x, _, SOME t) => box [string x, space, string "of", space, p_con env t])
+                        cons]
+    end
+
 fun p_sgn_item env (sgi, _) =
     case sgi of
         SgiConAbs (x, n, k) => box [string "con",
@@ -329,6 +345,22 @@
                                     string "=",
                                     space,
                                     p_con env c]
+      | SgiDatatype x => p_datatype env x
+      | SgiDatatypeImp (x, _, m1, ms, x') =>
+        let
+            val m1x = #1 (E.lookupStrNamed env m1)
+                handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
+        in
+            box [string "datatype",
+                 space,
+                 string x,
+                 space,
+                 string "=",
+                 space,
+                 string "datatype",
+                 space,
+                 p_list_sep (string ".") string (m1x :: ms @ [x'])]
+        end
       | SgiVal (x, n, c) => box [string "val",
                                  space,
                                  p_named x n,
@@ -435,6 +467,22 @@
                                   string "=",
                                   space,
                                   p_con env c]
+      | DDatatype x => p_datatype env x
+      | DDatatypeImp (x, _, m1, ms, x') =>
+        let
+            val m1x = #1 (E.lookupStrNamed env m1)
+                handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1
+        in
+            box [string "datatype",
+                 space,
+                 string x,
+                 space,
+                 string "=",
+                 space,
+                 string "datatype",
+                 space,
+                 p_list_sep (string ".") string (m1x :: ms @ [x'])]
+        end
       | DVal vi => box [string "val",
                         space,
                         p_vali env vi]
diff -r 4334bb734187 -r 34ccd7d2bea8 src/elab_util.sml
--- a/src/elab_util.sml	Thu Jul 24 11:32:01 2008 -0400
+++ b/src/elab_util.sml	Thu Jul 24 15:02:03 2008 -0400
@@ -365,7 +365,7 @@
         fun sgi ctx si acc =
             S.bindP (sgi' ctx si acc, sgn_item ctx)
 
-        and sgi' ctx (si, loc) =
+        and sgi' ctx (siAll as (si, loc)) =
             case si of
                 SgiConAbs (x, n, k) =>
                 S.map2 (kind k,
@@ -377,6 +377,16 @@
                         S.map2 (con ctx c,
                              fn c' =>
                                 (SgiCon (x, n, k', c'), loc)))
+              | SgiDatatype (x, n, xncs) =>
+                S.map2 (ListUtil.mapfold (fn (x, n, c) =>
+                                             case c of
+                                                 NONE => S.return2 (x, n, c)
+                                               | SOME c =>
+                                                 S.map2 (con ctx c,
+                                                      fn c' => (x, n, SOME c'))) xncs,
+                        fn xncs' =>
+                           (SgiDatatype (x, n, xncs'), loc))
+              | SgiDatatypeImp _ => S.return2 siAll
               | SgiVal (x, n, c) =>
                 S.map2 (con ctx c,
                      fn c' =>
@@ -408,6 +418,10 @@
                                                    bind (ctx, NamedC (x, k))
                                                  | SgiCon (x, _, k, _) =>
                                                    bind (ctx, NamedC (x, k))
+                                                 | SgiDatatype (x, n, xncs) =>
+                                                   bind (ctx, NamedC (x, (KType, loc)))
+                                                 | SgiDatatypeImp (x, _, _, _, _) =>
+                                                   bind (ctx, NamedC (x, (KType, loc)))
                                                  | SgiVal _ => ctx
                                                  | SgiStr (x, _, sgn) =>
                                                    bind (ctx, Str (x, sgn))
@@ -512,6 +526,23 @@
                                               (case #1 d of
                                                    DCon (x, _, k, _) =>
                                                    bind (ctx, NamedC (x, k))
+                                                 | DDatatype (x, n, xncs) =>
+                                                   let
+                                                       val ctx = bind (ctx, NamedC (x, (KType, loc)))
+                                                   in
+                                                       foldl (fn ((x, _, co), ctx) =>
+                                                                 let
+                                                                     val t =
+                                                                         case co of
+                                                                             NONE => CNamed n
+                                                                           | SOME t => TFun (t, (CNamed n, loc))
+                                                                 in
+                                                                     bind (ctx, NamedE (x, (t, loc)))
+                                                                 end)
+                                                       ctx xncs
+                                                   end
+                                                 | DDatatypeImp (x, n, m, ms, x') =>
+                                                   bind (ctx, NamedC (x, (KType, loc)))
                                                  | DVal (x, _, c, _) =>
                                                    bind (ctx, NamedE (x, c))
                                                  | DValRec vis =>
@@ -558,6 +589,16 @@
                             S.map2 (mfc ctx c,
                                     fn c' =>
                                        (DCon (x, n, k', c'), loc)))
+              | DDatatype (x, n, xncs) =>
+                S.map2 (ListUtil.mapfold (fn (x, n, c) =>
+                                             case c of
+                                                 NONE => S.return2 (x, n, c)
+                                               | SOME c =>
+                                                 S.map2 (mfc ctx c,
+                                                      fn c' => (x, n, SOME c'))) xncs,
+                        fn xncs' =>
+                           (DDatatype (x, n, xncs'), loc))
+              | DDatatypeImp _ => S.return2 dAll
               | DVal vi =>
                 S.map2 (mfvi ctx vi,
                      fn vi' =>
diff -r 4334bb734187 -r 34ccd7d2bea8 src/elaborate.sml
--- a/src/elaborate.sml	Thu Jul 24 11:32:01 2008 -0400
+++ b/src/elaborate.sml	Thu Jul 24 15:02:03 2008 -0400
@@ -1158,6 +1158,7 @@
        | UnmatchedSgi of L'.sgn_item
        | SgiWrongKind of L'.sgn_item * L'.kind * L'.sgn_item * L'.kind * kunify_error
        | SgiWrongCon of L'.sgn_item * L'.con * L'.sgn_item * L'.con * cunify_error
+       | SgiMismatchedDatatypes of L'.sgn_item * L'.sgn_item * (L'.con * L'.con * cunify_error) option
        | SgnWrongForm of L'.sgn * L'.sgn
        | UnWhereable of L'.sgn * string
        | WhereWrongKind of L'.kind * L'.kind * kunify_error
@@ -1189,6 +1190,15 @@
                      ("Con 1", p_con env c1),
                      ("Con 2", p_con env c2)];
          cunifyError env cerr)
+      | SgiMismatchedDatatypes (sgi1, sgi2, cerro) =>
+        (ErrorMsg.errorAt (#2 sgi1) "Mismatched 'datatype' specifications:";
+         eprefaces' [("Have", p_sgn_item env sgi1),
+                     ("Need", p_sgn_item env sgi2)];
+         Option.app (fn (c1, c2, ue) =>
+                        (eprefaces "Unification error"
+                                   [("Con 1", p_con env c1),
+                                    ("Con 2", p_con env c2)];
+                         cunifyError env ue)) cerro)
       | SgnWrongForm (sgn1, sgn2) =>
         (ErrorMsg.errorAt (#2 sgn1) "Incompatible signatures:";
          eprefaces' [("Sig 1", p_sgn env sgn1),
@@ -1223,6 +1233,7 @@
        | FunctorRebind of ErrorMsg.span
        | UnOpenable of L'.sgn
        | NotType of L'.kind * (L'.kind * L'.kind * kunify_error)
+       | DuplicateConstructor of string * ErrorMsg.span
 
 fun strError env err =
     case err of
@@ -1242,6 +1253,8 @@
                      ("Subkind 1", p_kind k1),
                      ("Subkind 2", p_kind k2)];
          kunifyError ue)
+      | DuplicateConstructor (x, loc) =>
+        ErrorMsg.errorAt loc ("Duplicate datatype constructor " ^ x)
 
 val hnormSgn = E.hnormSgn
 
@@ -1270,6 +1283,10 @@
             ([(L'.SgiCon (x, n, k', c'), loc)], (env', denv, gs' @ gs))
         end
 
+      | L.SgiDatatype _ => raise Fail "Elaborate SgiDatatype"
+
+      | L.SgiDatatypeImp _ => raise Fail "Elaborate SgiDatatypeImp"
+
       | L.SgiVal (x, c) =>
         let
             val (c', ck, gs') = elabCon (env, denv) c
@@ -1342,6 +1359,28 @@
                                    else
                                        ();
                                    (SS.add (cons, x), vals, sgns, strs))
+                                | L'.SgiDatatype (x, _, xncs) =>
+                                  let
+                                      val vals = foldl (fn ((x, _, _), vals) =>
+                                                           (if SS.member (vals, x) then
+                                                                sgnError env (DuplicateVal (loc, x))
+                                                            else
+                                                                ();
+                                                            SS.add (vals, x)))
+                                                       vals xncs
+                                  in
+                                      if SS.member (cons, x) then
+                                          sgnError env (DuplicateCon (loc, x))
+                                      else
+                                          ();
+                                      (SS.add (cons, x), vals, sgns, strs)
+                                  end
+                                | L'.SgiDatatypeImp (x, _, _, _, _) =>
+                                  (if SS.member (cons, x) then
+                                       sgnError env (DuplicateCon (loc, x))
+                                   else
+                                       ();
+                                   (SS.add (cons, x), vals, sgns, strs))
                                 | L'.SgiVal (x, _, _) =>
                                   (if SS.member (vals, x) then
                                        sgnError env (DuplicateVal (loc, x))
@@ -1476,6 +1515,22 @@
                                     | L'.SgiCon (x, n, k, c) =>
                                       ((L'.DCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc),
                                        (E.pushCNamedAs env' x n k (SOME c), denv'))
+                                    | L'.SgiDatatype (x, n, xncs) =>
+                                      let
+                                          val k = (L'.KType, loc)
+                                          val c = (L'.CModProj (str, strs, x), loc)
+                                      in
+                                          ((L'.DDatatypeImp (x, n, str, strs, x), loc),
+                                           (E.pushCNamedAs env' x n k (SOME c), denv'))
+                                      end
+                                    | L'.SgiDatatypeImp (x, n, m1, ms, x') =>
+                                      let
+                                          val k = (L'.KType, loc)
+                                          val c = (L'.CModProj (m1, ms, x'), loc)
+                                      in
+                                          ((L'.DCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc),
+                                           (E.pushCNamedAs env' x n k (SOME c), denv'))
+                                      end
                                     | L'.SgiVal (x, n, t) =>
                                       ((L'.DVal (x, n, t, (L'.EModProj (str, strs, x), loc)), loc),
                                        (E.pushENamedAs env' x n t, denv'))
@@ -1487,7 +1542,7 @@
                                        (E.pushSgnNamedAs env' x n sgn, denv'))
                                     | L'.SgiConstraint (c1, c2) =>
                                       ((L'.DConstraint (c1, c2), loc),
-                                       (env', denv (* D.assert env denv (c1, c2) *) )))
+                                       (env', denv)))
                               (env, denv) sgis
           | _ => (strError env (UnOpenable sgn);
                   ([], (env, denv)))
@@ -1528,6 +1583,8 @@
 fun sgiOfDecl (d, loc) =
     case d of
         L'.DCon (x, n, k, c) => [(L'.SgiCon (x, n, k, c), loc)]
+      | L'.DDatatype x => [(L'.SgiDatatype x, loc)]
+      | L'.DDatatypeImp x => [(L'.SgiDatatypeImp x, loc)]
       | L'.DVal (x, n, t, _) => [(L'.SgiVal (x, n, t), loc)]
       | L'.DValRec vis => map (fn (x, n, t, _) => (L'.SgiVal (x, n, t), loc)) vis
       | L'.DSgn (x, n, sgn) => [(L'.SgiSgn (x, n, sgn), loc)]
@@ -1551,7 +1608,7 @@
 
       | (L'.SgnConst sgis1, L'.SgnConst sgis2) =>
         let
-            fun folder (sgi2All as (sgi, _), (env, denv)) =
+            fun folder (sgi2All as (sgi, loc), (env, denv)) =
                 let
                     fun seek p =
                         let
@@ -1613,6 +1670,49 @@
                                          NONE
                                    | _ => NONE)
 
+                      | L'.SgiDatatype (x, n2, xncs2) =>
+                        seek (fn sgi1All as (sgi1, _) =>
+                                 case sgi1 of
+                                     L'.SgiDatatype (x', n1, xncs1) =>
+                                     let
+                                         fun mismatched ue =
+                                             (sgnError env (SgiMismatchedDatatypes (sgi1All, sgi2All, ue));
+                                              SOME (env, denv))
+
+                                         fun good () =
+                                             let
+                                                 val env = E.sgiBinds env sgi2All
+                                                 val env = if n1 = n2 then
+                                                               env
+                                                           else
+                                                               E.pushCNamedAs env x n1 (L'.KType, loc)
+                                                                              (SOME (L'.CNamed n1, loc))
+                                             in
+                                                 SOME (env, denv)
+                                             end
+
+                                         fun xncBad ((x1, _, t1), (x2, _, t2)) =
+                                             String.compare (x1, x2) <> EQUAL
+                                             orelse case (t1, t2) of
+                                                        (NONE, NONE) => false
+                                                      | (SOME t1, SOME t2) =>
+                                                        not (List.null (unifyCons (env, denv) t1 t2))
+                                                      | _ => true
+                                     in
+                                         (if x = x' then
+                                             if length xncs1 <> length xncs2
+                                                orelse ListPair.exists xncBad (xncs1, xncs2) then
+                                                 mismatched NONE
+                                             else
+                                                 good ()
+                                          else
+                                              NONE)
+                                         handle CUnify ue => mismatched (SOME ue)
+                                     end
+                                   | _ => NONE)
+
+                      | L'.SgiDatatypeImp _ => raise Fail "SgiDatatypeImp in subsgn"
+
                       | L'.SgiVal (x, n2, c2) =>
                         seek (fn sgi1All as (sgi1, _) =>
                                  case sgi1 of
@@ -1722,6 +1822,40 @@
 
             ([(L'.DCon (x, n, k', c'), loc)], (env', denv, gs' @ gs))
         end
+      | L.DDatatype (x, xcs) =>
+        let
+            val k = (L'.KType, loc)
+            val (env, n) = E.pushCNamed env x k NONE
+            val t = (L'.CNamed n, loc)
+
+            val (xcs, (used, env, gs)) =
+                ListUtil.foldlMap
+                (fn ((x, to), (used, env, gs)) =>
+                    let
+                        val (to, t, gs') = case to of
+                                           NONE => (NONE, t, gs)
+                                         | SOME t' =>
+                                           let
+                                               val (t', tk, gs') = elabCon (env, denv) t'
+                                           in
+                                               checkKind env t' tk k;
+                                               (SOME t', (L'.TFun (t', t), loc), gs' @ gs)
+                                           end
+
+                        val (env, n') = E.pushENamed env x t
+                    in
+                        if SS.member (used, x) then
+                            strError env (DuplicateConstructor (x, loc))
+                        else
+                            ();
+                        ((x, n', to), (SS.add (used, x), env, gs'))
+                    end)
+                (SS.empty, env, []) xcs
+        in
+            ([(L'.DDatatype (x, n, xcs), loc)], (env, denv, gs))
+        end
+
+      | L.DDatatypeImp _ => raise Fail "Elaborate DDatatypeImp"
       | L.DVal (x, co, e) =>
         let
             val (c', _, gs1) = case co of
@@ -1975,6 +2109,35 @@
                               in
                                   ((L'.SgiCon (x, n, k, c), loc) :: sgis, cons, vals, sgns, strs)
                               end
+                            | L'.SgiDatatype (x, n, xncs) =>
+                              let
+                                  val (cons, x) =
+                                      if SS.member (cons, x) then
+                                          (cons, "?" ^ x)
+                                      else
+                                          (SS.add (cons, x), x)
+
+                                  val (xncs, vals) =
+                                      ListUtil.foldlMap
+                                          (fn ((x, n, t), vals) =>
+                                              if SS.member (vals, x) then
+                                                  (("?" ^ x, n, t), vals)
+                                              else
+                                                  ((x, n, t), SS.add (vals, x)))
+                                      vals xncs
+                              in
+                                  ((L'.SgiDatatype (x, n, xncs), loc) :: sgis, cons, vals, sgns, strs)
+                              end
+                            | L'.SgiDatatypeImp (x, n, m1, ms, x') =>
+                              let
+                                  val (cons, x) =
+                                      if SS.member (cons, x) then
+                                          (cons, "?" ^ x)
+                                      else
+                                          (SS.add (cons, x), x)
+                              in
+                                  ((L'.SgiDatatypeImp (x, n, m1, ms, x'), loc) :: sgis, cons, vals, sgns, strs)
+                              end
                             | L'.SgiVal (x, n, c) =>
                               let
                                   val (vals, x) =
diff -r 4334bb734187 -r 34ccd7d2bea8 src/explify.sml
--- a/src/explify.sml	Thu Jul 24 11:32:01 2008 -0400
+++ b/src/explify.sml	Thu Jul 24 15:02:03 2008 -0400
@@ -95,6 +95,8 @@
     case sgi of
         L.SgiConAbs (x, n, k) => SOME (L'.SgiConAbs (x, n, explifyKind k), loc)
       | L.SgiCon (x, n, k, c) => SOME (L'.SgiCon (x, n, explifyKind k, explifyCon c), loc)
+      | L.SgiDatatype _ => raise Fail "Explify SgiDatatype"
+      | L.SgiDatatypeImp _ => raise Fail "Explify SgiDatatypeImp"
       | L.SgiVal (x, n, c) => SOME (L'.SgiVal (x, n, explifyCon c), loc)
       | L.SgiStr (x, n, sgn) => SOME (L'.SgiStr (x, n, explifySgn sgn), loc)
       | L.SgiSgn (x, n, sgn) => SOME (L'.SgiSgn (x, n, explifySgn sgn), loc)
@@ -112,6 +114,8 @@
 fun explifyDecl (d, loc : EM.span) =
     case d of
         L.DCon (x, n, k, c) => SOME (L'.DCon (x, n, explifyKind k, explifyCon c), loc)
+      | L.DDatatype _ => raise Fail "Explify DDatatype"
+      | L.DDatatypeImp _ => raise Fail "Explify DDatatypeImp"
       | L.DVal (x, n, t, e) => SOME (L'.DVal (x, n, explifyCon t, explifyExp e), loc)
       | L.DValRec vis => SOME (L'.DValRec (map (fn (x, n, t, e) => (x, n, explifyCon t, explifyExp e)) vis), loc)
 
diff -r 4334bb734187 -r 34ccd7d2bea8 src/lacweb.grm
--- a/src/lacweb.grm	Thu Jul 24 11:32:01 2008 -0400
+++ b/src/lacweb.grm	Thu Jul 24 15:02:03 2008 -0400
@@ -42,9 +42,10 @@
  | STRING of string | INT of Int64.int | FLOAT of Real64.real
  | SYMBOL of string | CSYMBOL of string
  | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
- | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER
+ | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
  | DIVIDE | GT
  | CON | LTYPE | VAL | REC | AND | FOLD | UNIT | KUNIT
+ | DATATYPE | OF
  | TYPE | NAME
  | ARROW | LARROW | DARROW
  | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE
@@ -62,6 +63,10 @@
  | vali of string * con option * exp
  | valis of (string * con option * exp) list
 
+ | barOpt of unit
+ | dcons of (string * con option) list
+ | dcon of string * con option
+
  | sgn of sgn
  | sgntm of sgn
  | sgi of sgn_item
@@ -73,6 +78,7 @@
  | kcolon of explicitness
 
  | path of string list * string
+ | cpath of string list * string
  | spath of str
  | mpath of string list
 
@@ -129,6 +135,8 @@
        | CON SYMBOL DCOLON kind EQ cexp (DCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright))
        | LTYPE SYMBOL EQ cexp           (DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
                                          s (LTYPEleft, cexpright))
+       | DATATYPE SYMBOL EQ barOpt dcons(DDatatype (SYMBOL, dcons), s (DATATYPEleft, dconsright))
+       | DATATYPE SYMBOL EQ DATATYPE path(DDatatypeImp (SYMBOL, #1 path, #2 path), s (DATATYPEleft, pathright))
        | VAL vali                       (DVal vali, s (VALleft, valiright))
        | VAL REC valis                  (DValRec valis, s (VALleft, valisright))
 
@@ -153,6 +161,15 @@
        | CONSTRAINT cterm TWIDDLE cterm (DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))
        | EXPORT spath                   (DExport spath, s (EXPORTleft, spathright))
 
+barOpt :                                ()
+       | BAR                            ()
+
+dcons  : dcon                           ([dcon])
+       | dcon BAR dcons                 (dcon :: dcons)
+
+dcon   : CSYMBOL                        (CSYMBOL, NONE)
+       | CSYMBOL OF cexp                (CSYMBOL, SOME cexp)
+
 vali   : SYMBOL EQ eexp                 (SYMBOL, NONE, eexp)
        | SYMBOL COLON cexp EQ eexp      (SYMBOL, SOME cexp, eexp)
 
@@ -182,6 +199,8 @@
        | CON SYMBOL DCOLON kind EQ cexp (SgiCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright))
        | LTYPE SYMBOL EQ cexp           (SgiCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
                                          s (LTYPEleft, cexpright))
+       | DATATYPE SYMBOL EQ barOpt dcons(SgiDatatype (SYMBOL, dcons), s (DATATYPEleft, dconsright))
+       | DATATYPE SYMBOL EQ DATATYPE path(SgiDatatypeImp (SYMBOL, #1 path, #2 path), s (DATATYPEleft, pathright))
        | VAL SYMBOL COLON cexp          (SgiVal (SYMBOL, cexp), s (VALleft, cexpright))
 
        | STRUCTURE CSYMBOL COLON sgn    (SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright))
@@ -239,6 +258,9 @@
 path   : SYMBOL                         ([], SYMBOL)
        | CSYMBOL DOT path               (let val (ms, x) = path in (CSYMBOL :: ms, x) end)
 
+cpath  : CSYMBOL                        ([], CSYMBOL)
+       | CSYMBOL DOT cpath              (let val (ms, x) = cpath in (CSYMBOL :: ms, x) end)
+
 mpath  : CSYMBOL                        ([CSYMBOL])
        | CSYMBOL DOT mpath              (CSYMBOL :: mpath)
 
@@ -290,6 +312,7 @@
 eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
 
        | path                           (EVar path, s (pathleft, pathright))
+       | cpath                          (EVar cpath, s (cpathleft, cpathright))
        | LBRACE rexp RBRACE             (ERecord rexp, s (LBRACEleft, RBRACEright))
        | UNIT                           (ERecord [], s (UNITleft, UNITright))
 
diff -r 4334bb734187 -r 34ccd7d2bea8 src/lacweb.lex
--- a/src/lacweb.lex	Thu Jul 24 11:32:01 2008 -0400
+++ b/src/lacweb.lex	Thu Jul 24 15:02:03 2008 -0400
@@ -248,9 +248,12 @@
 <INITIAL> "__"        => (Tokens.UNDERUNDER (pos yypos, pos yypos + size yytext));
 <INITIAL> "_"         => (Tokens.UNDER (pos yypos, pos yypos + size yytext));
 <INITIAL> "~"         => (Tokens.TWIDDLE (pos yypos, pos yypos + size yytext));
+<INITIAL> "|"         => (Tokens.BAR (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "con"       => (Tokens.CON (pos yypos, pos yypos + size yytext));
 <INITIAL> "type"      => (Tokens.LTYPE (pos yypos, pos yypos + size yytext));
+<INITIAL> "datatype"  => (Tokens.DATATYPE (pos yypos, pos yypos + size yytext));
+<INITIAL> "of"        => (Tokens.OF (pos yypos, pos yypos + size yytext));
 <INITIAL> "val"       => (Tokens.VAL (pos yypos, pos yypos + size yytext));
 <INITIAL> "rec"       => (Tokens.REC (pos yypos, pos yypos + size yytext));
 <INITIAL> "and"       => (Tokens.AND (pos yypos, pos yypos + size yytext));
diff -r 4334bb734187 -r 34ccd7d2bea8 src/source.sml
--- a/src/source.sml	Thu Jul 24 11:32:01 2008 -0400
+++ b/src/source.sml	Thu Jul 24 15:02:03 2008 -0400
@@ -71,6 +71,8 @@
 datatype sgn_item' =
          SgiConAbs of string * kind
        | SgiCon of string * kind option * con
+       | SgiDatatype of string * (string * con option) list
+       | SgiDatatypeImp of string * string list * string
        | SgiVal of string * con
        | SgiStr of string * sgn
        | SgiSgn of string * sgn
@@ -107,6 +109,8 @@
 
 datatype decl' =
          DCon of string * kind option * con
+       | DDatatype of string * (string * con option) list
+       | DDatatypeImp of string * string list * string
        | DVal of string * con option * exp
        | DValRec of (string * con option * exp) list
        | DSgn of string * sgn
diff -r 4334bb734187 -r 34ccd7d2bea8 src/source_print.sml
--- a/src/source_print.sml	Thu Jul 24 11:32:01 2008 -0400
+++ b/src/source_print.sml	Thu Jul 24 15:02:03 2008 -0400
@@ -241,6 +241,18 @@
 
 and p_exp e = p_exp' false e
 
+fun p_datatype (x, cons) =
+    box [string "datatype",
+         space,
+         string x,
+         space,
+         string "=",
+         space,
+         p_list_sep (box [space, string "|", space])
+         (fn (x, NONE) => string x
+           | (x, SOME t) => box [string x, space, string "of", space, p_con t])
+         cons]
+
 fun p_sgn_item (sgi, _) =
     case sgi of
         SgiConAbs (x, k) => box [string "con",
@@ -268,6 +280,17 @@
                                       string "=",
                                       space,
                                       p_con c]
+      | SgiDatatype x => p_datatype x
+      | SgiDatatypeImp (x, ms, x') =>
+        box [string "datatype",
+             space,
+             string x,
+             space,
+             string "=",
+             space,
+             string "datatype",
+             space,
+             p_list_sep (string ".") string (ms @ [x'])]
       | SgiVal (x, c) => box [string "val",
                               space,
                               string x,
@@ -371,6 +394,17 @@
                                     string "=",
                                     space,
                                     p_con c]
+      | DDatatype x => p_datatype x
+      | DDatatypeImp (x, ms, x') =>
+        box [string "datatype",
+             space,
+             string x,
+             space,
+             string "=",
+             space,
+             string "datatype",
+             space,
+             p_list_sep (string ".") string (ms @ [x'])]
       | DVal vi => box [string "val",
                         space,
                         p_vali vi]
diff -r 4334bb734187 -r 34ccd7d2bea8 tests/datatype.lac
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/datatype.lac	Thu Jul 24 15:02:03 2008 -0400
@@ -0,0 +1,13 @@
+datatype t = A | B
+
+val a = A
+val b = B
+
+datatype foo = C of t
+
+val c = C a
+
+datatype list = Nil | Cons of {Head : int, Tail : list}
+
+val nil = Nil
+val l1 = Cons {Head = 0, Tail = nil}