summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2010-05-27 16:36:17 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2010-05-27 16:36:17 -0400
commitd6b698a6ad00a5f707ae48af039388687ac9b4ba (patch)
treee323bae4aa24f7a07c4a5c0941b14dc88b97e75a
parent0091af30d2d24940404e49b30a6d0e2a0e4ba4e7 (diff)
-moduleOf command-line option; compatibility fixes and better error messages for SQLite
Diffstat
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml19
-rw-r--r--src/main.mlton.sml3
-rw-r--r--src/monoize.sml94
-rw-r--r--src/sqlite.sml28
5 files changed, 103 insertions, 43 deletions
diff --git a/src/compiler.sig b/src/compiler.sig
index cc23fe74..16207e8b 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -169,4 +169,6 @@ signature COMPILER = sig
val addPath : string * string -> unit
val addModuleRoot : string * string -> unit
+ val moduleOf : string -> string
+
end
diff --git a/src/compiler.sml b/src/compiler.sml
index d39122f0..1d15367f 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -1254,4 +1254,23 @@ fun compiler job =
else
OS.Process.exit OS.Process.failure
+fun moduleOf fname =
+ let
+ val mrs = !moduleRoots
+ val fname = OS.Path.mkCanonical fname
+ in
+ case List.find (fn (root, _) => String.isPrefix (root ^ "/") fname) mrs of
+ NONE => capitalize (OS.Path.base (OS.Path.file fname))
+ | SOME (root, name) =>
+ let
+ val fname = OS.Path.base fname
+ val fname = String.extract (fname, size root + 1, NONE)
+ val fs = String.fields (fn ch => ch = #"/") fname
+ val fs = List.filter (CharVector.exists (fn ch => not (Char.isDigit ch))) fs
+ val fs = map capitalize fs
+ in
+ String.concatWith "." (name :: fs)
+ end
+ end
+
end
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index f4f74be2..33838c93 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -85,6 +85,9 @@ fun doArgs args =
| "-iflow" :: rest =>
(Compiler.doIflow := true;
doArgs rest)
+ | "-moduleOf" :: fname :: _ =>
+ (print (Compiler.moduleOf fname ^ "\n");
+ OS.Process.exit OS.Process.success)
| arg :: rest =>
(if size arg > 0 andalso String.sub (arg, 0) = #"-" then
raise Fail ("Unknown flag " ^ arg)
diff --git a/src/monoize.sml b/src/monoize.sml
index e6c91abd..e2377bae 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1900,7 +1900,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
{disc = s,
result = s}), loc),
(L'.ECase (gf "Where",
- [((L'.PPrim (Prim.String "TRUE"), loc),
+ [((L'.PPrim (Prim.String (#trueString (Settings.currentDbms ()))),
+ loc),
sc ""),
((L'.PWild, loc),
strcat [sc " WHERE ", gf "Where"])],
@@ -2114,13 +2115,21 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.PRecord [("2", (L'.PPrim (Prim.String ""), loc), s)], loc),
(L'.ERel 2, loc)),
((L'.PWild, loc),
- strcat [(L'.EPrim (Prim.String "("), loc),
- (L'.ERel 2, loc),
- (L'.EPrim (Prim.String " JOIN "), loc),
- (L'.ERel 1, loc),
- (L'.EPrim (Prim.String " ON "), loc),
- (L'.ERel 0, loc),
- (L'.EPrim (Prim.String ")"), loc)])],
+ strcat ((if #nestedRelops
+ (Settings.currentDbms ()) then
+ [(L'.EPrim (Prim.String "("), loc)]
+ else
+ [])
+ @ [(L'.ERel 2, loc),
+ (L'.EPrim (Prim.String " JOIN "), loc),
+ (L'.ERel 1, loc),
+ (L'.EPrim (Prim.String " ON "), loc),
+ (L'.ERel 0, loc)]
+ @ (if #nestedRelops
+ (Settings.currentDbms ()) then
+ [(L'.EPrim (Prim.String ")"), loc)]
+ else
+ [])))],
{disc = (L'.TRecord [("1", s), ("2", s)], loc),
result = s}), loc)), loc)), loc)), loc),
fm)
@@ -2144,13 +2153,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
loc), s)], loc),
(L'.ERel 2, loc)),
((L'.PWild, loc),
- strcat [(L'.EPrim (Prim.String "("), loc),
- (L'.ERel 2, loc),
- (L'.EPrim (Prim.String " LEFT JOIN "), loc),
- (L'.ERel 1, loc),
- (L'.EPrim (Prim.String " ON "), loc),
- (L'.ERel 0, loc),
- (L'.EPrim (Prim.String ")"), loc)])],
+ strcat ((if #nestedRelops
+ (Settings.currentDbms ()) then
+ [(L'.EPrim (Prim.String "("), loc)]
+ else
+ [])
+ @ [(L'.ERel 2, loc),
+ (L'.EPrim (Prim.String " LEFT JOIN "),
+ loc),
+ (L'.ERel 1, loc),
+ (L'.EPrim (Prim.String " ON "), loc),
+ (L'.ERel 0, loc)]
+ @ (if #nestedRelops
+ (Settings.currentDbms ()) then
+ [(L'.EPrim (Prim.String ")"), loc)]
+ else
+ [])))],
{disc = (L'.TRecord [("1", s), ("2", s)], loc),
result = s}), loc)), loc)), loc)), loc)), loc),
fm)
@@ -2174,13 +2192,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
loc), s)], loc),
(L'.ERel 2, loc)),
((L'.PWild, loc),
- strcat [(L'.EPrim (Prim.String "("), loc),
- (L'.ERel 2, loc),
- (L'.EPrim (Prim.String " RIGHT JOIN "), loc),
- (L'.ERel 1, loc),
- (L'.EPrim (Prim.String " ON "), loc),
- (L'.ERel 0, loc),
- (L'.EPrim (Prim.String ")"), loc)])],
+ strcat ((if #nestedRelops
+ (Settings.currentDbms ()) then
+ [(L'.EPrim (Prim.String "("), loc)]
+ else
+ [])
+ @ [(L'.ERel 2, loc),
+ (L'.EPrim (Prim.String " RIGHT JOIN "),
+ loc),
+ (L'.ERel 1, loc),
+ (L'.EPrim (Prim.String " ON "), loc),
+ (L'.ERel 0, loc)]
+ @ (if #nestedRelops
+ (Settings.currentDbms ()) then
+ [(L'.EPrim (Prim.String ")"), loc)]
+ else
+ [])))],
{disc = (L'.TRecord [("1", s), ("2", s)], loc),
result = s}), loc)), loc)), loc)), loc)), loc),
fm)
@@ -2204,13 +2231,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
loc), s)], loc),
(L'.ERel 2, loc)),
((L'.PWild, loc),
- strcat [(L'.EPrim (Prim.String "("), loc),
- (L'.ERel 2, loc),
- (L'.EPrim (Prim.String " FULL JOIN "), loc),
- (L'.ERel 1, loc),
- (L'.EPrim (Prim.String " ON "), loc),
- (L'.ERel 0, loc),
- (L'.EPrim (Prim.String ")"), loc)])],
+ strcat ((if #nestedRelops
+ (Settings.currentDbms ()) then
+ [(L'.EPrim (Prim.String "("), loc)]
+ else
+ [])
+ @ [(L'.ERel 2, loc),
+ (L'.EPrim (Prim.String " FULL JOIN "),
+ loc),
+ (L'.ERel 1, loc),
+ (L'.EPrim (Prim.String " ON "), loc),
+ (L'.ERel 0, loc)]
+ @ (if #nestedRelops
+ (Settings.currentDbms ()) then
+ [(L'.EPrim (Prim.String ")"), loc)]
+ else
+ [])))],
{disc = (L'.TRecord [("1", s), ("2", s)], loc),
result = s}), loc)), loc)), loc)), loc)), loc),
fm)
diff --git a/src/sqlite.sml b/src/sqlite.sml
index 26cfc9d5..d628da16 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -58,7 +58,7 @@ fun checkRel (table, checkNullable) (s, xts) =
newline,
box [string "sqlite3_close(conn->conn);",
newline,
- string "uw_error(ctx, FATAL, \"Query preparation failed:\\n",
+ string "uw_error(ctx, FATAL, \"Query preparation failed:<br />",
string q,
string "\");",
newline],
@@ -77,7 +77,7 @@ fun checkRel (table, checkNullable) (s, xts) =
newline,
string "sqlite3_close(conn->conn);",
newline,
- string "uw_error(ctx, FATAL, \"No row returned:\\n",
+ string "uw_error(ctx, FATAL, \"No row returned:<br />",
string q,
string "\");",
newline],
@@ -90,7 +90,7 @@ fun checkRel (table, checkNullable) (s, xts) =
newline,
string "sqlite3_close(conn->conn);",
newline,
- string "uw_error(ctx, FATAL, \"Error getting row:\\n",
+ string "uw_error(ctx, FATAL, \"Error getting row:<br />",
string q,
string "\");",
newline],
@@ -104,7 +104,7 @@ fun checkRel (table, checkNullable) (s, xts) =
newline,
string "sqlite3_close(conn->conn);",
newline,
- string "uw_error(ctx, FATAL, \"Bad column count:\\n",
+ string "uw_error(ctx, FATAL, \"Bad column count:<br />",
string q,
string "\");",
newline],
@@ -242,7 +242,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
string "msg[1023] = 0;",
newline,
uhoh false ("Error preparing statement: "
- ^ String.toString s ^ "\\n%s") ["msg"]],
+ ^ String.toString s ^ "<br />%s") ["msg"]],
string "}",
newline]
end)
@@ -353,7 +353,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline],
string "else {",
newline,
- box [string "fprintf(stderr, \"Begin error: %s\\n\", sqlite3_errmsg(conn->conn));",
+ box [string "fprintf(stderr, \"Begin error: %s<br />\", sqlite3_errmsg(conn->conn));",
newline,
string "return 1;",
newline],
@@ -371,7 +371,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline],
string "else {",
newline,
- box [string "fprintf(stderr, \"Commit error: %s\\n\", sqlite3_errmsg(conn->conn));",
+ box [string "fprintf(stderr, \"Commit error: %s<br />\", sqlite3_errmsg(conn->conn));",
newline,
string "return 1;",
newline],
@@ -391,7 +391,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline],
string "else {",
newline,
- box [string "fprintf(stderr, \"Rollback error: %s\\n\", sqlite3_errmsg(conn->conn));",
+ box [string "fprintf(stderr, \"Rollback error: %s<br />\", sqlite3_errmsg(conn->conn));",
newline,
string "return 1;",
newline],
@@ -522,7 +522,7 @@ fun queryCommon {loc, query, cols, doCols} =
string "if (r != SQLITE_DONE) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
- string ": query step failed: %s\\n%s\", ",
+ string ": query step failed: %s<br />%s\", ",
query,
string ", sqlite3_errmsg(conn->conn));",
newline,
@@ -534,7 +534,7 @@ fun query {loc, cols, doCols} =
string "sqlite3_stmt *stmt;",
newline,
newline,
- string "if (sqlite3_prepare_v2(conn->conn, query, -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: %s\\n%s\", sqlite3_errmsg(conn->conn));",
+ string "if (sqlite3_prepare_v2(conn->conn, query, -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: %s<br />%s\", sqlite3_errmsg(conn->conn), query);",
newline,
newline,
string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);",
@@ -654,7 +654,7 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
string (String.toString query),
string "\", -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: ",
string (String.toString query),
- string "\\n%s\", sqlite3_errmsg(conn->conn));",
+ string "<br />%s\", sqlite3_errmsg(conn->conn));",
newline,
if nested then
box [string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);",
@@ -703,7 +703,7 @@ fun dmlCommon {loc, dml} =
string "if (r != SQLITE_DONE) uw_error(ctx, FATAL, \"",
string (ErrorMsg.spanToString loc),
- string ": DML step failed: %s\\n%s\", ",
+ string ": DML step failed: %s<br />%s\", ",
dml,
string ", sqlite3_errmsg(conn->conn));",
newline]
@@ -714,7 +714,7 @@ fun dml loc =
string "sqlite3_stmt *stmt;",
newline,
newline,
- string "if (sqlite3_prepare_v2(conn->conn, dml, -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: %s\\n%s\", dml, sqlite3_errmsg(conn->conn));",
+ string "if (sqlite3_prepare_v2(conn->conn, dml, -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: %s<br />%s\", dml, sqlite3_errmsg(conn->conn));",
newline,
newline,
string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);",
@@ -742,7 +742,7 @@ fun dmlPrepared {loc, id, dml, inputs} =
string (String.toString dml),
string "\", -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: ",
string (String.toString dml),
- string "\\n%s\", sqlite3_errmsg(conn->conn));",
+ string "<br />%s\", sqlite3_errmsg(conn->conn));",
newline,
string "conn->p",
string (Int.toString id),
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-29 23:40:47 +0000