Mercurial > urweb
changeset 1612:7bb8c560f23d
Announce sidedness errors with source locations
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Fri, 25 Nov 2011 11:08:51 -0500 |
| parents | 217384f4b8ea |
| children | 4973d31b5fff |
| files | src/mono_util.sig src/mono_util.sml src/sidecheck.sml |
| diffstat | 3 files changed, 104 insertions(+), 32 deletions(-) [+] |
line wrap: on
line diff
--- a/src/mono_util.sig Thu Nov 24 11:56:05 2011 -0500 +++ b/src/mono_util.sig Fri Nov 25 11:08:51 2011 -0500 @@ -80,6 +80,8 @@ exp : 'context * Mono.exp' * 'state -> 'state, bind : 'context * binder -> 'context} -> 'context -> 'state -> Mono.exp -> 'state + + val appLoc : (Mono.exp -> unit) -> Mono.exp -> unit end structure Decl : sig @@ -143,6 +145,8 @@ -> 'state -> Mono.file -> 'state val maxName : Mono.file -> int + + val appLoc : (Mono.exp -> unit) -> Mono.file -> unit end end
--- a/src/mono_util.sml Thu Nov 24 11:56:05 2011 -0500 +++ b/src/mono_util.sml Fri Nov 25 11:08:51 2011 -0500 @@ -467,6 +467,51 @@ S.Continue (_, s) => s | S.Return _ => raise Fail "MonoUtil.Exp.foldB: Impossible" +fun appLoc f = + let + fun appl e = + (f e; + case #1 e of + EPrim _ => () + | ERel _ => () + | ENamed _ => () + | ECon (_, _, eo) => Option.app appl eo + | ENone _ => () + | ESome (_, e) => appl e + | EFfi _ => () + | EFfiApp (_, _, es) => app appl es + | EApp (e1, e2) => (appl e1; appl e2) + | EAbs (_, _, _, e1) => appl e1 + | EUnop (_, e1) => appl e1 + | EBinop (_, _, e1, e2) => (appl e1; appl e2) + | ERecord xets => app (appl o #2) xets + | EField (e1, _) => appl e1 + | ECase (e1, pes, _) => (appl e1; app (appl o #2) pes) + | EStrcat (e1, e2) => (appl e1; appl e2) + | EError (e1, _) => appl e1 + | EReturnBlob {blob = e1, mimeType = e2, ...} => (appl e1; appl e2) + | ERedirect (e1, _) => appl e1 + | EWrite e1 => appl e1 + | ESeq (e1, e2) => (appl e1; appl e2) + | ELet (_, _, e1, e2) => (appl e1; appl e2) + | EClosure (_, es) => app appl es + | EQuery {query = e1, body = e2, initial = e3, ...} => (appl e1; appl e2; appl e3) + | EDml (e1, _) => appl e1 + | ENextval e1 => appl e1 + | ESetval (e1, e2) => (appl e1; appl e2) + | EUnurlify (e1, _, _) => appl e1 + | EJavaScript (_, e1) => appl e1 + | ESignalReturn e1 => appl e1 + | ESignalBind (e1, e2) => (appl e1; appl e2) + | ESignalSource e1 => appl e1 + | EServerCall (e1, _, _) => appl e1 + | ERecv (e1, _) => appl e1 + | ESleep e1 => appl e1 + | ESpawn e1 => appl e1) + in + appl + end + end structure Decl = struct @@ -703,6 +748,38 @@ | DPolicy _ => count | DOnError _ => count) 0 +fun appLoc f = + let + val eal = Exp.appLoc f + + fun appl (d : decl) = + case #1 d of + DDatatype _ => () + | DVal (_, _, _, e1, _) => eal e1 + | DValRec vis => app (eal o #4) vis + | DExport _ => () + | DTable (_, _, e1, e2) => (eal e1; eal e2) + | DSequence _ => () + | DView (_, _, e1) => eal e1 + | DDatabase _ => () + | DJavaScript _ => () + | DCookie _ => () + | DStyle _ => () + | DTask (e1, e2) => (eal e1; eal e2) + | DPolicy pol => applPolicy pol + | DOnError _ => () + + and applPolicy p = + case p of + PolClient e1 => eal e1 + | PolInsert e1 => eal e1 + | PolDelete e1 => eal e1 + | PolUpdate e1 => eal e1 + | PolSequence e1 => eal e1 + in + app appl + end + end end
--- a/src/sidecheck.sml Thu Nov 24 11:56:05 2011 -0500 +++ b/src/sidecheck.sml Fri Nov 25 11:08:51 2011 -0500 @@ -31,38 +31,29 @@ structure E = ErrorMsg -structure FS = BinarySetFn(struct - type ord_key = string * string - fun compare ((x1, y1), (x2, y2)) = Order.join (String.compare (x1, x2), - fn () => String.compare (y1, y2)) - end) - fun check ds = - let - val fs = MonoUtil.File.fold {typ = fn (_, fs) => fs, - exp = fn (e, fs) => - case e of - EFfi k => FS.add (fs, k) - | EFfiApp (k1, k2, _) => FS.add (fs, (k1, k2)) - | _ => fs, - decl = fn (_, fs) => fs} - FS.empty ds - in - FS.app (fn k as (k1, k2) => - if Settings.isClientOnly k then - let - val k2 = case k1 of - "Basis" => - (case k2 of - "get_client_source" => "get" - | _ => k2) - | _ => k2 - in - E.error ("Server-side code uses client-side-only identifier \"" ^ k1 ^ "." ^ k2 ^ "\"") - end - else - ()) fs; - ds - end + (MonoUtil.File.appLoc (fn (e, loc) => + let + fun error (k as (k1, k2)) = + if Settings.isClientOnly k then + let + val k2 = case k1 of + "Basis" => + (case k2 of + "get_client_source" => "get" + | _ => k2) + | _ => k2 + in + E.errorAt loc ("Server-side code uses client-side-only identifier \"" ^ k1 ^ "." ^ k2 ^ "\"") + end + else + () + in + case e of + EFfi k => error k + | EFfiApp (k1, k2, _) => error (k1, k2) + | _ => () + end) ds; + ds) end