Announce sidedness errors with source locations

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