0 | module DepGraph.Data
  1 |
  2 | import Data.String
  3 |
  4 | %default total
  5 |
  6 | dquote : String -> String
  7 | dquote str = "\"" ++ str ++ "\""
  8 |
  9 | joinSemicolon : List String -> String
 10 | joinSemicolon = joinBy "; "
 11 |
 12 | --------------------------------------------------------------------------------
 13 | -- Modules dependency graph
 14 | --------------------------------------------------------------------------------
 15 |
 16 | public export
 17 | record Module where
 18 |   constructor MkModule
 19 |   name : String
 20 |   deps : List String
 21 |
 22 | public export
 23 | record PkgModules where
 24 |   constructor MkPkgModules
 25 |   name : String
 26 |   modules : List Module
 27 |
 28 | public export
 29 | PkgsModules : Type
 30 | PkgsModules = List PkgModules
 31 |
 32 | export
 33 | Show PkgsModules where
 34 |   show pkgs = "digraph { splines=\"ortho\";" ++ subgraphs ++ edges ++ "}"
 35 |     where
 36 |       depEdge : String -> String -> String
 37 |       depEdge srcName destName = dquote srcName ++ " -> " ++ dquote destName
 38 |
 39 |       moduleEdge : Module -> String
 40 |       moduleEdge mod = joinSemicolon $ depEdge mod.name <$> mod.deps
 41 |
 42 |       pkgEdge : PkgModules -> String
 43 |       pkgEdge pkg = concat $ moduleEdge <$> pkg.modules
 44 |
 45 |       moduleNode : Module -> String
 46 |       moduleNode mod = dquote mod.name ++ "[style=\"filled\", fillcolor=white]"
 47 |
 48 |       pkgSubgraph : PkgModules -> String
 49 |       pkgSubgraph pkg =
 50 |         -- prefix the name with "cluster" to group its nodes in a labelled box
 51 |         "subgraph " ++ (dquote $ "cluster_" ++ pkg.name)
 52 |         ++ "{"
 53 |         ++ "style=\"filled\"; fillcolor = \"linen\";"
 54 |         ++ "label=" ++ dquote pkg.name ++ ";"
 55 |         ++ (joinSemicolon $ moduleNode <$> pkg.modules)
 56 |         ++ "}"
 57 |
 58 |       subgraphs, edges : String
 59 |       subgraphs = concat $ pkgSubgraph <$> pkgs
 60 |       edges = concat $ pkgEdge <$> pkgs
 61 |
 62 | --------------------------------------------------------------------------------
 63 | -- Packages dependency graph
 64 | --------------------------------------------------------------------------------
 65 |
 66 | public export
 67 | record Package where
 68 |   constructor MkPackage
 69 |   name : String
 70 |   deps : List String
 71 |   isLocal : Bool
 72 |
 73 | public export
 74 | Packages : Type
 75 | Packages = List Package
 76 |
 77 | export
 78 | Show Packages where
 79 |   show pkgs = "digraph {" ++ inner ++ "}"
 80 |     where
 81 |       depEdge : String -> String -> String
 82 |       depEdge srcName destName = dquote srcName ++ " -> " ++ dquote destName
 83 |
 84 |       pkgEdge : Package -> List String
 85 |       pkgEdge pkg = depEdge pkg.name <$> pkg.deps
 86 |
 87 |       pkgNode : Package -> String
 88 |       pkgNode pkg =
 89 |         (dquote pkg.name)
 90 |         ++ "["
 91 |         ++ (if pkg.isLocal
 92 |              then "style=\"filled\"; fillcolor =\"linen\";"
 93 |              else "")
 94 |         ++ "]"
 95 |
 96 |       edges = concat $ pkgEdge <$> pkgs
 97 |       nodes = pkgNode <$> pkgs
 98 |       inner = joinSemicolon (nodes ++ edges)
 99 |
100 |