summaryrefslogtreecommitdiff
path: root/src/compiler/GF/Infra/Dependencies.hs
blob: af20887114f5b3851562ab471b8a6c71c5f61de8 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
module GF.Infra.Dependencies (
  depGraph
  ) where

import GF.Grammar.Grammar
import GF.Infra.Modules
import GF.Infra.Ident

depGraph :: SourceGrammar -> String
depGraph = prDepGraph . grammar2moddeps

prDepGraph :: [(Ident,ModDeps)] -> String
prDepGraph deps = unlines $ [
  "digraph {"
  ] ++
  map mkNode deps ++
  concatMap mkArrows deps ++ [
  "}"
  ]
 where
   mkNode (i,dep) = unwords [showIdent i, "[",nodeAttr (modtype dep),"]"]
   nodeAttr ty = case ty of
       MTAbstract   -> "style = \"solid\", shape = \"box\""
       MTConcrete _ -> "style = \"solid\", shape = \"ellipse\""
       _ -> "style = \"dashed\", shape = \"ellipse\""
   mkArrows (i,dep) = 
     [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "of","]"] | j <- ofs dep] ++
     [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "ex","]"] | j <- extendeds dep] ++
     [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "op","]"] | j <- openeds dep] ++
     [unwords [showIdent i,"->",showIdent j,"[",arrowAttr "ed","]"] | j <- extrads dep]
   arrowAttr s = case s of
     "of" -> "style = \"solid\", arrowhead = \"empty\""
     "ex" -> "style = \"solid\""
     "op" -> "style = \"dashed\""
     "ed" -> "style = \"dotted\""

data ModDeps = ModDeps {
  modtype    :: ModuleType Ident,
  ofs        :: [Ident],
  extendeds  :: [Ident], 
  openeds    :: [Ident],
  extrads    :: [Ident],
  functors   :: [Ident],
  interfaces :: [Ident],
  instances  :: [Ident]
  }

noModDeps = ModDeps MTAbstract [] [] [] [] [] [] []

grammar2moddeps :: SourceGrammar -> [(Ident,ModDeps)]
grammar2moddeps gr = [(i,depMod m) | (i,m) <- modules gr] where
  depMod m = noModDeps{
    modtype = mtype m,
    ofs     = case mtype m of 
                MTConcrete i -> [i]
                MTInstance i -> [i]
                _ -> [],
    extendeds = map fst (extend m),
    openeds = map openedModule (opens m),
    extrads = mexdeps m
    }