summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/mono_util.sig4
-rw-r--r--src/mono_util.sml77
-rw-r--r--src/sidecheck.sml55
3 files changed, 104 insertions, 32 deletions
diff --git a/src/mono_util.sig b/src/mono_util.sig
index 06290e7d..7ce545e1 100644
--- a/src/mono_util.sig
+++ b/src/mono_util.sig
@@ -80,6 +80,8 @@ structure Exp : sig
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 @@ structure File : sig
-> 'state -> Mono.file -> 'state
val maxName : Mono.file -> int
+
+ val appLoc : (Mono.exp -> unit) -> Mono.file -> unit
end
end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index bb09f84d..39305d1b 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -467,6 +467,51 @@ fun foldB {typ, exp, bind} ctx s e =
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 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
| 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
diff --git a/src/sidecheck.sml b/src/sidecheck.sml
index 13cbccdb..b36d4935 100644
--- a/src/sidecheck.sml
+++ b/src/sidecheck.sml
@@ -31,38 +31,29 @@ open Mono
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