summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-10-19 15:47:47 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-10-19 15:47:47 -0400
commitf47af837f76a49a6b8bcca24ea1a1e1fcfefab02 (patch)
treed6ab2f51a59206e3173d0f40da9266f3fb11fdc5 /src
parent0a1e81c5811d640c00d5b5984d2254e0d8521743 (diff)
Support for URL prefixes that works with local demo
Diffstat (limited to 'src')
-rw-r--r--src/compiler.sig1
-rw-r--r--src/compiler.sml38
-rw-r--r--src/demo.sml4
-rw-r--r--src/monoize.sig2
-rw-r--r--src/monoize.sml17
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)