18da492 · Idris-dev · git.iko.soy

5-- |

6-- Module : sqlexpr

7-- Copyright : (c) The University of St Andrews, 2012

8−--

8+--

9-- Implementations for SQLite query data type.

10--

11-----------------------------------------------------------------------------

14-----------------------------------------------------------

15-- | SQL data type

16-----------------------------------------------------------

17−

17+

18data Value = VInt Int

19− |VStr String

19+ | VStr String

20− |VFloat Float

20+ | VFloat Float

21− |VCol String

21+ | VCol String

22− |VNULL

22+ | VNULL

23−

23+

24−--Perhaps could extend this by adding

24+--Perhaps could extend this by adding

25−-- a dot operator to allow mapping

25+-- a dot operator to allow mapping

26−-- between table and column and

26+-- between table and column and

27−-- comparing different table columns.

27+-- comparing different table columns.

28

29data Cond = Equals Value Value

30− |MkGT Value Value

30+ | MkGT Value Value

31− |MkGTE Value Value

31+ | MkGTE Value Value

32− |MkLT Value Value

32+ | MkLT Value Value

33− |MkLTE Value Value

33+ | MkLTE Value Value

34− |MkNULL Value

34+ | MkNULL Value

35

36data SelVar = Cols (List String)

37 | ALL

68 | CREATE SQL (List (Value, ColType , Constr))

69

70-- remember to remove these funcs later

71−-- foldr1 : (a -> a -> a) -> List a -> a

71+-- foldr1 : (a -> a -> a) -> List a -> a

72-- foldr1 f [x] = x

73-- foldr1 f (x::xs) = f x (foldr1 f xs)

74

75

76-- unwords' : List (List Char) -> List Char

77−-- unwords' [] = []

77+-- unwords' [] = []

78-- unwords' ws = (foldr1 addSpace ws)

79-- where

80-- addSpace : List Char -> List Char -> List Char

81−-- addSpace w s = w ++ (' ' :: s)

81+-- addSpace w s = w ++ (' ' :: s)

82−--

82+--

83−--

83+--

84-- unwords : List String -> String

85-- unwords = pack . unwords' . map unpack

86

87-----------------------------------------------------------

88-- | This function replaces values with question mark

89−-- following by an index number. It then puts the value

89+-- following by an index number. It then puts the value

90-- replaced, in the list.

91-----------------------------------------------------------

92

93−valString : List (Maybe(Int, Value)) -> Value -> (String, List (Maybe(Int, Value)))

93+valString : List (Maybe (Int, Value)) -> Value -> (String, List (Maybe (Int, Value)))

94−valString xs (VInt x) = ("?" ++ show (cast(length xs)+1), xs ++ [Just (cast((length xs)+1),(VInt x))])

94+valString xs (VInt x) = ("?" ++ show (cast (length xs) + 1), xs ++ [Just (cast ((length xs) + 1), (VInt x))])

95−valString xs (VStr x) = ("?" ++ show (cast(length xs)+1), xs ++ [Just (cast((length xs)+1),(VStr x))])

95+valString xs (VStr x) = ("?" ++ show (cast (length xs) + 1), xs ++ [Just (cast ((length xs) + 1), (VStr x))])

96−valString xs (VFloat x) = ("?" ++ show (cast(length xs)+1), xs ++ [Just (cast((length xs)+1),(VFloat x))])

96+valString xs (VFloat x) = ("?" ++ show (cast (length xs) + 1), xs ++ [Just (cast ((length xs) + 1), (VFloat x))])

97−valString xs (VCol n) = (n, xs)

97+valString xs (VCol n) = (n, xs)

98

99-----------------------------------------------------------

100-- | This function calls valString on a list of Values

101-- and separates the values by commas.

102-----------------------------------------------------------

103

104−listVal : List (Maybe(Int, Value)) -> List Value -> (String, List (Maybe(Int, Value)))

104+listVal : List (Maybe (Int, Value)) -> List Value -> (String, List (Maybe (Int, Value)))

105−listVal xs [] = ("", xs)

105+listVal xs [] = ("", xs)

106listVal xs (v::vs) = let (str, newxs) = (valString xs v) in

107− let (str', newxs') = listVal newxs vs in

107+ let (str', newxs') = listVal newxs vs in

108− ((unwords(intersperse "," (words(str) ++ words (str')))), newxs')

108+ (unwords (intersperse "," (words (str) ++ words (str'))), newxs')

109

110-----------------------------------------------------------

111-- | Parses the type of column to be created.

112-----------------------------------------------------------

113−

113+

114−getColType : List (Maybe(Int, Value)) -> ColType -> (String, List (Maybe(Int, Value)))

114+getColType : List (Maybe (Int, Value)) -> ColType -> (String, List (Maybe (Int, Value)))

115getColType xs (CInt x) = ("int", xs)

116getColType xs (Varchar str) = ("varchar(255)", xs)

117

119-- | CREATE Constraints

120-----------------------------------------------------------

121

122−getConstr : List (Maybe(Int, Value)) -> Constr -> (String, List (Maybe(Int, Value)))

122+getConstr : List (Maybe (Int, Value)) -> Constr -> (String, List (Maybe (Int, Value)))

123−getConstr xs (NOTNULL) = ("NOT NULL", xs)

123+getConstr xs (NOTNULL) = ("NOT NULL", xs)

124getConstr xs (UNIQUE constr) = ("NOT NULL UNIQUE", xs)

125−getConstr xs (PRIMARYKEY) = ("PRIMARY KEY", xs)

125+getConstr xs (PRIMARYKEY) = ("PRIMARY KEY", xs)

126−getConstr xs (FOREIGNKEY) = ("FOREIGN KEY", xs)

126+getConstr xs (FOREIGNKEY) = ("FOREIGN KEY", xs)

127−getConstr xs (CHECK) = ("CHECK", xs)

127+getConstr xs (CHECK) = ("CHECK", xs)

128−getConstr xs (DEFAULT) = ("DEFAULT", xs)

128+getConstr xs (DEFAULT) = ("DEFAULT", xs)

129−getConstr xs (None) = ("", xs)

129+getConstr xs (None) = ("", xs)

130

131putBrackets : String -> String

132putBrackets str = "(" ++ str ++ ")"

136-- This function is used for bracketing the nested queries.

137-----------------------------------------------------------

138complexType : SQL -> Bool

139−complexType (TBL tbl) = False

139+complexType (TBL tbl) = False

140complexType (SELECT vars sql c) = True

141−

141+

142-----------------------------------------------------------

143-- | Used in CREATE

144−-----------------------------------------------------------

144+-----------------------------------------------------------

145−

145+

146−listValType : List (Maybe(Int, Value)) -> List (Value, ColType , Constr) -> (String, List (Maybe(Int, Value)))

146+listValType : List (Maybe (Int, Value)) -> List (Value, ColType , Constr) -> (String, List (Maybe (Int, Value)))

147listValType xs [] = ("", xs)

148−listValType xs ((val, types, constr) :: vs) = let (str , newxs) = valString xs val in

148+listValType xs ((val, types, constr) :: vs) =

149+ let (str , newxs) = valString xs val in

149− let (str' , newxs') = getColType newxs types in

150+ let (str' , newxs') = getColType newxs types in

150− let (str'', newxs'') = getConstr newxs' constr in

151+ let (str'', newxs'') = getConstr newxs' constr in

151− let (finalstr, finalxs) = listValType newxs'' vs in

152+ let (finalstr, finalxs) = listValType newxs'' vs in

152− ((unwords(intersperse " " (words(str) ++ words(str') ++ words(str'') ++ words(finalstr)))) , finalxs)

153+ (unwords (intersperse " " (words str ++ words str' ++ words str'' ++ words finalstr)) , finalxs)

153

154

155

155-----------------------------------------------------------

156-----------------------------------------------------------

156-- | Evaluates a conditional WHERE clause

157-- | Evaluates a conditional WHERE clause

157−-----------------------------------------------------------

158+-----------------------------------------------------------

158

159

159−evalCond : List (Maybe(Int, Value)) -> Cond -> (String, List (Maybe(Int, Value)))

160+evalCond : List (Maybe (Int, Value)) -> Cond -> (String, List (Maybe (Int, Value)))

160evalCond xs (Equals val1 val2) = let (restring , newxs ) = valString xs val1 in

161evalCond xs (Equals val1 val2) = let (restring , newxs ) = valString xs val1 in

161 let (restring2, newxs') = valString newxs val2 in

162 let (restring2, newxs') = valString newxs val2 in

162− (restring ++ " = " ++ restring2, newxs')

163+ (restring ++ " = " ++ restring2, newxs')

163−

164+

164evalCond xs (MkGT val1 val2) = let (restring , newxs ) = valString xs val1 in

165evalCond xs (MkGT val1 val2) = let (restring , newxs ) = valString xs val1 in

165− let (restring2, newxs') = valString newxs val2 in

166+ let (restring2, newxs') = valString newxs val2 in

166− (restring ++ " > " ++ restring2, newxs')

167+ (restring ++ " > " ++ restring2, newxs')

167

168

168evalCond xs (MkGTE val1 val2) = let (restring , newxs ) = valString xs val1 in

169evalCond xs (MkGTE val1 val2) = let (restring , newxs ) = valString xs val1 in

169− let (restring2, newxs') = valString newxs val2 in

170+ let (restring2, newxs') = valString newxs val2 in

170− (restring ++ " >= " ++ restring2, newxs')

171+ (restring ++ " >= " ++ restring2, newxs')

171

172

172evalCond xs (MkLT val1 val2) = let (restring , newxs ) = valString xs val1 in

173evalCond xs (MkLT val1 val2) = let (restring , newxs ) = valString xs val1 in

173− let (restring2, newxs') = valString newxs val2 in

174+ let (restring2, newxs') = valString newxs val2 in

174− (restring ++ " < " ++ restring2, newxs')

175+ (restring ++ " < " ++ restring2, newxs')

175−

176+

176evalCond xs (MkLTE val1 val2) = let (restring , newxs ) = valString xs val1 in

177evalCond xs (MkLTE val1 val2) = let (restring , newxs ) = valString xs val1 in

177− let (restring2, newxs') = valString newxs val2 in

178+ let (restring2, newxs') = valString newxs val2 in

178− (restring ++ " =< " ++ restring2, newxs')

179+ (restring ++ " =< " ++ restring2, newxs')

179−

180+

180evalCond xs (MkNULL val) = let (restring , newxs ) = valString xs val in

181evalCond xs (MkNULL val) = let (restring , newxs ) = valString xs val in

181− (restring ++ " IS NULL " , newxs)

182+ (restring ++ " IS NULL " , newxs)

183+

182

184

183−-----------------------------------------------------------

184−-- | Evaluates queries by calling the other functions

185−-- on each part of the query

186−-----------------------------------------------------------

187−evalSQL : List (Maybe(Int, Value)) -> SQL -> ( String, List (Maybe(Int, Value)))

188-----------------------------------------------------------

185-----------------------------------------------------------

189-- | Evaluates clauses

186-- | Evaluates clauses

190-- Supports WHERE Clause

187-- Supports WHERE Clause

191-- WHERE Clause And Another-Clause

188-- WHERE Clause And Another-Clause

192-- WHERE Clause Or Another-Clause

189-- WHERE Clause Or Another-Clause

193−-----------------------------------------------------------

190+-----------------------------------------------------------

194−clauseString : List (Maybe(Int, Value)) -> Clause -> (String, List (Maybe(Int, Value)))

191+clauseString : List (Maybe (Int, Value)) -> Clause -> (String, List (Maybe (Int, Value)))

195

192

196clauseString xs (Empty) = ("" , []) -- No condition

193clauseString xs (Empty) = ("" , []) -- No condition

197clauseString xs (MkCond cond') = let (condstr, newxs) = evalCond xs cond' in

194clauseString xs (MkCond cond') = let (condstr, newxs) = evalCond xs cond' in

198− (condstr , newxs)

195+ (condstr , newxs)

199

196

200clauseString xs (AND c1 c2) = let (clausestr, newxs) = clauseString xs c1 in

197clauseString xs (AND c1 c2) = let (clausestr, newxs) = clauseString xs c1 in

201 let (clausestr2, newxs') = clauseString newxs c2 in

198 let (clausestr2, newxs') = clauseString newxs c2 in

202− (clausestr ++ " AND " ++clausestr2 , newxs')

199+ (clausestr ++ " AND " ++ clausestr2 , newxs')

203−

200+

204−clauseString xs (OR c1 c2) = let (clausestr, newxs) = clauseString xs c1 in

201+clauseString xs (OR c1 c2) = let (clausestr, newxs) = clauseString xs c1 in

205− let (clausestr2, newxs') = clauseString newxs c2 in

202+ let (clausestr2, newxs') = clauseString newxs c2 in

206− (clausestr ++ " OR " ++clausestr2 , newxs')

203+ (clausestr ++ " OR " ++ clausestr2 , newxs')

207−

204+

208

205

209-----------------------------------------------------------

206-----------------------------------------------------------

210-- | Evaluates conditional clauses.

207-- | Evaluates conditional clauses.

211-----------------------------------------------------------

208-----------------------------------------------------------

212−

209+

213−condClauseStr : List (Maybe(Int, Value)) -> condClause -> (String, List (Maybe(Int, Value)))

210+condClauseStr : List (Maybe (Int, Value)) -> condClause -> (String, List (Maybe (Int, Value)))

214condClauseStr xs (SET setcl) = let (condstr, newxs) = clauseString xs setcl in

211condClauseStr xs (SET setcl) = let (condstr, newxs) = clauseString xs setcl in

215− (" SET " ++ condstr, newxs)

212+ (" SET " ++ condstr, newxs)

216−

213+

217condClauseStr xs (WHERE setcl1 setcl2) = let (condstr, newxs) = condClauseStr xs setcl1 in

214condClauseStr xs (WHERE setcl1 setcl2) = let (condstr, newxs) = condClauseStr xs setcl1 in

218 let (condstr', newxs') = clauseString newxs setcl2 in

215 let (condstr', newxs') = clauseString newxs setcl2 in

219− ( condstr ++ " WHERE " ++ condstr', newxs')

216+ ( condstr ++ " WHERE " ++ condstr', newxs')

220−

217+

218+

219+-----------------------------------------------------------

220+-- | Evaluates queries by calling the other functions

221+-- on each part of the query

222+-----------------------------------------------------------

223+evalSQL : List (Maybe (Int, Value)) -> SQL -> (String, List (Maybe (Int, Value)))

221−-- SELECT data from tbl1 where num > (SELECT num from tbl1 where num = 24)

224+-- SELECT data from tbl1 where num > (SELECT num from tbl1 where num = 24)

222−-- evalSQL [] ((SELECT ALL)(TBL "tbl")(MkSQL ((SELECT ALL) (TBL "tbl")(MkCond (VCol "))))

225+-- evalSQL [] ((SELECT ALL)(TBL "tbl")(MkSQL ((SELECT ALL) (TBL "tbl")(MkCond (VCol "))))

223−-- NTBF

226+-- NTBF

224--clauseString xs (MkSQL sql) = (evalSQL xs sql)

227--clauseString xs (MkSQL sql) = (evalSQL xs sql)

225

228

226−-- Separate list of tables

229+-- Separate list of tables

227-- For complex type, return list returned by evalSQL

230-- For complex type, return list returned by evalSQL

228−-- And add brackets

231+-- And add brackets

229−evalSQL xs (TBL tbl) = ((unwords (intersperse "," ( tbl))), xs)

232+evalSQL xs (TBL tbl) = (unwords (intersperse "," ( tbl)), xs)

233+evalSQL xs (SELECT vars sql' c) =

230−evalSQL xs (SELECT vars sql' c) = let (sqlstring, newxs) = evalSQL xs sql' in

234+ let (sqlstring, newxs) = evalSQL xs sql' in

231− let (csstring, newxs') = clauseString newxs c in

235+ let (csstring, newxs') = clauseString newxs c in

232− case c of

236+ case c of

233− Empty => case vars of

237+ Empty => case vars of

234− (ALL ) => if complexType sql' then ("SELECT " ++ "*" ++ " FROM "

238+ ALL => if complexType sql'

239+ then ("SELECT " ++ "*" ++ " FROM " ++

235− ++ (putBrackets sqlstring) ++ csstring, newxs)

240+ putBrackets sqlstring ++ csstring, newxs)

236−

237− else ("SELECT " ++ "*" ++ " FROM " ++ sqlstring

241+ else ("SELECT " ++ "*" ++ " FROM " ++ sqlstring ++

238− ++ csstring, newxs')

242+ csstring, newxs')

239−

240− (Cols selvar) => if complexType sql' then ("SELECT " ++ (unwords selvar) ++

243+ Cols selvar => if complexType sql'

244+ then ("SELECT " ++ unwords selvar ++

241− " FROM " ++ (putBrackets sqlstring) ++ csstring, newxs)

245+ " FROM " ++ putBrackets sqlstring ++ csstring, newxs)

242−

243− else ("SELECT " ++ (unwords selvar )++ " FROM " ++ sqlstring

246+ else ("SELECT " ++ unwords selvar ++ " FROM " ++ sqlstring ++

244− ++ csstring, newxs')

247+ csstring, newxs')

245−

246− _ => case vars of

248+ _ => case vars of

247− (ALL ) => if complexType sql' then ("SELECT " ++ "*" ++ " FROM "

249+ ALL => if complexType sql'

250+ then ("SELECT " ++ "*" ++ " FROM " ++

248− ++ " WHERE " ++ csstring , newxs)

251+ " WHERE " ++ csstring, newxs)

249− else ("SELECT " ++ "*" ++ " FROM " ++ sqlstring

252+ else ("SELECT " ++ "*" ++ " FROM " ++ sqlstring

250− ++ " WHERE " ++ csstring , newxs')

253+ ++ " WHERE " ++ csstring, newxs')

251−

254+ Cols selvar => if complexType sql'

252− (Cols selvar) => if complexType sql' then ("SELECT " ++ (unwords selvar) ++ " FROM " ++

255+ then ("SELECT " ++ (unwords selvar) ++ " FROM " ++

253− (putBrackets sqlstring) ++ " WHERE "

256+ putBrackets sqlstring ++ " WHERE " ++

254− ++ csstring , newxs)

257+ csstring , newxs)

255−

256− else ("SELECT " ++ (unwords selvar) ++ " FROM " ++ sqlstring

258+ else ("SELECT " ++ (unwords selvar) ++ " FROM " ++ sqlstring ++

257− ++ " WHERE " ++ csstring , newxs')

259+ " WHERE " ++ csstring, newxs')

258−

260+

259−

261+

260−evalSQL xs (INSERT sql vals) = let (tblname, newvals) = evalSQL xs sql in

262+evalSQL xs (INSERT sql vals) = let (tblname, newvals) = evalSQL xs sql in

261− let (str, newxs ) = listVal newvals vals in

263+ let (str, newxs ) = listVal newvals vals in

262− ("INSERT INTO " ++ tblname ++ " VALUES (" ++ str ++ ")" , newxs)

264+ ("INSERT INTO " ++ tblname ++ " VALUES (" ++ str ++ ")", newxs)

263−

265+

264−evalSQL xs (INSERTC sql cols vals) = let (tblname, newvals) = evalSQL xs sql in

266+evalSQL xs (INSERTC sql cols vals) = let (tblname, newvals) = evalSQL xs sql in

265 let (strcol, newcol) = listVal newvals cols in

267 let (strcol, newcol) = listVal newvals cols in

266 let (strval, newcolval) = listVal newcol vals in

268 let (strval, newcolval) = listVal newcol vals in

267− ("INSERT INTO " ++ tblname ++ "(" ++ strcol ++ ")" ++ "VALUES (" ++ strval ++ ")", newcolval)

269+ ("INSERT INTO " ++ tblname ++ "(" ++ strcol ++ ")" ++ "VALUES (" ++ strval ++ ")", newcolval)

268

270

269

271

270evalSQL xs (UPDATE sql cl) = let (tblname, newxs) = evalSQL xs sql in

272evalSQL xs (UPDATE sql cl) = let (tblname, newxs) = evalSQL xs sql in

271− let (csstring, newxs') = condClauseStr newxs cl in

273+ let (csstring, newxs') = condClauseStr newxs cl in

272− ("UPDATE " ++ tblname ++ csstring, newxs')

274+ ("UPDATE " ++ tblname ++ csstring, newxs')

273

275

274evalSQL xs (CREATE sql details) = let (sqlstring, newxs) = evalSQL xs sql in

276evalSQL xs (CREATE sql details) = let (sqlstring, newxs) = evalSQL xs sql in

275 let (csstring, newxs') = listValType newxs details in

277 let (csstring, newxs') = listValType newxs details in

276− ("CREATE TABLE " ++ sqlstring ++ "(" ++ csstring ++ ")", newxs')

278+ ("CREATE TABLE " ++ sqlstring ++ "(" ++ csstring ++ ")", newxs')