--- Module for checking the type integrity of SQL expressions. --- This includes ensuring the same type on both sides of (binary) --- operations and in case expressions, correct types in insert --- and update statements and in all occasions in which at least one column --- reference is given. Furthermore foreign keys are marked for a --- proper translation in later modules. In addition it is ensured --- that no key columns can be updated directly, --- that aggregation functions are called with the correct type, --- embedded expressions are not compared with each other --- and null-values can't be used in case-expression. --- Warnings are generated in case the type of an embedded expression --- was set using context information. --- The module is organized in two stages. The first one retrieves --- all kind of information about the used types from the parser info module. --- The second stage checks the correct usage. --- of the types. --- @author: Julia Krone --- @version: 0.1 -- -------------------------------------------------------------------------- module SQLTyper(checkTypes) where import Data.Char ( toLower, toUpper ) import Data.List ( isInfixOf ) import Data.Time import qualified Data.Map as Map import ParseTypes import SQLAst import SQLParserInfoType ---Type Checker. --- Organized in two stages: --- 1. retrieving types from parser info --- 2. check type integrity of expressions --- If the first stage fails the second one is not started. --- First stage is only started if a valid AST without errors is passed. checkTypes :: PM [Statement] -> AttrTypeFM -> Pos -> PM [Statement] checkTypes (WM (Errors err) ws) _ _ = WM (throwPR err) ws checkTypes (WM (OK ast) ws) types p = let (WM resPR warns) = sequencePM (map (retrieveTypes p types) ast) in case resPR of (Errors err) -> (WM (throwPR err) (ws++warns)) (OK ast1) -> let (WM resPR1 warns1) = sequencePM (map (checkTypCons p) ast1) in (WM resPR1 (warns1++warns++ws)) -- --------------------------------first stage ------------------------------- retrieveTypes :: Pos -> AttrTypeFM -> Statement -> PM Statement retrieveTypes _ _ Rollback = cleanPM Rollback retrieveTypes _ _ Commit = cleanPM Commit retrieveTypes _ _ Transaction = cleanPM Transaction retrieveTypes p types (InTransaction stats) = liftPM (\typedStats -> InTransaction typedStats) (sequencePM (map (retrieveTypes p types) stats)) retrieveTypes p types (Delete tab cond) = liftPM (\typedCond -> (Delete tab typedCond)) (typCondition p types cond) retrieveTypes p types (Insert tab cols valss) = liftPM (\typedCols -> Insert tab typedCols valss) (typInsertColumns p types cols) retrieveTypes _ _ st@(UpdateEntity _ _) = cleanPM st retrieveTypes p types (Update tab assigns cond) = combinePMs (\typedAssigns typedCond -> (Update tab typedAssigns typedCond)) (typAssignments p types assigns) (typCondition p types cond) retrieveTypes p types (Select selHead order limit) = combinePMs (\typedHead typedOrd -> (Select typedHead typedOrd limit)) (typSelHead p types selHead) (typOrder p types order) -- ---------------------------- select - first stage ------------------------- typSelHead :: Pos -> AttrTypeFM -> SelectHead -> PM SelectHead typSelHead p types (Query selClause tab cond gr) = combinePMs (\(tSC,tTab) (tCond, tGr) -> (Query tSC tTab tCond tGr)) (combinePMs (,) (typSelClause p types selClause) (typTableRef p types tab)) (combinePMs (,) (typCondition p types cond) (typGroup p types gr)) typSelHead p types (Set setOp head1 head2) = combinePMs (\typHead1 typHead2 -> (Set setOp typHead1 typHead2)) (typSelHead p types head1) (typSelHead p types head2) typSelClause :: Pos -> AttrTypeFM -> SelectClause -> PM SelectClause typSelClause _ _ sc@(SelAll _) = cleanPM sc typSelClause p types (SelColumns sp elems) = liftPM (\typedElems -> (SelColumns sp typedElems)) (sequencePM (map (typSelElement p types) elems)) typSelElement :: Pos -> AttrTypeFM -> SelElement -> PM SelElement typSelElement p types (Col col) = liftPM (\typedCol -> (Col typedCol)) (typColumnRef p types col) typSelElement p types (Case cond op1 op2) = combinePMs (\tCond (top1, top2) -> (Case tCond top1 top2)) (typCondition p types cond) (combinePMs (,) (typOperand p types op1) (typOperand p types op2)) typSelElement p types (Aggregation fun sp col) = liftPM (\typedCol -> (Aggregation fun sp typedCol)) (typColumnRef p types col) typTableRef :: Pos -> AttrTypeFM -> TableRef -> PM TableRef typTableRef _ _ (TableRef tab Nothing) = cleanPM (TableRef tab Nothing) typTableRef p types (TableRef tab (Just join)) = liftPM (\tJoin -> (TableRef tab (Just tJoin))) (typJoinClause p types join) typJoinClause :: Pos -> AttrTypeFM -> JoinClause -> PM JoinClause typJoinClause _ _ jc@(CrossJoin _ Nothing) = cleanPM jc typJoinClause p types (CrossJoin tab (Just join)) = liftPM (\tJoin -> (CrossJoin tab (Just tJoin))) (typJoinClause p types join) typJoinClause p types (InnerJoin tab jCond Nothing) = liftPM (\tJoinCond -> (InnerJoin tab tJoinCond Nothing)) (typJoinCond p types jCond) typJoinClause p types (InnerJoin tab jCond (Just join)) = combinePMs (\tCond tJoin -> (InnerJoin tab tCond (Just tJoin))) (typJoinCond p types jCond) (typJoinClause p types join) typJoinCond :: Pos -> AttrTypeFM -> JoinCond -> PM JoinCond typJoinCond p types (JC cond) = liftPM (\tcond -> (JC tcond)) (typCondition p types cond) typGroup :: Pos -> AttrTypeFM -> (Maybe Group) -> PM (Maybe Group) typGroup _ _ Nothing = cleanPM Nothing typGroup p types (Just (GroupBy cols hav)) = combinePMs (\tCols tHav -> (Just (GroupBy tCols tHav))) (sequencePM (map (typColumnRef p types) cols)) (typHaving p types hav) typHaving :: Pos -> AttrTypeFM -> Having -> PM Having typHaving _ _ NoHave = cleanPM NoHave typHaving p types (CmpHave logOp hav1 hav2) = combinePMs (\thav1 thav2 -> (CmpHave logOp thav1 thav2)) (typHaving p types hav1) (typHaving p types hav2) typHaving p types (AggrHave fun sp col op operand) = combinePMs (\tCol tOp -> (AggrHave fun sp tCol op tOp)) (typColumnRef p types col) (typOperand p types operand) typHaving p types (Neg hav) = liftPM (\typedHave -> Neg typedHave) (typHaving p types hav) typHaving p types (SimpleHave cond) = liftPM (\typedCond -> SimpleHave typedCond) (typCondition p types cond) typOrder :: Pos -> AttrTypeFM -> Order -> PM Order typOrder p types (OrderBy colDirs) = liftPM (\tColDirs -> OrderBy tColDirs) (sequencePM (map (typSingleColDir p types) colDirs)) typSingleColDir :: Pos -> AttrTypeFM -> (ColumnRef, Dir) -> PM (ColumnRef, Dir) typSingleColDir p types (col, dir) = liftPM (\typedCol -> (typedCol, dir)) (typColumnRef p types col) -- ---------------------------- update - first stage -------------------------- typAssignments :: Pos -> AttrTypeFM -> [Assign] -> PM [Assign] typAssignments p types assigns = sequencePM (map (typAssignment p types) assigns) typAssignment :: Pos -> AttrTypeFM -> Assign -> PM Assign typAssignment p types (Assign col val) = liftPM (\typedCol -> Assign typedCol val) (typColumnRef p types col) -- ---------------------------- insert - first stage ------------------------- typInsertColumns :: Pos -> AttrTypeFM -> [ColumnRef] -> PM [ColumnRef] typInsertColumns p types cols = sequencePM (map (typColumnRef p types) cols) -- ----------------------------common elements - first stage ------------------ typCondition :: Pos -> AttrTypeFM -> Condition -> PM Condition typCondition _ _ c@(FK _ _ _) = cleanPM c typCondition p types (Cmp logOp cond1 cond2) = combinePMs (\ tc1 tc2 -> Cmp logOp tc1 tc2) (typCondition p types cond1) (typCondition p types cond2) typCondition p types (Not cond) = liftPM (\tc -> Not tc) (typCondition p types cond) typCondition p types (Exists stat) = liftPM (\tst -> Exists tst) (retrieveTypes p types stat) typCondition p types (IsNull operand) = liftPM (\top -> IsNull top) (typOperand p types operand) typCondition p types (NotNull operand) = liftPM (\top -> NotNull top) (typOperand p types operand) typCondition p types (AIn op vals) = liftPM (\top -> (AIn top vals)) (typOperand p types op) typCondition p types (ABinOp binOp op1 op2) = combinePMs (\ top1 top2 -> ABinOp binOp top1 top2) (typOperand p types op1) (typOperand p types op2) typCondition p types (ABetween op1 op2 op3) = combinePMs (\top1 (top2, top3) -> (ABetween top1 top2 top3)) (typOperand p types op1) (combinePMs (,) (typOperand p types op2) (typOperand p types op3)) typCondition _ _ NoCond = cleanPM NoCond typOperand :: Pos -> AttrTypeFM -> Operand -> PM Operand typOperand p types (Left col) = liftPM (\typedCol -> (Left typedCol)) (typColumnRef p types col) typOperand _ _ (Right val) = cleanPM (Right val) -- Core function of the first stage. Retrives type information -- from parser info and inserts it into the column node. typColumnRef :: Pos -> AttrTypeFM -> ColumnRef -> PM ColumnRef typColumnRef p types (Column (Unique tab) col _ nl al) = let typ = Map.lookup ((firstLow tab)++(firstUp col)) types in case typ of Nothing -> throwPM p ("Undefined type given for column "++tab++col) (Just typeStr) -> case typeStr of "int" -> cleanPM (Column (Unique tab) col I nl al) "float" -> cleanPM (Column (Unique tab) col F nl al) "string" -> cleanPM (Column (Unique tab) col S nl al) "char" -> cleanPM (Column (Unique tab) col C nl al) "date" -> cleanPM (Column (Unique tab) col D nl al) "bool" -> cleanPM (Column (Unique tab) col B nl al) _ -> cleanPM (Column (Unique tab) col (Key typeStr) nl al) -- this should not happen at this stage anymore. typColumnRef p _ (Column (Def _) col _ _ _) = throwPM p ("Column "++col++" could not be related to any table.") -- ---------------------------second stage --------------------------------------- checkTypCons :: Pos -> Statement -> PM Statement checkTypCons _ Rollback = cleanPM Rollback checkTypCons _ Commit = cleanPM Commit checkTypCons _ Transaction = cleanPM Transaction checkTypCons p (InTransaction stats) = liftPM (\checkedStats -> InTransaction checkedStats) (sequencePM (map (checkTypCons p) stats)) checkTypCons p (Delete tab cond) = liftPM (\checkedCond -> (Delete tab checkedCond)) (checkCondition p cond) checkTypCons p (Insert tab cols valss) = liftPM (\chValss -> (Insert tab cols chValss)) (checkInsertVals p tab cols valss) checkTypCons p (UpdateEntity tab val) = liftPM (\chVal -> (UpdateEntity tab chVal)) (checkEntUpdate p tab val) checkTypCons p (Update tab assigns cond) = combinePMs (\chAssigns chCond -> (Update tab chAssigns chCond)) (checkAssignments p assigns) (checkCondition p cond) checkTypCons p (Select selHead order limit) = liftPM (\chSelHead -> (Select chSelHead order limit)) (checkSelHead p selHead) -- -------------------------- select - second stage ------------------------------ -- Checks the types in SelectHead-node, in particular throws an error if -- types in parts of a combined select statement are not the same. checkSelHead :: Pos -> SelectHead -> PM SelectHead checkSelHead p (Query selClause tab cond gr) = combinePMs (\(chSelClause, chTab) (chCond, chGr) -> (Query chSelClause chTab chCond chGr)) (combinePMs (,) (checkSelClause p selClause) (checkTableRef p tab)) (combinePMs (,) (checkCondition p cond) (checkGroup p gr)) checkSelHead p (Set setOp head1 head2) = if (checkHeadsTogether head1 head2) then (combinePMs (\chHead1 chHead2 -> (Set setOp chHead1 chHead2)) (checkSelHead p head1) (checkSelHead p head2)) else throwPM p ("Queries combined by set operator have different "++ "result column types.") checkHeadsTogether :: SelectHead -> SelectHead -> Bool checkHeadsTogether (Query selclause1 _ _ _) (Query selclause2 _ _ _) = compareLists (extractElemTypes selclause1) (extractElemTypes selclause2) checkHeadsTogether head1 (Set _ head2 head3) = (checkHeadsTogether head1 head2) && (checkHeadsTogether head2 head3) extractElemTypes :: SelectClause -> [Type] extractElemTypes (SelAll _) = [] extractElemTypes (SelColumns _ elems) = (map getElemType elems) getElemType :: SelElement -> Type getElemType (Col col) = columnTyp col getElemType (Case _ (Left col) _ ) = columnTyp col getElemType (Case _ (Right val) _ ) = typeOf val getElemType (Aggregation ASum _ col) = columnTyp col getElemType (Aggregation AAvg _ _) = F getElemType (Aggregation ACount _ _) = I getElemType (Aggregation AMin _ col) = columnTyp col getElemType (Aggregation AMax _ col) = columnTyp col checkSelClause :: Pos -> SelectClause -> PM SelectClause checkSelClause _ sc@(SelAll _) = cleanPM sc checkSelClause p (SelColumns sp elems) = liftPM (\chElems -> (SelColumns sp chElems)) (sequencePM (map (checkSelElement p) elems)) checkSelElement :: Pos -> SelElement -> PM SelElement checkSelElement _ e@(Col _) = cleanPM e checkSelElement p (Case cond op1 op2) = combinePMs (\chCond (chOp1, chOp2) -> (Case chCond chOp1 chOp2)) (checkCondition p cond) (checkOpOp p op1 op2) checkSelElement p (Aggregation fun sp col) = liftPM (\chCol -> (Aggregation fun sp chCol)) (checkFunCol p fun col) -- Checks the use of Aggregation functions in Selectelements -- Avg and Sum can only be used with Int and Float checkFunCol :: Pos -> AFun -> ColumnRef -> PM ColumnRef checkFunCol p ASum col = case columnTyp col of I -> cleanPM col F -> cleanPM col _ -> throwPM p ("Inside function sum only columns of type Int" ++" or float are allowed.") checkFunCol p AAvg col = case columnTyp col of I -> cleanPM col F -> cleanPM col _ -> throwPM p ("Inside function avg only columns of type Int" ++" or float are allowed.") checkFunCol _ ACount col = cleanPM col checkFunCol _ AMin col = cleanPM col checkFunCol _ AMax col = cleanPM col checkTableRef :: Pos -> TableRef -> PM TableRef checkTableRef _ t@(TableRef _ Nothing) = cleanPM t checkTableRef p (TableRef t (Just join)) = liftPM (\chJoin -> (TableRef t (Just chJoin))) (checkJoinClause p join) checkJoinClause :: Pos -> JoinClause -> PM JoinClause checkJoinClause _ t@(CrossJoin _ Nothing) = cleanPM t checkJoinClause p (CrossJoin tab (Just join)) = liftPM (\chJoin -> (CrossJoin tab (Just chJoin))) (checkJoinClause p join) checkJoinClause p (InnerJoin t jCond Nothing) = liftPM (\chCond -> (InnerJoin t chCond Nothing)) (checkJoinCond p jCond) checkJoinClause p (InnerJoin t jCond (Just join)) = combinePMs (\chCond chJoin -> (InnerJoin t chCond (Just chJoin))) (checkJoinCond p jCond) (checkJoinClause p join) checkJoinCond :: Pos -> JoinCond -> PM JoinCond checkJoinCond p (JC cond) = liftPM (\chCond -> (JC chCond)) (checkCondition p cond) checkGroup :: Pos -> (Maybe Group) -> PM (Maybe Group) checkGroup _ Nothing = cleanPM Nothing checkGroup p (Just (GroupBy cols hav)) = liftPM (\chHave -> (Just (GroupBy cols chHave))) (checkHaving p hav) checkHaving :: Pos -> Having -> PM Having checkHaving _ NoHave = cleanPM NoHave checkHaving p (CmpHave logOp hav1 hav2) = combinePMs (\chHav1 chHav2 -> (CmpHave logOp chHav1 chHav2)) (checkHaving p hav1) (checkHaving p hav2) checkHaving p (Neg have) = liftPM (\chHav -> (Neg chHav)) (checkHaving p have) checkHaving p (AggrHave fun sp col op operand) = combinePMs (\chCol chOp -> (AggrHave fun sp chCol op chOp)) (checkFunCol p fun col) (checkAggrHave p fun col operand) checkHaving p (SimpleHave cond) = liftPM (\chCond -> (SimpleHave chCond)) (checkCondition p cond) -- Checks the use of aggregation functions in having-clauses. -- In case of Avg the operand has to be of type float, in case of -- Count of type int. In the remaining cases both operands have to be -- of the same type. checkAggrHave :: Pos -> AFun -> ColumnRef -> Operand -> PM Operand checkAggrHave p ASum col op = liftPM (\(chOp, _) -> chOp) (checkOpCol p op col) checkAggrHave p AAvg _ op = liftPM (\(chOp, _) -> chOp) (checkOpVal p op (FloatExp 0.0)) checkAggrHave p ACount _ op = liftPM (\(chOp, _) -> chOp) (checkOpVal p op (IntExp 0)) checkAggrHave p AMin col op = liftPM (\(chOp, _) -> chOp) (checkOpCol p op col) checkAggrHave p AMax col op = liftPM (\(chOp, _) -> chOp) (checkOpCol p op col) -- -------------------------- update - second stage --------------------------- -- Tries to find table name as part of the embedded expression -- (e.g. as Constructor). -- If unsuccesful type is set using the table name and a warning is thrown. checkEntUpdate :: Pos -> Table -> Value -> PM Value checkEntUpdate p (Table name _ _ ) (Emb exp _) = if (isInfixOf (firstUp name) exp) then cleanPM (Emb exp (Entity (firstUp name))) else warnOKPM (Emb exp (Entity (firstUp name))) [(p, ("Embedded expression in update statement was set" ++ " to type "++(firstUp name)))] checkAssignments :: Pos -> [Assign] -> PM [Assign] checkAssignments p assigns = sequencePM (map (checkAssign p) assigns) -- Ensures Key- and null-values are not set directly in an update statement. checkAssign :: Pos -> Assign -> PM Assign checkAssign p (Assign col@(Column (Unique tab) _ t _ _) val) = case val of AbsNull -> throwPM p ("Setting null-values directly is not supported by" ++" the CDBI-Interface, use update of whole "++ "entity instead.") _ -> case t of (Key tn) -> if tn == tab then throwPM p ("Setting key-values directly " ++"is not supported by the " ++"CDBI-Interface.") else liftPM (\(chCol, chVal) -> Assign chCol chVal) (checkColVal p col val) _ -> liftPM (\(chCol, chVal) -> Assign chCol chVal) (checkColVal p col val) -- this should not happen at this stage anymore. checkAssign p (Assign col@(Column (Def _ ) name _ _ _) _) = throwPM p ("Column "++name++" could not be related to any table.") -- -------------------------- insert - second stage --------------------------- -- In case an embedded expression is given: tries to find table name as part -- of the embedded expression (e.g. as Constructor). -- If unsuccesful type is set using the table name and a warning is thrown. -- Otherwise types of columns are compared with types of values. checkInsertVals :: Pos -> Table -> [ColumnRef] -> [[Value]] -> PM [[Value]] checkInsertVals p tab cols valss = sequencePM (map (compareInserts p tab cols) valss) compareInserts :: Pos -> Table -> [ColumnRef] -> [Value] -> PM [Value] compareInserts p (Table name _ _) cols vals = case vals of [(Emb exp _ )] -> if (isInfixOf (firstUp name) exp) -- is type constructor part of exp? then cleanPM [(Emb exp (Entity(firstUp name)))] else warnOKPM [(Emb exp (Entity(firstUp name)))] [(p,("Type of embedded expression " ++"was set to "++(firstUp name) ++" during preprocessing."))] _ -> compareInserts' p cols vals compareInserts' :: Pos -> [ColumnRef] -> [Value] -> PM [Value] compareInserts' _ [] _ = cleanPM [] compareInserts' p (c:cols) (v:vals) = case v of AbsNull -> liftPM (\chVals -> (v:chVals)) (compareInserts' p cols vals) (KeyExp _ _) -> liftPM (\chVals -> (v:chVals)) (compareInserts' p cols vals) (IntExp int) -> case columnTyp c of (Key tab) -> liftPM (\chVals -> ((KeyExp tab int):chVals)) (compareInserts' p cols vals) _ -> combinePMs (\(_, chVal) chVals -> (chVal:chVals)) (checkColVal p c v) (compareInserts' p cols vals) _ -> combinePMs (\(_, chVal) chVals -> (chVal:chVals)) (checkColVal p c v) (compareInserts' p cols vals) -- --------------------------- common elements - second stage ---------------------- checkCondition :: Pos -> Condition -> PM Condition checkCondition _ NoCond = cleanPM NoCond checkCondition _ c@(FK _ _ _) = cleanPM c checkCondition p (Cmp logOp cond1 cond2) = combinePMs (\chCond1 chCond2 -> (Cmp logOp chCond1 chCond2)) (checkCondition p cond1) (checkCondition p cond2) checkCondition p (Not cond) = liftPM (\chCond -> (Not chCond)) (checkCondition p cond) checkCondition p (Exists stat) = liftPM (\chStat -> (Exists chStat)) (checkSubquery p stat) checkCondition _ c@(IsNull _) = cleanPM c checkCondition _ c@(NotNull _) = cleanPM c checkCondition p (AIn op vals) = liftPM (\chOpVals -> (AIn (fst(head chOpVals)) (map snd chOpVals))) (sequencePM (map (checkOpVal p op) vals)) checkCondition p (ABinOp binOp op1 op2) = liftPM (\(chOp1, chOp2) -> (ABinOp binOp chOp1 chOp2)) (checkOpOp p op1 op2) checkCondition p (ABetween op1 op2 op3) = combinePMs (\(chOp1, chOp2) (_, chOp3) -> (ABetween chOp1 chOp2 chOp3)) (checkOpOp p op1 op2) (checkOpOp p op1 op3) checkSubquery :: Pos -> Statement -> PM Statement checkSubquery p (Select selHead order limit) = liftPM (\chSelHead -> (Select chSelHead order limit)) (checkSelHead p selHead) -- Compares type of operand with type of value checkOpVal :: Pos -> Operand -> Value -> PM (Operand, Value) checkOpVal p (Right val1) val2 = liftPM (\(chVal1, chVal2) -> ((Right chVal1), chVal2)) (checkValVal p val1 val2) checkOpVal p (Left col) val = liftPM (\(chCol, chVal) -> ((Left chCol),chVal)) (checkColVal p col val) -- Compares type of Operand to type of Column checkOpCol :: Pos -> Operand -> ColumnRef -> PM (Operand, ColumnRef) checkOpCol p (Right val) col = liftPM (\(chCol, chVal) -> ((Right chVal), chCol)) (checkColVal p col val) checkOpCol p (Left col1) col2 = liftPM (\(chCol1, chCol2) -> ((Left chCol1), chCol2)) (checkColCol p col1 col2) -- Compares types of two Operands checkOpOp :: Pos -> Operand -> Operand -> PM (Operand, Operand) checkOpOp p (Right val1) (Right val2) = liftPM (\(chVal1, chVal2) -> ((Right chVal1), (Right chVal2))) (checkValVal p val1 val2) checkOpOp p (Right val) (Left col) = liftPM (\(chCol, chVal) -> ((Right chVal), (Left chCol))) (checkColVal p col val) checkOpOp p (Left col) (Right val) = liftPM (\(chCol, chVal) -> ((Left chCol), (Right chVal))) (checkColVal p col val) checkOpOp p (Left col1) (Left col2) = liftPM (\(chCol1, chCol2) -> ((Left chCol1), (Left chCol2))) (checkColCol p col1 col2) -- Compares types of two values. -- Throws an error if they are not of the same type, if a null-value or -- key value is found. Throws a warning if type of embedded expression is -- set using context information. checkValVal :: Pos -> Value -> Value -> PM (Value, Value) checkValVal p v1@(IntExp int) v2 = case v2 of (IntExp _) -> cleanPM (v1,v2) (Emb exp _) -> warnOKPM (v1, (Emb exp I)) [(p, ("Information: embedded expression is "++ "assumed to be of type Int"))] _ -> throwPM p ("Type error: Int ("++(show int)++") and "++ (typeToStr (typeOf v2))++" are not compatible.") checkValVal p v1@(FloatExp f) v2 = case v2 of (FloatExp _) -> cleanPM (v1,v2) (Emb exp _) -> warnOKPM (v1, (Emb exp F)) [(p, ("Information: embedded expression is "++ "assumed to be of type Float"))] _ -> throwPM p ("Type error: Float ("++(show f)++") and "++ (typeToStr (typeOf v2))++" are not compatible.") checkValVal p v1@(StringExp str) v2 = case v2 of (StringExp _) -> cleanPM (v1,v2) (Emb exp _) -> warnOKPM (v1, (Emb exp S)) [(p, ("Information: embedded expression is "++ "assumed to be of type String"))] _ -> throwPM p ("Type error: String ("++str++") and "++ (typeToStr (typeOf v2))++" are not compatible.") checkValVal p v1@(DateExp d) v2 = case v2 of (DateExp _) -> combinePMs (\date1 date2 -> (date1,date2)) (checkDate p v1) (checkDate p v2) (Emb exp _) -> warnOKPM (v1, (Emb exp D)) [(p, ("Information: embedded expression is "++ "assumed to be of type Date"))] _ -> throwPM p ("Type error: Date ("++(show d)++") and "++ (typeToStr (typeOf v2))++" are not compatible.") checkValVal p v1@(BoolExp b) v2 = case v2 of (BoolExp _) -> cleanPM (v1,v2) (Emb exp _) -> warnOKPM (v1, (Emb exp B)) [(p, ("Information: embedded expression is "++ "assumed to be of type Bool"))] _ -> throwPM p ("Type error: Boolean ("++(show b)++") and "++ (typeToStr (typeOf v2))++" are not compatible.") checkValVal p v1@(CharExp c) v2 = case v2 of (CharExp _) -> cleanPM (v1,v2) (Emb exp _) -> warnOKPM (v1, (Emb exp C)) [(p, ("Information: embedded expression is "++ "assumed to be of type Char"))] _ -> throwPM p ("Type error: Char ("++(show c)++") and "++ (typeToStr (typeOf v2))++" are not compatible.") checkValVal p v1@(Emb _ _) v2 = case v2 of (Emb _ _) -> throwPM p ("Because of type safety it is " ++" not possible to compare " ++"two embedded expressions.") _ -> checkValVal p v2 v1 checkValVal p (KeyExp _ _) _ = throwPM p ("The CDBI-Interface does not allow" ++" the use of (foreign) key values " ++"in case exp.")-- this is actually not possible --cause KeyExp are dependent on a referencing column checkValVal p (AbsNull) _ = throwPM p ("The use of Null-values in " ++"case-expressions is not " ++"supported by the CDBI-Interface.") -- Compares type of a column to type of a value. -- Throws an error if they are not of the same type. -- Throws a warning if type of embedded expression is -- set using context information. checkColVal :: Pos -> ColumnRef -> Value -> PM (ColumnRef, Value) checkColVal p c@(Column _ col I _ _) val = case val of (IntExp _) -> cleanPM (c,val) (Emb exp _) -> warnOKPM (c, (Emb exp I)) [(p, ("Information: embedded expression is "++ "assumed to be of type Int"))] _ -> throwPM p ("Type error: Int ("++col++") and "++ (typeToStr (typeOf val))++" are not compatible.") checkColVal p c@(Column _ col F _ _) val = case val of (FloatExp _)-> cleanPM (c,val) (Emb exp _) -> warnOKPM (c, (Emb exp F)) [(p, ("Information: embedded expression is "++ "assumed to be of type Float"))] _ -> throwPM p ("Type error: Float ("++col++") and "++ (typeToStr (typeOf val))++" are not compatible.") checkColVal p c@(Column _ col B _ _) val = case val of (BoolExp _) -> cleanPM (c,val) (Emb exp _) -> warnOKPM (c, (Emb exp B)) [(p, ("Information: embedded expression is "++ "assumed to be of type Bool"))] _ -> throwPM p ("Type error: Bool ("++col++") and "++ (typeToStr (typeOf val))++" are not compatible.") checkColVal p c@(Column _ col C _ _) val = case val of (CharExp _) -> cleanPM (c,val) (Emb exp _) -> warnOKPM (c, (Emb exp C)) [(p, ("Information: embedded expression is "++ "assumed to be of type Char"))] _ -> throwPM p ("Type error: Char ("++col++") and "++ (typeToStr (typeOf val))++" are not compatible.") checkColVal p c@(Column _ col S _ _) val = case val of (StringExp _) -> cleanPM (c,val) (Emb exp _) -> warnOKPM (c, (Emb exp S)) [(p, ("Information: embedded expression is "++ "assumed to be of type String"))] _ -> throwPM p ("Type error: String ("++col++") and "++ (typeToStr (typeOf val))++" are not compatible.") checkColVal p c@(Column _ col D _ _) val = case val of (DateExp _) -> liftPM (\date -> (c, date)) (checkDate p val) (Emb exp _) -> warnOKPM (c, (Emb exp D)) [(p, ("Information: embedded expression is "++ "assumed to be of type Date"))] _ -> throwPM p ("Type error: Date ("++col++") and "++ (typeToStr (typeOf val))++" are not compatible.") checkColVal p c@(Column _ _ (Key reftab) _ _) val = case val of (IntExp i) -> cleanPM (c, (KeyExp reftab i)) (Emb exp _) -> warnOKPM (c, (Emb exp (Key reftab))) [(p, ("Information: embedded expression is "++ "assumed to be of type " ++(firstUp reftab)++"ID"))] _ -> throwPM p ("Type error: "++reftab++"ID and "++ (typeToStr (typeOf val))++" are not compatible.") -- Compares the type of two columns. Throws an error if they are not the same. checkColCol :: Pos -> ColumnRef -> ColumnRef -> PM (ColumnRef, ColumnRef) checkColCol p c1@(Column _ col I _ _) c2 = case columnTyp c2 of I -> cleanPM (c1, c2) _ -> throwPM p ("Type error: column of type Int ("++col ++") was combined with column of type "++ (typeToStr (columnTyp c2))) checkColCol p c1@(Column _ col F _ _) c2 = case columnTyp c2 of F -> cleanPM (c1, c2) _ -> throwPM p ("Type error: column of type Float ("++col++ ") was combined with column of type "++ (typeToStr (columnTyp c2))) checkColCol p c1@(Column _ col B _ _) c2 = case columnTyp c2 of B -> cleanPM (c1, c2) _ -> throwPM p ("Type error: column of type Bool ("++col++ ") was combined with column of type "++ (typeToStr (columnTyp c2))) checkColCol p c1@(Column _ col C _ _) c2 = case columnTyp c2 of C -> cleanPM (c1, c2) _ -> throwPM p ("Type error: column of type Char ("++col++ ") was combined with column of type "++ (typeToStr (columnTyp c2))) checkColCol p c1@(Column _ col S _ _) c2 = case columnTyp c2 of S -> cleanPM (c1, c2) _ -> throwPM p ("Type error: column of type String ("++col++ ") was combined with column of type "++ (typeToStr (columnTyp c2))) checkColCol p c1@(Column _ col D _ _) c2 = case columnTyp c2 of D -> cleanPM (c1, c2) _ -> throwPM p ("Type error: column of type Date ("++col++ ") was combined with column of type "++ (typeToStr (columnTyp c2))) checkColCol p c1@(Column _ _ (Key tab1) _ _) c2 = case columnTyp c2 of (Key tab2) -> if tab1 == tab2 then cleanPM (c1,c2) else throwPM p ("Type error: foreign keys are " ++"referencing different tables: " ++ tab1++" and "++tab2) _ -> throwPM p ("Type error: column of type "++ (typeToStr (columnTyp c1))++ " was combined with column of type "++ (typeToStr (columnTyp c2))) checkDate :: Pos -> Value -> PM Value checkDate p date = case date of (DateExp (CalendarTime y m d _ _ _ _ )) -> if (y >= 1970) && (1 <= m) && (m <= 12) && (1<= d) && (d <= 31) then cleanPM date else warnOKPM (date) [(p, ("It seems like your date-expression is not in the"++ " correct form: year(four-digit) month day hour"++ " minute second"))] _ -> cleanPM date typeToStr :: Type -> String typeToStr I = "Int" typeToStr F = "Float" typeToStr B = "Boolean" typeToStr C = "Char" typeToStr D = "Date" typeToStr S = "String" typeToStr Unknown = "Unknown (Null or embedded)" typeToStr (Key tab) = (firstUp tab)++"ID" typeToStr (Entity name) = name columnTyp :: ColumnRef -> Type columnTyp (Column _ _ t _ _) = t typeOf :: Value -> Type typeOf (IntExp _) = I typeOf (FloatExp _) = F typeOf (StringExp _) = S typeOf (DateExp _) = D typeOf (BoolExp _) = B typeOf (CharExp _ ) = C typeOf (Emb _ _) = Unknown typeOf AbsNull = Unknown typeOf (KeyExp tab _) = (Key tab) --auxiliary functions -------------------------- firstUp :: String -> String firstUp [] = "" firstUp (s:str) = (toUpper s):str firstLow :: String -> String firstLow [] = "" firstLow (s:str) = (toLower s):str compareLists :: Eq a => [a] -> [a] -> Bool compareLists [] [] = True compareLists [] (_:_) = False compareLists (_:_) [] = False compareLists (a:as) (b:bs) = if (a == b) then compareLists as bs else False