URLs

5 files changed, 39 insertions, 3 deletions

diff --git a/src/c/urweb.c b/src/c/urweb.c
index 67985d35..89358a06 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1973,3 +1973,7 @@ failure_kind uw_initialize(uw_context ctx) {
 
   return r;
 }
+
+uw_Basis_string uw_Basis_bless(uw_context ctx, uw_Basis_string s) {
+  return s;
+}
diff --git a/src/mono_opt.sig b/src/mono_opt.sig
index d0268087..b1652c71 100644
--- a/src/mono_opt.sig
+++ b/src/mono_opt.sig
@@ -30,4 +30,6 @@ signature MONO_OPT = sig
     val optimize : Mono.file -> Mono.file
     val optExp : Mono.exp -> Mono.exp
 
+    val bless : (string -> bool) ref
+
 end
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index dfa0420c..205ae3fb 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -30,6 +30,8 @@ structure MonoOpt :> MONO_OPT = struct
 open Mono
 structure U = MonoUtil
 
+val bless = ref (fn _ : string => true)
+
 fun typ t = t
 fun decl d = d
 
@@ -371,6 +373,13 @@ fun exp e =
 
       | EJavaScript (_, _, SOME (e, _)) => e
 
+      | EFfiApp ("Basis", "bless", [(se as EPrim (Prim.String s), loc)]) =>
+        (if !bless s then
+             ()
+         else
+             ErrorMsg.errorAt loc "Invalid URL passed to 'bless'";
+         se)
+
       | EFfiApp ("Basis", "checkString", [(EPrim (Prim.String s), loc)]) => 
         let
             fun uwify (cs, acc) =
diff --git a/src/monoize.sml b/src/monoize.sml
index 950de1e1..bf26fda2 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -126,6 +126,7 @@ fun monoType env =
                   | L.CApp ((L.CFfi ("Basis", "read"), _), t) =>
                     readType (mt env dtmap t, loc)
 
+                  | L.CFfi ("Basis", "url") => (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
@@ -2075,6 +2076,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                 L'.ERecord xes => xes
                               | _ => raise Fail "Non-record attributes!"
 
+                val attrs =
+                    if List.exists (fn ("Link", _, _) => true
+                                     | _ => false) attrs then
+                        List.filter (fn ("Href", _, _) => false
+                                      | _ => true) attrs
+                    else
+                        attrs
+
                 fun findOnload (attrs, acc) =
                     case attrs of
                         [] => (NONE, acc)
@@ -2137,8 +2146,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                       let
                                           val fooify =
                                               case x of
-                                                  "Href" => urlifyExp
-                                                | "Link" => urlifyExp
+                                                  "Link" => urlifyExp
+                                                | "Action" => urlifyExp
                                                 | _ => attrifyExp
 
                                           val xp = " " ^ lowercaseFirst x ^ "=\""
diff --git a/src/urweb.grm b/src/urweb.grm
index 7e1f6757..7288359a 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -1280,7 +1280,19 @@ tagHead: BEGIN_TAG                      (let
 attrs  :                                ([])
        | attr attrs                     (attr :: attrs)
 
-attr   : SYMBOL EQ attrv                ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), attrv)
+attr   : SYMBOL EQ attrv                ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)),
+                                         if (SYMBOL = "href" orelse SYMBOL = "src")
+                                            andalso (case #1 attrv of
+                                                         EPrim _ => true
+                                                       | _ => false) then
+                                             let
+                                                 val loc = s (attrvleft, attrvright)
+                                             in
+                                                 (EApp ((EVar (["Basis"], "bless", Infer), loc),
+                                                        attrv), loc)
+                                             end
+                                         else
+                                             attrv)
                 
 attrv  : INT                            (EPrim (Prim.Int INT), s (INTleft, INTright))
        | FLOAT                          (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))