Mercurial > urweb

comparison src/monoize.sml @ 877:dae141d911d9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
MySQL accepts generated demo DDL
author Adam Chlipala <adamc@hcoop.net>
date Thu, 16 Jul 2009 13:59:30 -0400
parents 3c7b48040dcf
children 5805fa825fe8
comparison
equal deleted inserted replaced
876:025806b3c014 877:dae141d911d9
62 in 62 in
63 case c of 63 case c of
64 L.CName s => s 64 L.CName s => s
65 | _ => poly () 65 | _ => poly ()
66 end 66 end
67
68 fun lowercaseFirst "" = ""
69 | lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0)))
70 ^ String.extract (s, 1, NONE)
71
72 fun monoNameLc env c = lowercaseFirst (monoName env c)
67 73
68 fun readType' (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc), 74 fun readType' (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
69 (L'.TOption t, loc)), loc) 75 (L'.TOption t, loc)), loc)
70 fun readErrType (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc), 76 fun readErrType (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc),
71 t), loc) 77 t), loc)
627 end 633 end
628 634
629 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs) 635 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs)
630 636
631 val readCookie = ref IS.empty 637 val readCookie = ref IS.empty
638
639 fun isBlobby (t : L.con) =
640 case #1 t of
641 L.CFfi ("Basis", "string") => true
642 | L.CFfi ("Basis", "blob") => true
643 | _ => false
632 644
633 fun monoExp (env, st, fm) (all as (e, loc)) = 645 fun monoExp (env, st, fm) (all as (e, loc)) =
634 let 646 let
635 val strcat = strcat loc 647 val strcat = strcat loc
636 val strcatComma = strcatComma loc 648 val strcatComma = strcatComma loc
1366 val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc) 1378 val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc)
1367 in 1379 in
1368 ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc), 1380 ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc),
1369 (L'.EPrim (Prim.String 1381 (L'.EPrim (Prim.String
1370 (String.concatWith ", " 1382 (String.concatWith ", "
1371 (map (fn (x, _) => "uw_" ^ monoName env x) unique))), 1383 (map (fn (x, _) =>
1384 "uw_" ^ monoNameLc env x
1385 ^ (if #textKeysNeedLengths (Settings.currentDbms ())
1386 andalso isBlobby t then
1387 "(767)"
1388 else
1389 "")) unique))),
1372 loc)), loc), 1390 loc)), loc),
1373 fm) 1391 fm)
1374 end 1392 end
1375 1393
1376 | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) => 1394 | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) =>
1404 (L.CRecord (_, unique), _)) => 1422 (L.CRecord (_, unique), _)) =>
1405 let 1423 let
1406 val unique = (nm, t) :: unique 1424 val unique = (nm, t) :: unique
1407 in 1425 in
1408 ((L'.EPrim (Prim.String ("UNIQUE (" 1426 ((L'.EPrim (Prim.String ("UNIQUE ("
1409 ^ String.concatWith ", " (map (fn (x, _) => "uw_" ^ monoName env x) unique) 1427 ^ String.concatWith ", "
1428 (map (fn (x, t) => "uw_" ^ monoNameLc env x
1429 ^ (if #textKeysNeedLengths (Settings.currentDbms ())
1430 andalso isBlobby t then
1431 "(767)"
1432 else
1433 "")) unique)
1410 ^ ")")), loc), 1434 ^ ")")), loc),
1411 fm) 1435 fm)
1412 end 1436 end
1413 1437
1414 | L.ECApp ((L.EFfi ("Basis", "linkable_same"), loc), _) => 1438 | L.ECApp ((L.EFfi ("Basis", "linkable_same"), loc), _) =>
1445 in 1469 in
1446 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (mat, mat), loc), 1470 ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (mat, mat), loc),
1447 (L'.EAbs ("m", mat, mat, 1471 (L'.EAbs ("m", mat, mat,
1448 (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc), 1472 (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc),
1449 [((L'.PPrim (Prim.String ""), loc), 1473 [((L'.PPrim (Prim.String ""), loc),
1450 (L'.ERecord [("1", (L'.EPrim (Prim.String ("uw_" ^ nm1)), 1474 (L'.ERecord [("1", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1)),
1451 loc), string), 1475 loc), string),
1452 ("2", (L'.EPrim (Prim.String ("uw_" ^ nm2)), 1476 ("2", (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2)),
1453 loc), string)], loc)), 1477 loc), string)], loc)),
1454 ((L'.PWild, loc), 1478 ((L'.PWild, loc),
1455 (L'.ERecord [("1", (L'.EStrcat ( 1479 (L'.ERecord [("1", (L'.EStrcat (
1456 (L'.EPrim (Prim.String ("uw_" ^ nm1 ^ ", ")), 1480 (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm1
1481 ^ ", ")),
1457 loc), 1482 loc),
1458 (L'.EField ((L'.ERel 0, loc), "1"), loc)), 1483 (L'.EField ((L'.ERel 0, loc), "1"), loc)),
1459 loc), string), 1484 loc), string),
1460 ("2", (L'.EStrcat ( 1485 ("2", (L'.EStrcat (
1461 (L'.EPrim (Prim.String ("uw_" ^ nm2 ^ ", ")), loc), 1486 (L'.EPrim (Prim.String ("uw_" ^ lowercaseFirst nm2
1487 ^ ", ")), loc),
1462 (L'.EField ((L'.ERel 0, loc), "2"), loc)), 1488 (L'.EField ((L'.ERel 0, loc), "2"), loc)),
1463 loc), string)], 1489 loc), string)],
1464 loc))], 1490 loc))],
1465 {disc = string, 1491 {disc = string,
1466 result = mat}), loc)), loc)), loc), 1492 result = mat}), loc)), loc)), loc),
2144 _), _), 2170 _), _),
2145 _), _), 2171 _), _),
2146 _), _), 2172 _), _),
2147 _), _), 2173 _), _),
2148 (L.CName tab, _)), _), 2174 (L.CName tab, _)), _),
2149 (L.CName field, _)) => ((L'.EPrim (Prim.String (tab ^ ".uw_" ^ field)), loc), fm) 2175 (L.CName field, _)) => ((L'.EPrim (Prim.String (tab ^ ".uw_" ^ lowercaseFirst field)), loc), fm)
2150 2176
2151 | L.ECApp ( 2177 | L.ECApp (
2152 (L.ECApp ( 2178 (L.ECApp (
2153 (L.ECApp ( 2179 (L.ECApp (
2154 (L.ECApp ( 2180 (L.ECApp (
2156 (L.EFfi ("Basis", "sql_exp"), _), 2182 (L.EFfi ("Basis", "sql_exp"), _),
2157 _), _), 2183 _), _),
2158 _), _), 2184 _), _),
2159 _), _), 2185 _), _),
2160 _), _), 2186 _), _),
2161 (L.CName nm, _)) => ((L'.EPrim (Prim.String ("_" ^ nm)), loc), fm) 2187 (L.CName nm, _)) => ((L'.EPrim (Prim.String ("_" ^ lowercaseFirst nm)), loc), fm)
2162 2188
2163 | L.ECApp ( 2189 | L.ECApp (
2164 (L.ECApp ( 2190 (L.ECApp (
2165 (L.ECApp ( 2191 (L.ECApp (
2166 (L.ECApp ( 2192 (L.ECApp (
2409 [] => (NONE, acc) 2435 [] => (NONE, acc)
2410 | ("Onload", e, _) :: rest => (SOME e, List.revAppend (acc, rest)) 2436 | ("Onload", e, _) :: rest => (SOME e, List.revAppend (acc, rest))
2411 | x :: rest => findOnload (rest, x :: acc) 2437 | x :: rest => findOnload (rest, x :: acc)
2412 2438
2413 val (onload, attrs) = findOnload (attrs, []) 2439 val (onload, attrs) = findOnload (attrs, [])
2414
2415 fun lowercaseFirst "" = ""
2416 | lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0)))
2417 ^ String.extract (s, 1, NONE)
2418 2440
2419 val (class, fm) = monoExp (env, st, fm) class 2441 val (class, fm) = monoExp (env, st, fm) class
2420 2442
2421 fun tagStart tag = 2443 fun tagStart tag =
2422 let 2444 let