Mercurial > urweb

comparison src/urweb.grm @ 325:e457d8972ff1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Crud listing IDs
author Adam Chlipala <adamc@hcoop.net>
date Thu, 11 Sep 2008 17:41:52 -0400
parents 0aee86b8a6d6
children eec65c11d3e2
comparison
equal deleted inserted replaced
324:b91480c9a729 325:e457d8972ff1
150 (EApp (e, e2), loc) 150 (EApp (e, e2), loc)
151 end 151 end
152 152
153 val inDml = ref false 153 val inDml = ref false
154 154
155 fun tagIn bt =
156 case bt of
157 "table" => "tabl"
158 | _ => bt
159
155 %% 160 %%
156 %header (functor UrwebLrValsFn(structure Token : TOKEN)) 161 %header (functor UrwebLrValsFn(structure Token : TOKEN))
157 162
158 %term 163 %term
159 EOF 164 EOF
185 | NE | LT | LE | GT | GE 190 | NE | LT | LE | GT | GE
186 191
187 %nonterm 192 %nonterm
188 file of decl list 193 file of decl list
189 | decls of decl list 194 | decls of decl list
190 | decl of decl 195 | decl of decl list
191 | vali of string * con option * exp 196 | vali of string * con option * exp
192 | valis of (string * con option * exp) list 197 | valis of (string * con option * exp) list
193 | copt of con option 198 | copt of con option
194 199
195 | dargs of string list 200 | dargs of string list
324 file : decls (decls) 329 file : decls (decls)
325 | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))), 330 | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))),
326 s (SIGleft, sgisright))]) 331 s (SIGleft, sgisright))])
327 332
328 decls : ([]) 333 decls : ([])
329 | decl decls (decl :: decls) 334 | decl decls (decl @ decls)
330 335
331 decl : CON SYMBOL cargl2 kopt EQ cexp (let 336 decl : CON SYMBOL cargl2 kopt EQ cexp (let
332 val loc = s (CONleft, cexpright) 337 val loc = s (CONleft, cexpright)
333 338
334 val k = Option.getOpt (kopt, (KWild, loc)) 339 val k = Option.getOpt (kopt, (KWild, loc))
335 val (c, k) = cargl2 (cexp, k) 340 val (c, k) = cargl2 (cexp, k)
336 in 341 in
337 (DCon (SYMBOL, SOME k, c), loc) 342 [(DCon (SYMBOL, SOME k, c), loc)]
338 end) 343 end)
339 | LTYPE SYMBOL EQ cexp (DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp), 344 | LTYPE SYMBOL EQ cexp ([(DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
340 s (LTYPEleft, cexpright)) 345 s (LTYPEleft, cexpright))])
341 | DATATYPE SYMBOL dargs EQ barOpt dcons(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright)) 346 | DATATYPE SYMBOL dargs EQ barOpt dcons([(DDatatype (SYMBOL, dargs, dcons), s (DATATYPEleft, dconsright))])
342 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path 347 | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path
343 (case dargs of 348 (case dargs of
344 [] => (DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright)) 349 [] => [(DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))]
345 | _ => raise Fail "Arguments specified for imported datatype") 350 | _ => raise Fail "Arguments specified for imported datatype")
346 | VAL vali (DVal vali, s (VALleft, valiright)) 351 | VAL vali ([(DVal vali, s (VALleft, valiright))])
347 | VAL REC valis (DValRec valis, s (VALleft, valisright)) 352 | VAL REC valis ([(DValRec valis, s (VALleft, valisright))])
348 | FUN valis (DValRec valis, s (FUNleft, valisright)) 353 | FUN valis ([(DValRec valis, s (FUNleft, valisright))])
349 354
350 | SIGNATURE CSYMBOL EQ sgn (DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright)) 355 | SIGNATURE CSYMBOL EQ sgn ([(DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))])
351 | STRUCTURE CSYMBOL EQ str (DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright)) 356 | STRUCTURE CSYMBOL EQ str ([(DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright))])
352 | STRUCTURE CSYMBOL COLON sgn EQ str (DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright)) 357 | STRUCTURE CSYMBOL COLON sgn EQ str ([(DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright))])
353 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str 358 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str
354 (DStr (CSYMBOL1, NONE, 359 ([(DStr (CSYMBOL1, NONE,
355 (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))), 360 (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))),
356 s (FUNCTORleft, strright)) 361 s (FUNCTORleft, strright))])
357 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str 362 | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str
358 (DStr (CSYMBOL1, NONE, 363 ([(DStr (CSYMBOL1, NONE,
359 (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))), 364 (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))),
360 s (FUNCTORleft, strright)) 365 s (FUNCTORleft, strright))])
361 | EXTERN STRUCTURE CSYMBOL COLON sgn (DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright)) 366 | EXTERN STRUCTURE CSYMBOL COLON sgn ([(DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright))])
362 | OPEN mpath (case mpath of 367 | OPEN mpath (case mpath of
363 [] => raise Fail "Impossible mpath parse [1]" 368 [] => raise Fail "Impossible mpath parse [1]"
364 | m :: ms => (DOpen (m, ms), s (OPENleft, mpathright))) 369 | m :: ms => [(DOpen (m, ms), s (OPENleft, mpathright))])
370 | OPEN mpath LPAREN str RPAREN (let
371 val loc = s (OPENleft, RPARENright)
372
373 val m = case mpath of
374 [] => raise Fail "Impossible mpath parse [4]"
375 | m :: ms =>
376 foldl (fn (m, str) => (StrProj (str, m), loc))
377 (StrVar m, loc) ms
378 in
379 [(DStr ("anon", NONE, (StrApp (m, str), loc)), loc),
380 (DOpen ("anon", []), loc)]
381 end)
365 | OPEN CONSTRAINTS mpath (case mpath of 382 | OPEN CONSTRAINTS mpath (case mpath of
366 [] => raise Fail "Impossible mpath parse [3]" 383 [] => raise Fail "Impossible mpath parse [3]"
367 | m :: ms => (DOpenConstraints (m, ms), s (OPENleft, mpathright))) 384 | m :: ms => [(DOpenConstraints (m, ms), s (OPENleft, mpathright))])
368 | CONSTRAINT cterm TWIDDLE cterm (DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)) 385 | CONSTRAINT cterm TWIDDLE cterm ([(DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))])
369 | EXPORT spath (DExport spath, s (EXPORTleft, spathright)) 386 | EXPORT spath ([(DExport spath, s (EXPORTleft, spathright))])
370 | TABLE SYMBOL COLON cexp (DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright)) 387 | TABLE SYMBOL COLON cexp ([(DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))])
371 | CLASS SYMBOL EQ cexp (DClass (SYMBOL, cexp), s (CLASSleft, cexpright)) 388 | CLASS SYMBOL EQ cexp ([(DClass (SYMBOL, cexp), s (CLASSleft, cexpright))])
372 | CLASS SYMBOL SYMBOL EQ cexp (let 389 | CLASS SYMBOL SYMBOL EQ cexp (let
373 val loc = s (CLASSleft, cexpright) 390 val loc = s (CLASSleft, cexpright)
374 val k = (KType, loc) 391 val k = (KType, loc)
375 val c = (CAbs (SYMBOL2, SOME k, cexp), loc) 392 val c = (CAbs (SYMBOL2, SOME k, cexp), loc)
376 in 393 in
377 (DClass (SYMBOL1, c), s (CLASSleft, cexpright)) 394 [(DClass (SYMBOL1, c), s (CLASSleft, cexpright))]
378 end) 395 end)
379 396
380 kopt : (NONE) 397 kopt : (NONE)
381 | DCOLON kind (SOME kind) 398 | DCOLON kind (SOME kind)
382 399
851 pos)), pos) 868 pos)), pos)
852 end) 869 end)
853 870
854 | tag GT xml END_TAG (let 871 | tag GT xml END_TAG (let
855 val pos = s (tagleft, GTright) 872 val pos = s (tagleft, GTright)
856 in 873 val et = tagIn END_TAG
857 if #1 tag = END_TAG then 874 in
858 if END_TAG = "lform" then 875 if #1 tag = et then
876 if et = "lform" then
859 (EApp ((EVar (["Basis"], "lform"), pos), 877 (EApp ((EVar (["Basis"], "lform"), pos),
860 xml), pos) 878 xml), pos)
861 else 879 else
862 (EApp (#2 tag, xml), pos) 880 (EApp (#2 tag, xml), pos)
863 else 881 else
864 (ErrorMsg.errorAt pos "Begin and end tags don't match."; 882 (if ErrorMsg.anyErrors () then
883 ()
884 else
885 ErrorMsg.errorAt pos "Begin and end tags don't match.";
865 (EFold, pos)) 886 (EFold, pos))
866 end) 887 end)
867 | LBRACE eexp RBRACE (eexp) 888 | LBRACE eexp RBRACE (eexp)
868 889
869 tag : tagHead attrs (let 890 tag : tagHead attrs (let
876 (ERecord [], pos)), pos)), 897 (ERecord [], pos)), pos)),
877 pos)) 898 pos))
878 end) 899 end)
879 900
880 tagHead: BEGIN_TAG (let 901 tagHead: BEGIN_TAG (let
902 val bt = tagIn BEGIN_TAG
881 val pos = s (BEGIN_TAGleft, BEGIN_TAGright) 903 val pos = s (BEGIN_TAGleft, BEGIN_TAGright)
882 in 904 in
883 (BEGIN_TAG, 905 (bt,
884 (EVar ([], BEGIN_TAG), pos)) 906 (EVar ([], bt), pos))
885 end) 907 end)
886 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) 908 | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
887 909
888 attrs : ([]) 910 attrs : ([])
889 | attr attrs (attr :: attrs) 911 | attr attrs (attr :: attrs)