Mercurial > urweb
diff src/urweb.grm @ 325:e457d8972ff1
Crud listing IDs
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 11 Sep 2008 17:41:52 -0400 |
| parents | 0aee86b8a6d6 |
| children | eec65c11d3e2 |
line wrap: on
line diff
--- a/src/urweb.grm Thu Sep 11 13:06:51 2008 -0400 +++ b/src/urweb.grm Thu Sep 11 17:41:52 2008 -0400 @@ -152,6 +152,11 @@ val inDml = ref false +fun tagIn bt = + case bt of + "table" => "tabl" + | _ => bt + %% %header (functor UrwebLrValsFn(structure Token : TOKEN)) @@ -187,7 +192,7 @@ %nonterm file of decl list | decls of decl list - | decl of decl + | decl of decl list | vali of string * con option * exp | valis of (string * con option * exp) list | copt of con option @@ -326,7 +331,7 @@ s (SIGleft, sgisright))]) decls : ([]) - | decl decls (decl :: decls) + | decl decls (decl @ decls) decl : CON SYMBOL cargl2 kopt EQ cexp (let val loc = s (CONleft, cexpright) @@ -334,47 +339,59 @@ val k = Option.getOpt (kopt, (KWild, loc)) val (c, k) = cargl2 (cexp, k) in - (DCon (SYMBOL, SOME k, c), loc) + [(DCon (SYMBOL, SOME k, c), loc)] end) - | LTYPE SYMBOL EQ cexp (DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp), - s (LTYPEleft, cexpright)) - | DATATYPE SYMBOL dargs EQ barOpt dcons(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright)) + | LTYPE SYMBOL EQ cexp ([(DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp), + s (LTYPEleft, cexpright))]) + | DATATYPE SYMBOL dargs EQ barOpt dcons([(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright))]) | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path (case dargs of - [] => (DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright)) + [] => [(DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))] | _ => raise Fail "Arguments specified for imported datatype") - | VAL vali (DVal vali, s (VALleft, valiright)) - | VAL REC valis (DValRec valis, s (VALleft, valisright)) - | FUN valis (DValRec valis, s (FUNleft, valisright)) + | VAL vali ([(DVal vali, s (VALleft, valiright))]) + | VAL REC valis ([(DValRec valis, s (VALleft, valisright))]) + | FUN valis ([(DValRec valis, s (FUNleft, valisright))]) - | SIGNATURE CSYMBOL EQ sgn (DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright)) - | STRUCTURE CSYMBOL EQ str (DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright)) - | STRUCTURE CSYMBOL COLON sgn EQ str (DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright)) + | SIGNATURE CSYMBOL EQ sgn ([(DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))]) + | STRUCTURE CSYMBOL EQ str ([(DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright))]) + | STRUCTURE CSYMBOL COLON sgn EQ str ([(DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright))]) | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str - (DStr (CSYMBOL1, NONE, - (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))), - s (FUNCTORleft, strright)) + ([(DStr (CSYMBOL1, NONE, + (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))), + s (FUNCTORleft, strright))]) | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str - (DStr (CSYMBOL1, NONE, - (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))), - s (FUNCTORleft, strright)) - | EXTERN STRUCTURE CSYMBOL COLON sgn (DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright)) + ([(DStr (CSYMBOL1, NONE, + (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))), + s (FUNCTORleft, strright))]) + | EXTERN STRUCTURE CSYMBOL COLON sgn ([(DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright))]) | OPEN mpath (case mpath of [] => raise Fail "Impossible mpath parse [1]" - | m :: ms => (DOpen (m, ms), s (OPENleft, mpathright))) + | m :: ms => [(DOpen (m, ms), s (OPENleft, mpathright))]) + | OPEN mpath LPAREN str RPAREN (let + val loc = s (OPENleft, RPARENright) + + val m = case mpath of + [] => raise Fail "Impossible mpath parse [4]" + | m :: ms => + foldl (fn (m, str) => (StrProj (str, m), loc)) + (StrVar m, loc) ms + in + [(DStr ("anon", NONE, (StrApp (m, str), loc)), loc), + (DOpen ("anon", []), loc)] + end) | OPEN CONSTRAINTS mpath (case mpath of [] => raise Fail "Impossible mpath parse [3]" - | m :: ms => (DOpenConstraints (m, ms), s (OPENleft, mpathright))) - | CONSTRAINT cterm TWIDDLE cterm (DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)) - | EXPORT spath (DExport spath, s (EXPORTleft, spathright)) - | TABLE SYMBOL COLON cexp (DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright)) - | CLASS SYMBOL EQ cexp (DClass (SYMBOL, cexp), s (CLASSleft, cexpright)) + | m :: ms => [(DOpenConstraints (m, ms), s (OPENleft, mpathright))]) + | CONSTRAINT cterm TWIDDLE cterm ([(DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))]) + | EXPORT spath ([(DExport spath, s (EXPORTleft, spathright))]) + | TABLE SYMBOL COLON cexp ([(DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))]) + | CLASS SYMBOL EQ cexp ([(DClass (SYMBOL, cexp), s (CLASSleft, cexpright))]) | CLASS SYMBOL SYMBOL EQ cexp (let val loc = s (CLASSleft, cexpright) val k = (KType, loc) val c = (CAbs (SYMBOL2, SOME k, cexp), loc) in - (DClass (SYMBOL1, c), s (CLASSleft, cexpright)) + [(DClass (SYMBOL1, c), s (CLASSleft, cexpright))] end) kopt : (NONE) @@ -853,15 +870,19 @@ | tag GT xml END_TAG (let val pos = s (tagleft, GTright) + val et = tagIn END_TAG in - if #1 tag = END_TAG then - if END_TAG = "lform" then + if #1 tag = et then + if et = "lform" then (EApp ((EVar (["Basis"], "lform"), pos), xml), pos) else (EApp (#2 tag, xml), pos) else - (ErrorMsg.errorAt pos "Begin and end tags don't match."; + (if ErrorMsg.anyErrors () then + () + else + ErrorMsg.errorAt pos "Begin and end tags don't match."; (EFold, pos)) end) | LBRACE eexp RBRACE (eexp) @@ -878,10 +899,11 @@ end) tagHead: BEGIN_TAG (let + val bt = tagIn BEGIN_TAG val pos = s (BEGIN_TAGleft, BEGIN_TAGright) in - (BEGIN_TAG, - (EVar ([], BEGIN_TAG), pos)) + (bt, + (EVar ([], bt), pos)) end) | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))