Parsing basic patterns

6 files changed, 68 insertions, 0 deletions

diff --git a/src/elaborate.sml b/src/elaborate.sml
index cd2c25d7..d19dcfce 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1137,6 +1137,8 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
             in
                 ((L'.EFold dom, loc), foldType (dom, loc), [])
             end
+
+          | L.ECase _ => raise Fail "Elaborate ECase"
     end
             
 
diff --git a/src/lacweb.grm b/src/lacweb.grm
index a1a0663f..a5a4f745 100644
--- a/src/lacweb.grm
+++ b/src/lacweb.grm
@@ -51,6 +51,7 @@ fun uppercaseFirst "" = ""
  | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE
  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN
  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT
+ | CASE
 
  | XML_BEGIN of string | XML_END
  | NOTAGS of string 
@@ -99,6 +100,11 @@ fun uppercaseFirst "" = ""
  | tag of string * exp
  | tagHead of string * exp
 
+ | branch of pat * exp
+ | branchs of (pat * exp) list
+ | pat of pat
+ | pterm of pat
+
  | attrs of (con * exp) list
  | attr of con * exp
  | attrv of exp
@@ -310,6 +316,7 @@ eexp   : eapps                          (eapps)
 
        | LPAREN eexp RPAREN DCOLON cexp (EAnnot (eexp, cexp), s (LPARENleft, cexpright))
        | eexp MINUSMINUS cexp           (ECut (eexp, cexp), s (eexpleft, cexpright))
+       | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright))
 
 eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
 
@@ -330,6 +337,19 @@ eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
                                                (EPrim (Prim.String ""), s (XML_BEGINleft, XML_ENDright))),
                                          s (XML_BEGINleft, XML_ENDright))
 
+branch : pat DARROW eexp                (pat, eexp)
+
+branchs:                                ([])
+       | BAR branch branchs             (branch :: branchs)
+
+pat    : pterm                          (pterm)
+       | cpath pterm                    (PCon (#1 cpath, #2 cpath, SOME pterm), s (cpathleft, ptermright))
+
+pterm  : SYMBOL                         (PVar SYMBOL, s (SYMBOLleft, SYMBOLright))
+       | cpath                          (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright))
+       | UNDER                          (PWild, s (UNDERleft, UNDERright))
+       | LPAREN pat RPAREN              (pat)
+
 rexp   :                                ([])
        | ident EQ eexp                  ([(ident, eexp)])
        | ident EQ eexp COMMA rexp       ((ident, eexp) :: rexp)
diff --git a/src/lacweb.lex b/src/lacweb.lex
index 506537e5..862d5d31 100644
--- a/src/lacweb.lex
+++ b/src/lacweb.lex
@@ -259,6 +259,7 @@ notags = [^<{\n]+;
 <INITIAL> "and"       => (Tokens.AND (pos yypos, pos yypos + size yytext));
 <INITIAL> "fn"        => (Tokens.FN (pos yypos, pos yypos + size yytext));
 <INITIAL> "fold"      => (Tokens.FOLD (pos yypos, pos yypos + size yytext));
+<INITIAL> "case"      => (Tokens.CASE (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "structure" => (Tokens.STRUCTURE (pos yypos, pos yypos + size yytext));
 <INITIAL> "signature" => (Tokens.SIGNATURE (pos yypos, pos yypos + size yytext));
diff --git a/src/source.sml b/src/source.sml
index 6439aaa4..b11828f0 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -89,6 +89,13 @@ and sgn' =
 withtype sgn_item = sgn_item' located
 and sgn = sgn' located
 
+datatype pat' =
+         PWild
+       | PVar of string
+       | PCon of string list * string * pat option
+
+withtype pat = pat' located
+
 datatype exp' =
          EAnnot of exp * con
 
@@ -105,6 +112,8 @@ datatype exp' =
        | ECut of exp * con
        | EFold
 
+       | ECase of exp * (pat * exp) list
+
 withtype exp = exp' located
 
 datatype decl' =
diff --git a/src/source_print.sml b/src/source_print.sml
index b69b0b58..79f3c254 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -162,6 +162,17 @@ and p_name (all as (c, _)) =
         CName s => string s
       | _ => p_con all
 
+fun p_pat' par (p, _) =
+    case p of
+        PWild => string "_"
+      | PVar s => string s
+      | PCon (ms, x, NONE) => p_list_sep (string ".") string (ms @ [x])
+      | PCon (ms, x, SOME p) => parenIf par (box [p_list_sep (string ".") string (ms @ [x]),
+                                                  space,
+                                                  p_pat' true p])
+
+val p_pat = p_pat' false
+
 fun p_exp' par (e, _) =
     case e of
         EAnnot (e, t) => box [string "(",
@@ -239,6 +250,19 @@ fun p_exp' par (e, _) =
                                          p_con' true c])
       | EFold => string "fold"
 
+      | ECase (e, pes) => parenIf par (box [string "case",
+                                            space,
+                                            p_exp' false e,
+                                            space,
+                                            string "of",
+                                            space,
+                                            p_list_sep (box [space, string "|", space])
+                                            (fn (p, e) => box [p_pat p,
+                                                               space,
+                                                               string "=>",
+                                                               space,
+                                                               p_exp e]) pes])
+
 and p_exp e = p_exp' false e
 
 fun p_datatype (x, cons) =
diff --git a/tests/case.lac b/tests/case.lac
new file mode 100644
index 00000000..dc3fe03b
--- /dev/null
+++ b/tests/case.lac
@@ -0,0 +1,12 @@
+datatype t = A | B
+
+val swap = fn x : t => case x of A => B | B => A
+
+datatype u = C of t | D
+
+val out = fn x : u => case x of C y => y | D => A
+
+datatype nat = O | S of nat
+
+val is_two = fn x : int_list =>
+        case x of S (S O) => A | _ => B