summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/cjr_print.sig2
-rw-r--r--src/cjr_print.sml47
-rw-r--r--src/compiler.sig7
-rw-r--r--src/compiler.sml117
-rw-r--r--src/monoize.sml1
-rw-r--r--tests/query.urp3
6 files changed, 154 insertions, 23 deletions
diff --git a/src/cjr_print.sig b/src/cjr_print.sig
index f8ffa193..baef005e 100644
--- a/src/cjr_print.sig
+++ b/src/cjr_print.sig
@@ -33,5 +33,7 @@ signature CJR_PRINT = sig
val p_decl : CjrEnv.env -> Cjr.decl Print.printer
val p_file : CjrEnv.env -> Cjr.file Print.printer
+ val p_sql : CjrEnv.env -> Cjr.file Print.printer
+
val debug : bool ref
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index de8f21fc..ff2cada1 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1238,4 +1238,51 @@ fun p_file env (ds, ps) =
newline]
end
+fun p_sqltype env (tAll as (t, loc)) =
+ let
+ val s = case t of
+ TFfi ("Basis", "int") => "int8"
+ | TFfi ("Basis", "float") => "float8"
+ | TFfi ("Basis", "string") => "text"
+ | TFfi ("Basis", "bool") => "bool"
+ | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
+ Print.eprefaces' [("Type", p_typ env tAll)];
+ "ERROR")
+ in
+ string s
+ end
+
+fun p_sql env (ds, _) =
+ let
+ val (pps, _) = ListUtil.foldlMap
+ (fn (dAll as (d, _), env) =>
+ let
+ val pp = case d of
+ DTable (s, xts) =>
+ box [string "CREATE TABLE ",
+ string s,
+ string "(",
+ p_list (fn (x, t) =>
+ box [string "lw_",
+ string x,
+ space,
+ string ":",
+ space,
+ p_sqltype env t,
+ space,
+ string "NOT",
+ space,
+ string "NULL"]) xts,
+ string ");",
+ newline,
+ newline]
+ | _ => box []
+ in
+ (pp, E.declBinds env dAll)
+ end)
+ env ds
+ in
+ box pps
+ end
+
end
diff --git a/src/compiler.sig b/src/compiler.sig
index a58784a9..30fef941 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -31,7 +31,10 @@ signature COMPILER = sig
type job = {
database : string option,
- sources : string list
+ sources : string list,
+ exe : string,
+ sql : string option,
+ debug : bool
}
val compile : string -> unit
val compileC : {cname : string, oname : string, ename : string} -> unit
@@ -65,6 +68,7 @@ signature COMPILER = sig
val mono_reduce : (Mono.file, Mono.file) phase
val mono_shake : (Mono.file, Mono.file) phase
val cjrize : (Mono.file, Cjr.file) phase
+ val sqlify : (Mono.file, Cjr.file) phase
val toParseJob : (string, job) transform
val toParse : (string, Source.file) transform
@@ -83,5 +87,6 @@ signature COMPILER = sig
val toMono_shake : (string, Mono.file) transform
val toMono_opt2 : (string, Mono.file) transform
val toCjrize : (string, Cjr.file) transform
+ val toSqlify : (string, Cjr.file) transform
end
diff --git a/src/compiler.sml b/src/compiler.sml
index 93eeebb7..f9fe0da8 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -37,7 +37,10 @@ structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData
type job = {
database : string option,
- sources : string list
+ sources : string list,
+ exe : string,
+ sql : string option,
+ debug : bool
}
type ('src, 'dst) phase = {
@@ -190,15 +193,25 @@ val parseUr = {
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]
@@ -218,6 +231,10 @@ val parseUrp = {
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
@@ -229,8 +246,7 @@ val parseUrp = {
let
val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
(String.explode line))
- val fname = OS.Path.concat (dir, fname)
- handle OS.Path.Path => fname
+ val fname = relify fname
in
fname :: acc
end
@@ -238,10 +254,18 @@ val parseUrp = {
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 = []}
- | SOME "\n" => {database = database, sources = readSources []}
+ NONE => finish (database, exe, sql, debug, [])
+ | 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)
@@ -253,12 +277,23 @@ val parseUrp = {
(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
@@ -270,7 +305,7 @@ 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)
@@ -414,6 +449,13 @@ val cjrize = {
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
@@ -432,17 +474,48 @@ fun compile job =
NONE => print "Ur compilation failed\n"
| SOME file =>
let
- val cname = "/tmp/urweb.c"
- val oname = "/tmp/urweb.o"
- val ename = "/tmp/webapp"
-
- val outf = TextIO.openOut cname
- val s = TextIOPP.openOut {dst = outf, wid = 80}
+ val job = valOf (run (transform parseUrp "parseUrp") job)
+
+ val (cname, oname, cleanup) =
+ if #debug job then
+ ("/tmp/urweb.c", "/tmp/urweb.o", fn () => ())
+ 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);
- TextIO.closeOut outf;
-
- compileC {cname = cname, oname = oname, ename = ename}
+ let
+ val outf = TextIO.openOut cname
+ val s = TextIOPP.openOut {dst = outf, wid = 80}
+ 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
diff --git a/src/monoize.sml b/src/monoize.sml
index 0930d28b..b0b4309e 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1417,6 +1417,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
+ val s = "lw_" ^ s
val e = (L'.EPrim (Prim.String s), loc)
val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
diff --git a/tests/query.urp b/tests/query.urp
index 7c31bb32..ac7cb6e3 100644
--- a/tests/query.urp
+++ b/tests/query.urp
@@ -1,3 +1,6 @@
+debug
database dbname=test
+exe /tmp/webapp
+sql /tmp/urweb.sql
query
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-05 11:27:44 +0000