StaticAnalysis.hs revision 4ce999f12f90d3dfdf180def615a8b9883c95f50
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder{- |
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian MaederModule : $Header$
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian MaederDescription : static analysis for Relational Schemes
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian MaederCopyright : Dominik Luecke, Uni Bremen 2008
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian MaederLicense : similar to LGPL, see Hets/LICENSE.txt or LIZENZ.txt
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian MaederMaintainer : luecke@informatik.uni-bremen.de
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian MaederStability : provisional
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian MaederPortability : portable
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederstatic analysis for Relational Schemes
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder-}
1d330b771706686190ad2f3711ec5769c555c708Christian Maeder
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maedermodule RelationalScheme.StaticAnalysis
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder (
737526b54e46fa1a76c4b5e793124ee765adef6cChristian Maeder basic_Rel_analysis
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder )
1d330b771706686190ad2f3711ec5769c555c708Christian Maeder where
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederimport RelationalScheme.AS
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederimport RelationalScheme.Sign
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederimport Common.ExtSign
c4e912fc181d72c8d0e0e38d0351278182f0d0b5Christian Maederimport Common.GlobalAnnotations
c4e912fc181d72c8d0e0e38d0351278182f0d0b5Christian Maederimport Common.Result
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederimport Common.AS_Annotation
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederimport qualified Data.Set as Set
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederimport Common.Id
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederimport Control.Monad
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederimport Data.Maybe
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederimport Data.List
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder
1d330b771706686190ad2f3711ec5769c555c708Christian Maederbasic_Rel_analysis :: (RSScheme, Sign,GlobalAnnos) ->
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder Result (RSScheme, ExtSign Sign RSSymbol,[Named Sentence])
c4e912fc181d72c8d0e0e38d0351278182f0d0b5Christian Maederbasic_Rel_analysis (spec, sign, _) =
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder let
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder sens = getRels spec
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder sig = getSignature spec
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder in
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder do
e05956d1da3c97e4d808926f97c6841c4a561991Christian Maeder os <- sig `uniteSig` sign
fe883661c9d1a5a8b42ac4e8673ec133d9dad354Christian Maeder when (tables os == Set.empty) (fatal_error "Empty signature" nullRange)
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder let syms = getSymbols sig
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder mapM (analyse_relationship os) sens
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder return (spec, ExtSign
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder {
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder plainSign = os
613c474338a210f2aad9817376e5a3ce1fdde886Christian Maeder , nonImportedSymbols = syms
613c474338a210f2aad9817376e5a3ce1fdde886Christian Maeder },
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder map makeNamedSen sens)
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder
6e5180855658f12f9059d9041f447bf0935de344Christian Maeder-- ^ Function to determine the symbols of a spec
8a1f427564a5ae2db32332512237ef645289c34dChristian MaedergetSymbols :: RSTables -> Set.Set RSSymbol
e05956d1da3c97e4d808926f97c6841c4a561991Christian MaedergetSymbols inTbl =
c0467970183fa3dc894edea3caf9ca05d3a09fa8Christian Maeder Set.fold (\x y ->
613c474338a210f2aad9817376e5a3ce1fdde886Christian Maeder Set.union
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder (foldl (\b a -> SColumn (t_name x) (c_name a) (c_data a) (c_key a)
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder `Set.insert` b) Set.empty $ columns x) $
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder (STable $ t_name x) `Set.insert` y) Set.empty $ tables inTbl
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder-- ^ outputs a sorted list of sorts
b475a916d62584a2af5f51749240db7a5f0c8b82Christian MaedercollectTypes :: RSTables -> [RSQualId] -> [RSDatatype]
b475a916d62584a2af5f51749240db7a5f0c8b82Christian MaedercollectTypes tb qar =
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder sort $ map (collectType tb) qar
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder
8a1f427564a5ae2db32332512237ef645289c34dChristian MaedercollectType :: RSTables -> RSQualId -> RSDatatype
b475a916d62584a2af5f51749240db7a5f0c8b82Christian MaedercollectType tbi qi =
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder let
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder tb = tables tbi
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder (tn, cn) = case qi of
6e5180855658f12f9059d9041f447bf0935de344Christian Maeder RSQualId i1 i2 _ -> (i1,i2)
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder t = head $ Set.toList $ Set.filter (\x -> t_name x == tn) tb
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder r = head $ filter (\x -> c_name x == cn) $ columns t
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder in
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder c_data r
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder{-
b475a916d62584a2af5f51749240db7a5f0c8b82Christian MaedercollectNames :: RSTables -> [RSQualId] -> [Id]
b475a916d62584a2af5f51749240db7a5f0c8b82Christian MaedercollectNames tb qar =
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder sort $ map (collectName tb) qar
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder
9e5221faf8ff37ebdac127972874fccd378ccbe0Christian MaedercollectName :: RSTables -> RSQualId -> Id
b475a916d62584a2af5f51749240db7a5f0c8b82Christian MaedercollectName tbi qi =
c4e912fc181d72c8d0e0e38d0351278182f0d0b5Christian Maeder let
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder tb = tables tbi
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder (tn, cn) = case qi of
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder RSQualId i1 i2 _ -> (i1,i2)
6e5180855658f12f9059d9041f447bf0935de344Christian Maeder t = head $ Set.toList $ Set.filter (\x -> t_name x == tn) tb
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder r = head $ filter (\x -> c_name x == cn) $ columns t
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder in
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder c_name r
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder-}
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder
8a1f427564a5ae2db32332512237ef645289c34dChristian Maederanalyse_relationship :: RSTables -> Annoted RSRel -> Result (Annoted RSRel)
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederanalyse_relationship tbi reli =
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder let
1d330b771706686190ad2f3711ec5769c555c708Christian Maeder tb = tables tbi
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder rel = item reli
6e5180855658f12f9059d9041f447bf0935de344Christian Maeder (relDom, relCo, _, rn) = case rel of
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder RSRel r1 r2 r3 r4 -> (r1,r2,r3,r4)
7c56ba9d3d481421a827c947233e669059056ca3Christian Maeder (t2,_) = case head $ relCo of
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder RSQualId i1 i2 _ -> (i1, i2)
375dbb1a6d9b4cd2758c6a25ac526267970437b1Christian Maeder tf2 = Set.toList $ Set.filter (\x -> t_name x == t2) tb
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder keyz2 = t_keys $ head $ tf2
7c57322afb6342e5cc8b1fdc96050b707407fc61Christian Maeder domT = collectTypes tbi relDom
7c57322afb6342e5cc8b1fdc96050b707407fc61Christian Maeder codoT = collectTypes tbi relCo
7c56ba9d3d481421a827c947233e669059056ca3Christian Maeder-- domN = collectNames tbi relDom
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder-- codoN = collectNames tbi relCo
7c56ba9d3d481421a827c947233e669059056ca3Christian Maeder in
do
when (domT /= codoT) (fatal_error ("The types of the left and right " ++
" right hand side of: " ++ (show rel) ++ " do not match") rn)
-- when (domN /= codoN && length domN > 1) (fatal_error ("The names of the left and right " ++
-- " right hand side of: " ++ (show rel) ++ " do not match") rn)
mapM (analyse_RSQualid rn tb) relDom
k2 <- mapM (analyse_RSQualidK rn tb) relCo
let kl2 = Set.fromList $ map fromJust $ filter (\x -> case x of
Nothing -> False
_ -> True) $map (\(_,y) -> y) k2
when (kl2 /= keyz2) (fatal_error ("Not all keys are used on the right hand side of: " ++
(show rel)) rn)
return $ reli
analyse_RSQualid :: Range -> Set.Set RSTable -> RSQualId -> Result RSQualId
analyse_RSQualid rn st quid =
let
(tname, cname) = case quid of
RSQualId i1 i2 _ -> (i1, i2)
ft = Set.filter (\x -> t_name x == tname) st
cols = Set.fromList $ map c_name $ columns $ head $ Set.toList ft
in
do
when (cname `Set.notMember` cols) (fatal_error ((show cname) ++ " is not" ++
" defined") rn)
return $ quid
analyse_RSQualidK :: Range -> Set.Set RSTable -> RSQualId -> Result (RSQualId, Maybe Id)
analyse_RSQualidK rn st quid =
let
(tname, cname) = case quid of
RSQualId i1 i2 _ -> (i1, i2)
ft = Set.filter (\x -> t_name x == tname) st
in
case (Set.size ft) of
0 -> return $ (quid, Nothing)
1 -> do
let tid = head $ Set.toList ft
keyz = t_keys tid
when (cname `Set.notMember` keyz) (fatal_error ((show cname) ++ " is used "++
"as a key, but not defined as one") rn)
return $ (quid, Just $ cname)
_ -> fatal_error ("Duplicate table name: " ++ (show ft)) rn