Mercurial > urweb
comparison src/elaborate.sml @ 1294:b4480a56cab7
Server-side 'onError'
author | Adam Chlipala <adam@chlipala.net> |
---|---|
date | Tue, 07 Sep 2010 08:28:07 -0400 |
parents | 1e6a4f9d3e4a |
children | 3c334458c84f |
comparison
equal
deleted
inserted
replaced
1293:acabf3935060 | 1294:b4480a56cab7 |
---|---|
2677 | L'.DDatabase _ => [] | 2677 | L'.DDatabase _ => [] |
2678 | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] | 2678 | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] |
2679 | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] | 2679 | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] |
2680 | L'.DTask _ => [] | 2680 | L'.DTask _ => [] |
2681 | L'.DPolicy _ => [] | 2681 | L'.DPolicy _ => [] |
2682 | L'.DOnError _ => [] | |
2682 | 2683 |
2683 and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = | 2684 and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = |
2684 ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), | 2685 ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), |
2685 ("sgn2", p_sgn env sgn2)];*) | 2686 ("sgn2", p_sgn env sgn2)];*) |
2686 case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of | 2687 case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of |
3855 val t1' = (L'.CModProj (!basis_r, [], "sql_policy"), loc) | 3856 val t1' = (L'.CModProj (!basis_r, [], "sql_policy"), loc) |
3856 in | 3857 in |
3857 checkCon env e1' t1 t1'; | 3858 checkCon env e1' t1 t1'; |
3858 ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs)) | 3859 ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs)) |
3859 end | 3860 end |
3861 | |
3862 | L.DOnError (m1, ms, s) => | |
3863 (case E.lookupStr env m1 of | |
3864 NONE => (expError env (UnboundStrInExp (loc, m1)); | |
3865 ([], (env, denv, []))) | |
3866 | SOME (n, sgn) => | |
3867 let | |
3868 val (str, sgn) = foldl (fn (m, (str, sgn)) => | |
3869 case E.projectStr env {sgn = sgn, str = str, field = m} of | |
3870 NONE => (conError env (UnboundStrInCon (loc, m)); | |
3871 (strerror, sgnerror)) | |
3872 | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) | |
3873 ((L'.StrVar n, loc), sgn) ms | |
3874 | |
3875 val t = case E.projectVal env {sgn = sgn, str = str, field = s} of | |
3876 NONE => (expError env (UnboundExp (loc, s)); | |
3877 cerror) | |
3878 | SOME t => t | |
3879 | |
3880 val page = (L'.CModProj (!basis_r, [], "page"), loc) | |
3881 val xpage = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc), page), loc) | |
3882 val func = (L'.TFun ((L'.CModProj (!basis_r, [], "xbody"), loc), xpage), loc) | |
3883 in | |
3884 unifyCons env loc t func; | |
3885 ([(L'.DOnError (n, ms, s), loc)], (env, denv, gs)) | |
3886 end) | |
3860 | 3887 |
3861 (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) | 3888 (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) |
3862 in | 3889 in |
3863 (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll)];*) | 3890 (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll)];*) |
3864 r | 3891 r |