diff options
author | Adam Chlipala <adamc@hcoop.net> | 2008-10-19 15:47:47 -0400 |
---|---|---|
committer | Adam Chlipala <adamc@hcoop.net> | 2008-10-19 15:47:47 -0400 |
commit | f47af837f76a49a6b8bcca24ea1a1e1fcfefab02 (patch) | |
tree | d6ab2f51a59206e3173d0f40da9266f3fb11fdc5 /src | |
parent | 0a1e81c5811d640c00d5b5984d2254e0d8521743 (diff) |
Support for URL prefixes that works with local demo
Diffstat (limited to 'src')
-rw-r--r-- | src/compiler.sig | 1 | ||||
-rw-r--r-- | src/compiler.sml | 38 | ||||
-rw-r--r-- | src/demo.sml | 4 | ||||
-rw-r--r-- | src/monoize.sig | 2 | ||||
-rw-r--r-- | src/monoize.sml | 17 |
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) |