Mercurial > urweb
diff src/mono_fooify.sml @ 2262:34ad83d9b729
Fix recording bugs to do with nesting and buffer reallocation. Stop MonoFooify printing spurious errors.
author | Ziv Scully <ziv@mit.edu> |
---|---|
date | Wed, 07 Oct 2015 08:58:08 -0400 |
parents | f81f1930c5d6 |
children | a647a1560628 |
line wrap: on
line diff
--- a/src/mono_fooify.sml Wed Sep 30 00:33:52 2015 -0400 +++ b/src/mono_fooify.sml Wed Oct 07 08:58:08 2015 -0400 @@ -127,9 +127,13 @@ structure E = ErrorMsg +exception TypeMismatch of Fm.t * E.span +exception CantPass of Fm.t * typ +exception DontKnow of Fm.t * typ + val dummyExp = (EPrim (Prim.Int 0), E.dummySpan) -fun fooifyExp fk lookupENamed lookupDatatype = +fun fooifyExpWithExceptions fk lookupENamed lookupDatatype = let fun fooify fm (e, tAll as (t, loc)) = case #1 e of @@ -155,8 +159,7 @@ arg'), loc)), loc), fm) end - | _ => (E.errorAt loc "Type mismatch encoding attribute"; - (e, fm)) + | _ => raise TypeMismatch (fm, loc) in attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) end @@ -165,10 +168,8 @@ TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) | TFfi (m, x) => (if Settings.mayClientToServer (m, x) (* TODO: better error message. (Then again, user should never see this.) *) - then () - else (E.errorAt loc "MonoFooify: can't pass type from client to server"; - Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]); - ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)) + then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) + else raise CantPass (fm, tAll)) | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) | TRecord ((x, t) :: xts) => @@ -291,38 +292,50 @@ ((EApp ((ENamed n, loc), e), loc), fm) end - | _ => (E.errorAt loc "Don't know how to encode attribute/URL type"; - Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; - (dummyExp, fm)) + | _ => raise DontKnow (fm, tAll) in fooify end +fun fooifyExp fk lookupENamed lookupDatatype fm exp = + fooifyExpWithExceptions fk lookupENamed lookupDatatype fm exp + handle TypeMismatch (fm, loc) => + (E.errorAt loc "Type mismatch encoding attribute"; + (dummyExp, fm)) + | CantPass (fm, typ as (_, loc)) => + (E.errorAt loc "MonoFooify: can't pass type from client to server"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)]; + (dummyExp, fm)) + | DontKnow (fm, typ as (_, loc)) => + (E.errorAt loc "Don't know how to encode attribute/URL type"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)]; + (dummyExp, fm)) + + (* Has to be set at the end of [Monoize]. *) val canonicalFm = ref (Fm.empty 0 : Fm.t) fun urlify env expTyp = - if ErrorMsg.anyErrors () - then ((* DEBUG *) print "already error"; NONE) - else - let - val (exp, fm) = - fooifyExp - Url - (fn n => - let - val (_, t, _, s) = MonoEnv.lookupENamed env n - in - (t, s) - end) - (fn n => MonoEnv.lookupDatatype env n) - (!canonicalFm) - expTyp - in - if ErrorMsg.anyErrors () - then ((* DEBUG *) print "why"; (ErrorMsg.resetErrors (); NONE)) - else (canonicalFm := fm; SOME exp) - end + let + val (exp, fm) = + fooifyExpWithExceptions + Url + (fn n => + let + val (_, t, _, s) = MonoEnv.lookupENamed env n + in + (t, s) + end) + (fn n => MonoEnv.lookupDatatype env n) + (!canonicalFm) + expTyp + in + canonicalFm := fm; + SOME exp + end + handle TypeMismatch _ => NONE + | CantPass _ => NONE + | DontKnow _ => NONE fun getNewFmDecls () = let