Mercurial > urweb
diff 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 |
line wrap: on
line diff
--- a/src/elaborate.sml Sun Sep 05 14:00:57 2010 -0400 +++ b/src/elaborate.sml Tue Sep 07 08:28:07 2010 -0400 @@ -2679,6 +2679,7 @@ | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] | L'.DTask _ => [] | L'.DPolicy _ => [] + | L'.DOnError _ => [] and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3858,6 +3859,32 @@ ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs)) end + | L.DOnError (m1, ms, s) => + (case E.lookupStr env m1 of + NONE => (expError env (UnboundStrInExp (loc, m1)); + ([], (env, denv, []))) + | SOME (n, sgn) => + let + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => (conError env (UnboundStrInCon (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + + val t = case E.projectVal env {sgn = sgn, str = str, field = s} of + NONE => (expError env (UnboundExp (loc, s)); + cerror) + | SOME t => t + + val page = (L'.CModProj (!basis_r, [], "page"), loc) + val xpage = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc), page), loc) + val func = (L'.TFun ((L'.CModProj (!basis_r, [], "xbody"), loc), xpage), loc) + in + unifyCons env loc t func; + ([(L'.DOnError (n, ms, s), loc)], (env, denv, gs)) + end) + (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll)];*)