changeset 274:e4baf03a3a64

Generating SQL files
author Adam Chlipala <adamc@hcoop.net>
date Tue, 02 Sep 2008 13:44:54 -0400 (2008-09-02)
parents 09c66a30ef32
children 73456bfde988
files src/cjr_print.sig src/cjr_print.sml src/compiler.sig src/compiler.sml src/monoize.sml tests/query.urp
diffstat 6 files changed, 152 insertions(+), 21 deletions(-) [+]
line wrap: on
line diff
--- a/src/cjr_print.sig	Tue Sep 02 13:09:54 2008 -0400
+++ b/src/cjr_print.sig	Tue Sep 02 13:44:54 2008 -0400
@@ -33,5 +33,7 @@
     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
--- a/src/cjr_print.sml	Tue Sep 02 13:09:54 2008 -0400
+++ b/src/cjr_print.sml	Tue Sep 02 13:44:54 2008 -0400
@@ -1238,4 +1238,51 @@
              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
--- a/src/compiler.sig	Tue Sep 02 13:09:54 2008 -0400
+++ b/src/compiler.sig	Tue Sep 02 13:44:54 2008 -0400
@@ -31,7 +31,10 @@
 
     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 @@
     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 @@
     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
--- a/src/compiler.sml	Tue Sep 02 13:09:54 2008 -0400
+++ b/src/compiler.sml	Tue Sep 02 13:44:54 2008 -0400
@@ -37,7 +37,10 @@
 
 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 @@
               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 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 @@
                                             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 @@
                               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 @@
                                   (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 @@
   | 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 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 @@
         NONE => print "Ur compilation failed\n"
       | SOME file =>
         let
-            val cname = "/tmp/urweb.c"
-            val oname = "/tmp/urweb.o"
-            val ename = "/tmp/webapp"
+            val job = valOf (run (transform parseUrp "parseUrp") job)
 
-            val outf = TextIO.openOut cname
-            val s = TextIOPP.openOut {dst = outf, wid = 80}
+            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;
+            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;
 
-            compileC {cname = cname, oname = oname, ename = ename}
+                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
--- a/src/monoize.sml	Tue Sep 02 13:09:54 2008 -0400
+++ b/src/monoize.sml	Tue Sep 02 13:44:54 2008 -0400
@@ -1417,6 +1417,7 @@
             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
--- a/tests/query.urp	Tue Sep 02 13:09:54 2008 -0400
+++ b/tests/query.urp	Tue Sep 02 13:44:54 2008 -0400
@@ -1,3 +1,6 @@
+debug
 database dbname=test
+exe /tmp/webapp
+sql /tmp/urweb.sql
 
 query