Mercurial > urweb

comparison src/iflow.sml @ 1697:cb0f05bdc183

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Refactor SQL parsing code from Iflow to Sql, add querydml parser.
author Edward Z. Yang <ezyang@mit.edu>
date Mon, 12 Mar 2012 12:00:23 -0700
parents 0577be31a435
children c1e3805e604e
comparison
equal deleted inserted replaced
1696:177547450bb9 1697:cb0f05bdc183
26 *) 26 *)
27 27
28 structure Iflow :> IFLOW = struct 28 structure Iflow :> IFLOW = struct
29 29
30 open Mono 30 open Mono
31 open Sql
31 32
32 structure IS = IntBinarySet 33 structure IS = IntBinarySet
33 structure IM = IntBinaryMap 34 structure IM = IntBinaryMap
34 35
35 structure SK = struct 36 structure SK = struct
54 "urlifyString_w", 55 "urlifyString_w",
55 "urlifyBool_w", 56 "urlifyBool_w",
56 "set_cookie"] 57 "set_cookie"]
57 58
58 val writers = SS.addList (SS.empty, writers) 59 val writers = SS.addList (SS.empty, writers)
59
60 type lvar = int
61
62 datatype func =
63 DtCon0 of string
64 | DtCon1 of string
65 | UnCon of string
66 | Other of string
67
68 datatype exp =
69 Const of Prim.t
70 | Var of int
71 | Lvar of lvar
72 | Func of func * exp list
73 | Recd of (string * exp) list
74 | Proj of exp * string
75
76 datatype reln =
77 Known
78 | Sql of string
79 | PCon0 of string
80 | PCon1 of string
81 | Eq
82 | Ne
83 | Lt
84 | Le
85 | Gt
86 | Ge
87
88 datatype prop =
89 True
90 | False
91 | Unknown
92 | And of prop * prop
93 | Or of prop * prop
94 | Reln of reln * exp list
95 | Cond of exp * prop
96 60
97 local 61 local
98 open Print 62 open Print
99 val string = PD.string 63 val string = PD.string
100 in 64 in
224 fun p_atom a = 188 fun p_atom a =
225 p_prop (case a of 189 p_prop (case a of
226 AReln x => Reln x 190 AReln x => Reln x
227 | ACond x => Cond x) 191 | ACond x => Cond x)
228 192
229 val debug = ref false
230
231 (* Congruence closure *) 193 (* Congruence closure *)
232 structure Cc :> sig 194 structure Cc :> sig
233 type database 195 type database
234 196
235 exception Contradiction 197 exception Contradiction
826 fun patCon pc = 788 fun patCon pc =
827 case pc of 789 case pc of
828 PConVar n => "C" ^ Int.toString n 790 PConVar n => "C" ^ Int.toString n
829 | PConFfi {mod = m, datatyp = d, con = c, ...} => m ^ "." ^ d ^ "." ^ c 791 | PConFfi {mod = m, datatyp = d, con = c, ...} => m ^ "." ^ d ^ "." ^ c
830 792
831 datatype chunk =
832 String of string
833 | Exp of Mono.exp
834
835 fun chunkify e =
836 case #1 e of
837 EPrim (Prim.String s) => [String s]
838 | EStrcat (e1, e2) =>
839 let
840 val chs1 = chunkify e1
841 val chs2 = chunkify e2
842 in
843 case chs2 of
844 String s2 :: chs2' =>
845 (case List.last chs1 of
846 String s1 => List.take (chs1, length chs1 - 1) @ String (s1 ^ s2) :: chs2'
847 | _ => chs1 @ chs2)
848 | _ => chs1 @ chs2
849 end
850 | _ => [Exp e]
851
852 type 'a parser = chunk list -> ('a * chunk list) option
853
854 fun always v chs = SOME (v, chs)
855
856 fun parse p s =
857 case p (chunkify s) of
858 SOME (v, []) => SOME v
859 | _ => NONE
860
861 fun const s chs =
862 case chs of
863 String s' :: chs => if String.isPrefix s s' then
864 SOME ((), if size s = size s' then
865 chs
866 else
867 String (String.extract (s', size s, NONE)) :: chs)
868 else
869 NONE
870 | _ => NONE
871
872 fun follow p1 p2 chs =
873 case p1 chs of
874 NONE => NONE
875 | SOME (v1, chs) =>
876 case p2 chs of
877 NONE => NONE
878 | SOME (v2, chs) => SOME ((v1, v2), chs)
879
880 fun wrap p f chs =
881 case p chs of
882 NONE => NONE
883 | SOME (v, chs) => SOME (f v, chs)
884
885 fun wrapP p f chs =
886 case p chs of
887 NONE => NONE
888 | SOME (v, chs) =>
889 case f v of
890 NONE => NONE
891 | SOME r => SOME (r, chs)
892
893 fun alt p1 p2 chs =
894 case p1 chs of
895 NONE => p2 chs
896 | v => v
897
898 fun altL ps =
899 case rev ps of
900 [] => (fn _ => NONE)
901 | p :: ps =>
902 foldl (fn (p1, p2) => alt p1 p2) p ps
903
904 fun opt p chs =
905 case p chs of
906 NONE => SOME (NONE, chs)
907 | SOME (v, chs) => SOME (SOME v, chs)
908
909 fun skip cp chs =
910 case chs of
911 String "" :: chs => skip cp chs
912 | String s :: chs' => if cp (String.sub (s, 0)) then
913 skip cp (String (String.extract (s, 1, NONE)) :: chs')
914 else
915 SOME ((), chs)
916 | _ => SOME ((), chs)
917
918 fun keep cp chs =
919 case chs of
920 String "" :: chs => keep cp chs
921 | String s :: chs' =>
922 let
923 val (befor, after) = Substring.splitl cp (Substring.full s)
924 in
925 if Substring.isEmpty befor then
926 NONE
927 else
928 SOME (Substring.string befor,
929 if Substring.isEmpty after then
930 chs'
931 else
932 String (Substring.string after) :: chs')
933 end
934 | _ => NONE
935
936 fun ws p = wrap (follow (skip (fn ch => ch = #" "))
937 (follow p (skip (fn ch => ch = #" ")))) (#1 o #2)
938
939 fun log name p chs =
940 (if !debug then
941 (print (name ^ ": ");
942 app (fn String s => print s
943 | _ => print "???") chs;
944 print "\n")
945 else
946 ();
947 p chs)
948
949 fun list p chs =
950 altL [wrap (follow p (follow (ws (const ",")) (list p)))
951 (fn (v, ((), ls)) => v :: ls),
952 wrap (ws p) (fn v => [v]),
953 always []] chs
954
955 val ident = keep (fn ch => Char.isAlphaNum ch orelse ch = #"_")
956
957 val t_ident = wrapP ident (fn s => if String.isPrefix "T_" s then
958 SOME (String.extract (s, 2, NONE))
959 else
960 NONE)
961 val uw_ident = wrapP ident (fn s => if String.isPrefix "uw_" s andalso size s >= 4 then
962 SOME (str (Char.toUpper (String.sub (s, 3)))
963 ^ String.extract (s, 4, NONE))
964 else
965 NONE)
966
967 val field = wrap (follow t_ident
968 (follow (const ".")
969 uw_ident))
970 (fn (t, ((), f)) => (t, f))
971
972 datatype Rel =
973 Exps of exp * exp -> prop
974 | Props of prop * prop -> prop
975
976 datatype sqexp =
977 SqConst of Prim.t
978 | SqTrue
979 | SqFalse
980 | SqNot of sqexp
981 | Field of string * string
982 | Computed of string
983 | Binop of Rel * sqexp * sqexp
984 | SqKnown of sqexp
985 | Inj of Mono.exp
986 | SqFunc of string * sqexp
987 | Unmodeled
988 | Null
989
990 fun cmp s r = wrap (const s) (fn () => Exps (fn (e1, e2) => Reln (r, [e1, e2])))
991
992 val sqbrel = altL [cmp "=" Eq,
993 cmp "<>" Ne,
994 cmp "<=" Le,
995 cmp "<" Lt,
996 cmp ">=" Ge,
997 cmp ">" Gt,
998 wrap (const "AND") (fn () => Props And),
999 wrap (const "OR") (fn () => Props Or)]
1000
1001 datatype ('a, 'b) sum = inl of 'a | inr of 'b
1002
1003 fun string chs =
1004 case chs of
1005 String s :: chs =>
1006 if size s >= 2 andalso String.sub (s, 0) = #"'" then
1007 let
1008 fun loop (cs, acc) =
1009 case cs of
1010 [] => NONE
1011 | c :: cs =>
1012 if c = #"'" then
1013 SOME (String.implode (rev acc), cs)
1014 else if c = #"\\" then
1015 case cs of
1016 c :: cs => loop (cs, c :: acc)
1017 | _ => raise Fail "Iflow.string: Unmatched backslash escape"
1018 else
1019 loop (cs, c :: acc)
1020 in
1021 case loop (String.explode (String.extract (s, 1, NONE)), []) of
1022 NONE => NONE
1023 | SOME (s, []) => SOME (s, chs)
1024 | SOME (s, cs) => SOME (s, String (String.implode cs) :: chs)
1025 end
1026 else
1027 NONE
1028 | _ => NONE
1029
1030 val prim =
1031 altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit)))
1032 (fn (x, ((), y)) => Option.map Prim.Float (Real64.fromString (x ^ "." ^ y))))
1033 (opt (const "::float8"))) #1,
1034 wrap (follow (wrapP (keep Char.isDigit)
1035 (Option.map Prim.Int o Int64.fromString))
1036 (opt (const "::int8"))) #1,
1037 wrap (follow (opt (const "E")) (follow string (opt (const "::text"))))
1038 (Prim.String o #1 o #2)]
1039
1040 fun known' chs =
1041 case chs of
1042 Exp (EFfi ("Basis", "sql_known"), _) :: chs => SOME ((), chs)
1043 | _ => NONE
1044
1045 fun sqlify chs =
1046 case chs of
1047 Exp (EFfiApp ("Basis", f, [(e, _)]), _) :: chs =>
1048 if String.isPrefix "sqlify" f then
1049 SOME (e, chs)
1050 else
1051 NONE
1052 | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
1053 (EPrim (Prim.String "TRUE"), _)),
1054 ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
1055 (EPrim (Prim.String "FALSE"), _))], _), _) :: chs =>
1056 SOME (e, chs)
1057
1058 | _ => NONE
1059
1060 fun constK s = wrap (const s) (fn () => s)
1061
1062 val funcName = altL [constK "COUNT",
1063 constK "MIN",
1064 constK "MAX",
1065 constK "SUM",
1066 constK "AVG"]
1067
1068 val unmodeled = altL [const "COUNT(*)",
1069 const "CURRENT_TIMESTAMP"]
1070
1071 fun sqexp chs =
1072 log "sqexp"
1073 (altL [wrap prim SqConst,
1074 wrap (const "TRUE") (fn () => SqTrue),
1075 wrap (const "FALSE") (fn () => SqFalse),
1076 wrap (const "NULL") (fn () => Null),
1077 wrap field Field,
1078 wrap uw_ident Computed,
1079 wrap known SqKnown,
1080 wrap func SqFunc,
1081 wrap unmodeled (fn () => Unmodeled),
1082 wrap sqlify Inj,
1083 wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",")
1084 (follow (keep (fn ch => ch <> #")")) (const ")")))))
1085 (fn ((), (e, _)) => e),
1086 wrap (follow (const "(NOT ") (follow sqexp (const ")")))
1087 (fn ((), (e, _)) => SqNot e),
1088 wrap (follow (ws (const "("))
1089 (follow (wrap
1090 (follow sqexp
1091 (alt
1092 (wrap
1093 (follow (ws sqbrel)
1094 (ws sqexp))
1095 inl)
1096 (always (inr ()))))
1097 (fn (e1, sm) =>
1098 case sm of
1099 inl (bo, e2) => Binop (bo, e1, e2)
1100 | inr () => e1))
1101 (const ")")))
1102 (fn ((), (e, ())) => e)])
1103 chs
1104
1105 and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")"))))
1106 (fn ((), ((), (e, ()))) => e) chs
1107
1108 and func chs = wrap (follow funcName (follow (const "(") (follow sqexp (const ")"))))
1109 (fn (f, ((), (e, ()))) => (f, e)) chs
1110
1111 datatype sitem =
1112 SqField of string * string
1113 | SqExp of sqexp * string
1114
1115 val sitem = alt (wrap (follow sqexp (follow (const " AS ") uw_ident))
1116 (fn (e, ((), s)) => SqExp (e, s)))
1117 (wrap field SqField)
1118
1119 val select = log "select"
1120 (wrap (follow (const "SELECT ") (list sitem))
1121 (fn ((), ls) => ls))
1122
1123 val fitem = wrap (follow uw_ident
1124 (follow (const " AS ")
1125 t_ident))
1126 (fn (t, ((), f)) => (t, f))
1127
1128 val from = log "from"
1129 (wrap (follow (const "FROM ") (list fitem))
1130 (fn ((), ls) => ls))
1131
1132 val wher = wrap (follow (ws (const "WHERE ")) sqexp)
1133 (fn ((), ls) => ls)
1134
1135 type query1 = {Select : sitem list,
1136 From : (string * string) list,
1137 Where : sqexp option}
1138
1139 val query1 = log "query1"
1140 (wrap (follow (follow select from) (opt wher))
1141 (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher}))
1142
1143 datatype query =
1144 Query1 of query1
1145 | Union of query * query
1146
1147 val orderby = log "orderby"
1148 (wrap (follow (ws (const "ORDER BY "))
1149 (follow (list sqexp)
1150 (opt (ws (const "DESC")))))
1151 ignore)
1152
1153 fun query chs = log "query"
1154 (wrap
1155 (follow
1156 (alt (wrap (follow (const "((")
1157 (follow query
1158 (follow (const ") UNION (")
1159 (follow query (const "))")))))
1160 (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2)))
1161 (wrap query1 Query1))
1162 (opt orderby))
1163 #1)
1164 chs
1165
1166 datatype dml =
1167 Insert of string * (string * sqexp) list
1168 | Delete of string * sqexp
1169 | Update of string * (string * sqexp) list * sqexp
1170
1171 val insert = log "insert"
1172 (wrapP (follow (const "INSERT INTO ")
1173 (follow uw_ident
1174 (follow (const " (")
1175 (follow (list uw_ident)
1176 (follow (const ") VALUES (")
1177 (follow (list sqexp)
1178 (const ")")))))))
1179 (fn ((), (tab, ((), (fs, ((), (es, ())))))) =>
1180 (SOME (tab, ListPair.zipEq (fs, es)))
1181 handle ListPair.UnequalLengths => NONE))
1182
1183 val delete = log "delete"
1184 (wrap (follow (const "DELETE FROM ")
1185 (follow uw_ident
1186 (follow (const " AS T_T WHERE ")
1187 sqexp)))
1188 (fn ((), (tab, ((), es))) => (tab, es)))
1189
1190 val setting = log "setting"
1191 (wrap (follow uw_ident (follow (const " = ") sqexp))
1192 (fn (f, ((), e)) => (f, e)))
1193
1194 val update = log "update"
1195 (wrap (follow (const "UPDATE ")
1196 (follow uw_ident
1197 (follow (const " AS T_T SET ")
1198 (follow (list setting)
1199 (follow (ws (const "WHERE "))
1200 sqexp)))))
1201 (fn ((), (tab, ((), (fs, ((), e))))) =>
1202 (tab, fs, e)))
1203
1204 val dml = log "dml"
1205 (altL [wrap insert Insert,
1206 wrap delete Delete,
1207 wrap update Update])
1208
1209 type check = exp * ErrorMsg.span 793 type check = exp * ErrorMsg.span
1210 794
1211 structure St :> sig 795 structure St :> sig
1212 val reset : unit -> unit 796 val reset : unit -> unit
1213 797