Ur/Web: src/compiler.sml comparison

comparison src/compiler.sml @ 274:e4baf03a3a64

Generating SQL files

author	Adam Chlipala <adamc@hcoop.net>
date	Tue, 02 Sep 2008 13:44:54 -0400
parents	4d80d6122df1
children	fdd7a698be01

comparison

equal deleted inserted replaced

-:09c66a30ef32
+:e4baf03a3a64
 structure Lex = Lex
 structure LrParser = LrParser)
 type job = {
 database : string option,
-sources : string list
+sources : string list,
+exe : string,
+sql : string option,
+debug : bool
 }
 type ('src, 'dst) phase = {
 func : 'src -> 'dst,
 print : 'dst -> Print.PD.pp_desc
 | _ => absyn
 end
 handle LrParser.ParseError => [],
 print = SourcePrint.p_file}
-fun p_job {database, sources} =
+fun p_job {database, exe, sql, sources, debug} =
 let
 open Print.PD
 open Print
 in
-box [case database of
+box [if debug then
+box [string "DEBUG", newline]
+else
+box [],
+case database of
 NONE => string "No database."
 | SOME db => string ("Database: " ^ db),
 newline,
+string "Exe: ",
+string exe,
+newline,
+case sql of
+NONE => string "No SQL file."
+| SOME sql => string ("SQL fle: " ^ sql),
 string "Sources:",
 p_list string sources,
 newline]
 end
 val parseUrp = {
 func = fn filename =>
 let
 val dir = OS.Path.dir filename
 val inf = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
+fun relify fname =
+OS.Path.concat (dir, fname)
+handle OS.Path.Path => fname
 fun readSources acc =
 case TextIO.inputLine inf of
 NONE => rev acc
 | SOME line =>
 acc
 else
 let
 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
 (String.explode line))
-val fname = OS.Path.concat (dir, fname)
+val fname = relify fname
-handle OS.Path.Path => fname
 in
 fname :: acc
 end
 in
 readSources acc
 end
-fun read database =
+fun finish (database, exe, sql, debug, sources) =
+{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) =
 case TextIO.inputLine inf of
-NONE => {database = database, sources = []}
+NONE => finish (database, exe, sql, debug, [])
-| SOME "\n" => {database = database, sources = readSources []}
+| SOME "\n" => finish (database, exe, sql, debug, readSources [])
 | SOME line =>
 let
 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
 val cmd = Substring.string (trim cmd)
 val arg = Substring.string (trim arg)
 case cmd of
 "database" =>
 (case database of
 NONE => ()
 | SOME _ => ErrorMsg.error "Duplicate 'database' directive";
-read (SOME arg))
+read (SOME arg, exe, sql, debug))
+| "exe" =>
+(case exe of
+NONE => ()
+| SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
+read (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)
 | _ => (ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
-read database)
+read (database, exe, sql, debug))
 end
 in
-read NONE
+read (NONE, NONE, NONE, false)
 before TextIO.closeIn inf
 end,
 print = p_job
 }
 fun capitalize "" = ""
 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
 val parse = {
-func = fn {database, sources = fnames} =>
+func = fn {database, sources = fnames, ...} : job =>
 let
 fun nameOf fname = capitalize (OS.Path.file fname)
 fun parseOne fname =
 let
 func = Cjrize.cjrize,
 print = CjrPrint.p_file CjrEnv.empty
 }
 val toCjrize = transform cjrize "cjrize" o toMono_opt2
+val sqlify = {
+func = Cjrize.cjrize,
+print = CjrPrint.p_sql CjrEnv.empty
+}
+val toSqlify = transform sqlify "sqlify" o toMono_opt2
 fun compileC {cname, oname, ename} =
 let
 val compile = "gcc -O3 -I include -c " ^ cname ^ " -o " ^ oname
 val link = "gcc -O3 -pthread -lpq clib/urweb.o " ^ oname ^ " clib/driver.o -o " ^ ename
 fun compile job =
 case run toCjrize job of
 NONE => print "Ur compilation failed\n"
 | SOME file =>
 let
-val cname = "/tmp/urweb.c"
+val job = valOf (run (transform parseUrp "parseUrp") job)
-val oname = "/tmp/urweb.o"
-val ename = "/tmp/webapp"
+val (cname, oname, cleanup) =
+if #debug job then
-val outf = TextIO.openOut cname
+("/tmp/urweb.c", "/tmp/urweb.o", fn () => ())
-val s = TextIOPP.openOut {dst = outf, wid = 80}
+else
+let
+val dir = OS.FileSys.tmpName ()
+val cname = OS.Path.joinDirFile {dir = dir, file = "urweb.c"}
+val oname = OS.Path.joinDirFile {dir = dir, file = "urweb.o"}
+in
+OS.FileSys.mkDir dir;
+(cname, oname,
+fn () => (OS.FileSys.remove cname;
+OS.FileSys.remove oname;
+OS.FileSys.rmDir dir))
+end
+val ename = #exe job
 in
-Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
+let
-TextIO.closeOut outf;
+val outf = TextIO.openOut cname
+val s = TextIOPP.openOut {dst = outf, wid = 80}
-compileC {cname = cname, oname = oname, ename = ename}
+in
+Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
+TextIO.closeOut outf;
+case #sql job of
+NONE => ()
+| SOME sql =>
+let
+val outf = TextIO.openOut sql
+val s = TextIOPP.openOut {dst = outf, wid = 80}
+in
+Print.fprint s (CjrPrint.p_sql CjrEnv.empty file);
+TextIO.closeOut outf
+end;
+compileC {cname = cname, oname = oname, ename = ename};
+cleanup ()
+end
+handle ex => (((cleanup ()) handle _ => ()); raise ex)
 end
 end

Mercurial > urweb

comparison src/compiler.sml @ 274:e4baf03a3a64