1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
|
module CPP.ICode.Parser.SQL.Namer(nameStatements) where
import Data.Char (toLower)
import CPP.ICode.ParseTypes
import CPP.ICode.Parser.SQL.AST
import CPP.ICode.Parser.SQL.Symboltab
nameStatements :: PM [Statement] -> Pos -> PM [Statement]
nameStatements (PM( WM (Errors err) ws)) _ = PM $ WM (throwPR err) ws
nameStatements (PM (WM (OK ast) ws)) p =
let (PM (WM resPR warns)) = sequencePM (map (nameStatement p emptyTable) ast)
in (PM $ WM resPR (ws ++ warns))
type AliasSymTab = Symboltable [(String,String, Int)] Int
nameStatement :: Pos -> AliasSymTab -> Statement -> PM Statement
nameStatement p st (Select selhead order lim) =
let (nSelHeadPm, st1) = nameSelHead p st selhead
in combinePMs (\nSelHead nOrder -> Select nSelHead nOrder lim)
nSelHeadPm
(nameOrder p st1 order)
nameStatement p st (Update tab assigns cond) = nameUpdate p st tab assigns cond
nameStatement _ _ (UpdateEntity tab val) = cleanPM (UpdateEntity tab val)
nameStatement p st (Delete tab cond) = nameDelete p tab st cond
nameStatement p st (Insert tab cols valss) = nameInsert p tab st cols valss
nameStatement _ _ Transaction = cleanPM Transaction
nameStatement p _ (InTransaction stats) =
liftPM (\nStats -> (InTransaction nStats))
(sequencePM (map (nameStatement p emptyTable) stats))
nameStatement _ _ Commit = cleanPM Commit
nameStatement _ _ Rollback = cleanPM Rollback
nameSelHead :: Pos -> AliasSymTab -> SelectHead -> (PM SelectHead, AliasSymTab)
nameSelHead p st (Query selclause tabs cond group) =
let symtab = insertTabs tabs st
in case symtab of
Right st1 -> ((combinePMs (\(nsc, ntabs) (nCond, nGroup)
-> (Query nsc ntabs nCond nGroup))
(combinePMs (,)(nameSelClause p st1 selclause)
(nameTableRefs p st1 tabs))
(combinePMs (,)(nameCond p st1 cond)
(nameGroup p st1 group))), st1)
Left err -> ((throwPM p err), st)
nameSelHead p st (Set op h1 h2) =
let (nhead1, st1) = nameSelHead p st h1
(nhead2, st2) = nameSelHead p emptyTable h2
in ((combinePMs (\nh1 nh2 -> (Set op nh1 nh2))
nhead1
nhead2)
,(combineST st1 st2))
nameSelClause :: Pos -> AliasSymTab -> SelectClause -> PM SelectClause
nameSelClause _ _ sc@(SelAll _) = cleanPM sc
nameSelClause p st (SelColumns sp elems) =
liftPM (\nElems -> (SelColumns sp nElems))
(nameElems p st elems)
nameTableRefs :: Pos -> AliasSymTab -> TableRef -> PM TableRef
nameTableRefs p st (TableRef tab Nothing) =
liftPM (\nTab -> (TableRef nTab Nothing))
(nameTable p st tab)
nameTableRefs p st (TableRef tab (Just (CrossJoin tab2 join))) =
combinePMs (\(nTab, nTab2) nJoin ->
(TableRef nTab (Just (CrossJoin nTab2 nJoin))))
(combinePMs (,)
(nameTable p st tab)
(nameTable p st tab2))
(nameJoins p st join)
nameTableRefs p st (TableRef tab (Just (InnerJoin tab2 cond join))) =
combinePMs (\(nTab, nTab2) (nJoinCond, nJoin) ->
(TableRef nTab (Just (InnerJoin nTab2 nJoinCond nJoin))))
(combinePMs (,) (nameTable p st tab)
(nameTable p st tab2))
(combinePMs (,) (nameJoinCond p st cond)
(nameJoins p st join))
nameJoins :: Pos -> AliasSymTab -> Maybe JoinClause -> PM (Maybe JoinClause)
nameJoins _ _ Nothing = cleanPM Nothing
nameJoins p st (Just (CrossJoin tab join)) =
combinePMs (\nTab nJoin -> (Just (CrossJoin nTab nJoin)))
(nameTable p st tab)
(nameJoins p st join)
nameJoins p st (Just (InnerJoin tab cond join)) =
combinePMs (\nTab (nCond, nJoin) -> (Just (InnerJoin nTab nCond nJoin)))
(nameTable p st tab)
(combinePMs (,)(nameJoinCond p st cond)
(nameJoins p st join))
nameJoinCond :: Pos -> AliasSymTab -> JoinCond -> PM JoinCond
nameJoinCond p st (JC cond)=
liftPM (\nCond -> (JC nCond))
(nameCond p st cond)
nameCond :: Pos -> AliasSymTab -> Condition -> PM Condition
nameCond p st (FK (ps1,_) rel (ps2,_)) =
combinePMs (\nTab1 nTab2 -> (FK nTab1 rel nTab2))
(getTable p ps1 st)
(getTable p ps2 st)
nameCond p st (Cmp op cond1 cond2) =
combinePMs (\nCond1 nCond2 ->(Cmp op nCond1 nCond2))
(nameCond p st cond1)
(nameCond p st cond2)
nameCond p st (Not cond) = liftPM (\nCond -> (Not nCond))
(nameCond p st cond)
nameCond p st (Exists stat) = liftPM (\nStat -> (Exists nStat))
(nameStatement p (enterScope st) stat)
nameCond p st (IsNull op) = liftPM (\nOp -> (IsNull nOp))
(nameOperand p st op)
nameCond p st (NotNull op) = liftPM (\nOp -> (NotNull nOp))
(nameOperand p st op)
nameCond p st (AIn op vals) = liftPM (\nOp -> (AIn nOp vals))
(nameOperand p st op)
nameCond p st (ABinOp bop op1 op2) =
combinePMs (\nOp1 nOp2 -> (ABinOp bop nOp1 nOp2))
(nameOperand p st op1)
(nameOperand p st op2)
nameCond p st (ABetween op1 op2 op3) =
combinePMs (\nOp1 (nOp2,nOp3) -> (ABetween nOp1 nOp2 nOp3))
(nameOperand p st op1)
(combinePMs (,) (nameOperand p st op2)
(nameOperand p st op3))
nameCond _ _ NoCond = cleanPM NoCond
nameGroup :: Pos -> AliasSymTab -> Maybe Group -> PM (Maybe Group)
nameGroup p st (Just (GroupBy cols hav)) =
combinePMs (\nCols nHave -> (Just (GroupBy nCols nHave)))
(nameColumns p st cols)
(nameHaving p st hav)
nameGroup _ _ Nothing = cleanPM Nothing
nameElems :: Pos -> AliasSymTab -> [SelElement] -> PM [SelElement]
nameElems p st elems = sequencePM (map (nameSingleElem p st) elems)
nameSingleElem :: Pos -> AliasSymTab -> SelElement -> PM SelElement
nameSingleElem p st (Aggregation fun sp col) =
liftPM (\nCol -> (Aggregation fun sp nCol))
(nameSingleColumn p st col)
nameSingleElem p st (Col col) = liftPM (\nCol -> (Col nCol))
(nameSingleColumn p st col)
nameSingleElem p st (Case cond op1 op2) =
combinePMs (\nCond (nOp1, nOp2) -> (Case nCond nOp1 nOp2))
(nameCond p st cond)
(combinePMs (,) (nameOperand p st op1)
(nameOperand p st op2))
nameOperand :: Pos -> AliasSymTab-> Operand -> PM Operand
nameOperand p st (Left col) = liftPM (\nCol -> (Left nCol))
(nameSingleColumn p st col)
nameOperand _ _ (Right val) = cleanPM (Right val)
nameHaving :: Pos -> AliasSymTab -> Having -> PM Having
nameHaving p st (SimpleHave cond) = liftPM (\nCond -> (SimpleHave nCond))
(nameCond p st cond)
nameHaving p st (AggrHave fun sp col bop op) =
combinePMs (\nCol nOp -> (AggrHave fun sp nCol bop nOp))
(nameSingleColumn p st col )
(nameOperand p st op)
nameHaving p st (Neg have) = liftPM (\nHave -> (Neg nHave))
(nameHaving p st have)
nameHaving p st (CmpHave lop have1 have2) =
combinePMs (\nH1 nH2 -> (CmpHave lop nH1 nH2))
(nameHaving p st have1)
(nameHaving p st have2)
nameHaving _ _ NoHave = cleanPM NoHave
nameOrder :: Pos -> AliasSymTab -> Order -> PM Order
nameOrder p st (OrderBy colDirs) =
liftPM (\nOrds -> OrderBy nOrds)
(sequencePM (map (nameSingleOrder p st) colDirs))
nameSingleOrder :: Pos -> AliasSymTab -> (ColumnRef, Dir) -> PM (ColumnRef, Dir)
nameSingleOrder p st (col, dir) = liftPM (\nCol -> (nCol,dir))
(nameSingleColumn p st col)
nameUpdate :: Pos ->
AliasSymTab ->
Table ->
[Assign] ->
Condition ->
PM Statement
nameUpdate p st tab assigns cond =
let symtab = insertTab tab st
in case symtab of
Right st1 -> combinePMs (\nAssigns nCond -> (Update tab nAssigns nCond))
(nameAssignments p st1 assigns)
(nameCond p st1 cond)
Left err -> throwPM p err
nameAssignments :: Pos -> AliasSymTab -> [Assign] -> PM [Assign]
nameAssignments p st assigns = sequencePM (map (nameAssign p st) assigns)
nameAssign :: Pos -> AliasSymTab -> Assign -> PM Assign
nameAssign p st (Assign col val) =
liftPM (\nCol -> (Assign nCol val))
(nameSingleColumn p st col)
nameInsert :: Pos ->
Table ->
AliasSymTab ->
[ColumnRef] ->
[[Value]] ->
PM Statement
nameInsert p tab st cols valss =
let symtab = insertTab tab st
in case symtab of
Right st1 -> liftPM (\nCols -> (Insert tab nCols valss))
(nameColumns p st1 cols)
Left err -> throwPM p err
nameDelete :: Pos -> Table -> AliasSymTab -> Condition -> PM Statement
nameDelete p tab st cond =
let symtab = insertTab tab st
in case symtab of
Right st1 -> liftPM (\nCond -> (Delete tab nCond))
(nameCond p st1 cond)
Left err -> throwPM p err
insertTabs :: TableRef -> AliasSymTab -> Either String AliasSymTab
insertTabs (TableRef tab join) st =
checkJoinForTabs join (insertTab tab st)
checkJoinForTabs :: Maybe JoinClause ->
Either String AliasSymTab ->
Either String AliasSymTab
checkJoinForTabs Nothing st = st
checkJoinForTabs (Just (CrossJoin tab join)) (Right st) =
checkJoinForTabs join (insertTab tab st)
checkJoinForTabs (Just (InnerJoin tab _ join)) (Right st) =
checkJoinForTabs join (insertTab tab st)
checkJoinForTabs (Just _) (Left tab) = (Left tab)
insertTab :: Table -> AliasSymTab -> Either String AliasSymTab
insertTab (Table name al _) st =
let cnt = lookupSecondTable (toLowerCase name) st
in let n = case cnt of
Nothing -> 0
Just c -> c
in if(al == "table")
then case lookupFirstTable (toLowerCase name) st of
Nothing -> Right (insertDefFirstTab
(toLowerCase al)
[(name, al, n)]
(++)
(insertSecondTable
(toLowerCase name)
(n+1)
(insertFirstTable (toLowerCase name)
[(name, name, n)]
st)))
(Just _) -> Left ("Ambiguous table reference: "++name)
else case lookupFirstTable (toLowerCase al) st of
Nothing -> Right (insertFirstTable
(toLowerCase al)
[(name, al, n)]
(insertSecondTable (toLowerCase name)
(n+1)
st))
(Just _) -> Left ("Alias "++al++" was defined for more "
++"than one table.")
nameColumns :: Pos -> AliasSymTab -> [ColumnRef] -> PM [ColumnRef]
nameColumns p st cols = sequencePM (map (nameSingleColumn p st) cols)
nameSingleColumn :: Pos -> AliasSymTab -> ColumnRef -> PM ColumnRef
nameSingleColumn p st (Column (Unique pseudo) column typ nullable _) =
case lookupFirstTable (toLowerCase pseudo) st of
Nothing -> throwPM p ("Table alias "++pseudo++
" was not defined or "++
"is not visible.")
(Just ((tab, orgAl, cnt):_)) ->
if orgAl == pseudo
then cleanPM (Column (Unique tab) column typ nullable cnt)
else warnOKPM (Column (Unique tab) column typ nullable cnt)
[(p, ("Found different notation of same "++
"alias: "++pseudo++" and "++orgAl))]
nameSingleColumn p st (Column (Def pseudo) column typ nullable cnt) =
case lookupFirstTable (toLowerCase (head pseudo)) st of
Nothing -> throwPM p ("No table given for column "
++column++". Maybe alias was"
++" defined but not used.")
(Just tabs) -> let tns = map fstOfTriple tabs
in cleanPM (Column (Def tns) column typ nullable cnt)
nameTable :: Pos -> AliasSymTab -> Table -> PM Table
nameTable p st (Table name al _) =
let key = if(al == "table")
then (toLowerCase name)
else (toLowerCase al)
in case lookupFirstTable key st of
Nothing -> throwPM p ("No Table found for table "++name)
(Just ((n, _ , cnt):_)) -> if ((toLowerCase n) == (toLowerCase name))
then cleanPM (Table name al cnt)
else throwPM p ("Alias "++key++
" is defined for" ++
" more than one table.")
getTable :: Pos -> String -> AliasSymTab -> PM (String, Int)
getTable p pseudo st =
case lookupFirstTable (toLowerCase pseudo) st of
Nothing -> throwPM p ("Table alias "++pseudo++
" was not defined.")
(Just ((tab, orgAl, cnt):_)) ->
if orgAl == pseudo
then cleanPM (tab, cnt)
else warnOKPM (tab, cnt)
[(p, ("Found different notation of same "++
"alias or table: "++pseudo++" and "++
orgAl))]
toLowerCase :: String -> String
toLowerCase str = map toLower str
fstOfTriple :: (a,b,c) -> a
fstOfTriple (ele, _ , _) = ele
|