{- |
Module : ./Adl/StatAna.hs
Description : static ADL analysis
Copyright : (c) Stef Joosten, Christian Maeder DFKI GmbH 2010
License : GPLv2 or higher, see LICENSE.txt
Maintainer : Christian.Maeder@dfki.de
Stability : provisional
Portability : portable
-}
module Adl.StatAna where
import Adl.As
import Adl.Sign
import Common.AS_Annotation
import Common.Doc
import Common.DocUtils
import Common.ExtSign
import Common.GlobalAnnotations
import Common.Id
import Common.Result
import Common.Lib.State
import qualified Common.Lib.Rel as Rel
import Common.Utils
import Control.Monad
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Maybe
import Data.List
basicAna :: (Context, Sign, GlobalAnnos)
-> Result (Context, ExtSign Sign Symbol, [Named Sen])
basicAna (Context m ps, sig, _) =
let (nps, env) = runState (mapM anaPatElem ps) $ toEnv sig
in Result (reverse $ msgs env)
$ Just (Context m nps, ExtSign (closeSign $ sign env) $ syms env
, reverse $ sens env)
data Env = Env
{ sign :: Sign
, syms :: Set.Set Symbol
, sens :: [Named Sen]
, msgs :: [Diagnosis]
}
toEnv :: Sign -> Env
toEnv s = Env { sign = s, syms = Set.empty, sens = [], msgs = [] }
addMsgs :: [Diagnosis] -> State Env ()
addMsgs ds = do
e <- get
put e { msgs = ds ++ msgs e }
addSens :: [Named Sen] -> State Env ()
addSens ns = do
e <- get
put e { sens = ns ++ sens e }
addSyms :: Set.Set Symbol -> State Env ()
addSyms sys = do
e <- get
put e { syms = Set.union sys $ syms e }
symsOf :: Relation -> Set.Set Symbol
symsOf r = let
y = relType r
s = relSrc y
t = relTrg y
in Set.fromList [Con s, Con t, Rel r]
addRel :: Relation -> State Env ()
addRel r = do
e <- get
let s = sign e
m = rels s
i = simpleIdToId $ decnm r
l = Map.findWithDefault Set.empty i m
v = relType r
put e { sign = s { rels = Map.insert i (Set.insert v l) m } }
addIsa :: Concept -> Concept -> State Env ()
addIsa c1 c2 = do
e <- get
let s = sign e
r = isas s
sys = symOf s
if Set.member (Con c1) sys then
if Set.member (Con c2) sys then
if c1 == c2 then addMsgs [mkDiag Warning "no specialization" c1]
else if Rel.path c2 c1 r then
addMsgs [mkDiag Error "opposite ISA known" c1]
else if Rel.path c1 c2 r then
addMsgs [mkDiag Hint "redeclared ISA" c1]
else put e { sign = s { isas = Rel.insertPair c1 c2 r }}
else addMsgs [mkDiag Error "unknown ISA" c2]
else addMsgs [mkDiag Error "unknown GEN" c1]
data TypedRule = TypedRule Rule RelType deriving Show
instance Pretty TypedRule where
pretty (TypedRule r (RelType c1 c2)) =
fsep [pretty r <+> text "::", pretty c1 <+> cross <+> pretty c2]
anaRule :: Rule -> State Env Rule
anaRule r = do
s <- gets sign
case typeRule s r of
[] -> do
addMsgs [mkDiag Error "no typing found" $ findTypeFailure s r]
return r
l@(TypedRule e (RelType c1 c2) : t) -> do
if null t then do
case c1 of
Anything -> addMsgs [mkDiag Error "source concept is anything" r]
_ -> return ()
case c2 of
Anything -> addMsgs [mkDiag Error "target concept is anything" r]
_ -> return ()
else addMsgs [Diag Error
(unlines $ "ambiguous typings found:"
: map (`showDoc` "") l) $ getRangeSpan r]
return e
findTypeFailure :: Sign -> Rule -> Rule
findTypeFailure s r = case r of
Tm _ -> r
UnExp _ e -> if null (typeRule s e) then findTypeFailure s e else r
MulExp o es -> case es of
[] -> error "findTypeFailure"
e : t | null (typeRule s e) -> findTypeFailure s e
| null t -> e
| otherwise -> let n = MulExp o t in if null (typeRule s n)
then findTypeFailure s n else r
-- | analyze rule and return resolved one
typeRule :: Sign -> Rule -> [TypedRule]
typeRule s rule =
let m = rels s
i = isas s
in case rule of
Tm (Sgn n ty@(RelType rs rt)) -> let str = tokStr n in
if str == "V" then [TypedRule rule ty] else
if str == "I" then case (rs, rt) of
(Anything, Anything) ->
map (\ c -> let y = RelType c c in TypedRule (Tm $ Sgn n y) y)
. keepMins (flip $ isSubConcept i) . Set.toList $ conceptsOf s
_ -> case compatible i rs rt of
Just c -> let y = RelType c c in [TypedRule (Tm $ Sgn n y) y]
Nothing -> []
else Set.fold
(\ (RelType f t) l -> maybeToList (do
a <- compatible i f rs
b <- compatible i t rt
let y = RelType a b
return $ TypedRule (Tm $ Sgn n y) y) ++ l) []
$ Map.findWithDefault Set.empty (simpleIdToId n) m
UnExp o r -> concatMap
(\ (TypedRule e t@(RelType a b)) -> map (TypedRule $ UnExp o e)
$ case o of
Co -> [RelType b a]
Cp -> [t]
_ -> case compatible i a b of
Nothing -> []
Just c -> [RelType c c]
) $ typeRule s r
MulExp o es -> case es of
[] -> error "typeRule"
r : t -> if null t then typeRule s r else
let rs = typeRule s r
ts = typeRule s $ MulExp o t
in
[ TypedRule fe ty
| TypedRule ne (RelType a b) <- rs
, TypedRule re (RelType p q) <- ts
, let fe = case re of
MulExp op nt | op == o -> MulExp o $ ne : nt
_ -> MulExp o [ne, re]
, let res = if elem o [Fc, Fd] then
case compatible i b p of
Nothing -> Nothing
Just _ -> Just $ RelType a q
else do
na <- compatible i a p
nb <- compatible i b q
return $ RelType na nb
, Just ty <- [res]]
compatible :: Rel.Rel Concept -> Concept -> Concept -> Maybe Concept
compatible r c1 c2 = case () of
_ | isSubConcept r c1 c2 -> Just c1
| isSubConcept r c2 c1 -> Just c2
_ -> Nothing
isSubConcept :: Rel.Rel Concept -> Concept -> Concept -> Bool
isSubConcept r c1 c2 = c1 == c2 || case c2 of
Anything -> True
_ -> Rel.path c1 c2 r
anaAtts :: KeyAtt -> State Env KeyAtt
anaAtts (KeyAtt m r) = do
n <- anaRule r
return $ KeyAtt m n
conceptsOf :: Sign -> Set.Set Concept
conceptsOf = Set.fold (\ sy -> case sy of
Con c -> Set.insert c
_ -> id) Set.empty . symOf
anaObject :: Object -> State Env ()
anaObject (Object _ r _ os) = do
anaRule r
mapM_ (anaObject . \ o -> o { expr = MulExp Fc [r, expr o]}) os
anaPatElem :: PatElem -> State Env PatElem
anaPatElem pe = case pe of
Pr h u -> do
nu <- anaRule u
addSens [case h of
Always -> makeNamed "" $ Assertion Nothing nu
RuleHeader k t -> makeNamed (show t) $ Assertion (Just k) nu]
return $ Pr h nu
Pm qs d@(Sgn _ ty@(RelType c1 c2)) b -> do
addRel d
let (nqs, ws) = if c1 == c2 then (qs, []) else
partition ((< Sym) . propProp) qs
addMsgs $ map (mkDiag Error $ "bad concepts "
++ showDoc ty " with property") ws
addSens $ map (\ q -> makeNamed (show (decnm d) ++ "_"
++ showUp (propProp q))
$ DeclProp d q) nqs
return $ Pm nqs d b
Pg c1 c2 -> do
addIsa c1 c2
return pe
Pk (KeyDef l c atts) -> do
csyms <- gets $ conceptsOf . sign
unless (Set.member c csyms) $
addMsgs [mkDiag Error "unknown KEY concept" c]
natts <- mapM anaAtts atts
return $ Pk $ KeyDef l c natts
Plug _ o -> do
anaObject o
return pe
_ -> return pe