SQLNamer.curry 17.5 KB
Newer Older
Michael Hanus's avatar
Michael Hanus committed
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
--- This module resolves the pseudonym-tablename-binding for all columns 
--- and all relationship constraints in each parsed statement
--- with the help of a symboltable.
--- Errors are thrown whenever an alias can not be resolved, 
--- because it was not defined or is not visible or it was defined
--- more than once. An error is also thrown for an alias that was
--- defined but not used.
---@author: Julia Krone
---@version: 0.1
-- ------------------------------------------------------------------------

module SQLNamer(nameStatements) where

import Char (toLower)

import ParseTypes

import SQLAst
import Symboltab


--- Takes a list of completely parsed statements (wrapped in a PM),
--- inserts the name of the corresponding table (resolving the 
--- pseudonym if given) and sets the right alias (int) for CDBI
--- in each AST-node representing a column. The correct CDBI-alias
--- is also set for each table-node and relationship-constraint-node.
--- An error is thrown, if the referenced alias was not defined
--- in the corresponding statement or if it is defined more than once.
--- Consistence with the data model is not checked at this stage.
---@param pm - the PM containing list of parsed statements
---@return unchanged PM if it contained errors
---        PM with named columns otherwise
nameStatements ::  PM [Statement] -> Pos -> PM [Statement]
nameStatements (WM (Errors err) ws) _ = WM (throwPR err) ws
nameStatements (WM (OK ast) ws)     p = 
  let (WM resPR warns) = sequencePM (map (nameStatement p emptyTable) ast)
   in (WM resPR (ws ++ warns))

-- Symboltable structure used for the naming process.
-- The first finite map saves the notation given by the user,
-- the pseudonym and the CDBI-alias. The second FM keeps track of how often
-- a table name was referenced to calculate the correct CDBI-alias.
type AliasSymTab = Symboltable [(String,String, Int)] Int  
  
--naming-function for statement node  
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                                 

-- naming-funtion for selectHead-node
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))

-- naming-function for SelectClause-node
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)

-- naming-function for TableRef-node
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))

-- naming-function for JoinClause-node                                    
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))

-- naming-function for JoinCond-node
nameJoinCond :: Pos -> AliasSymTab -> JoinCond -> PM JoinCond
nameJoinCond p st (JC cond)=
   liftPM (\nCond -> (JC nCond))
          (nameCond p st cond)
                                      
-- naming-function for Condition-node
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

-- naming-function for Group-node
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)

-- naming-function for an Element-node in SelectClause
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))

-- naming-function for an operand-node
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) 

-- naming-function for Having-node
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

-- naming-function for Order-node
nameOrder :: Pos -> AliasSymTab -> Order -> PM Order
nameOrder p st (OrderBy colDirs) = 
   liftPM (\nOrds -> OrderBy nOrds)
          (sequencePM (map (nameSingleOrder p st) colDirs))

-- naming-function for a single column-direction-pair in Order-clause
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)
         -- this should not happen in update statements
       Left err  -> throwPM p err

nameAssignments :: Pos -> AliasSymTab -> [Assign] -> PM [Assign]
nameAssignments p st assigns =  sequencePM (map (nameAssign p st) assigns) 

-- naming-function for Assign-node
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)  
          --this should not happen in isert statements
        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)
          --this should not happen in delete statements
         Left err  -> throwPM p err

--insert of one or more wrapped in TableRef-node
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)

-- inserts a single table into the symbol table, returns modified symbol table
-- Increases count for CDBI-alias and also inserts it.
-- In case of default alias "table" also the tablename itself is 
-- inserted as alias.
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)                                 
                                  
-- naming-function for ColumnRef-node
-- replaces alias with table name and inserts CDBI-alias into column node
-- If alias is not found an error is thrown.
-- Warning is generated if notation of aliases differs.
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 --can just be default name "table"
     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)                                       

-- inserts correct CDBI-Alias into each table-node
-- ensures that alias is unique
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) --can not happen
         (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.")

-- Lookup-function used by relationship constraint     
-- Error is thrown if alias was not defined, a warning
-- is generated if notation differs from defined alias.
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