safeGet

6 files changed, 33 insertions, 8 deletions

diff --git a/src/compiler.sig b/src/compiler.sig
index 6be2b22f..0516d97e 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2009, Adam Chlipala
+(* Copyright (c) 2008-2010, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -53,7 +53,8 @@ signature COMPILER = sig
          filterMime : Settings.rule list,
          protocol : string option,
          dbms : string option,
-         sigFile : string option
+         sigFile : string option,
+         safeGets : string list
     }
     val compile : string -> bool
     val compiler : string -> unit
diff --git a/src/compiler.sml b/src/compiler.sml
index 237cad08..5a97f13d 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -57,7 +57,8 @@ type job = {
      filterMime : Settings.rule list,
      protocol : string option,
      dbms : string option,
-     sigFile : string option
+     sigFile : string option,
+     safeGets : string list
 }
 
 type ('src, 'dst) phase = {
@@ -385,6 +386,7 @@ fun parseUrp' accLibs fname =
                 val protocol = ref NONE
                 val dbms = ref NONE
                 val sigFile = ref (Settings.getSigFile ())
+                val safeGets = ref []
 
                 fun finish sources =
                     let
@@ -413,7 +415,8 @@ fun parseUrp' accLibs fname =
                             sources = sources,
                             protocol = !protocol,
                             dbms = !dbms,
-                            sigFile = !sigFile
+                            sigFile = !sigFile,
+                            safeGets = rev (!safeGets)
                         }
 
                         fun mergeO f (old, new) =
@@ -456,7 +459,8 @@ fun parseUrp' accLibs fname =
                                                     (#sources old),
                             protocol = mergeO #2 (#protocol old, #protocol new),
                             dbms = mergeO #2 (#dbms old, #dbms new),
-                            sigFile = mergeO #2 (#sigFile old, #sigFile new)
+                            sigFile = mergeO #2 (#sigFile old, #sigFile new),
+                            safeGets = #safeGets old @ #safeGets new
                         }
                     in
                         if accLibs then
@@ -569,7 +573,7 @@ fun parseUrp' accLibs fname =
                               | "include" => headers := relifyA arg :: !headers
                               | "script" => scripts := arg :: !scripts
                               | "clientToServer" => clientToServer := ffiS () :: !clientToServer
-                              | "effectful" => effectful := ffiS () :: !effectful
+                              | "safeGet" => safeGets := arg :: !safeGets
                               | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
                               | "clientOnly" => clientOnly := ffiS () :: !clientOnly
                               | "serverOnly" => serverOnly := ffiS () :: !serverOnly
@@ -642,6 +646,7 @@ fun parseUrp' accLibs fname =
                 Settings.setMimeRules (#filterMime job);
                 Option.app Settings.setProtocol (#protocol job);
                 Option.app Settings.setDbms (#dbms job);
+                Settings.setSafeGets (#safeGets job);
                 job
             end
     in
diff --git a/src/demo.sml b/src/demo.sml
index 6ae64264..a67411de 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -114,7 +114,8 @@ fun make' {prefix, dirname, guided} =
             filterMime = #filterMime combined @ #filterMime urp,
             protocol = mergeWith #2 (#protocol combined, #protocol urp),
             dbms = mergeWith #2 (#dbms combined, #dbms urp),
-            sigFile = mergeWith #2 (#sigFile combined, #sigFile urp)
+            sigFile = mergeWith #2 (#sigFile combined, #sigFile urp),
+            safeGets = []
         }
 
         val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
diff --git a/src/effectize.sml b/src/effectize.sml
index 1685fbe9..7f148476 100644
--- a/src/effectize.sml
+++ b/src/effectize.sml
@@ -143,7 +143,12 @@ fun effectize file =
               | DExport (Link, n, _) =>
                 (case IM.find (writers, n) of
                      NONE => ()
-                   | SOME (loc, s) => ErrorMsg.errorAt loc ("A link (" ^ s ^ ") could cause side effects; try implementing it with a form instead");
+                   | SOME (loc, s) =>
+                     if Settings.isSafeGet s then
+                         ()
+                     else
+                         ErrorMsg.errorAt loc ("A link (" ^ s
+                                               ^ ") could cause side effects; try implementing it with a form instead");
                  ((DExport (Link, n, IM.inDomain (pushers, n)), #2 d), evs))
               | DExport (Action _, n, _) =>
                 ((DExport (Action (if IM.inDomain (writers, n) then
diff --git a/src/settings.sig b/src/settings.sig
index 3179c229..94472eb1 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -198,4 +198,8 @@ signature SETTINGS = sig
     val setSigFile : string option -> unit
     val getSigFile : unit -> string option
 
+    (* Which GET-able functions should be allowed to have side effects? *)
+    val setSafeGets : string list -> unit
+    val isSafeGet : string -> bool
+
 end
diff --git a/src/settings.sml b/src/settings.sml
index cd081725..97c16675 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -452,4 +452,13 @@ val sigFile = ref (NONE : string option)
 fun setSigFile v = sigFile := v
 fun getSigFile () = !sigFile
 
+structure SS = BinarySetFn(struct
+                           type ord_key = string
+                           val compare = String.compare
+                           end)
+
+val safeGet = ref SS.empty
+fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
+fun isSafeGet x = SS.member (!safeGet, x)
+
 end