module GF.Infra.Dependencies (
  depGraph
  ) where

import GF.Grammar.Grammar
--import GF.Infra.Ident(Ident)
import GF.Text.Pretty(render)

import Data.List (nub,isPrefixOf)

-- the list gives the only modules to show, e.g. to hide the library details
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],
  ModDeps -> [ModuleName]
extrads    :: [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