|
sourcecode:
|
{-# OPTIONS_FRONTEND -Wno-incomplete-patterns #-}
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 stats0 =
let finExpr = if withrundb
then applyF (mCDBI, "runWithDB")
[constF (mModel, "sqliteDBFile"),
concatStatements stats0]
else concatStatements stats0
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) _ =
-- 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"
|