Crud listing IDs

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)))