{- |
Module : ./RelationalScheme/StaticAnalysis.hs
Description : static analysis for Relational Schemes
Copyright : Dominik Luecke, Uni Bremen 2008
License : GPLv2 or higher, see LICENSE.txt or LIZENZ.txt
Maintainer : luecke@informatik.uni-bremen.de
Stability : provisional
Portability : portable
static analysis for Relational Schemes
-}
(
basic_Rel_analysis
)
where
import RelationalScheme.AS
import RelationalScheme.Sign
import Common.AS_Annotation
import Common.ExtSign
import Common.GlobalAnnotations
import Common.Id
import Common.Result
import Control.Monad
import Data.Maybe
import qualified Data.Set as Set
basic_Rel_analysis :: (RSScheme, Sign, GlobalAnnos) ->
Result (RSScheme, ExtSign Sign RSSymbol, [Named Sentence])
basic_Rel_analysis (spec, sign, _) =
let
sens = getRels spec
sig = getSignature spec
in
do
os <- sig `uniteSig` sign
when (tables os == Set.empty) (fatal_error "Empty signature" nullRange)
let syms = getSymbols sig
mapM_ (analyse_relationship os) sens
return (spec, ExtSign
{
plainSign = os
, nonImportedSymbols = syms
},
map makeNamedSen sens)
-- ^ Function to determine the symbols of a spec
getSymbols :: RSTables -> Set.Set RSSymbol
getSymbols inTbl =
Set.fold (\ x y ->
(foldl (\ b a -> SColumn (t_name x) (c_name a) (c_data a) (c_key a)
`Set.insert` b) Set.empty $ columns x) $
(STable $ t_name x) `Set.insert` y) Set.empty $ tables inTbl
-- ^ outputs a sorted list of sorts
collectTypes :: RSTables -> [RSQualId] -> [RSDatatype]
collectTypes tb = map (collectType tb)
collectType :: RSTables -> RSQualId -> RSDatatype
collectType tbi qi =
let
tb = tables tbi
(tn, cn) = case qi of
RSQualId i1 i2 _ -> (i1, i2)
t = head $ Set.toList $ Set.filter (\ x -> t_name x == tn) tb
r = head $ filter (\ x -> c_name x == cn) $ columns t
in
c_data r
{-
collectNames :: RSTables -> [RSQualId] -> [Id]
collectNames tb qar =
sort $ map (collectName tb) qar
collectName :: RSTables -> RSQualId -> Id
collectName tbi qi =
let
tb = tables tbi
(tn, cn) = case qi of
RSQualId i1 i2 _ -> (i1,i2)
t = head $ Set.toList $ Set.filter (\x -> t_name x == tn) tb
r = head $ filter (\x -> c_name x == cn) $ columns t
in
c_name r
-}
analyse_relationship :: RSTables -> Annoted RSRel -> Result (Annoted RSRel)
analyse_relationship tbi reli =
let
tb = tables tbi
rel = item reli
(relDom, relCo, _, rn) = case rel of
RSRel r1 r2 r3 r4 -> (r1, r2, r3, r4)
(t2, _) = case head relCo of
RSQualId i1 i2 _ -> (i1, i2)
tf2 = Set.toList $ Set.filter (\ x -> t_name x == t2) tb
keyz2 = t_keys $ head tf2
domT = collectTypes tbi relDom
codoT = collectTypes tbi relCo
{- domN = collectNames tbi relDom
codoN = collectNames tbi relCo -}
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 snd k2
when (kl2 /= Set.map fst 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 = Set.map fst $ 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