Mercurial > urweb

comparison src/cjr_print.sml @ 467:3f1b9231a37b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Inserted a NULL value
author Adam Chlipala <adamc@hcoop.net>
date Thu, 06 Nov 2008 15:37:38 -0500
parents bb27c7efcd90
children 4efab85405be
comparison
equal deleted inserted replaced
466:1626dcba13ee 467:3f1b9231a37b
406 e 406 e
407 else 407 else
408 box [string "uw_Basis_strdup(ctx, ", e, string ")"] 408 box [string "uw_Basis_strdup(ctx, ", e, string ")"]
409 | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"] 409 | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
410 | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"] 410 | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"]
411
411 | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL"; 412 | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
412 Print.eprefaces' [("Type", p_typ env tAll)]; 413 Print.eprefaces' [("Type", p_typ env tAll)];
413 string "ERROR") 414 string "ERROR")
415
416 fun p_getcol wontLeakStrings env (tAll as (t, loc)) i =
417 case t of
418 TOption t =>
419 box [string "(PQgetisnull (res, i, ",
420 string (Int.toString i),
421 string ") ? NULL : ",
422 case t of
423 (TFfi ("Basis", "string"), _) => p_getcol wontLeakStrings env t i
424 | _ => box [string "({",
425 newline,
426 p_typ env t,
427 space,
428 string "*tmp = uw_malloc(ctx, sizeof(",
429 p_typ env t,
430 string "));",
431 newline,
432 string "*tmp = ",
433 p_getcol wontLeakStrings env t i,
434 string ";",
435 newline,
436 string "tmp;",
437 newline,
438 string "})"],
439 string ")"]
440
441 | _ =>
442 p_unsql wontLeakStrings env tAll
443 (box [string "PQgetvalue(res, i, ",
444 string (Int.toString i),
445 string ")"])
414 446
415 datatype sql_type = 447 datatype sql_type =
416 Int 448 Int
417 | Float 449 | Float
418 | String 450 | String
419 | Bool 451 | Bool
420 | Time 452 | Time
421 453 | Nullable of sql_type
422 fun p_sql_type t = 454
423 string (case t of 455 fun p_sql_type' t =
424 Int => "uw_Basis_int" 456 case t of
425 | Float => "uw_Basis_float" 457 Int => "uw_Basis_int"
426 | String => "uw_Basis_string" 458 | Float => "uw_Basis_float"
427 | Bool => "uw_Basis_bool" 459 | String => "uw_Basis_string"
428 | Time => "uw_Basis_time") 460 | Bool => "uw_Basis_bool"
461 | Time => "uw_Basis_time"
462 | Nullable String => "uw_Basis_string"
463 | Nullable t => p_sql_type' t ^ "*"
464
465 fun p_sql_type t = string (p_sql_type' t)
429 466
430 fun getPargs (e, _) = 467 fun getPargs (e, _) =
431 case e of 468 case e of
432 EPrim (Prim.String _) => [] 469 EPrim (Prim.String _) => []
433 | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2 470 | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2
446 Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"] 483 Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
447 | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"] 484 | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
448 | String => e 485 | String => e
449 | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] 486 | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
450 | Time => box [string "uw_Basis_sqlifyTime(ctx, ", e, string ")"] 487 | Time => box [string "uw_Basis_sqlifyTime(ctx, ", e, string ")"]
488 | Nullable String => e
489 | Nullable t => box [string "(",
490 e,
491 string " == NULL ? NULL : ",
492 p_ensql t (box [string "*", e]),
493 string ")"]
451 494
452 fun notLeaky env allowHeapAllocated = 495 fun notLeaky env allowHeapAllocated =
453 let 496 let
454 fun nl (t, _) = 497 fun nl (t, _) =
455 case t of 498 case t of
1167 string ".", 1210 string ".",
1168 string proj, 1211 string proj,
1169 space, 1212 space,
1170 string "=", 1213 string "=",
1171 space, 1214 space,
1172 p_unsql wontLeakStrings env t 1215 p_getcol wontLeakStrings env t i,
1173 (box [string "PQgetvalue(res, i, ",
1174 string (Int.toString i),
1175 string ")"]),
1176 string ";", 1216 string ";",
1177 newline]) outputs, 1217 newline]) outputs,
1178 1218
1179 newline, 1219 newline,
1180 newline, 1220 newline,
1658 string "return 0;", 1698 string "return 0;",
1659 newline, 1699 newline,
1660 string "}", 1700 string "}",
1661 newline] 1701 newline]
1662 1702
1663 | DPreparedStatements [] => box [] 1703 | DPreparedStatements [] =>
1704 box [string "static void uw_db_prepare(uw_context ctx) {",
1705 newline,
1706 string "}"]
1664 | DPreparedStatements ss => 1707 | DPreparedStatements ss =>
1665 box [string "static void uw_db_prepare(uw_context ctx) {", 1708 box [string "static void uw_db_prepare(uw_context ctx) {",
1666 newline, 1709 newline,
1667 string "PGconn *conn = uw_get_db(ctx);", 1710 string "PGconn *conn = uw_get_db(ctx);",
1668 newline, 1711 newline,
1706 datatype 'a search = 1749 datatype 'a search =
1707 Found of 'a 1750 Found of 'a
1708 | NotFound 1751 | NotFound
1709 | Error 1752 | Error
1710 1753
1711 fun p_sqltype' env (tAll as (t, loc)) = 1754 fun p_sqltype'' env (tAll as (t, loc)) =
1712 case t of 1755 case t of
1713 TFfi ("Basis", "int") => "int8" 1756 TFfi ("Basis", "int") => "int8"
1714 | TFfi ("Basis", "float") => "float8" 1757 | TFfi ("Basis", "float") => "float8"
1715 | TFfi ("Basis", "string") => "text" 1758 | TFfi ("Basis", "string") => "text"
1716 | TFfi ("Basis", "bool") => "bool" 1759 | TFfi ("Basis", "bool") => "bool"
1717 | TFfi ("Basis", "time") => "timestamp" 1760 | TFfi ("Basis", "time") => "timestamp"
1718 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type"; 1761 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
1719 Print.eprefaces' [("Type", p_typ env tAll)]; 1762 Print.eprefaces' [("Type", p_typ env tAll)];
1720 "ERROR") 1763 "ERROR")
1721 1764
1765 fun p_sqltype' env (tAll as (t, loc)) =
1766 case t of
1767 (TOption t, _) => p_sqltype'' env t
1768 | _ => p_sqltype'' env t ^ " NOT NULL"
1769
1722 fun p_sqltype env t = string (p_sqltype' env t) 1770 fun p_sqltype env t = string (p_sqltype' env t)
1771
1772 fun p_sqltype_base' env t =
1773 case t of
1774 (TOption t, _) => p_sqltype'' env t
1775 | _ => p_sqltype'' env t
1776
1777 fun p_sqltype_base env t = string (p_sqltype_base' env t)
1778
1779 fun is_not_null t =
1780 case t of
1781 (TOption _, _) => false
1782 | _ => true
1723 1783
1724 fun p_file env (ds, ps) = 1784 fun p_file env (ds, ps) =
1725 let 1785 let
1726 val (pds, env) = ListUtil.foldlMap (fn (d, env) => 1786 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
1727 (p_decl env d, 1787 (p_decl env d,
1995 String.concat ["(attname = 'uw_", 2055 String.concat ["(attname = 'uw_",
1996 CharVector.map 2056 CharVector.map
1997 Char.toLower (ident x), 2057 Char.toLower (ident x),
1998 "' AND atttypid = (SELECT oid FROM pg_type", 2058 "' AND atttypid = (SELECT oid FROM pg_type",
1999 " WHERE typname = '", 2059 " WHERE typname = '",
2000 p_sqltype' env t, 2060 p_sqltype_base' env t,
2001 "'))"]) xts), 2061 "') AND attnotnull = ",
2062 if is_not_null t then
2063 "TRUE"
2064 else
2065 "FALSE",
2066 ")"]) xts),
2002 ")"] 2067 ")"]
2003 2068
2004 val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", 2069 val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
2005 sl, 2070 sl,
2006 "') AND attname LIKE 'uw_%'"] 2071 "') AND attname LIKE 'uw_%'"]
2293 string "(", 2358 string "(",
2294 p_list (fn (x, t) => 2359 p_list (fn (x, t) =>
2295 box [string "uw_", 2360 box [string "uw_",
2296 string (CharVector.map Char.toLower x), 2361 string (CharVector.map Char.toLower x),
2297 space, 2362 space,
2298 p_sqltype env t, 2363 p_sqltype env (t, ErrorMsg.dummySpan)]) xts,
2299 space,
2300 string "NOT",
2301 space,
2302 string "NULL"]) xts,
2303 string ");", 2364 string ");",
2304 newline, 2365 newline,
2305 newline] 2366 newline]
2306 | DSequence s => 2367 | DSequence s =>
2307 box [string "CREATE SEQUENCE ", 2368 box [string "CREATE SEQUENCE ",