summaryrefslogtreecommitdiff
path: root/src/urweb.grm
diff options
context:
space:
mode:
Diffstat (limited to 'src/urweb.grm')
-rw-r--r--src/urweb.grm86
1 files changed, 54 insertions, 32 deletions
diff --git a/src/urweb.grm b/src/urweb.grm
index efa35117..c8dd5698 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -152,6 +152,11 @@ fun native_op (oper, e1, e2, loc) =
val inDml = ref false
+fun tagIn bt =
+ case bt of
+ "table" => "tabl"
+ | _ => bt
+
%%
%header (functor UrwebLrValsFn(structure Token : TOKEN))
@@ -187,7 +192,7 @@ val inDml = ref false
%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 @@ file : decls (decls)
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 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let
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 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata"), s (NO
| 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 @@ tag : tagHead attrs (let
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)))
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-06 16:45:50 +0000