{- |

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

-}

module RelationalScheme.StaticAnalysis

(

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 ->

Set.union

(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