module Language.Clafer.Intermediate.SimpleScopeAnalyzer (simpleScopeAnalysis) where
import Language.Clafer.Common
import Data.Graph
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Ord
import Data.Ratio
import Language.Clafer.Intermediate.Intclafer
import Prelude hiding (exp)
isReference :: IClafer -> Bool
isReference = isOverlapping . super
isConcrete :: IClafer -> Bool
isConcrete = not . isReference
isSuperest :: [IClafer] -> IClafer -> Bool
isSuperest clafers clafer = isNothing $ directSuper clafers clafer
simpleScopeAnalysis :: IModule -> [(String, Integer)]
simpleScopeAnalysis IModule{mDecls = decls'} =
[(a, b) | (a, b) <- finalAnalysis, isReferenceOrSuper a, b /= 0]
where
finalAnalysis = Map.toList $ foldl analyzeComponent supersAnalysis connectedComponents
isReferenceOrSuper uid' =
isReference clafer || isSuperest clafers clafer
where
clafer = findClafer uid'
isConcrete' uid' = isConcrete $ findClafer uid'
upperCards u =
Map.findWithDefault (error $ "No upper cardinality for clafer named \"" ++ u ++ "\".") u upperCardsMap
upperCardsMap = Map.fromList [(uid c, snd $ fromJust $ card c) | c <- clafers]
supersAnalysis = foldl (analyzeSupers clafers) Map.empty decls'
constraintAnalysis = analyzeConstraints constraints upperCards
(subclaferMap, parentMap) = analyzeHierarchy clafers
connectedComponents = analyzeDependencies clafers
clafers = concatMap findClafers decls'
constraints = concatMap findConstraints decls'
findClafer uid' = fromJust $ find (isEqClaferId uid') clafers
lowCard clafer =
max low constraintLow
where
low = fst $ fromJust $ card clafer
constraintLow = Map.findWithDefault 0 (uid clafer) constraintAnalysis
analyzeComponent analysis' component =
case flattenSCC component of
[uid'] -> analyzeSingleton uid' analysis'
uids ->
foldr analyzeSingleton assume uids
where
assume = foldr (`Map.insert` 1) analysis' uids
where
analyzeSingleton uid' analysis'' = analyze analysis'' $ findClafer uid'
analyze :: Map String Integer -> IClafer -> Map String Integer
analyze analysis clafer =
Map.insertWith max (uid clafer) scope analysis
where
scope
| isAbstract clafer = sum subclaferScopes
| otherwise = parentScope * lowCard clafer
subclaferScopes = map (findOrError " subclafer scope not found" analysis) $ filter isConcrete' subclafers
parentScope =
case parent' of
Just parent'' -> findOrError " parent scope not found" analysis parent''
Nothing -> rootScope
subclafers = Map.findWithDefault [] (uid clafer) subclaferMap
parent' = Map.lookup (uid clafer) parentMap
rootScope = 1
findOrError message m key = Map.findWithDefault (error $ key ++ message) key m
analyzeSupers :: [IClafer] -> Map String Integer -> IElement -> Map String Integer
analyzeSupers clafers analysis (IEClafer clafer) =
foldl (analyzeSupers clafers) analysis' (elements clafer)
where
lowerBound = max 1 $ fst (fromJust $ card clafer)
analysis' = case (directSuper clafers clafer) of
(Just c) -> Map.alter ((if isReference clafer then maxLB else incLB) lowerBound) (uid c) analysis
Nothing -> analysis
incLB lb' Nothing = Just lb'
incLB lb' (Just lb) = Just (lb + lb')
maxLB lb' Nothing = Just lb'
maxLB lb' (Just lb) = Just (max lb lb')
analyzeSupers _ analysis _ = analysis
analyzeConstraints :: [PExp] -> (String -> Integer) -> Map String Integer
analyzeConstraints constraints upperCards =
foldr analyzeConstraint Map.empty $ filter isOneOrSomeConstraint constraints
where
isOneOrSomeConstraint PExp{exp = IDeclPExp{quant = quant'}} =
case quant' of
IOne -> True
ISome -> True
_ -> False
isOneOrSomeConstraint _ = False
analyzeConstraint PExp{exp = IDeclPExp{oDecls = [], bpexp = bpexp'}} analysis =
foldr atLeastOne analysis path'
where
path' = dropThisAndParent $ unfoldJoins bpexp'
atLeastOne = Map.insertWith max `flip` 1
analyzeConstraint PExp{exp = IDeclPExp{oDecls = decls'}} analysis =
foldr analyzeDecl analysis decls'
analyzeConstraint _ analysis = analysis
analyzeDecl IDecl{isDisj = isDisj', decls = decls', body = body'} analysis =
foldr (uncurry insert') analysis $ zip path' scores
where
path' = dropThisAndParent $ unfoldJoins body'
minScope = if isDisj' then fromIntegral $ length decls' else 1
insert' = Map.insertWith max
scores = assign path' minScope
assign [] _ = [1]
assign (p : ps) score =
pScore : ps'
where
ps' = assign ps score
psScore = product $ ps'
pDesireScore = ceiling (score % psScore)
pMaxScore = upperCards p
pScore = min' pDesireScore pMaxScore
min' a b = if b == 1 then a else min a b
dropThisAndParent = dropWhile (== "parent") . dropWhile (== "this")
analyzeDependencies :: [IClafer] -> [SCC String]
analyzeDependencies clafers = connComponents
where
connComponents = stronglyConnComp [(key, key, depends) | (key, depends) <- dependencyGraph]
dependencies = concatMap (dependency clafers) clafers
dependencyGraph = Map.toList $ Map.fromListWith (++) [(a, [b]) | (a, b) <- dependencies]
dependency :: [IClafer] -> IClafer -> [(String, String)]
dependency clafers clafer =
selfDependency : (maybeToList superDependency ++ childDependencies)
where
selfDependency = (uid clafer, uid clafer)
superDependency
| isReference clafer = Nothing
| otherwise =
do
super' <- directSuper clafers clafer
return (uid super', uid clafer)
childDependencies = [(uid child, uid clafer) | child <- childClafers clafer]
analyzeHierarchy :: [IClafer] -> (Map String [String], Map String String)
analyzeHierarchy clafers =
foldl hierarchy (Map.empty, Map.empty) clafers
where
hierarchy (subclaferMap, parentMap) clafer = (subclaferMap', parentMap')
where
subclaferMap' =
case super' of
Just super'' -> Map.insertWith (++) (uid super'') [uid clafer] subclaferMap
Nothing -> subclaferMap
super' = directSuper clafers clafer
parentMap' = foldr (flip Map.insert $ uid clafer) parentMap (map uid $ childClafers clafer)
directSuper :: [IClafer] -> IClafer -> Maybe IClafer
directSuper clafers clafer =
second $ findHierarchy getSuper clafers clafer
where
second [] = Nothing
second [_] = Nothing
second (_:x:_) = Just x
findClafers :: IElement -> [IClafer]
findClafers (IEClafer clafer) = clafer : concatMap findClafers (elements clafer)
findClafers _ = []
findConstraints :: IElement -> [PExp]
findConstraints IEConstraint{cpexp = c} = [c]
findConstraints (IEClafer clafer) = concatMap findConstraints (elements clafer)
findConstraints _ = []
childClafers :: IClafer -> [IClafer]
childClafers clafer =
mapMaybe asClafer (elements clafer)
where
asClafer (IEClafer claf) = Just claf
asClafer _ = Nothing
unfoldJoins :: PExp -> [String]
unfoldJoins pexp =
fromMaybe [] $ unfoldJoins' pexp
where
unfoldJoins' PExp{exp = (IFunExp "." args)} =
return $ args >>= unfoldJoins
unfoldJoins' PExp{exp = IClaferId{sident = sident'}} =
return $ [sident']
unfoldJoins' _ =
fail "not a join"