Support for URL prefixes that works with local demo

5 files changed, 44 insertions, 18 deletions

diff --git a/src/compiler.sig b/src/compiler.sig
index 31a940c2..f0914d0f 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -30,6 +30,7 @@
 signature COMPILER = sig
 
     type job = {
+         prefix : string,
          database : string option,
          sources : string list,
          exe : string,
diff --git a/src/compiler.sml b/src/compiler.sml
index c413715a..717f5ae1 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -36,6 +36,7 @@ structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData
                          structure LrParser = LrParser)
 
 type job = {
+     prefix : string,
      database : string option,
      sources : string list,
      exe : string,
@@ -198,7 +199,7 @@ val parseUr = {
               handle LrParser.ParseError => [],
      print = SourcePrint.p_file}    
 
-fun p_job {database, exe, sql, sources, debug} =
+fun p_job {prefix, database, exe, sql, sources, debug} =
     let
         open Print.PD
         open Print
@@ -259,18 +260,19 @@ val parseUrp = {
                               readSources acc
                           end
 
-                  fun finish (database, exe, sql, debug, sources) =
-                      {database = database,
+                  fun finish (prefix, database, exe, sql, debug, sources) =
+                      {prefix = Option.getOpt (prefix, "/"),
+                       database = database,
                        exe = Option.getOpt (exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
                                                                       ext = SOME "exe"}),
                        sql = sql,
                        debug = debug,
                        sources = sources}
 
-                  fun read (database, exe, sql, debug) =
+                  fun read (prefix, database, exe, sql, debug) =
                       case TextIO.inputLine inf of
-                          NONE => finish (database, exe, sql, debug, [])
-                        | SOME "\n" => finish (database, exe, sql, debug, readSources [])
+                          NONE => finish (prefix, database, exe, sql, debug, [])
+                        | SOME "\n" => finish (prefix, database, exe, sql, debug, readSources [])
                         | SOME line =>
                           let
                               val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
@@ -278,28 +280,36 @@ val parseUrp = {
                               val arg = Substring.string (trim arg)
                           in
                               case cmd of
-                                  "database" =>
+                                  "prefix" =>
+                                  (case prefix of
+                                       NONE => ()
+                                     | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive";
+                                   read (SOME arg, database, exe, sql, debug))
+                                | "database" =>
                                   (case database of
                                        NONE => ()
                                      | SOME _ => ErrorMsg.error "Duplicate 'database' directive";
-                                   read (SOME arg, exe, sql, debug))
+                                   read (prefix, SOME arg, exe, sql, debug))
                                 | "exe" =>
                                   (case exe of
                                        NONE => ()
                                      | SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
-                                   read (database, SOME (relify arg), sql, debug))
+                                   read (prefix, database, SOME (relify arg), sql, debug))
                                 | "sql" =>
                                   (case sql of
                                        NONE => ()
                                      | SOME _ => ErrorMsg.error "Duplicate 'sql' directive";
-                                   read (database, exe, SOME (relify arg), debug))
-                                | "debug" => read (database, exe, sql, true)
+                                   read (prefix, database, exe, SOME (relify arg), debug))
+                                | "debug" => read (prefix, database, exe, sql, true)
                                 | _ => (ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
-                                        read (database, exe, sql, debug))
+                                        read (prefix, database, exe, sql, debug))
                           end
+
+                  val job = read (NONE, NONE, NONE, NONE, false)
               in
-                  read (NONE, NONE, NONE, false)
-                  before TextIO.closeIn inf
+                  TextIO.closeIn inf;
+                  Monoize.urlPrefix := #prefix job;
+                  job
               end,
     print = p_job
 }
diff --git a/src/demo.sml b/src/demo.sml
index 5bb11fa5..80506576 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -75,6 +75,7 @@ fun make {prefix, dirname} =
               | (SOME v1, SOME v2) => SOME (f (v1, v2))
 
         fun combiner (combined : Compiler.job, urp : Compiler.job) = {
+            prefix = prefix,
             database = mergeWith (fn (v1, v2) =>
                                      if v1 = v2 then
                                          v1
@@ -337,6 +338,9 @@ fun make {prefix, dirname} =
                                       TextIO.output (outf, "\n")))
                            (#database combined);
                 TextIO.output (outf, "sql demo.sql\n");
+                TextIO.output (outf, "prefix ");
+                TextIO.output (outf, prefix);
+                TextIO.output (outf, "\n");
                 TextIO.output (outf, "\n");
 
                 app (fn s =>
diff --git a/src/monoize.sig b/src/monoize.sig
index 838d7c4c..4e02e5ea 100644
--- a/src/monoize.sig
+++ b/src/monoize.sig
@@ -27,6 +27,8 @@
 
 signature MONOIZE = sig
 
+    val urlPrefix : string ref
+
     val monoize : CoreEnv.env -> Core.file -> Mono.file
 
     val liftExpInExp : int -> Mono.exp -> Mono.exp
diff --git a/src/monoize.sml b/src/monoize.sml
index da7b9767..720a9485 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -35,6 +35,8 @@ structure L' = Mono
 
 structure IM = IntBinaryMap
 
+val urlPrefix = ref "/"
+
 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
 
 structure U = MonoUtil
@@ -264,7 +266,7 @@ fun fooifyExp fk env =
                 let
                     val (_, _, _, s) = Env.lookupENamed env fnam
                 in
-                    ((L'.EPrim (Prim.String ("/" ^ s)), loc), fm)
+                    ((L'.EPrim (Prim.String (!urlPrefix ^ s)), loc), fm)
                 end
               | L'.EClosure (fnam, args) =>
                 let
@@ -287,7 +289,7 @@ fun fooifyExp fk env =
                           | _ => (E.errorAt loc "Type mismatch encoding attribute";
                                   (e, fm))
                 in
-                    attrify (args, ft, (L'.EPrim (Prim.String ("/" ^ s)), loc), fm)
+                    attrify (args, ft, (L'.EPrim (Prim.String (!urlPrefix ^ s)), loc), fm)
                 end
               | _ =>
                 case t of
@@ -1283,8 +1285,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
 
                                               val xp = " " ^ lowercaseFirst x ^ "=\""
 
-
-
                                               val (e, fm) = fooify env fm (e, t)
                                           in
                                               ((L'.EStrcat (s,
@@ -1677,6 +1677,15 @@ fun monoDecl (env, fm) (all as (d, loc)) =
 
 fun monoize env ds =
     let
+        val p = !urlPrefix
+        val () =
+            if p = "" then
+                urlPrefix := "/"
+            else if String.sub (p, size p - 1) <> #"/" then
+                urlPrefix := p ^ "/"
+            else
+                ()
+
         val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
                                      case monoDecl (env, fm) d of
                                          NONE => (env, fm, ds)