@@ -0,0 +1,132 @@
1+module main
2+import prelude.list
3+
4+-----------------------------------------------------------
5+-- * SQL data type
6+-----------------------------------------------------------
7+
8+data Value = VInt Int
9+ |VStr String
10+ |VCol String
11+
12+data Cond = Equals Value Value
13+ |MkGT Value Value
14+ |MkGTE Value Value
15+ |MkLT Value Value
16+ |MkLTE Value Value
17+--TODO |MkIN (List Value)
18+--TODO |MkIN SQL
19+
20+
21+data Clause = MkCond Cond
22+ | AND Clause Clause
23+ | OR Clause Clause
24+ | Empty
25+
26+data SelVar = Cols (List String)
27+ |ALL
28+
29+data SQL = SELECT SelVar SQL Clause
30+ | TBL String
31+ | INSERT SQL (List Value)
32+
33+
34+foldr1 : (a -> a -> a) -> List a -> a
35+foldr1 f [x] = x
36+foldr1 f (x::xs) = f x (foldr1 f xs)
37+
38+
39+unwords' : List (List Char) -> List Char
40+unwords' [] = []
41+unwords' ws = (foldr1 addSpace ws)
42+ where
43+ addSpace : List Char -> List Char -> List Char
44+ addSpace w s = w ++ (' ' :: s)
45+
46+
47+unwords : List String -> String
48+unwords = pack . unwords' . map unpack
49+
50+
51+mapping : Int -> List a -> List (Int, a)
52+mapping counter [] = []
53+mapping counter (x :: xs) = (counter, x) :: mapping (counter + 1) xs
54+
55+
56+popintoList : Maybe Value -> List (Maybe Value) -> List (Maybe Value)
57+popintoList (Just x) [] = [(Just x)]
58+popintoList (Just (x)) ((Just x) :: xs) = (popintoList (Just x) xs)
59+popintoList Nothing [] = []
60+
61+valString : List (Maybe Value) -> Value -> (String, List (Maybe Value))
62+valString xs (VInt x) = ("?", xs ++ [Just (VInt x)])
63+valString xs (VStr x) = ("?", xs ++ [Just (VStr x)])
64+valString xs (VCol n) = (n, xs)
65+
66+
67+evalCond : List (Maybe Value) -> Cond -> (String, List (Maybe Value))
68+evalCond xs (Equals val1 val2) = let (restring , newxs ) = valString xs val1 in
69+ let (restring2, newxs') = valString newxs val2 in
70+ (restring ++ " = " ++ restring2, (newxs ++ newxs'))
71+
72+evalCond xs (MkGT val1 val2) = let (restring , newxs ) = valString xs val1 in
73+ let (restring2, newxs') = valString newxs val2 in
74+ (restring ++ " > " ++ restring2, (newxs ++ newxs'))
75+
76+evalCond xs (MkGTE val1 val2) = let (restring , newxs ) = valString xs val1 in
77+ let (restring2, newxs') = valString newxs val2 in
78+ (restring ++ " >= " ++ restring2, (newxs ++ newxs'))
79+
80+evalCond xs (MkLT val1 val2) = let (restring , newxs ) = valString xs val1 in
81+ let (restring2, newxs') = valString newxs val2 in
82+ (restring ++ " < " ++ restring2, (newxs ++ newxs'))
83+
84+evalCond xs (MkLTE val1 val2) = let (restring , newxs ) = valString xs val1 in
85+ let (restring2, newxs') = valString newxs val2 in
86+ (restring ++ " =< " ++ restring2, (newxs ++ newxs'))
87+
88+
89+clauseString : List (Maybe Value) -> Clause -> (String, List (Maybe Value))
90+clauseString xs (Empty) = ("" , []) -- No condition
91+clauseString xs (MkCond cond') = let (condstr, newxs) = evalCond xs cond' in
92+ (condstr , newxs)
93+
94+clauseString xs (AND c1 c2) = let (clausestr, newxs) = clauseString xs c1 in
95+ let (clausestr2, newxs') = clauseString newxs c2 in
96+ (clausestr ++ " AND " ++clausestr2 , newxs')
97+
98+clauseString xs (OR c1 c2) = let (clausestr, newxs) = clauseString xs c1 in
99+ let (clausestr2, newxs') = clauseString newxs c2 in
100+ (clausestr ++ " OR " ++clausestr2 , newxs')
101+
102+
103+varString : List String -> String
104+varString xs = (unwords xs)
105+
106+
107+evalSQL : List (Maybe Value) -> SQL -> ( String, List (Maybe Value))
108+evalSQL xs (TBL tbl) = (tbl, xs)
109+evalSQL xs (SELECT vars sql' c) = let (sqlstring, newxs) = evalSQL xs sql' in
110+ let (csstring, newxs') = clauseString newxs c in
111+ case c of
112+ Empty => case vars of
113+ (ALL ) => ("SELECT " ++ "*" ++ " FROM (" ++ sqlstring ++ ") " ++ csstring, map snd ( mapping 0 newxs'))
114+ (Cols selvar) => ("SELECT " ++ unwords ( intersperse "" ( selvar ++ (words ( " FROM (" ++ sqlstring ++ ")")))) ++ csstring, map snd ( mapping 0 newxs'))
115+
116+ _ => case vars of
117+ (ALL ) => ("SELECT " ++ "*" ++ " FROM (" ++ sqlstring ++ ") " ++ "WHERE" ++ csstring, map snd ( mapping 0 newxs'))
118+ (Cols selvar) => ("SELECT " ++ unwords ( intersperse "" ( selvar ++ (words ( " FROM (" ++ sqlstring ++ ")")))) ++ "WHERE" ++ csstring, map snd ( mapping 0 newxs'))
119+
120+
121+display : (String, List (Maybe Value)) -> String
122+display (x, (xs)) = show x
123+
124+evalSQL2 : List (Maybe Value) -> String -> (String, List (Maybe Value))
125+evalSQL2 [] sql = (sql, [])
126+evalSQL2 ((Just (VInt x)) :: xs) sql = let ("string" , newxs) = evalSQL2 xs sql in
127+ ("string" ++ sql , Just (VInt x) :: newxs)
128+
129+main : IO ()
130+main = print (display(evalSQL [] ((SELECT ALL)(TBL "tbl") (MkCond (Equals (VCol "col")(VInt 1))))))
131+
132+