Mercurial > urweb

changeset 170:a158f8c5aa55

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Parsing basic patterns
author Adam Chlipala <adamc@hcoop.net>
date Tue, 29 Jul 2008 16:38:15 -0400
parents 2232ab355f66
children c7a6e6dbc318
files src/elaborate.sml src/lacweb.grm src/lacweb.lex src/source.sml src/source_print.sml tests/case.lac
diffstat 6 files changed, 68 insertions(+), 0 deletions(-) [+]
line wrap: on
line diff
--- a/src/elaborate.sml	Tue Jul 29 16:02:02 2008 -0400
+++ b/src/elaborate.sml	Tue Jul 29 16:38:15 2008 -0400
@@ -1137,6 +1137,8 @@
             in
                 ((L'.EFold dom, loc), foldType (dom, loc), [])
             end
+
+          | L.ECase _ => raise Fail "Elaborate ECase"
     end
             
 
--- a/src/lacweb.grm	Tue Jul 29 16:02:02 2008 -0400
+++ b/src/lacweb.grm	Tue Jul 29 16:38:15 2008 -0400
@@ -51,6 +51,7 @@
  | 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 @@
  | 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 @@
 
        | 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 @@
                                                (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)
--- a/src/lacweb.lex	Tue Jul 29 16:02:02 2008 -0400
+++ b/src/lacweb.lex	Tue Jul 29 16:38:15 2008 -0400
@@ -259,6 +259,7 @@
 <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));
--- a/src/source.sml	Tue Jul 29 16:02:02 2008 -0400
+++ b/src/source.sml	Tue Jul 29 16:38:15 2008 -0400
@@ -89,6 +89,13 @@
 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 @@
        | ECut of exp * con
        | EFold
 
+       | ECase of exp * (pat * exp) list
+
 withtype exp = exp' located
 
 datatype decl' =
--- a/src/source_print.sml	Tue Jul 29 16:02:02 2008 -0400
+++ b/src/source_print.sml	Tue Jul 29 16:38:15 2008 -0400
@@ -162,6 +162,17 @@
         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 @@
                                          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) =
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/case.lac	Tue Jul 29 16:38:15 2008 -0400
@@ -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