(* Copyright (c) 2008-2010, 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 Demo :> DEMO = struct
val noEmacs = ref false
fun make' {prefix, dirname, guided} =
let
val prose = OS.Path.joinDirFile {dir = dirname,
file = "prose"}
val inf = TextIO.openIn prose
val outDir = OS.Path.concat (dirname, "out")
val () = if OS.FileSys.access (outDir, []) then
()
else
OS.FileSys.mkDir outDir
val fname = OS.Path.joinDirFile {dir = outDir,
file = "index.html"}
val out = TextIO.openOut fname
val () = (TextIO.output (out, "\n");
TextIO.closeOut out)
val fname = OS.Path.joinDirFile {dir = outDir,
file = "demos.html"}
val demosOut = TextIO.openOut fname
val () = (TextIO.output (demosOut, "\n\n");
TextIO.output (demosOut, " Intro\n\n"))
val fname = OS.Path.joinDirFile {dir = dirname,
file = "demo.urs"}
val ursOut = TextIO.openOut fname
val () = (TextIO.output (ursOut, "val main : unit -> transaction page\n");
TextIO.closeOut ursOut)
val fname = OS.Path.joinDirFile {dir = dirname,
file = "demo.ur"}
val urOut = TextIO.openOut fname
val () = TextIO.output (urOut, "fun main () = return \n")
fun mergeWith f (o1, o2) =
case (o1, o2) of
(NONE, _) => o2
| (_, NONE) => o1
| (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
else
raise Fail "Different demos want to use different database strings")
(#database combined, #database urp),
sources = foldl (fn (file, files) =>
if List.exists (fn x => x = file) files then
files
else
files @ [file])
(#sources combined) (#sources urp),
exe = case Settings.getExe () of
NONE => OS.Path.joinDirFile {dir = dirname,
file = "demo.exe"}
| SOME s => s,
sql = SOME (case Settings.getSql () of
NONE => OS.Path.joinDirFile {dir = dirname,
file = "demo.sql"}
| SOME s => s),
debug = Settings.getDebug (),
timeout = Int.max (#timeout combined, #timeout urp),
profile = false,
ffi = [],
link = [],
headers = [],
scripts = [],
clientToServer = [],
effectful = [],
benignEffectful = [],
clientOnly = [],
serverOnly = [],
jsFuncs = [],
rewrites = #rewrites combined @ #rewrites urp,
filterUrl = #filterUrl combined @ #filterUrl urp,
filterMime = #filterMime combined @ #filterMime urp,
protocol = mergeWith #2 (#protocol combined, #protocol urp),
dbms = mergeWith #2 (#dbms combined, #dbms urp),
sigFile = mergeWith #2 (#sigFile combined, #sigFile urp),
safeGets = [],
onError = NONE,
minHeap = 0
}
val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
fun capitalize "" = ""
| capitalize s = str (Char.toUpper (String.sub (s, 0)))
^ String.extract (s, 1, NONE)
fun startUrp urp =
let
val base = OS.Path.base urp
val name = capitalize base
val () = (TextIO.output (demosOut, " ");
TextIO.output (demosOut, name);
TextIO.output (demosOut, "\n"))
val () = (TextIO.output (urOut, " ");
TextIO.output (urOut, name);
TextIO.output (urOut, "\n"))
val urp_file = OS.Path.joinDirFile {dir = dirname,
file = urp}
val out = OS.Path.joinBaseExt {base = base,
ext = SOME "html"}
val out = OS.Path.joinDirFile {dir = outDir,
file = out}
val out = TextIO.openOut out
val () = (TextIO.output (out, "\n");
TextIO.closeOut out)
val () = TextIO.closeOut out
val out = OS.Path.joinBaseExt {base = base,
ext = SOME "desc"}
val out = OS.Path.joinBaseExt {base = out,
ext = SOME "html"}
val out = TextIO.openOut (OS.Path.joinDirFile {dir = outDir,
file = out})
in
case parse (OS.Path.base urp_file) of
NONE => raise Fail ("Can't parse " ^ urp_file)
| SOME urpData =>
(TextIO.output (out, "\n");
TextIO.output (out, name);
TextIO.output (out, "\n\n\n");
TextIO.output (out, name);
TextIO.output (out, "
\n\n[ Application");
TextIO.output (out, " | ");
TextIO.output (out, urp);
TextIO.output (out, "");
app (fn file =>
let
fun ifEx s =
let
val src = OS.Path.joinBaseExt {base = file,
ext = SOME s}
val src' = OS.Path.file src
in
if String.isPrefix (OS.Path.mkAbsolute {path = dirname,
relativeTo = OS.FileSys.getDir ()}) src
andalso OS.FileSys.access (src, []) then
(TextIO.output (out, " | ");
TextIO.output (out, src');
TextIO.output (out, ""))
else
()
end
in
ifEx "urs";
ifEx "ur"
end) (#sources urpData);
TextIO.output (out, " ]\n\n");
(urpData, out))
end
fun endUrp out =
(TextIO.output (out, "\n\n");
TextIO.closeOut out)
fun readUrp (combined, out) =
let
fun finished () = endUrp out
fun readUrp' () =
case TextIO.inputLine inf of
NONE => (finished ();
combined)
| SOME line =>
if String.isSuffix ".urp\n" line then
let
val urp = String.substring (line, 0, size line - 1)
val (urpData, out) = startUrp urp
in
finished ();
readUrp (combiner (combined, urpData),
out)
end
else
(TextIO.output (out, line);
readUrp' ())
in
readUrp' ()
end
val indexFile = OS.Path.joinDirFile {dir = outDir,
file = "intro.html"}
val out = TextIO.openOut indexFile
val () = TextIO.output (out, "\nUr/Web Demo\n\n\n")
fun readIndex () =
let
fun finished () = (TextIO.output (out, "\n\n");
TextIO.closeOut out)
in
case TextIO.inputLine inf of
NONE => (finished ();
NONE)
| SOME line =>
if String.isSuffix ".urp\n" line then
let
val urp = String.substring (line, 0, size line - 1)
val (urpData, out) = startUrp urp
in
finished ();
SOME (readUrp (urpData,
out))
end
else
(TextIO.output (out, line);
readIndex ())
end
fun prettyPrint () =
let
val dir = Posix.FileSys.opendir dirname
fun loop () =
case Posix.FileSys.readdir dir of
NONE => Posix.FileSys.closedir dir
| SOME file =>
let
fun doit f =
f (OS.Path.joinDirFile {dir = dirname,
file = file},
OS.Path.mkAbsolute
{relativeTo = OS.FileSys.getDir (),
path = OS.Path.joinDirFile {dir = outDir,
file = OS.Path.joinBaseExt {base = file,
ext = SOME "html"}}})
fun highlight () =
doit (fn (src, html) =>
let
val dirty =
let
val srcSt = Posix.FileSys.stat src
val htmlSt = Posix.FileSys.stat html
in
Time.> (Posix.FileSys.ST.mtime srcSt,
Posix.FileSys.ST.mtime htmlSt)
end handle OS.SysErr _ => true
val cmd = "emacs --eval \"(progn "
^ "(global-font-lock-mode t) "
^ "(add-to-list 'load-path \\\""
^ Config.sitelisp
^ "/\\\") "
^ "(load \\\"urweb-mode-startup\\\") "
^ "(urweb-mode) "
^ "(find-file \\\""
^ src
^ "\\\") "
^ "(switch-to-buffer (htmlize-buffer)) "
^ "(write-file \\\""
^ html
^ "\\\") "
^ "(kill-emacs))\""
in
if dirty then
(print (">>> " ^ cmd ^ "\n");
ignore (OS.Process.system cmd))
else
()
end)
val highlight = fn () => if !noEmacs then () else highlight ()
in
if OS.Path.base file = "demo" then
()
else case OS.Path.ext file of
SOME "urp" =>
doit (fn (src, html) =>
let
val inf = TextIO.openIn src
val out = TextIO.openOut html
fun loop () =
case TextIO.inputLine inf of
NONE => ()
| SOME line => (TextIO.output (out, line);
loop ())
in
TextIO.output (out, "\n\n");
loop ();
TextIO.output (out, "\n\n");
TextIO.closeIn inf;
TextIO.closeOut out
end)
| SOME "urs" => highlight ()
| SOME "ur" => highlight ()
| _ => ();
loop ()
end
in
loop ()
end
in
case readIndex () of
NONE => raise Fail "No demo applications!"
| SOME combined =>
let
val () = (TextIO.output (urOut, "\n");
TextIO.closeOut urOut)
val fname = OS.Path.joinDirFile {dir = dirname,
file = "demo.urp"}
val outf = TextIO.openOut fname
fun filters kind =
app (fn rule : Settings.rule =>
(TextIO.output (outf, case #action rule of
Settings.Allow => "allow"
| Settings.Deny => "deny");
TextIO.output (outf, " ");
TextIO.output (outf, kind);
TextIO.output (outf, " ");
TextIO.output (outf, #pattern rule);
case #kind rule of
Settings.Exact => ()
| Settings.Prefix => TextIO.output (outf, "*");
TextIO.output (outf, "\n")))
in
Option.app (fn db => (TextIO.output (outf, "database ");
TextIO.output (outf, db);
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");
app (fn rule =>
(TextIO.output (outf, "rewrite ");
TextIO.output (outf, case #pkind rule of
Settings.Any => "any"
| Settings.Url => "url"
| Settings.Table => "table"
| Settings.Sequence => "sequence"
| Settings.View => "view"
| Settings.Relation => "relation"
| Settings.Cookie => "cookie"
| Settings.Style => "style");
TextIO.output (outf, " ");
TextIO.output (outf, #from rule);
case #kind rule of
Settings.Exact => ()
| Settings.Prefix => TextIO.output (outf, "*");
TextIO.output (outf, " ");
TextIO.output (outf, #to rule);
TextIO.output (outf, "\n"))) (#rewrites combined);
filters "url" (#filterUrl combined);
filters "mime" (#filterMime combined);
TextIO.output (outf, "\n");
app (fn s =>
let
val s = OS.Path.mkAbsolute {relativeTo = OS.FileSys.getDir (),
path = s}
in
TextIO.output (outf, s);
TextIO.output (outf, "\n")
end)
(#sources combined);
TextIO.output (outf, "\n");
TextIO.output (outf, "demo\n");
TextIO.closeOut outf;
let
val b = Compiler.compile (OS.Path.base fname)
in
TextIO.output (demosOut, "\n\n");
TextIO.closeOut demosOut;
if b then
prettyPrint ()
else
();
b
end
end
end
fun make args = if make' args then
()
else
OS.Process.exit OS.Process.failure
end