Mercurial > urweb
changeset 170:a158f8c5aa55
Parsing basic patterns
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Tue, 29 Jul 2008 16:38:15 -0400 (2008-07-29) |
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