7ce7e7613d5f66523dfee99cec72dc92c579e91bChristian MaederDescription : static ADL analysis
7ce7e7613d5f66523dfee99cec72dc92c579e91bChristian MaederCopyright : (c) Stef Joosten, Christian Maeder DFKI GmbH 2010
98890889ffb2e8f6f722b00e265a211f13b5a861Corneliu-Claudiu ProdescuLicense : GPLv2 or higher, see LICENSE.txt
7ce7e7613d5f66523dfee99cec72dc92c579e91bChristian MaederMaintainer : Christian.Maeder@dfki.de
7ce7e7613d5f66523dfee99cec72dc92c579e91bChristian MaederStability : provisional
7ce7e7613d5f66523dfee99cec72dc92c579e91bChristian MaederPortability : portable
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maederimport qualified Common.Lib.Rel as Rel
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maederimport qualified Data.Set as Set
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maederimport qualified Data.Map as Map
083c76e485943cbbdeef6ee4bcf5c0d72b77051eChristian MaederbasicAna :: (Context, Sign, GlobalAnnos)
67bbc7a1baf72322f967b9aeabe9fdbfad343d05Christian Maeder -> Result (Context, ExtSign Sign Symbol, [Named Sen])
42a89bb3427a04f416d7158ac680180e4d908cfdChristian MaederbasicAna (Context m ps, sig, _) =
e176e60e3d82527d508ac4df2f980751849ee45aChristian Maeder let (nps, env) = runState (mapM anaPatElem ps) $ toEnv sig
f5ba1df84889802c56bf5c6dec99310bc72aab35Christian Maeder in Result (reverse $ msgs env)
51dc4ec3c58b834d0ef0eb3d5a8d9379983377bfChristian Maeder $ Just (Context m nps, ExtSign (closeSign $ sign env) $ syms env
51dc4ec3c58b834d0ef0eb3d5a8d9379983377bfChristian Maeder , reverse $ sens env)
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maederdata Env = Env
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder { sign :: Sign
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder , syms :: Set.Set Symbol
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder , sens :: [Named Sen]
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder , msgs :: [Diagnosis]
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaedertoEnv :: Sign -> Env
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaedertoEnv s = Env { sign = s, syms = Set.empty, sens = [], msgs = [] }
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaederaddMsgs :: [Diagnosis] -> State Env ()
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaederaddMsgs ds = do
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder put e { msgs = ds ++ msgs e }
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaederaddSens :: [Named Sen] -> State Env ()
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaederaddSens ns = do
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder put e { sens = ns ++ sens e }
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaederaddSyms :: Set.Set Symbol -> State Env ()
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaederaddSyms sys = do
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder put e { syms = Set.union sys $ syms e }
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaedersymsOf :: Relation -> Set.Set Symbol
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaedersymsOf r = let
cb26aa08ea668c555cc2916d682e072c4de73d9dChristian Maeder y = relType r
cb26aa08ea668c555cc2916d682e072c4de73d9dChristian Maeder in Set.fromList [Con s, Con t, Rel r]
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaederaddRel :: Relation -> State Env ()
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder let s = sign e
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder i = simpleIdToId $ decnm r
cb26aa08ea668c555cc2916d682e072c4de73d9dChristian Maeder v = relType r
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder put e { sign = s { rels = Map.insert i (Set.insert v l) m } }
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaederaddIsa :: Concept -> Concept -> State Env ()
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaederaddIsa c1 c2 = do
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder let s = sign e
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder sys = symOf s
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder if Set.member (Con c1) sys then
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder if Set.member (Con c2) sys then
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder if c1 == c2 then addMsgs [mkDiag Warning "no specialization" c1]
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder else if Rel.path c2 c1 r then
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder addMsgs [mkDiag Error "opposite ISA known" c1]
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder else if Rel.path c1 c2 r then
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder addMsgs [mkDiag Hint "redeclared ISA" c1]
e0f1794e365dd347e97b37d7d22b2fce27296fa1Christian Maeder else put e { sign = s { isas = Rel.insertPair c1 c2 r }}
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder else addMsgs [mkDiag Error "unknown ISA" c2]
e176e60e3d82527d508ac4df2f980751849ee45aChristian Maeder else addMsgs [mkDiag Error "unknown GEN" c1]
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maederdata TypedRule = TypedRule Rule RelType deriving Show
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maederinstance Pretty TypedRule where
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder pretty (TypedRule r (RelType c1 c2)) =
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder fsep [pretty r <+> text "::", pretty c1 <+> cross <+> pretty c2]
42a89bb3427a04f416d7158ac680180e4d908cfdChristian MaederanaRule :: Rule -> State Env Rule
42a89bb3427a04f416d7158ac680180e4d908cfdChristian MaederanaRule r = do
5211faa927398e638ba91bb9967cb4b969c30b87Christian Maeder s <- gets sign
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder case typeRule s r of
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder addMsgs [mkDiag Error "no typing found" $ findTypeFailure s r]
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder l@(TypedRule e (RelType c1 c2) : t) -> do
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder if null t then do
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder Anything -> addMsgs [mkDiag Error "source concept is anything" r]
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder _ -> return ()
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder Anything -> addMsgs [mkDiag Error "target concept is anything" r]
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder _ -> return ()
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder else addMsgs [Diag Error
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder (unlines $ "ambiguous typings found:"
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder : map (`showDoc` "") l) $ getRangeSpan r]
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian MaederfindTypeFailure :: Sign -> Rule -> Rule
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian MaederfindTypeFailure s r = case r of
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder UnExp _ e -> if null (typeRule s e) then findTypeFailure s e else r
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder MulExp o es -> case es of
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder [] -> error "findTypeFailure"
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder e : t | null (typeRule s e) -> findTypeFailure s e
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder | otherwise -> let n = MulExp o t in if null (typeRule s n)
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder then findTypeFailure s n else r
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder-- | analyze rule and return resolved one
42a89bb3427a04f416d7158ac680180e4d908cfdChristian MaedertypeRule :: Sign -> Rule -> [TypedRule]
42a89bb3427a04f416d7158ac680180e4d908cfdChristian MaedertypeRule s rule =
5211faa927398e638ba91bb9967cb4b969c30b87Christian Maeder let m = rels s
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder in case rule of
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder Tm (Sgn n ty@(RelType rs rt)) -> let str = tokStr n in
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder if str == "V" then [TypedRule rule ty] else
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder if str == "I" then case (rs, rt) of
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder (Anything, Anything) ->
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder map (\ c -> let y = RelType c c in TypedRule (Tm $ Sgn n y) y)
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder . keepMins (flip $ isSubConcept i) . Set.toList $ conceptsOf s
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder _ -> case compatible i rs rt of
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder Just c -> let y = RelType c c in [TypedRule (Tm $ Sgn n y) y]
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder Nothing -> []
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder (\ (RelType f t) l -> maybeToList (do
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder a <- compatible i f rs
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder b <- compatible i t rt
cb26aa08ea668c555cc2916d682e072c4de73d9dChristian Maeder let y = RelType a b
cb26aa08ea668c555cc2916d682e072c4de73d9dChristian Maeder return $ TypedRule (Tm $ Sgn n y) y) ++ l) []
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder $ Map.findWithDefault Set.empty (simpleIdToId n) m
b96278bb8b562ffe81c8cfa0c9408dfd9e33d2b3Christian Maeder UnExp o r -> concatMap
b96278bb8b562ffe81c8cfa0c9408dfd9e33d2b3Christian Maeder (\ (TypedRule e t@(RelType a b)) -> map (TypedRule $ UnExp o e)
b96278bb8b562ffe81c8cfa0c9408dfd9e33d2b3Christian Maeder Co -> [RelType b a]
b96278bb8b562ffe81c8cfa0c9408dfd9e33d2b3Christian Maeder _ -> case compatible i a b of
b96278bb8b562ffe81c8cfa0c9408dfd9e33d2b3Christian Maeder Nothing -> []
b96278bb8b562ffe81c8cfa0c9408dfd9e33d2b3Christian Maeder Just c -> [RelType c c]
b96278bb8b562ffe81c8cfa0c9408dfd9e33d2b3Christian Maeder ) $ typeRule s r
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder MulExp o es -> case es of
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder [] -> error "typeRule"
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder r : t -> if null t then typeRule s r else
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder let rs = typeRule s r
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder ts = typeRule s $ MulExp o t
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder [ TypedRule fe ty
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder | TypedRule ne (RelType a b) <- rs
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder , TypedRule re (RelType p q) <- ts
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder , let fe = case re of
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder MulExp op nt | op == o -> MulExp o $ ne : nt
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder _ -> MulExp o [ne, re]
ea9c85afaa9e7cc986b1bf81ad3abaa05b8af463Christian Maeder , let res = if elem o [Fc, Fd] then
ea9c85afaa9e7cc986b1bf81ad3abaa05b8af463Christian Maeder case compatible i b p of
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder Nothing -> Nothing
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder Just _ -> Just $ RelType a q
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder na <- compatible i a p
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder nb <- compatible i b q
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder return $ RelType na nb
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder , Just ty <- [res]]
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maedercompatible :: Rel.Rel Concept -> Concept -> Concept -> Maybe Concept
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maedercompatible r c1 c2 = case () of
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder _ | isSubConcept r c1 c2 -> Just c1
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder | isSubConcept r c2 c1 -> Just c2
5211faa927398e638ba91bb9967cb4b969c30b87Christian MaederisSubConcept :: Rel.Rel Concept -> Concept -> Concept -> Bool
42a89bb3427a04f416d7158ac680180e4d908cfdChristian MaederisSubConcept r c1 c2 = c1 == c2 || case c2 of
5211faa927398e638ba91bb9967cb4b969c30b87Christian Maeder Anything -> True
42a89bb3427a04f416d7158ac680180e4d908cfdChristian MaederanaAtts :: KeyAtt -> State Env KeyAtt
42a89bb3427a04f416d7158ac680180e4d908cfdChristian MaederanaAtts (KeyAtt m r) = do
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder n <- anaRule r
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder return $ KeyAtt m n
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian MaederconceptsOf :: Sign -> Set.Set Concept
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian MaederconceptsOf = Set.fold (\ sy -> case sy of
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder _ -> id) Set.empty . symOf
63fe8df192422852a8bdaed34a56ab1bc917cddaChristian MaederanaObject :: Object -> State Env ()
63fe8df192422852a8bdaed34a56ab1bc917cddaChristian MaederanaObject (Object _ r _ os) = do
63fe8df192422852a8bdaed34a56ab1bc917cddaChristian Maeder mapM_ (anaObject . \ o -> o { expr = MulExp Fc [r, expr o]}) os
42a89bb3427a04f416d7158ac680180e4d908cfdChristian MaederanaPatElem :: PatElem -> State Env PatElem
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian MaederanaPatElem pe = case pe of
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder nu <- anaRule u
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder addSens [case h of
534d2a17ea35f30d0d462fa539d633b6ba389da6Christian Maeder Always -> makeNamed "" $ Assertion Nothing nu
534d2a17ea35f30d0d462fa539d633b6ba389da6Christian Maeder RuleHeader k t -> makeNamed (show t) $ Assertion (Just k) nu]
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder return $ Pr h nu
7f4b96a0849d37fed48ac51d31403906d23ea609Christian Maeder Pm qs d@(Sgn _ ty@(RelType c1 c2)) b -> do
08eabcc70456fa8e6d34521ba20946630d5e16b2Christian Maeder let (nqs, ws) = if c1 == c2 then (qs, []) else
08eabcc70456fa8e6d34521ba20946630d5e16b2Christian Maeder partition ((< Sym) . propProp) qs
7f4b96a0849d37fed48ac51d31403906d23ea609Christian Maeder addMsgs $ map (mkDiag Error $ "bad concepts "
7f4b96a0849d37fed48ac51d31403906d23ea609Christian Maeder ++ showDoc ty " with property") ws
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder addSens $ map (\ q -> makeNamed (show (decnm d) ++ "_"
b3a1b1916655e6f42515598cc9eb0541f3d05f61Christian Maeder ++ showUp (propProp q))
08eabcc70456fa8e6d34521ba20946630d5e16b2Christian Maeder $ DeclProp d q) nqs
08eabcc70456fa8e6d34521ba20946630d5e16b2Christian Maeder return $ Pm nqs d b
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder Pg c1 c2 -> do
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder Pk (KeyDef l c atts) -> do
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder csyms <- gets $ conceptsOf . sign
04a4c290d69debb9933c0a01469d76be6e0a16d5Christian Maeder unless (Set.member c csyms) $
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder addMsgs [mkDiag Error "unknown KEY concept" c]
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder natts <- mapM anaAtts atts
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder return $ Pk $ KeyDef l c natts
63fe8df192422852a8bdaed34a56ab1bc917cddaChristian Maeder Plug _ o -> do
42a89bb3427a04f416d7158ac680180e4d908cfdChristian Maeder _ -> return pe