Avoid any JavaScript when pages don't need it; update demo prose

author: Adam Chlipala <adamc@hcoop.net> 2009-03-10 10:44:26 -0400
committer: Adam Chlipala <adamc@hcoop.net> 2009-03-10 10:44:26 -0400
commit: 6237af88655d8989ac803d3561074c4304c08922 (patch)
tree: da2a0ab3f900743c5d1aaa01d30b665aa858f021
parent: 2b9a7afa2abf672396d5ee38d9301f88b9a06dff (diff)
21 files changed, 232 insertions, 35 deletions
diff --git a/demo/metaform.ur b/demo/metaform.ur
index 0e2e5ee3..26462215 100644
--- a/demo/metaform.ur
+++ b/demo/metaform.ur
@@ -1,7 +1,7 @@
 functor Make (M : sig
                   con fs :: {Unit}
                   val fl : folder fs
-                  val names : $(mapUT string fs)
+                  val names : $(mapU string fs)
               end) = struct
 
     fun handler values = return <xml><body>
@@ -14,9 +14,9 @@ functor Make (M : sig
 
     fun main () = return <xml><body>
       <form>
-        {foldUR [string] [fn cols :: {Unit} => xml form [] (mapUT string cols)]
+        {foldUR [string] [fn cols :: {Unit} => xml form [] (mapU string cols)]
                 (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] name
-                                 (acc : xml form [] (mapUT string rest)) => <xml>
+                                 (acc : xml form [] (mapU string rest)) => <xml>
                                    <li> {[name]}: <textbox{nm}/></li>
                                    {useMore acc}
                                  </xml>)
diff --git a/demo/metaform.urs b/demo/metaform.urs
index 505cb906..0544e56b 100644
--- a/demo/metaform.urs
+++ b/demo/metaform.urs
@@ -1,7 +1,7 @@
 functor Make (M : sig
                   con fs :: {Unit}
                   val fl : folder fs
-                  val names : $(mapUT string fs)
+                  val names : $(mapU string fs)
               end) : sig
     val main : unit -> transaction page
 end
diff --git a/demo/prose b/demo/prose
index 29c12c38..e7de3471 100644
--- a/demo/prose
+++ b/demo/prose
@@ -1,4 +1,4 @@
-<p><b>Ur/Web</b> is a domain-specific language for programming web applications backed by SQL databases.  It is (strongly) statically-typed (like ML and Haskell) and purely functional (like Haskell).  <b>Ur</b> is the base language, and the web-specific features of Ur/Web (mostly) come only in the form of special rules for parsing and optimization.  The Ur core looks a lot like <a href="http://sml.sourceforge.net/">Standard ML</a>, with a few <a href="http://www.haskell.org/">Haskell</a>-isms added, and kinder, gentler versions added of many features from dependently-typed languages like the logic behind <a href="http://coq.inria.fr/">Coq</a>.  The type system is much more expressive than in ML and Haskell, such that well-typed web applications cannot "go wrong," not just in handling single HTTP requests, but across their entire lifetimes of interacting with HTTP clients.  Beyond that, Ur is unusual is using ideas from dependent typing to enable very effective metaprogramming, or programming with explicit analysis of type structure.  Many common web application components can be built by Ur/Web functions that operate on types, where it seems impossible to achieve similar code re-use in more established languages.</p>
+<p><b>Ur/Web</b> is a domain-specific language for programming web applications backed by SQL databases.  It is (strongly) statically-typed (like ML and Haskell) and purely functional (like Haskell).  <b>Ur</b> is the base language, and the web-specific features of Ur/Web (mostly) come only in the form of special rules for parsing and optimization.  The Ur core looks a lot like <a href="http://sml.sourceforge.net/">Standard ML</a>, with a few <a href="http://www.haskell.org/">Haskell</a>-isms added, and kinder, gentler versions added of many features from dependently-typed languages like the logic behind <a href="http://coq.inria.fr/">Coq</a>.  The type system is much more expressive than in ML and Haskell, such that well-typed web applications cannot "go wrong," not just in handling single HTTP requests, but across their entire lifetimes of interacting with HTTP clients.  Beyond that, Ur is unusual in using ideas from dependent typing to enable very effective metaprogramming, or programming with explicit analysis of type structure.  Many common web application components can be built by Ur/Web functions that operate on types, where it seems impossible to achieve similar code re-use in more established statically-typed languages.</p>
 
 <p>This demo is built automatically from Ur/Web sources and supporting files.  If you unpack the Ur/Web source distribution, then the following steps will build you a local version of this demo:
 
@@ -92,19 +92,33 @@ ref.urp
 
 <p>The functor creates a new encapsulated SQL sequence and table on each call.  These local relations show up in the automatically-generated SQL file that should be run to prepare the database for use, but they are invisible from client code.  We could change the functor to create different SQL relations, without needing to change client code.</p>
 
+<p>Note that, in <tt>ref.ur</tt>, the <tt>inj</tt> components of functor arguments are omitted.  Since these arguments are type class witnesses, the compiler infers them automatically based on the choices of <tt>data</tt>.</p>
+
 tree.urp
 
 <p>Here we see how we can abstract over common patterns of SQL queries.  In particular, since standard SQL does not help much with queries over trees, we write a function for traversing an SQL tree, building an HTML representation, based on a user-provided function for rendering individual rows.</p>
 
+<p>The signature of <tt>TreeFun.Make</tt> tells us that, to instantiate the functor, we must provide</p>
+<ol>
+        <li> A primary key type <tt>key</tt></li>
+        <li> SQL field names <tt>id</tt> (for primary keys) and <tt>parent</tt> (for parent links)</li>
+        <li> A type-level record <tt>cols</tt> of field names besides <tt>id</tt> and <tt>parent</tt></li>
+        <li> "Proofs" that <tt>id</tt> is distinct from <tt>parent</tt> and that neither of <tt>id</tt> and <tt>parent</tt> appears in <tt>cols</tt></li>
+        <li> Witnesses that both <tt>key</tt> and <tt>option key</tt> belong to the type class <tt>sql_injectable</tt>, which indicates that they are fair game to use with SQL</li>
+        <li> An SQL table <tt>tab</tt>, containing a field <tt>id</tt> of type <tt>key</tt>, a field <tt>parent</tt> of type <tt>option key</tt>, and every field of <tt>cols</tt></li>
+</ol>
+
 sum.urp
 
 <p>Metaprogramming is one of the most important facilities of Ur.  This example shows how to write a function that is able to sum up the fields of records of integers, no matter which set of fields the particular record has.</p>
 
 <p>Ur's support for analysis of types is based around extensible records, or <i>row types</i>.  In the definition of the <tt>sum</tt> function, we see the type parameter <tt>fs</tt> assigned the <i>kind</i> <tt>{Unit}</tt>, which stands for records of types of kind <tt>Unit</tt>.  The <tt>Unit</tt> kind has only one inhabitant, <tt>()</tt>.  The kind <tt>Type</tt> is for "normal" types.</p>
 
-<p>The unary <tt>$</tt> operator is used to build a record <tt>Type</tt> from a <tt>{Type}</tt> (that is, the kind of records of types).  The library function <tt>mapUT</tt> takes in a <tt>Type</tt> <i>t</i> and a <tt>{Unit}</tt> <i>r</i>, and it builds a <tt>{Type}</tt> as long as <i>r</i>, where every field is assigned value <i>t</i>.</p>
+<p>The <tt>sum</tt> function also takes an argument <tt>fl</tt> of type <tt>folder fs</tt>.  Folders represent permutations of the elements of type-level records.  We can use a folder to iterate over a type-level record in the order indicated by the permutation.</p>
+
+<p>The unary <tt>$</tt> operator is used to build a record <tt>Type</tt> from a <tt>{Type}</tt> (that is, the kind of records of types).  The library function <tt>mapU</tt> takes in a type <i>t</i> of kind <t>K</t> and a <tt>{Unit}</tt> <i>r</i>, and it builds a <tt>{K}</tt> as long as <i>r</i>, where every field is assigned value <i>t</i>.</p>
 
-<p>Another library function <tt>foldUR</tt> is defined at the level of expressions, while <tt>mapUT</tt> is a type-level function.  <tt>foldUR</tt> takes 6 arguments, some of them types and some values.  Type arguments are distinguished by being written within brackets.  The arguments to <tt>foldUR</tt> respectively tell us:
+<p>Another library function <tt>foldUR</tt> is defined at the level of expressions, while <tt>mapU</tt> is a type-level function.  <tt>foldUR</tt> takes 7 arguments, some of them types and some values.  Type arguments are distinguished by being written within brackets.  The arguments to <tt>foldUR</tt> respectively tell us:
 
 <ol>
 <li> The type we will assign to each record field</li>
@@ -112,6 +126,7 @@ sum.urp
 <li> A function that updates the accumulator based on the current record field name, the rest of the input record type, the current record field value, and the current accumulator</li>
 <li> The initial accumulator value</li>
 <li> The input record type</li>
+<li> A folder for that type</li>
 <li> The input record value</li>
 </ol>
 
@@ -119,7 +134,7 @@ An unusual part of the third argument is the syntax <tt>[t1 ~ t2]</tt> within a
 
 <p>The general syntax for constant row types is <tt>[Name1 = t1, ..., NameN = tN]</tt>, and there is a shorthand version <tt>[Name1, ..., NameN]</tt> for records of <tt>Unit</tt>s.</p>
 
-<p>With <tt>sum</tt> defined, it is easy to make some sample calls.  The form of the code for <tt>main</tt> does not make it apparent, but the compiler must "reverse engineer" the appropriate <tt>{Unit}</tt> from the <tt>{Type}</tt> available from the context at each call to <tt>sum</tt>.</p>
+<p>With <tt>sum</tt> defined, it is easy to make some sample calls.  The form of the code for <tt>main</tt> does not make it apparent, but the compiler must "reverse engineer" the appropriate <tt>{Unit}</tt> from the <tt>{Type}</tt> available from the context at each call to <tt>sum</tt>.  The compiler also infers a <tt>folder</tt> for each call, guessing at the desired permutations by examining the orders in which field names are written in the code.</p>
 
 tcSum.urp
 
@@ -129,8 +144,8 @@ metaform1.urp
 
 <p>We can use metaprogramming with row types to build HTML forms (and their handlers) generically.  The functor <tt>Metaform.Make</tt> takes in a unit row <tt>fs</tt> and a value-level record <tt>names</tt> assigning string names to the fields of <tt>fs</tt>.  The functor implementation builds a form handler with a library function <tt>foldURX2</tt>, which runs over two value-level records in parallel, building an XML fragment.</p>
 
-<p>The form itself is generated using the more primitive <tt>foldUR</tt>.  We see the type <tt>xml form [] (mapUT string cols)</tt> as the result of the fold.  This is the type of XML fragments that are suitable for inclusion in forms, require no form fields to be defined on entry, and themselves define form fields whose names and types are given by <tt>mapUT string cols</tt>.  The <tt>useMore</tt> function "weakens" the type of an XML fragment, so that it "pretends" to require additional fields as input.  This weakening is necessary to accommodate the general typing rule for concatenating bits of XML.</tt>
-<p>The functor use in <tt>Metaform1</tt> is trivial.  The compiler infers the value of the structure member <tt>fs</tt> from the type of the value provided for <tt>names</tt>.</p>
+<p>The form itself is generated using the more primitive <tt>foldUR</tt>.  We see the type <tt>xml form [] (mapU string cols)</tt> as the result of the fold.  This is the type of XML fragments that are suitable for inclusion in forms, require no form fields to be defined on entry, and themselves define form fields whose names and types are given by <tt>mapU string cols</tt>.  The <tt>useMore</tt> function "weakens" the type of an XML fragment, so that it "pretends" to require additional fields as input.  This weakening is necessary to accommodate the general typing rule for concatenating bits of XML.</tt>
+<p>The functor use in <tt>Metaform1</tt> is trivial.  The compiler infers the values of the structure members <tt>fs</tt> and <tt>fl</tt> from the type of the value provided for <tt>names</tt>.</p>
 
 metaform2.urp
 
@@ -165,7 +180,7 @@ crud1.urp
 
 <p>Looking at <tt>crud1.ur</tt>, we see that a use of the functor is almost trivial.  Only the value components of the argument structure must be provided.  The column row type is inferred, and the disjointness constraint is proved automatically.</p>
 
-<p>We won't go into detail on the implementation of <tt>Crud.Make</tt>.  The types of the functions used there can be found in the signatures of the built-in <tt>Basis</tt> module and the <tt>Top</tt> module from the standard library.  The signature of the first and the signature and implementation of the second can be found in the <tt>lib</tt> directory of the Ur/Web distribution.</p>
+<p>We won't go into detail on the implementation of <tt>Crud.Make</tt>.  The types of the functions used there can be found in the signatures of the built-in <tt>Basis</tt> module and the <tt>Top</tt> module from the standard library.  The signature of the first and the signature and implementation of the second can be found in the <tt>lib/ur</tt> directory of the Ur/Web distribution.</p>
 
 crud2.urp
 
diff --git a/demo/ref.ur b/demo/ref.ur
index 1e406dd9..983cc814 100644
--- a/demo/ref.ur
+++ b/demo/ref.ur
@@ -1,9 +1,9 @@
 structure IR = RefFun.Make(struct
-                               type t = int
+                               type data = int
                            end)
 
 structure SR = RefFun.Make(struct
-                               type t = string
+                               type data = string
                            end)
 
 fun main () =
diff --git a/demo/sql.urp b/demo/sql.urp
index 06fbbd24..7894da95 100644
--- a/demo/sql.urp
+++ b/demo/sql.urp
@@ -1,4 +1,3 @@
-debug
 database dbname=test
 sql sql.sql
 
diff --git a/demo/sum.ur b/demo/sum.ur
index d2c03004..d967454c 100644
--- a/demo/sum.ur
+++ b/demo/sum.ur
@@ -1,4 +1,4 @@
-fun sum (fs ::: {Unit}) (fl : folder fs) (x : $(mapUT int fs)) =
+fun sum (fs ::: {Unit}) (fl : folder fs) (x : $(mapU int fs)) =
     foldUR [int] [fn _ => int]
     (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] n acc => n + acc)
     0 [fs] fl x
diff --git a/demo/tcSum.ur b/demo/tcSum.ur
index 080de173..13cefc39 100644
--- a/demo/tcSum.ur
+++ b/demo/tcSum.ur
@@ -1,4 +1,4 @@
-fun sum (t ::: Type) (_ : num t) (fs ::: {Unit}) (fl : folder fs) (x : $(mapUT t fs)) =
+fun sum (t ::: Type) (_ : num t) (fs ::: {Unit}) (fl : folder fs) (x : $(mapU t fs)) =
     foldUR [t] [fn _ => t]
     (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] n acc => n + acc)
     zero [fs] fl x
diff --git a/demo/tree.urp b/demo/tree.urp
index 880a7ab4..0ded4202 100644
--- a/demo/tree.urp
+++ b/demo/tree.urp
@@ -1,4 +1,3 @@
-debug
 database dbname=test
 sql tree.sql
 
diff --git a/include/urweb.h b/include/urweb.h
index a5bb8dc0..fb3b5068 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -39,6 +39,7 @@ void uw_write(uw_context, const char*);
 uw_Basis_int uw_Basis_new_client_source(uw_context, uw_Basis_string);
 uw_unit uw_Basis_set_client_source(uw_context, uw_Basis_int, uw_Basis_string);
 
+void uw_set_script_header(uw_context, const char*);
 char *uw_Basis_get_script(uw_context, uw_unit);
 
 char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int);
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index 053075bd..f4adaba7 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -55,7 +55,7 @@ con fst3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.1
 con snd3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.2
 con thd3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.3
 
-con mapUT = fn f :: Type => map (fn _ :: Unit => f)
+con mapU = K ==> fn f :: K => map (fn _ :: Unit => f)
 
 con ex = fn tf :: (Type -> Type) =>
             res ::: Type -> (choice :: Type -> tf choice -> res) -> res
@@ -75,7 +75,7 @@ fun foldUR (tf :: Type) (tr :: {Unit} -> Type)
                 -> [[nm] ~ rest] =>
                       tf -> tr rest -> tr ([nm] ++ rest))
            (i : tr []) (r :: {Unit}) (fold : folder r)=
-    fold [fn r :: {Unit} => $(mapUT tf r) -> tr r]
+    fold [fn r :: {Unit} => $(mapU tf r) -> tr r]
          (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc
                           [[nm] ~ rest] r =>
              f [nm] [rest] ! r.nm (acc (r -- nm)))
@@ -86,7 +86,7 @@ fun foldUR2 (tf1 :: Type) (tf2 :: Type) (tr :: {Unit} -> Type)
                 -> [[nm] ~ rest] =>
                       tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest))
            (i : tr []) (r :: {Unit}) (fold : folder r) =
-    fold [fn r :: {Unit} => $(mapUT tf1 r) -> $(mapUT tf2 r) -> tr r]
+    fold [fn r :: {Unit} => $(mapU tf1 r) -> $(mapU tf2 r) -> tr r]
          (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc
                           [[nm] ~ rest] r1 r2 =>
              f [nm] [rest] ! r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index 583b025f..bb85abd0 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -29,7 +29,7 @@ con fst3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.1
 con snd3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.2
 con thd3 = K1 ==> K2 ==> K3 ==> fn t :: (K1 * K2 * K3) => t.3
 
-con mapUT = fn f :: Type => map (fn _ :: Unit => f)
+con mapU = K ==> fn f :: K => map (fn _ :: Unit => f)
 
 con ex = fn tf :: (Type -> Type) =>
             res ::: Type -> (choice :: Type -> tf choice -> res) -> res
@@ -46,19 +46,19 @@ val foldUR : tf :: Type -> tr :: ({Unit} -> Type)
              -> (nm :: Name -> rest :: {Unit}
                  -> [[nm] ~ rest] =>
                        tf -> tr rest -> tr ([nm] ++ rest))
-             -> tr [] -> r :: {Unit} -> folder r -> $(mapUT tf r) -> tr r
+             -> tr [] -> r :: {Unit} -> folder r -> $(mapU tf r) -> tr r
 
 val foldUR2 : tf1 :: Type -> tf2 :: Type -> tr :: ({Unit} -> Type)
              -> (nm :: Name -> rest :: {Unit}
                  -> [[nm] ~ rest] =>
                        tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest))
-             -> tr [] -> r :: {Unit} -> folder r -> $(mapUT tf1 r) -> $(mapUT tf2 r) -> tr r
+             -> tr [] -> r :: {Unit} -> folder r -> $(mapU tf1 r) -> $(mapU tf2 r) -> tr r
 
 val foldURX2: tf1 :: Type -> tf2 :: Type -> ctx :: {Unit}
               -> (nm :: Name -> rest :: {Unit}
                   -> [[nm] ~ rest] =>
                         tf1 -> tf2 -> xml ctx [] [])
-              -> r :: {Unit} -> folder r -> $(mapUT tf1 r) -> $(mapUT tf2 r) -> xml ctx [] []
+              -> r :: {Unit} -> folder r -> $(mapU tf1 r) -> $(mapU tf2 r) -> xml ctx [] []
 
 val foldR : K --> tf :: (K -> Type) -> tr :: ({K} -> Type)
              -> (nm :: Name -> t :: K -> rest :: {K}
diff --git a/src/c/urweb.c b/src/c/urweb.c
index e28fa5f4..823e8824 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -42,6 +42,8 @@ struct uw_context {
 
   cleanup *cleanup, *cleanup_front, *cleanup_back;
 
+  const char *script_header;
+
   char error_message[ERROR_BUF_LEN];
 };
 
@@ -71,6 +73,8 @@ uw_context uw_init(size_t outHeaders_len, size_t script_len, size_t page_len, si
 
   ctx->cleanup_front = ctx->cleanup_back = ctx->cleanup = malloc(0);
 
+  ctx->script_header = "";
+  
   ctx->error_message[0] = 0;
 
   ctx->script_front = ctx->script = malloc(script_len);
@@ -235,6 +239,10 @@ char *uw_get_optional_input(uw_context ctx, int n) {
   return (ctx->inputs[n] == NULL ? "" : ctx->inputs[n]);
 }
 
+void uw_set_script_header(uw_context ctx, const char *s) {
+  ctx->script_header = s;
+}
+
 static void uw_check_heap(uw_context ctx, size_t extra) {
   if (ctx->heap_back - ctx->heap_front < extra) {
     size_t desired = ctx->heap_front - ctx->heap + extra, next;
@@ -380,9 +388,9 @@ char *uw_Basis_get_script(uw_context ctx, uw_unit u) {
     r[0] = 0;
     return r;
   } else {
-    char *r = uw_malloc(ctx, 41 + (ctx->script_front - ctx->script));
+    char *r = uw_malloc(ctx, 41 + (ctx->script_front - ctx->script) + strlen(ctx->script_header));
 
-    sprintf(r, "<script>%s</script>", ctx->script);
+    sprintf(r, "%s<script>%s</script>", ctx->script_header, ctx->script);
     return r;
   }
 }
diff --git a/src/cjr.sml b/src/cjr.sml
index a38a1b0d..688326e4 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -113,6 +113,10 @@ datatype decl' =
 
 withtype decl = decl' located
 
-type file = decl list * (Core.export_kind * string * int * typ list * typ) list
+datatype sidedness =
+         ServerOnly
+       | ServerAndClient
+
+type file = decl list * (Core.export_kind * string * int * typ list * typ * sidedness) list
 
 end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index aff5efd3..ab808426 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008, Adam Chlipala
+(* Copyright (c) 2008-2009, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -2130,7 +2130,7 @@ fun p_file env (ds, ps) =
                                                 E.declBinds env d))
                              env ds
 
-        val fields = foldl (fn ((ek, _, _, ts, _), fields) =>
+        val fields = foldl (fn ((ek, _, _, ts, _, _), fields) =>
                                case ek of
                                    Core.Link => fields
                                  | Core.Rpc => fields
@@ -2251,7 +2251,7 @@ fun p_file env (ds, ps) =
                              string "}"]
                 end
 
-        fun p_page (ek, s, n, ts, ran) =
+        fun p_page (ek, s, n, ts, ran, side) =
             let
                 val (ts, defInputs, inputsVar) =
                     case ek of
@@ -2346,6 +2346,12 @@ fun p_file env (ds, ps) =
                                     string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
                                     newline,
                                     string "uw_write(ctx, \"<html>\");",
+                                    newline,
+                                    string "uw_set_script_header(ctx, \"",
+                                    string (case side of
+                                                ServerAndClient => "<script src=\\\"/app.js\\\"></script>\\n"
+                                              | ServerOnly => ""),
+                                    string "\");",
                                     newline]),
                      box [string "{",
                           newline,
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 9d9ab36c..e637c82c 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -519,7 +519,7 @@ fun cifyDecl ((d, loc), sm) =
             val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts
             val (t, sm) = cifyTyp (t, sm)
         in
-            (NONE, SOME (ek, "/" ^ s, n, ts, t), sm)
+            (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndClient), sm)
         end
 
       | L.DTable (s, xts) =>
diff --git a/src/compiler.sig b/src/compiler.sig
index b7418f2a..8ef41a58 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -80,6 +80,7 @@ signature COMPILER = sig
     val fuse : (Mono.file, Mono.file) phase
     val pathcheck : (Mono.file, Mono.file) phase
     val cjrize : (Mono.file, Cjr.file) phase
+    val scriptcheck : (Cjr.file, Cjr.file) phase
     val prepare : (Cjr.file, Cjr.file) phase
     val sqlify : (Mono.file, Cjr.file) phase
 
@@ -115,6 +116,7 @@ signature COMPILER = sig
     val toMono_shake2 : (string, Mono.file) transform
     val toPathcheck : (string, Mono.file) transform
     val toCjrize : (string, Cjr.file) transform
+    val toScriptcheck : (string, Cjr.file) transform
     val toPrepare : (string, Cjr.file) transform
     val toSqlify : (string, Cjr.file) transform
 
diff --git a/src/compiler.sml b/src/compiler.sml
index d74da2a6..b433a7b6 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -558,12 +558,19 @@ val cjrize = {
 
 val toCjrize = transform cjrize "cjrize" o toPathcheck
 
+val scriptcheck = {
+    func = ScriptCheck.classify,
+    print = CjrPrint.p_file CjrEnv.empty
+}
+
+val toScriptcheck = transform scriptcheck "scriptcheck" o toCjrize
+
 val prepare = {
     func = Prepare.prepare,
     print = CjrPrint.p_file CjrEnv.empty
 }
 
-val toPrepare = transform prepare "prepare" o toCjrize
+val toPrepare = transform prepare "prepare" o toScriptcheck
 
 val sqlify = {
     func = Cjrize.cjrize,
diff --git a/src/monoize.sml b/src/monoize.sml
index 892ae81f..57bf26e3 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1924,9 +1924,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             in
                 case tag of
                     "body" => normal ("body", NONE,
-                                      SOME (L'.EStrcat ((L'.EPrim (Prim.String "<script src=\"/app.js\"></script>"), loc),
-                                                        (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]),
-                                                         loc)), loc))
+                                      SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
 
                   | "dyn" =>
                     (case attrs of
diff --git a/src/scriptcheck.sig b/src/scriptcheck.sig
new file mode 100644
index 00000000..bc9b6377
--- /dev/null
+++ b/src/scriptcheck.sig
@@ -0,0 +1,32 @@
+(* Copyright (c) 2009, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+signature SCRIPT_CHECK = sig
+
+    val classify : Cjr.file -> Cjr.file
+
+end
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
new file mode 100644
index 00000000..bfe87766
--- /dev/null
+++ b/src/scriptcheck.sml
@@ -0,0 +1,123 @@
+(* Copyright (c) 2009, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure ScriptCheck :> SCRIPT_CHECK = struct
+
+open Cjr
+
+structure SS = BinarySetFn(struct
+                           type ord_key = string
+                           val compare = String.compare
+                           end)
+structure IS = IntBinarySet
+
+val csBasis = SS.addList (SS.empty,
+                          ["new_client_source",
+                           "get_client_source",
+                           "set_client_source",
+                           "alert"])
+
+fun classify (ds, ps) =
+    let
+        fun inString {needle, haystack} =
+            let
+                val (_, suffix) = Substring.position needle (Substring.full haystack)
+            in
+                not (Substring.isEmpty suffix)
+            end
+
+        fun hasClient csids =
+            let
+                fun hasClient e =
+                    case #1 e of
+                        EPrim (Prim.String s) => inString {needle = "<script", haystack = s}
+                      | EPrim _ => false
+                      | ERel _ => false
+                      | ENamed n => IS.member (csids, n)
+                      | ECon (_, _, NONE) => false
+                      | ECon (_, _, SOME e) => hasClient e
+                      | ENone _ => false
+                      | ESome (_, e) => hasClient e
+                      | EFfi ("Basis", x) => SS.member (csBasis, x)
+                      | EFfi _ => false
+                      | EFfiApp ("Basis", x, es) => SS.member (csBasis, x)
+                                                    orelse List.exists hasClient es
+                      | EFfiApp (_, _, es) => List.exists hasClient es
+                      | EApp (e, es) => hasClient e orelse List.exists hasClient es
+                      | EUnop (_, e) => hasClient e
+                      | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2
+                      | ERecord (_, xes) => List.exists (hasClient o #2) xes
+                      | EField (e, _) => hasClient e
+                      | ECase (e, pes, _) => hasClient e orelse List.exists (hasClient o #2) pes
+                      | EError (e, _) => hasClient e
+                      | EWrite e => hasClient e
+                      | ESeq (e1, e2) => hasClient e1 orelse hasClient e2
+                      | ELet (_, _, e1, e2) => hasClient e1 orelse hasClient e2
+                      | EQuery {query, body, initial, ...} => hasClient query orelse hasClient body
+                                                              orelse hasClient initial
+                      | EDml {dml, ...} => hasClient dml
+                      | ENextval {seq, ...} => hasClient seq
+                      | EUnurlify (e, _) => hasClient e
+            in
+                hasClient
+            end
+
+        fun decl ((d, _), csids) =
+            let
+                val hasClient = hasClient csids
+            in
+                case d of
+                    DVal (_, n, _, e) => if hasClient e then
+                                             IS.add (csids, n)
+                                         else
+                                             csids
+                  | DFun (_, n, _, _, e) => if hasClient e then
+                                                IS.add (csids, n)
+                                            else
+                                                csids
+                  | DFunRec xes => if List.exists (fn (_, _, _, _, e) => hasClient e) xes then
+                                       foldl (fn ((_, n, _, _, _), csids) => IS.add (csids, n))
+                                             csids xes
+                                   else
+                                       csids
+                  | _ => csids
+            end
+
+        val csids = foldl decl IS.empty ds
+
+        val ps = map (fn (ek, x, n, ts, t, _) =>
+                         (ek, x, n, ts, t,
+                          if IS.member (csids, n) then
+                              ServerAndClient
+                          else
+                              ServerOnly)) ps
+    in
+        (ds, ps)
+    end
+
+end
+
diff --git a/src/sources b/src/sources
index f5574365..ba453f62 100644
--- a/src/sources
+++ b/src/sources
@@ -160,6 +160,9 @@ cjr_print.sml
 cjrize.sig
 cjrize.sml
 
+scriptcheck.sig
+scriptcheck.sml
+
 prepare.sig
 prepare.sml
author	Adam Chlipala <adamc@hcoop.net>	2009-03-10 10:44:26 -0400
committer	Adam Chlipala <adamc@hcoop.net>	2009-03-10 10:44:26 -0400
commit	6237af88655d8989ac803d3561074c4304c08922 (patch)
tree	da2a0ab3f900743c5d1aaa01d30b665aa858f021
parent	2b9a7afa2abf672396d5ee38d9301f88b9a06dff (diff)