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
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
-- ---------------------------------------------------------
--- This module translates the abstract syntax tree
--- into a curry programm using the AbstractCurry libraries.
--- Errors are thrown for limitations caused by CDBI.
--- The translation is provided as a single line string as
--- required by currypp.
---
--- @author Julia Krone
--- @version June 2023
-- ---------------------------------------------------------

module CPP.ICode.Parser.SQL.Translator(translate) where

import AbstractCurry.Types
import AbstractCurry.Pretty
import AbstractCurry.Build
import Data.Char            ( toLower, toUpper )
import Data.List            ( intercalate, splitOn )
import Text.Pretty          ( pPrint )

import CPP.ICode.ParseTypes

import CPP.ICode.Parser.SQL.AST

-- module name needed for qualified names
mCDBI :: String
mCDBI = "Database.CDBI.ER"

--- Invokes the translation of the AST into a string of curry code
--- in case a valid AST is given, does nothing otherwise.
translate :: PM [Statement] -> Bool -> String -> Pos -> PM String
translate (PM (WM (Errors err) ws)) _ _ _ = PM $ WM (throwPR err) ws
translate (PM (WM (OK stats) ws)) withrundb mModel pos =
  let (PM (WM resPR warns)) = sequencePM (map (transStatement pos mModel) stats )
   in liftPM showFunction (PM $ WM resPR (warns++ws))
 where
  -- The list of CExpr representing the statements is concatenated and pretty
  -- printed. To obtain a single-line translation, line feeds are replaced by
  -- space characters and indentation is removed
  showFunction stats =
    let finExpr = if withrundb
                    then applyF (mCDBI, "runWithDB")
                                [constF (mModel, "sqliteDBFile"),
                                 concatStatements stats]
                    else concatStatements stats
        finStr = (pPrint (ppCExpr defaultOptions finExpr))
        newLines = splitOn ['\n'] finStr
    in '(' : removeIndents (intercalate [' '] newLines) ++ ")"

removeIndents :: String -> String
removeIndents [] = []
removeIndents (s:str) =
  case s of
     ' ' -> let (_, rest) = span (\c -> c == ' ') str
             in s : removeIndents rest
     _   -> s : removeIndents str

concatStatements :: [CExpr] -> CExpr
concatStatements [] = CLambda [cpvar "conn"]
                              (applyF (pre "return")
                                      [applyE (CSymbol (pre "Right"))
                                              [(CSymbol (pre "()"))]])
concatStatements [stat] = stat
concatStatements (s1:s2:stats) = applyF (mCDBI, ">+")
                                        [s1, (concatStatements (s2:stats))]

-- -----------------------------------translation -----------------------------
-- Call corresponding translation for each kind of statement
transStatement ::  Pos -> String -> Statement -> PM CExpr
transStatement p mModel (Select selhead order lim)  =
 bindPM  (transLimit lim)
         (transSelHead p mModel selhead order )
transStatement p mModel (Update tab assigns cond) =
  combinePMs (\table valCond -> applyF (mCDBI, "updateEntries")(table:valCond))
             (transTableName mModel tab)
             (transUpdate p mModel assigns cond)
transStatement _ mModel (UpdateEntity tab val) =
  liftPM (\table -> applyF (mCDBI, "updateEntry")
                           [table, transValue mModel val False])
         (transTableName mModel tab)
transStatement p mModel (Delete tab cond) = transDelete p mModel tab cond
transStatement _ mModel (Insert tab cols valss) =
  combinePMs (\func args -> applyF func args)
             (getInsertFunction valss)
             (combinePMs (\d t -> [d,t])
                         (transTableName mModel tab)
                         (transInsertData mModel tab cols valss) )
transStatement p mModel (InTransaction sts) = transTransaction p mModel sts
transStatement _ _ Transaction =
        cleanPM (CLambda [cpvar "c"]
                (applyF (pre "(>>)")
                        [(applyF (mCDBI, "begin") [cvar "c"]),
                         (applyF (pre "return")
                                 [applyE (CSymbol (pre "Right"))
                                         [(CSymbol (pre "()"))]])]))
transStatement _ _ Commit =
        cleanPM (CLambda [cpvar "c"]
                (applyF (pre "(>>)")
                        [(applyF (mCDBI, "commit") [cvar "c"]),
                         (applyF (pre "return")
                                 [applyE (CSymbol (pre "Right"))
                                         [(CSymbol (pre "()"))]])]))
transStatement _ _ Rollback =
        cleanPM (CLambda [cpvar "c"]
                (applyF (pre "(>>)")
                        [(applyF (mCDBI, "rollback") [cvar "c"]),
                         (applyF (pre "return")
                                 [applyE (CSymbol (pre "Right"))
                                         [(CSymbol (pre "()"))]])]))

-- ---------------------transaction -------------------------
-- The translation of a transactional statement requires the concatenation
-- of staements with a monadic operator after the translation of
-- each single statement
transTransaction :: Pos -> String -> [Statement] -> PM CExpr
transTransaction p _ []  = throwPM p ("Transaction without statements found.")
transTransaction p mModel [s] = transStatement p mModel s
transTransaction p mModel (s1:s2:sts) =
       combinePMs (\trS1 trSts ->  applyF (mCDBI, ">+")
                                          [trS1, trSts])
                  (transStatement p mModel s1)
                  (transTransaction p mModel (s2:sts))

-- ----------------------select statement --------------------
-- The translation of select statements requires a distinction between
-- simple or compound statements and subsequently between single column
-- selection or complete table rows (entities).
transSelHead :: Pos -> String -> SelectHead -> Order -> CExpr -> PM CExpr
transSelHead p mModel q@(Query selClause tab cond gr) order lim =
  case selClause of
     (SelAll sp)      -> transToGetEnt p mModel sp tab cond gr order lim
     (SelColumns _ _) -> (combinePMs
                            (\(fun, select) trOrd ->
                                  applyF fun
                                         ([(list2ac []),
                                           (list2ac [select]),
                                           trOrd,
                                           lim]))
                            (combinePMs (,)
                                        (getColFunc p q)
                                        (transToGetCol p mModel q))
                            (transOrder p mModel order))
transSelHead p mModel (Set op head1 head2) order lim =
   let setops = list2ac (getSetOpList op head2)
   in combinePMs (\fun (trHeads, trOrd) ->
                      applyF fun ([setops, (list2ac trHeads), trOrd, lim]))
                 (getColFunc p head1)
                 (combinePMs (,)
                             (transSetParts p mModel head1 head2)
                             (transOrder p mModel order))

getSetOpList :: ASetOp -> SelectHead -> [CExpr]
getSetOpList op (Query _ _ _ _) = [(transSetOp op)]
getSetOpList op (Set nextOp _ head2) =
   ((transSetOp op):(getSetOpList nextOp head2))

transSetOp :: ASetOp -> CExpr
transSetOp AUnion = (CSymbol (mCDBI, "Union"))
transSetOp AExcept = (CSymbol (mCDBI, "Except"))
transSetOp AIntersect = (CSymbol (mCDBI, "Intersect"))

-- Further set operations can just appear in the second selectHead.
transSetParts :: Pos -> String -> SelectHead -> SelectHead -> PM [CExpr]
transSetParts p mModel head1 head2@(Query _ _ _ _) =
   combinePMs (\h1 h2 -> [h1, h2])
              (transToGetCol p mModel head1)
              (transToGetCol p mModel head2)
transSetParts p mModel head1 (Set _ h1 h2) =
  combinePMs (:)
             (transToGetCol p mModel head1)
             (transSetParts p mModel h1 h2)


transSp :: ASpecifier -> CExpr
transSp AAll = CSymbol (mCDBI, "All")
transSp ADistinct = CSymbol (mCDBI, "Distinct")

-- tranlsation function for selection of one or more complete entities.
transToGetEnt :: Pos ->
                 String ->
                 ASpecifier ->
                 TableRef ->
                 Condition ->
                 (Maybe Group) ->
                 Order ->
                 CExpr ->
                 PM CExpr
transToGetEnt p mModel sp tab cond gr order lim =
  case tab of
     (TableRef t Nothing)  ->
            combinePMs (\table condOrd ->
                             (applyF (mCDBI, "getEntries")
                                     ([(transSp sp), table]++condOrd++[lim])))
                       (transTableName mModel t)
                       (combinePMs (\trCond trOrd -> trCond++[trOrd])
                                   (transSelCond p mModel cond gr)
                                   (transOrder p mModel order))
     (TableRef _ (Just _)) ->
            combinePMs (\cdsNJoin trCond ->
                            (applyF (mCDBI, "getEntriesCombined")
                                    ([(transSp sp)]++cdsNJoin++trCond++[lim])))
                       (getCDJoin p mModel tab)
                       (combinePMs (\trCond trOrd -> trCond ++[trOrd])
                                   (transSelCond p mModel cond gr)
                                   (transOrder p mModel order))


getCDJoin :: Pos -> String -> TableRef -> PM [CExpr]
getCDJoin p mModel (TableRef tab join) =
  combinePMs (\ trJoin trCD -> trCD++[trJoin])
             (getJoins p mModel join)
             (getCombDesc p mModel tab join)

-- Throws error in case more than three entities are combined which
-- is not supported yet, but can easily be added according to the translation
-- of two and three entities given below.
getCombDesc :: Pos -> String -> Table -> (Maybe JoinClause) -> PM [CExpr]
getCombDesc _ _ _ Nothing = cleanPM []
getCombDesc p mModel tab (Just join) =
    let tabs = tab:(countTabs (Just join))
    in case length tabs of
            2  -> getTwoEntStr mModel tabs
            3  -> getThreeEntStr mModel tabs
            _  -> throwPM p ("This number of joined tables is not supported. "
                             ++"Reduce number of tables or select up to "
                             ++"5 columns and join an arbitrary number of "
                             ++"tables.")

countTabs :: (Maybe JoinClause) -> [Table]
countTabs Nothing = []
countTabs (Just (CrossJoin tab join)) = tab:(countTabs join)
countTabs (Just (InnerJoin tab _ join)) = tab:(countTabs join)

-- Translation of the combination of two entity types.
getTwoEntStr :: String -> [Table] -> PM [CExpr]
getTwoEntStr mModel  ((Table name1 _ al1):(Table name2 _ al2):_)=
     (cleanPM [(applyF
                (mCDBI, "combineDescriptions")
                [(constF (mModel, entity2Description name1)),
                 (cvar(show al1)),
                 (constF (mModel, entity2Description name2)),
                 (cvar (show al2)),
                 (CLambda [(cpvar "e1"), (cpvar "e2")]
                          (applyF (pre "(,)") [(cvar "e1"), (cvar "e2")])),
                 (constF (pre "id"))])])

-- Translation of the combination of three entity types.
getThreeEntStr :: String -> [Table] -> PM [CExpr]
getThreeEntStr mModel ((Table name1 _ al1):(Table name2 _ al2):(Table name3 _ al3):_)=
  (cleanPM
    [(applyF (mCDBI, "addDescription")
             [(constF (mModel, entity2Description name3)),
              (cvar(show al3)),
              (CLambda [(cpvar "e3"),
                        (tuplePattern [(cpvar "e1"),
                                       (cpvar "e2"),
                                       (cpvar "_")])]
                        (applyF (pre "(,,)") [(cvar "e1"),
                                              (cvar "e2"),
                                              (cvar "e3")])),
              (CLambda [(tuplePattern [(cpvar "_"),
                                       (cpvar "_"),
                                       (cpvar "e3")])]
                       (cvar "e3")),
              (applyF (mCDBI, "combineDescriptions")
                      [(constF (mModel, entity2Description name1)),
                       (cvar(show al1)),
                       (constF (mModel, entity2Description name2)),
                       (cvar(show al2)),
                       (CLambda [(cpvar "e1"), (cpvar "e2")]
                                (applyF (pre "(,,)") [(cvar "e1"),
                                                      (cvar "e2"),
                                                      (cvar "_")])),
                       (CLambda [(tuplePattern [(cpvar "e1"), (cpvar "e2"), (cpvar "_")])]
                                (applyF (pre "(,,)") [(cvar "e1"), (cvar "e2")]))])])])

getJoins :: Pos -> String -> (Maybe JoinClause) -> PM CExpr
getJoins p mModel join = liftPM (\joinList -> list2ac joinList)
                                (getNextJoin p mModel join)

getNextJoin :: Pos -> String -> (Maybe JoinClause) -> PM [CExpr]
getNextJoin _ _ Nothing = cleanPM []
getNextJoin p mModel (Just (CrossJoin _ join)) =
    combinePMs (:) (cleanPM (constF (mCDBI, "crossJoin")))
                   (getNextJoin p mModel join)
getNextJoin p mModel (Just(InnerJoin _ cond join)) =
    combinePMs (:) (getInnerJoin p mModel cond)
                   (getNextJoin p mModel join)

getInnerJoin :: Pos -> String -> JoinCond -> PM CExpr
getInnerJoin p mModel (JC cond) =
    liftPM (\trCond -> (applyF (mCDBI, "innerJoin") [trCond]))
           (transCond p mModel cond)

-- Returns correct function name according to number of columns.
-- Returns an error for more than six columns or compound selects
-- for complete entity cause neither is supported by CDBI.
getColFunc :: Pos -> SelectHead -> PM (String, String)
getColFunc p (Query (SelColumns _ elems) _ _ _) =
    case length elems of
         1 -> cleanPM (mCDBI, "getColumn")
         2 -> cleanPM (mCDBI, "getColumnTuple")
         3 -> cleanPM (mCDBI, "getColumnTriple")
         4 -> cleanPM (mCDBI, "getColumnFourTuple")
         5 -> cleanPM (mCDBI, "getColumnFiveTuple")
         6 -> cleanPM (mCDBI, "getColumnSixTuple")
         _ -> throwPM p ("The selection of more than six columns is not " ++
                         "supported by the CDBI-Interface.")
getColFunc p (Query (SelAll _) _ _ _) =
  throwPM p ("The Combination of '*' and Setoperators is not supported.")
getColFunc p (Set _ _ _) =
  throwPM p ("Internal parsing error: this should not happen")

-- Returns construction of datatypes for selection of single columns
-- according to number of columns.
-- Returns an error for more than six columns or compound selects
-- for complete entity cause neither is supported by CDBI.
transToGetCol ::  Pos -> String -> SelectHead -> PM CExpr
transToGetCol p mModel q@(Query (SelColumns _ es) _ _ _) =
  case (length es) of
     1 -> transToSingleCol p mModel q
     2 -> transToTupleCol p mModel q
     3 -> transToTripleCol p mModel q
     4 -> transToFourTCol p mModel q
     5 -> transToFiveTCol p mModel q
     6 -> transToSixTCol p mModel q
     _ ->  throwPM p ("The selection of more than six columns is not " ++
                      "supported by the CDBI-Interface.")
transToGetCol p _ (Query (SelAll _) _ _ _) =
    throwPM p ("The combination of '*' and set operators is not supported.")
transToGetCol p _ (Set _ _ _ ) = throwPM p ("The combination of '*' "++
                                            "and set operators is "++
                                            "not supported.")

-- Translation to SingleColumnSelect.
transToSingleCol :: Pos -> String -> SelectHead -> PM CExpr
transToSingleCol p mModel (Query (SelColumns sp es) tab cond gr) =
  combinePMs (\sc (trTabs, trCond) ->
                    (applyE (CSymbol (mCDBI, "SingleCS"))
                            ([(transSp sp), sc, trTabs]++trCond)))
             (transColSingleCol p mModel (head es))
             (combinePMs (,)
                         (transTabsNJoins p mModel tab)
                         (transSelCond p mModel cond gr))

-- Translation to TupleColumnSelect.
transToTupleCol :: Pos -> String -> SelectHead -> PM CExpr
transToTupleCol p mModel (Query (SelColumns sp es) tab cond gr) =
  combinePMs (\tupleCol (trTab, trCond) ->
                   applyE (CSymbol (mCDBI, "TupleCS"))
                          ([(transSp sp), tupleCol, trTab]++trCond))
             (transColumnCol p mModel "tupleCol" es )
             (combinePMs (,)
                         (transTabsNJoins p mModel tab)
                         (transSelCond p mModel cond gr))

-- Translation to TripleColumnSelect.
transToTripleCol :: Pos -> String -> SelectHead -> PM CExpr
transToTripleCol p mModel (Query (SelColumns sp es) tab cond gr)=
  combinePMs (\tupleCol (trTab, trCond) ->
                   applyE (CSymbol (mCDBI, "TripleCS"))
                          ([(transSp sp), tupleCol, trTab]++trCond))
             (transColumnCol p mModel "tripleCol" es)
             (combinePMs (,)
                         (transTabsNJoins p mModel tab)
                         (transSelCond p mModel cond gr))

-- Translation to FourColumnSelect.
transToFourTCol :: Pos -> String -> SelectHead -> PM CExpr
transToFourTCol p mModel (Query (SelColumns sp es) tab cond gr) =
   combinePMs (\tupleCol (trTab, trCond) ->
                    applyE (CSymbol (mCDBI, "FourCS"))
                           ([(transSp sp), tupleCol, trTab]++trCond))
             (transColumnCol p mModel "fourCol" es)
             (combinePMs (,)
                         (transTabsNJoins p mModel tab)
                         (transSelCond p mModel cond gr))

-- Translation to FiveColumnSelect.
transToFiveTCol :: Pos -> String -> SelectHead -> PM CExpr
transToFiveTCol p mModel (Query (SelColumns sp es) tab cond gr) =
  combinePMs (\tupleCol (trTab, trCond) ->
                  applyE (CSymbol (mCDBI, "FiveCS"))
                         ([(transSp sp), tupleCol, trTab]++trCond))
             (transColumnCol p mModel "fiveCol" es)
             (combinePMs (,)
                         (transTabsNJoins p mModel tab)
                         (transSelCond p mModel cond gr))

-- Translation to SixColumnSelect.
transToSixTCol :: Pos -> String -> SelectHead -> PM CExpr
transToSixTCol p mModel (Query (SelColumns sp es) tab cond gr) =
  combinePMs (\tupleCol (trTab, trCond) ->
                  applyE (CSymbol (mCDBI, "SixCS"))
                         ([(transSp sp), tupleCol, trTab]++trCond))
             (transColumnCol p mModel "sixCol" es)
             (combinePMs (,)
                         (transTabsNJoins p mModel tab)
                         (transSelCond p mModel cond gr))


-- Translation function for ColumnCollection type for all arities
-- based on function for ColumnSingleCollection.
transColumnCol :: Pos -> String -> String -> [SelElement] -> PM CExpr
transColumnCol p mModel constr es =
 liftPM (\elems -> applyF (mCDBI, constr) elems)
        (sequencePM (map (transColSingleCol p mModel) es))


-- Translation to a ColumnSingleCollection.
transColSingleCol :: Pos -> String -> SelElement -> PM CExpr
transColSingleCol p mModel (Col col)  =
         (transToColDesc p mModel col (constF (mCDBI, "none")))
transColSingleCol p mModel (Aggregation fun sp col) =
         (transToColDesc p mModel col (transFun fun sp))
transColSingleCol p mModel (Case cond val1 val2) =
  combinePMs (\c ((tv1,tv2), fun) ->
                 applyF (mCDBI, "caseThen")
                        [(applyF (mCDBI, "condition") [c]), tv1, tv2, fun])
             (transCond p mModel cond)
             (combinePMs (,)
                         (combinePMs (,)
                                    (transOperand p mModel val1)
                                    (transOperand p mModel val2))
                         (valTypeNFun p val1 val2))

transToColDesc :: Pos -> String -> ColumnRef -> CExpr -> PM CExpr
transToColDesc _ mModel (Column (Unique tab) col _ _ al) fun =
  cleanPM (applyF (mCDBI, "singleCol")
                  [(constF (mModel, ((firstLow tab)++col++"ColDesc"))),
                   (cvar (show al)),
                   fun])
-- should not happen at this stage anymore
transToColDesc p _ (Column (Def _) col _ _ _) _ =
  throwPM p ("Translator: Column "++col++" could not be related to any table.")

transFun :: AFun -> ASpecifier -> CExpr
transFun ASum sp = applyF (mCDBI, "sum") [(transSp sp)]
transFun AAvg sp = applyF (mCDBI, "avg") [(transSp sp)]
transFun ACount sp = applyF (mCDBI, "count") [(transSp sp)]
transFun AMin _ = constF (mCDBI, "minV")
transFun AMax _ = constF (mCDBI, "maxV")

valTypeNFun :: Pos -> Operand -> Operand -> PM CExpr
valTypeNFun p (Right (IntExp _ )) v2 =
  case v2 of
   (Left (Column _ _ (Key _) _ _)) -> throwPM p ("Key columns are not allowed "
                                                 ++"in case-expressions due "
                                                 ++"to restrictions of the CDBI"
                                                 ++" interface.")
   _                             -> cleanPM (constF (mCDBI, "caseResultInt"))
valTypeNFun _ (Right (FloatExp _)) _= cleanPM
                                          (constF (mCDBI, "caseResultFloat"))
valTypeNFun _ (Right (StringExp _)) _ = cleanPM
                                          (constF (mCDBI, "caseResultString"))
valTypeNFun _ (Right (DateExp _)) _ = cleanPM (constF (mCDBI,"caseResultDate"))
valTypeNFun _ (Right (BoolExp _)) _ = cleanPM (constF (mCDBI,"caseResultBool"))
valTypeNFun _ (Right (CharExp _)) _ = cleanPM (constF (mCDBI,"caseResultChar"))
valTypeNFun p (Right (KeyExp _ _)) _ =
    throwPM p ("Key columns are not allowed in case-expressions"++
                            " due to restrictions of the CDBI interface.")
valTypeNFun p (Right (Emb _ typ)) v2 =
 case v2 of
   (Left (Column _ _ (Key _) _ _)) -> throwPM p ("Key columns are not allowed "
                                                 ++"in case-expressions due "
                                                 ++"to restrictions of the CDBI"
                                                 ++" interface.")
   _                             -> cleanPM
                                     (constF (mCDBI,
                                              ("caseResult"++(transTyp typ))))
valTypeNFun p (Right AbsNull) _ = throwPM p ("This should not happen, because"
                                              ++" preprocessing was already "
                                              ++"stopped.")
valTypeNFun p (Left (Column _ _ typ _ _)) _ =
  case typ of
     (Key _) -> throwPM p ("Key columns are not allowed in case-expressions"++
                            " due to restrictions of the CDBI interface.")
     _       -> cleanPM (constF (mCDBI, ("caseResult"++(transTyp typ))))

-- Translation to TC type.
transTabsNJoins :: Pos -> String -> TableRef -> PM CExpr
transTabsNJoins p mModel  (TableRef tab join)=
  liftPM (\trTab -> applyE (CSymbol (mCDBI, "TC"))
                           ((transTab mModel tab)++[trTab]))
         (transTables p mModel join)

transTables :: Pos -> String -> (Maybe JoinClause) -> PM CExpr
transTables _ _ Nothing = cleanPM (CSymbol (pre "Nothing"))
transTables p mModel (Just (CrossJoin tab join)) =
     liftPM (\trJoin ->
                applyE (CSymbol (pre "Just"))
                       [applyF (pre "(,)")
                               [(constF (mCDBI, "crossJoin")),
                                (applyE (CSymbol (mCDBI, "TC"))
                                        ((transTab mModel tab)++[trJoin]))]])
            (transTables p mModel join)
transTables p mModel (Just (InnerJoin tab cond join)) =
     combinePMs (\trCond trJoin ->
                      applyE (CSymbol (pre "Just"))
                             [applyF (pre "(,)")
                                     [trCond,
                                      (applyE (CSymbol (mCDBI, "TC"))
                                      ((transTab mModel tab) ++[trJoin]))]])
                (getInnerJoin p mModel cond)
                (transTables p mModel join )


transTab :: String -> Table -> [CExpr]
transTab mModel (Table name _ alias) =
  [(constF (mModel, ((firstLow name)++"Table"))),
           (cvar (show alias))]

-- Translation to Criteria data type.
transSelCond :: Pos -> String -> Condition -> (Maybe Group) -> PM [CExpr]
transSelCond p mModel cond gr =
  combinePMs (\c trGr -> [applyE (CSymbol (mCDBI, "Criteria")) [c, trGr]])
             (transCond p mModel cond)
             (transGroup p mModel gr)

-- Translation for Group-by-clause.
transGroup :: Pos -> String -> (Maybe Group) -> PM CExpr
transGroup _ _  Nothing = cleanPM (CSymbol (pre "Nothing"))
transGroup p mModel (Just (GroupBy cols hav)) =
                            (transGroupBy p mModel cols hav)

transGroupBy :: Pos -> String -> [ColumnRef] -> Having -> PM CExpr
transGroupBy _ _ [] _ = cleanPM (CSymbol (pre "Nothing"))
transGroupBy p mModel (c:cs) hav =
          combinePMs (\col gbt -> (applyE (CSymbol (pre "Just"))
                                          [applyF (mCDBI, "groupBy")
                                                  [col, gbt]]))
                     (transColumn p mModel c)
                     (transGroupByTail p mModel cs hav)

transGroupByTail :: Pos -> String -> [ColumnRef] -> Having -> PM CExpr
transGroupByTail p mModel [] hav = transHaving p mModel hav
transGroupByTail p mModel (c:cs) hav =
      combinePMs (\col gbt -> (applyF (mCDBI, "groupByCol")
                                       [col, gbt]))
                 (transColumn p mModel c)
                 (transGroupByTail p mModel cs hav)

-- Translation for having-clause.
transHaving :: Pos -> String -> Having -> PM CExpr
transHaving p mModel have =
     case have of
         NoHave -> cleanPM (constF (mCDBI, "noHave"))
         _      -> liftPM (\cond -> (applyF (mCDBI, "having") [cond]))
                          (transHavCond p mModel have)

transHavCond :: Pos -> String -> Having -> PM CExpr
transHavCond p mModel (SimpleHave cond) =
    liftPM (\c -> (applyF (mCDBI, "condition") [c]))
           (transCond p mModel cond)
transHavCond p mModel (Neg hav) =
    liftPM (\c -> (applyE (CSymbol (mCDBI, "Neg")) [c]))
           (transHavCond p mModel hav)
transHavCond p mModel (CmpHave op hav1 hav2) =
   combinePMs (\ trHav1 trHav2 ->
                   (applyE (CSymbol (mCDBI, (transLogForHav op)))
                           [list2ac [trHav1, trHav2 ]]))
              (transHavCond p mModel hav1)
              (transHavCond p mModel hav2)
transHavCond p mModel (AggrHave fun sp op1 bop op2) =
  let trfun = case fun of
        ASum   -> getSumFun op1
        AAvg   -> getAvgFun op1
        ACount -> (mCDBI, "countCol")
        AMin   -> (mCDBI, "minCol")
        AMax   -> (mCDBI, "maxCol")
  in combinePMs (\(col, operand) binOp ->
                     (applyF trfun [(transSp sp),
                                     col,
                                     operand,
                                    (constF binOp)]))
                (combinePMs (,) (transColumn p mModel op1)
                                (transOperand p mModel op2))
                (transBinOp bop)
  where getSumFun (Column _ _ I _ _) = (mCDBI, "sumIntCol")
        getSumFun (Column _ _ F _ _) = (mCDBI, "sumFloatCol")
        getAvgFun (Column _ _ I _ _) = (mCDBI, "avgIntCol")
        getAvgFun (Column _ _ F _ _) = (mCDBI, "avgFloatCol")


transLogForHav :: ALogOp -> String
transLogForHav AAnd = "HAnd"
transLogForHav AOr  = "Or"

-- Translation for order-by-clause.
transOrder :: Pos -> String -> Order -> PM CExpr
transOrder _ _ (OrderBy []) = cleanPM (list2ac [])
transOrder p mModel (OrderBy (cd:colDirs)) =
  (liftPM (\ords -> list2ac ords)
          (sequencePM (map (transColDir p mModel) (cd:colDirs))))

transColDir :: Pos -> String -> (ColumnRef, Dir) -> PM CExpr
transColDir p mModel (col , Asc) =
      liftPM (\c -> applyF (mCDBI, "ascOrder") [c])
             (transColumn p mModel col)
transColDir p mModel (col , Desc) =
    liftPM (\c -> applyF (mCDBI, "descOrder") [c])
           (transColumn p mModel col)

--Translation for Limit-clause.
transLimit :: (Maybe Int) -> PM CExpr
transLimit Nothing = cleanPM (CSymbol (pre "Nothing"))
transLimit (Just lim) = cleanPM (applyE (CSymbol (pre "Just"))
                                        [(cvar(show lim))])

-- -----------------------update statement -------------------

-- Translation of update statement.
transUpdate :: Pos -> String -> [Assign] -> Condition -> PM [CExpr]
transUpdate p mModel assigns cond =
  combinePMs (\ trAss trCond -> [trAss, trCond])
             (transAssigns p mModel assigns)
             (transCond p mModel cond)

transAssigns :: Pos -> String -> [Assign] -> PM CExpr
transAssigns p mModel assigns =
  liftPM (\trAss -> list2ac trAss)
         (sequencePM (map (transAssign p mModel) assigns))


transAssign :: Pos -> String -> Assign -> PM CExpr
transAssign p mModel (Assign col val) =
   combinePMs (\trVal trCol-> applyF (mCDBI, "colVal") [trCol, trVal])
              (transCondValue p mModel val )
              (transUpdColumn p mModel col)

-- Columns have to be translated differently than in conditions or select.
transUpdColumn :: Pos -> String -> ColumnRef -> PM CExpr
transUpdColumn _ mModel (Column (Unique tab) col _ _ _) =
               cleanPM (constF (mModel, ((firstLow tab)++"Column"++col)))
-- this should not happen at this stage anymore
transUpdColumn p _ (Column (Def _) col _ _ _) =
                    throwPM p ("Column "++col++" could not be related "
                                ++"to any table.")


-- ------------------------delete statement -------------------
-- Translation of delete statement.
transDelete :: Pos -> String -> Table -> Condition -> PM CExpr
transDelete p mModel tab cond =
   combinePMs (\table trCond -> (applyF (mCDBI, "deleteEntries")
                                      [table, trCond]))
                          (transTableName mModel tab )
                          (transMaybeCond p mModel cond)

-- In delete statements the condition is a maybe-Value.
transMaybeCond :: Pos -> String -> Condition -> PM CExpr
transMaybeCond p mModel cond =
  case cond of
       NoCond   -> cleanPM (CSymbol (pre "Nothing"))
       _        -> liftPM (\c -> applyE (CSymbol (pre "Just")) [c])
                          (transCond p mModel cond)

-- ----------------------- insert statement -------------------

-- Depending on the number of given lists of values
-- there are different CDBI functions to apply.
getInsertFunction :: [[Value]] -> PM (String, String)
getInsertFunction valss =
  if length valss > 1
    then cleanPM (mCDBI, "insertEntries")
    else cleanPM (mCDBI, "insertEntry")

-- Translation of list of lists of values.
transInsertData :: String -> Table ->  [ColumnRef] -> [[Value]] -> PM CExpr
transInsertData mModel (Table tab _ _) cols valss=
  let entities = (map (transEntity mModel tab cols) valss)
  in if length entities == 1
       then cleanPM (head entities)
       else cleanPM (list2ac entities)

-- Distinguishes between embedded expression or list with values.
-- In latter case apply constructor of entity.
transEntity :: String -> String -> [ColumnRef] -> [Value] -> CExpr
transEntity mModel tab cols vals =
  case vals of
    [(Emb exp _)] -> (cvar exp)
    _             -> applyE (CSymbol (mModel, (firstUp tab)))
                            (transInsertValues mModel cols vals)

-- Translates list of values to insert.
transInsertValues :: String -> [ColumnRef] -> [Value] -> [CExpr]
transInsertValues _ []    _  = []
transInsertValues _ (_:_) [] = []
transInsertValues mModel (Column _ _ _ nl _ : cs) (v:vs) =
  transValue mModel v nl : transInsertValues mModel cs vs

-- ----------------------- common elements --------------------

-- Traslation of table name as used in update, insert and delete.
transTableName :: String -> Table -> PM CExpr
transTableName mModel (Table tab _ _) =
  cleanPM (constF (mModel, entity2Description tab))

-- Translation of values as used in insert statements.
transValue :: String -> Value -> Bool -> CExpr
transValue _ (Emb exp etype) nullable =
  -- Note: nullable strings are not represented as Maybe String but as String
  addJustIfNullable (nullable && etype /= S) (cvar ("(" ++ exp ++ ")"))
transValue _ (IntExp int) nullable =
  addJustIfNullable nullable (cvar (show int))
transValue _ (FloatExp float) nullable =
  addJustIfNullable nullable (cvar(show float))
transValue _ (StringExp string) nullable =
  -- Note: nullable strings are not represented as Maybe String but as String
  string2ac string
transValue _ (DateExp date) nullable =
  addJustIfNullable nullable
    (applyF ("Time", "toClockTime") [(cvar (show date))])
transValue _ (BoolExp bool) nullable =
  addJustIfNullable nullable (cvar (show bool))
transValue _ (CharExp char) nullable =
  addJustIfNullable nullable (cvar (show char))
transValue mModel (KeyExp tab int) nullable =
  addJustIfNullable nullable
    (applyE (CSymbol (mModel, firstUp tab ++ "ID")) [cvar (show int)])
transValue _ AbsNull _ = CSymbol (pre "Nothing")

addJustIfNullable :: Bool -> CExpr -> CExpr
addJustIfNullable nullable exp =
  if nullable then applyE (CSymbol (pre "Just")) [exp]
              else exp

-- Translation of values as used in conditions, update and case-expressions.
transCondValue :: Pos -> String -> Value ->  PM CExpr
transCondValue _  mModel (Emb exp typ) =
 let mModule = case typ of
                (Key _) -> mModel
                _       -> mCDBI
  in cleanPM (applyF (mModule, (firstLow (transTyp typ)))
                     [cvar ("("++exp++")")])
transCondValue _ _ (IntExp int) =
     cleanPM (applyF (mCDBI, "int") [cvar (show int)])
transCondValue _ _ (FloatExp float) =
     cleanPM (applyF (mCDBI, "float") [cvar (show float)])
transCondValue _ _ (StringExp str) =
     cleanPM (applyF (mCDBI, "string") [string2ac str])
transCondValue _ _ (DateExp date) =
     cleanPM (applyF (mCDBI, "date")
             [applyF ("Time", "toClockTime")
                     [cvar (show date)]])
transCondValue _ _ (BoolExp bool) =
     cleanPM (applyF (mCDBI, "bool") [cvar (show bool)])
transCondValue _ _ (CharExp char) =
     cleanPM (applyF (mCDBI, "char") [cvar (show char)])
transCondValue _ mModel (KeyExp tab i) =
     cleanPM (applyF (mModel, ((firstLow tab)++"ID"))
             [applyE (CSymbol (mModel, ((firstUp tab)++"ID")))
                     [(cvar (show i))]])
transCondValue p _ AbsNull = throwPM p ("This should not happen, cause "
                                         ++"preprocessing was already"++
                                         " stopped after Consistency Check.")

-- Translation of condition-clause, finally used for all statements.
transCond :: Pos -> String -> Condition -> PM CExpr
transCond p mModel (FK (tab1, al1) rel (tab2, al2)) =
  getConstraint p mModel rel (firstLow tab1) al1 (firstLow tab2) al2
transCond p mModel (Cmp logop cond1 cond2) =
  combinePMs (\trLogop conds -> applyE trLogop [list2ac conds])
             (transLogOp logop)
             (combinePMs (\tcond1 tcond2 -> [tcond1,tcond2])
                         (transCond p mModel cond1)
                         (transCond p mModel cond2))
transCond  p mModel (Not cond)=
     liftPM (\trcond -> applyE (CSymbol (mCDBI, "Not")) [trcond])
            (transCond p mModel cond)
transCond p mModel (Exists stat) = transSubquery p mModel stat
transCond p mModel (IsNull op) = liftPM (\trop -> applyF (mCDBI, "isNull")
                                                         [trop])
                                        (transOperand p mModel op)
transCond p mModel (NotNull op) = liftPM (\trop -> applyF (mCDBI, "isNotNull")
                                                          [trop])
                                         (transOperand p mModel op)
transCond p mModel (AIn op vals) =
    combinePMs (\ trop trvals -> applyF (mCDBI,"isIn")  [trop, trvals] )
               (transOperand p mModel op)
               (transValList p mModel vals)
transCond p mModel (ABinOp bop op1 op2) =
    combinePMs (\trBop (top1, top2) -> applyE (CSymbol trBop) [top1, top2] )
               (transBinOp bop)
               (combinePMs (,)
                           (transOperand p mModel op1)
                           (transOperand p mModel op2))
transCond p mModel (ABetween op1 op2 op3) =
    combinePMs (\ top1 top23 -> (applyE (CSymbol (mCDBI, "between"))
                                        (top1:top23)))
               (transOperand p mModel op1)
               (combinePMs (\ o1 o2 -> [o1,o2])
                           (transOperand p mModel op2)
                           (transOperand p mModel op3))
transCond _ _ NoCond = cleanPM (CSymbol (mCDBI, "None"))

-- Translation of subquery for Exists-constraint.
transSubquery :: Pos -> String -> Statement -> PM CExpr
transSubquery p mModel (Select selHead order limit) =
 case limit of
   Nothing -> combinePMs (\headStr _ -> applyE (CSymbol (mCDBI, "Exists"))
                                               headStr)
                         (transHeadForSub p mModel selHead)
                         (transOrderForSub p order)
   (Just _ ) -> throwPM p ("Found limit inside an exists constraint.")

transHeadForSub :: Pos -> String -> SelectHead -> PM [CExpr]
transHeadForSub p mModel (Query _ tab cond gr) =
  case gr of
       (Just _)  -> throwPM p ("Group-Statements inside exists-constraints are"
                                ++ " not supported by the CDBI-Interface")
       Nothing   -> combinePMs (\ trTab trCond -> trTab++[trCond])
                               (transTableForSub p mModel tab)
                               (transCond p mModel cond)
transHeadForSub p _ (Set _ _ _) = throwPM p ("Set-operations inside an exists-"
                                              ++"constraint are not supported"
                                              ++ " by the CDBI-Interface")

transOrderForSub :: Pos -> Order -> PM Order
transOrderForSub _ (OrderBy []) = cleanPM (OrderBy [])
transOrderForSub p (OrderBy (_:_)) = throwPM p ("Found OrderBy inside an "
                                                 ++"exists-constraint.")

transTableForSub :: Pos -> String -> TableRef -> PM [CExpr]
transTableForSub _ mModel (TableRef (Table name _ alias) Nothing) =
  cleanPM [(constF (mModel, (firstLow name)++"Table")), (cvar(show alias))]
transTableForSub p _ (TableRef _ (Just _)) =
     throwPM p ("More than one Table inside exists-"
                 ++"constraint is not supported by "
                 ++"the CDBI-Interface")

-- Translation of Satisfies constraint into normal foreign key constraint
-- in condition clauses.
getConstraint :: Pos -> String -> AbsRel -> String -> Int -> String -> Int
                                                               -> PM CExpr
getConstraint p mModel rel tab1 al1 tab2 al2 =
  case rel of
    (AOneToN relName) ->
       cleanPM
         (applyF (mCDBI, "equal")
                 [(applyF (mCDBI, "colNum")
                          [(constF (mModel, (tab1++"ColumnKey"))),
                           (cvar (show al1))]),
                  (applyF (mCDBI, "colNum")
                          [(constF (mModel, (tab2++"Column"++(firstUp tab1)
                                             ++relName++"Key"))),
                           (cvar(show al2))])])
    (ANToOne relName) ->
       cleanPM
         (applyF (mCDBI, "equal")
                 [(applyF (mCDBI, "colNum")
                          [(constF (mModel ,(tab2++"ColumnKey"))),
                           (cvar (show al2))]),
                  (applyF (mCDBI, "colNum")
                          [(constF (mModel, (tab1++"Column"++(firstUp tab2)
                                               ++relName++"Key"))),
                           (cvar (show al1))])])
    (AMToN relName) ->
       cleanPM
         (applyE
           (CSymbol (mCDBI, "Exists"))
           [(constF (mModel, (firstLow relName)++"Table")),
            (cvar "0"),
            (applyE (CSymbol (mCDBI, "And"))
                    [list2ac
                      [(applyF (mCDBI, "equal")
                               [(applyF (mCDBI, "col")
                                        [(constF (mModel, ((firstLow relName)
                                                            ++"Column"++(firstUp tab1)
                                                            ++relName++"Key")))]),
                                (applyF (mCDBI, "colNum")
                                        [(constF (mModel,(tab1++"ColumnKey"))),
                                         (cvar (show al1))])]),
                       (applyF (mCDBI, "equal")
                               [(applyF (mCDBI, "col")
                                        [(constF (mModel, ((firstLow relName)++
                                                            "Column"++(firstUp tab2)
                                                            ++relName++"Key")))]),
                                (applyF (mCDBI, "colNum")
                                        [(constF (mModel,(tab2++"ColumnKey"))),
                                         (cvar (show al2))])])]])])
    (NotSpec relName)   -> throwPM p ("Internal Error: Relation: "
                                        ++relName++" could not be resoled.")

transLogOp :: ALogOp ->  PM CExpr
transLogOp AAnd = cleanPM (CSymbol (mCDBI, "And"))
transLogOp AOr  = cleanPM (CSymbol (mCDBI, "Or"))

transOperand :: Pos -> String -> Operand -> PM CExpr
transOperand p mModel (Left col) = transColumn p mModel col
transOperand p mModel (Right val) = transCondValue p mModel val

-- Translation of Columns for all but the update statement.
transColumn :: Pos -> String -> ColumnRef -> PM CExpr
transColumn _ mModel (Column (Unique tab) col _ _ al) =
      cleanPM (applyF (mCDBI, "colNum")
                      [(constF (mModel, ((firstLow tab)++"Column"++col))),
                       (cvar (show al))])
-- this should not happen at this stage anymore
transColumn p _ (Column (Def _ ) col _ _ _) =
  throwPM p (" Translator: Column "++col++" could not be related to any table.")

-- Translation of value list used in isIn-constraint.
transValList :: Pos -> String -> [Value] -> PM CExpr
transValList p mModel vals =
    liftPM (\trVals -> list2ac trVals)
           (sequencePM (map (transCondValue p mModel) vals))

transBinOp :: AstOp -> PM (String, String)
transBinOp ALth = cleanPM (mCDBI, "lessThan")
transBinOp ALe  = cleanPM (mCDBI, "lessThanEqual")
transBinOp AGth = cleanPM (mCDBI, "greaterThan")
transBinOp AGe  = cleanPM (mCDBI, "greaterThanEqual")
transBinOp AEq  = cleanPM (mCDBI, "equal")
transBinOp AUnEq = cleanPM (mCDBI, "notEqual")
transBinOp ALike = cleanPM (mCDBI, "like")

transTyp :: Type -> String
transTyp I = "Int"
transTyp F = "Float"
transTyp C = "Char"
transTyp B = "Bool"
transTyp S = "String"
transTyp D = "Date"
transTyp (Key name) = name++"ID"
transTyp (Entity name) = name
transTyp Unknown = "unknown"

firstUp :: String -> String
firstUp [] = []
firstUp (s:str) = (toUpper s):str

firstLow :: String -> String
firstLow [] = []
firstLow (s:str) = (toLower s):str

-- Translates an entity name into its description operation
-- generated by ERD2CDBI.
entity2Description :: String -> String
entity2Description name = firstLow name ++ "_CDBI_Description"