diff options
-rw-r--r-- | src/elaborate.sml | 2 | ||||
-rw-r--r-- | src/lacweb.grm | 20 | ||||
-rw-r--r-- | src/lacweb.lex | 1 | ||||
-rw-r--r-- | src/source.sml | 9 | ||||
-rw-r--r-- | src/source_print.sml | 24 | ||||
-rw-r--r-- | tests/case.lac | 12 |
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 |