module GF.Infra.Dependencies (
depGraph
) where
import GF.Grammar.Grammar
import GF.Text.Pretty(render)
import Data.List (nub,isPrefixOf)
depGraph :: Maybe [String] -> Grammar -> String
depGraph :: Maybe [String] -> Grammar -> String
depGraph Maybe [String]
only = [(ModuleName, ModDeps)] -> String
prDepGraph ([(ModuleName, ModDeps)] -> String)
-> (Grammar -> [(ModuleName, ModDeps)]) -> Grammar -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [String] -> Grammar -> [(ModuleName, ModDeps)]
grammar2moddeps Maybe [String]
only
prDepGraph :: [(ModuleName,ModDeps)] -> String
prDepGraph :: [(ModuleName, ModDeps)] -> String
prDepGraph [(ModuleName, ModDeps)]
deps = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
String
"digraph {"
] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
((ModuleName, ModDeps) -> String)
-> [(ModuleName, ModDeps)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, ModDeps) -> String
forall a. Pretty a => (a, ModDeps) -> String
mkNode [(ModuleName, ModDeps)]
deps [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
((ModuleName, ModDeps) -> [String])
-> [(ModuleName, ModDeps)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModuleName, ModDeps) -> [String]
forall a. Pretty a => (a, ModDeps) -> [String]
mkArrows [(ModuleName, ModDeps)]
deps [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [
String
"}"
]
where
mkNode :: (a, ModDeps) -> String
mkNode (a
i,ModDeps
dep) = [String] -> String
unwords [a -> String
forall a. Pretty a => a -> String
render a
i, String
"[",ModuleType -> String
nodeAttr (ModDeps -> ModuleType
modtype ModDeps
dep),String
"]"]
nodeAttr :: ModuleType -> String
nodeAttr ModuleType
ty = case ModuleType
ty of
ModuleType
MTAbstract -> String
"style = \"solid\", shape = \"box\""
MTConcrete ModuleName
_ -> String
"style = \"solid\", shape = \"ellipse\""
ModuleType
_ -> String
"style = \"dashed\", shape = \"ellipse\""
mkArrows :: (a, ModDeps) -> [String]
mkArrows (a
i,ModDeps
dep) =
[[String] -> String
unwords [a -> String
forall a. Pretty a => a -> String
render a
i,String
"->",ModuleName -> String
forall a. Pretty a => a -> String
render ModuleName
j,String
"[",String -> String
arrowAttr String
"of",String
"]"] | ModuleName
j <- ModDeps -> [ModuleName]
ofs ModDeps
dep] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[[String] -> String
unwords [a -> String
forall a. Pretty a => a -> String
render a
i,String
"->",ModuleName -> String
forall a. Pretty a => a -> String
render ModuleName
j,String
"[",String -> String
arrowAttr String
"ex",String
"]"] | ModuleName
j <- ModDeps -> [ModuleName]
extendeds ModDeps
dep] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[[String] -> String
unwords [a -> String
forall a. Pretty a => a -> String
render a
i,String
"->",ModuleName -> String
forall a. Pretty a => a -> String
render ModuleName
j,String
"[",String -> String
arrowAttr String
"op",String
"]"] | ModuleName
j <- ModDeps -> [ModuleName]
openeds ModDeps
dep] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[[String] -> String
unwords [a -> String
forall a. Pretty a => a -> String
render a
i,String
"->",ModuleName -> String
forall a. Pretty a => a -> String
render ModuleName
j,String
"[",String -> String
arrowAttr String
"ed",String
"]"] | ModuleName
j <- ModDeps -> [ModuleName]
extrads ModDeps
dep]
arrowAttr :: String -> String
arrowAttr String
s = case String
s of
String
"of" -> String
"style = \"solid\", arrowhead = \"empty\""
String
"ex" -> String
"style = \"solid\""
String
"op" -> String
"style = \"dashed\""
String
"ed" -> String
"style = \"dotted\""
data ModDeps = ModDeps {
ModDeps -> ModuleType
modtype :: ModuleType,
ModDeps -> [ModuleName]
ofs :: [ModuleName],
ModDeps -> [ModuleName]
extendeds :: [ModuleName],
ModDeps -> [ModuleName]
openeds :: [ModuleName],
:: [ModuleName],
ModDeps -> [ModuleName]
functors :: [ModuleName],
ModDeps -> [ModuleName]
interfaces :: [ModuleName],
ModDeps -> [ModuleName]
instances :: [ModuleName]
}
noModDeps :: ModDeps
noModDeps = ModuleType
-> [ModuleName]
-> [ModuleName]
-> [ModuleName]
-> [ModuleName]
-> [ModuleName]
-> [ModuleName]
-> [ModuleName]
-> ModDeps
ModDeps ModuleType
MTAbstract [] [] [] [] [] [] []
grammar2moddeps :: Maybe [String] -> Grammar -> [(ModuleName,ModDeps)]
grammar2moddeps :: Maybe [String] -> Grammar -> [(ModuleName, ModDeps)]
grammar2moddeps Maybe [String]
monly Grammar
gr = [(ModuleName
i,ModuleName -> ModuleInfo -> ModDeps
forall p. p -> ModuleInfo -> ModDeps
depMod ModuleName
i ModuleInfo
m) | (ModuleName
i,ModuleInfo
m) <- Grammar -> [(ModuleName, ModuleInfo)]
modules Grammar
gr, ModuleName -> Bool
forall a. Pretty a => a -> Bool
yes ModuleName
i]
where
depMod :: p -> ModuleInfo -> ModDeps
depMod p
i ModuleInfo
m =
ModDeps
noModDeps{
modtype :: ModuleType
modtype = ModuleInfo -> ModuleType
mtype ModuleInfo
m,
ofs :: [ModuleName]
ofs = case ModuleInfo -> ModuleType
mtype ModuleInfo
m of
MTConcrete ModuleName
i -> [ModuleName
i | ModuleName -> Bool
forall a. Pretty a => a -> Bool
yes ModuleName
i]
MTInstance (ModuleName
i,MInclude
_) -> [ModuleName
i | ModuleName -> Bool
forall a. Pretty a => a -> Bool
yes ModuleName
i]
ModuleType
_ -> [],
extendeds :: [ModuleName]
extendeds = [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
nub ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ (ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter ModuleName -> Bool
forall a. Pretty a => a -> Bool
yes ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ((ModuleName, MInclude) -> ModuleName)
-> [(ModuleName, MInclude)] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, MInclude) -> ModuleName
forall a b. (a, b) -> a
fst (ModuleInfo -> [(ModuleName, MInclude)]
mextend ModuleInfo
m),
openeds :: [ModuleName]
openeds = [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
nub ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ (ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter ModuleName -> Bool
forall a. Pretty a => a -> Bool
yes ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ (OpenSpec -> ModuleName) -> [OpenSpec] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map OpenSpec -> ModuleName
openedModule (ModuleInfo -> [OpenSpec]
mopens ModuleInfo
m),
extrads :: [ModuleName]
extrads = [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
nub ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ (ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter ModuleName -> Bool
forall a. Pretty a => a -> Bool
yes ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ModuleInfo -> [ModuleName]
mexdeps ModuleInfo
m
}
yes :: a -> Bool
yes a
i = case Maybe [String]
monly of
Just [String]
only -> String -> [String] -> Bool
forall (t :: * -> *). Foldable t => String -> t String -> Bool
match (a -> String
forall a. Pretty a => a -> String
render a
i) [String]
only
Maybe [String]
_ -> Bool
True
match :: String -> t String -> Bool
match String
s t String
os = (String -> Bool) -> t String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\String
x -> String -> String -> Bool
doMatch String
x String
s) t String
os
doMatch :: String -> String -> Bool
doMatch String
x String
s = case String -> Char
forall a. [a] -> a
last String
x of
Char
'*' -> String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String -> String
forall a. [a] -> [a]
init String
x) String
s
Char
_ -> String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s