module Drasil.Generator.SRS.TraceabilityGraphs (outputDot) where

import Prelude hiding ((<>))

import System.Directory (setCurrentDirectory)
import Text.PrettyPrint.HughesPJ (Doc, render, text, (<>), (<+>), vcat, nest,
  hsep, empty)

import Drasil.Build.Artifacts (createDirIfMissing)
import Drasil.Database (UID)
import Drasil.Metadata.TraceabilityGraphs (GraphInfo(..), NodeFamily(..),
  Label)

-- | Creates the directory for output, gathers all individual graph output
-- functions and calls them.
outputDot :: FilePath -> GraphInfo -> IO ()
outputDot :: FilePath -> GraphInfo -> IO ()
outputDot FilePath
outputFilePath GraphInfo
gi = do
  Bool -> FilePath -> IO ()
createDirIfMissing Bool
False FilePath
outputFilePath
  FilePath -> IO ()
setCurrentDirectory FilePath
outputFilePath
  GraphInfo
-> FilePath
-> (GraphInfo -> [(UID, [UID])])
-> [GraphInfo -> NodeFamily]
-> IO ()
mkOutput GraphInfo
gi FilePath
"avsa" GraphInfo -> [(UID, [UID])]
edgesAvsA [GraphInfo -> NodeFamily
assumpNF]
  GraphInfo
-> FilePath
-> (GraphInfo -> [(UID, [UID])])
-> [GraphInfo -> NodeFamily]
-> IO ()
mkOutput GraphInfo
gi FilePath
"avsall" GraphInfo -> [(UID, [UID])]
edgesAvsAll [GraphInfo -> NodeFamily
assumpNF, GraphInfo -> NodeFamily
ddNF, GraphInfo -> NodeFamily
tmNF, GraphInfo -> NodeFamily
gdNF, GraphInfo -> NodeFamily
imNF, GraphInfo -> NodeFamily
reqNF, GraphInfo -> NodeFamily
chgNF]
  GraphInfo
-> FilePath
-> (GraphInfo -> [(UID, [UID])])
-> [GraphInfo -> NodeFamily]
-> IO ()
mkOutput GraphInfo
gi FilePath
"refvsref" GraphInfo -> [(UID, [UID])]
edgesRefvsRef [GraphInfo -> NodeFamily
ddNF, GraphInfo -> NodeFamily
tmNF, GraphInfo -> NodeFamily
gdNF, GraphInfo -> NodeFamily
imNF]
  GraphInfo
-> FilePath
-> (GraphInfo -> [(UID, [UID])])
-> [GraphInfo -> NodeFamily]
-> IO ()
mkOutput GraphInfo
gi FilePath
"allvsr" GraphInfo -> [(UID, [UID])]
edgesAllvsR [GraphInfo -> NodeFamily
assumpNF, GraphInfo -> NodeFamily
ddNF, GraphInfo -> NodeFamily
tmNF, GraphInfo -> NodeFamily
gdNF, GraphInfo -> NodeFamily
imNF, GraphInfo -> NodeFamily
reqNF, GraphInfo -> NodeFamily
gsNF]
  GraphInfo
-> FilePath
-> (GraphInfo -> [(UID, [UID])])
-> [GraphInfo -> NodeFamily]
-> IO ()
mkOutput GraphInfo
gi FilePath
"allvsall" GraphInfo -> [(UID, [UID])]
edgesAllvsAll [GraphInfo -> NodeFamily
assumpNF, GraphInfo -> NodeFamily
ddNF, GraphInfo -> NodeFamily
tmNF, GraphInfo -> NodeFamily
gdNF, GraphInfo -> NodeFamily
imNF, GraphInfo -> NodeFamily
reqNF, GraphInfo -> NodeFamily
gsNF, GraphInfo -> NodeFamily
chgNF]

-- | General output function for making a traceability graph. Takes in the graph information, title, edge generator functions, and node family functions.
mkOutput :: GraphInfo -> String -> (GraphInfo -> [(UID, [UID])]) -> [GraphInfo -> NodeFamily] -> IO ()
mkOutput :: GraphInfo
-> FilePath
-> (GraphInfo -> [(UID, [UID])])
-> [GraphInfo -> NodeFamily]
-> IO ()
mkOutput GraphInfo
gi FilePath
ttl GraphInfo -> [(UID, [UID])]
getDirections [GraphInfo -> NodeFamily]
getLabels =
  FilePath -> FilePath -> IO ()
writeFile (FilePath
ttl FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".dot") (Doc -> FilePath
render (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> [(UID, [UID])] -> [NodeFamily] -> Doc
mkDot FilePath
ttl (GraphInfo -> [(UID, [UID])]
getDirections GraphInfo
gi) (((GraphInfo -> NodeFamily) -> NodeFamily)
-> [GraphInfo -> NodeFamily] -> [NodeFamily]
forall a b. (a -> b) -> [a] -> [b]
map ((GraphInfo -> NodeFamily) -> GraphInfo -> NodeFamily
forall a b. (a -> b) -> a -> b
$ GraphInfo
gi) [GraphInfo -> NodeFamily]
getLabels))

-- | Constructs the full DOT document.
mkDot :: String -> [(UID, [UID])] -> [NodeFamily] -> Doc
mkDot :: FilePath -> [(UID, [UID])] -> [NodeFamily] -> Doc
mkDot FilePath
title [(UID, [UID])]
edges [NodeFamily]
families =
  [Doc] -> Doc
vcat
    [ FilePath -> Doc
text FilePath
"digraph" Doc -> Doc -> Doc
<+> FilePath -> Doc
quote FilePath
title Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
"{",
      Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ([Doc] -> Doc) -> [[Doc]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Doc] -> Doc
vcat [((UID, [UID]) -> Doc) -> [(UID, [UID])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (UID, [UID]) -> Doc
mkDirections [(UID, [UID])]
edges, (NodeFamily -> Doc) -> [NodeFamily] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map NodeFamily -> Doc
mkNodes [NodeFamily]
families],
      FilePath -> Doc
text FilePath
"}"
    ]

mkDirections :: (UID, [UID]) -> Doc
mkDirections :: (UID, [UID]) -> Doc
mkDirections (UID
u, [UID]
deps) = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (UID -> Doc) -> [UID] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (UID -> UID -> Doc
forall {a} {a}. (Show a, Show a) => a -> a -> Doc
mkEdge UID
u) ((UID -> Bool) -> [UID] -> [UID]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (UID -> Bool) -> UID -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (FilePath -> Bool) -> (UID -> FilePath) -> UID -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UID -> FilePath
forall a. Show a => a -> FilePath
show) [UID]
deps)
  where
    mkEdge :: a -> a -> Doc
mkEdge a
src a
dest = FilePath -> Doc
quote (a -> FilePath
forall a. Show a => a -> FilePath
show a
src) Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
"->" Doc -> Doc -> Doc
<+> FilePath -> Doc
quote (a -> FilePath
forall a. Show a => a -> FilePath
show a
dest) Doc -> Doc -> Doc
<> FilePath -> Doc
text FilePath
";"

mkNodes :: NodeFamily -> Doc
mkNodes :: NodeFamily -> Doc
mkNodes NF {nodeUIDs :: NodeFamily -> [UID]
nodeUIDs = [UID]
u, nodeLabels :: NodeFamily -> [FilePath]
nodeLabels = [FilePath]
ls, nfLabel :: NodeFamily -> FilePath
nfLabel = FilePath
lbl, nfColour :: NodeFamily -> FilePath
nfColour = FilePath
col} =
  [Doc] -> Doc
vcat
    [ [Doc] -> Doc
vcat ((UID -> FilePath -> Doc) -> [UID] -> [FilePath] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (FilePath -> UID -> FilePath -> Doc
forall {a}. Show a => FilePath -> a -> FilePath -> Doc
mkNode FilePath
col) [UID]
u [FilePath]
ls),
      FilePath -> [UID] -> Doc
mkSubgraph FilePath
lbl [UID]
u
    ]
  where
    mkNode :: FilePath -> a -> FilePath -> Doc
mkNode FilePath
c a
n FilePath
l = FilePath -> Doc
quote (a -> FilePath
forall a. Show a => a -> FilePath
show a
n)
      Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
"[shape=box, color=black, style=filled, fillcolor="
      Doc -> Doc -> Doc
<> FilePath -> Doc
quote FilePath
c Doc -> Doc -> Doc
<> FilePath -> Doc
text FilePath
", label=" Doc -> Doc -> Doc
<> FilePath -> Doc
quote FilePath
l Doc -> Doc -> Doc
<> FilePath -> Doc
text FilePath
"];"

mkSubgraph :: Label -> [UID] -> Doc
mkSubgraph :: FilePath -> [UID] -> Doc
mkSubgraph FilePath
title [UID]
contents
  | FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
title Bool -> Bool -> Bool
|| [UID] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UID]
contents = Doc
empty
  | Bool
otherwise =
      [Doc] -> Doc
vcat
        [ FilePath -> Doc
text FilePath
"subgraph" Doc -> Doc -> Doc
<+> FilePath -> Doc
quote FilePath
title Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
"{",
          Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
            [ FilePath -> Doc
text FilePath
"rank=\"same\";",
              [Doc] -> Doc
hsep ((UID -> Doc) -> [UID] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Doc
quote (FilePath -> Doc) -> (UID -> FilePath) -> UID -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UID -> FilePath
forall a. Show a => a -> FilePath
show) [UID]
contents) Doc -> Doc -> Doc
<> FilePath -> Doc
text FilePath
";"
            ],
          FilePath -> Doc
text FilePath
"}"
        ]

quote :: String -> Doc
quote :: FilePath -> Doc
quote = FilePath -> Doc
text (FilePath -> Doc) -> (FilePath -> FilePath) -> FilePath -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
forall {t :: * -> *}. Foldable t => t Char -> FilePath
escape
  where
    escape :: t Char -> FilePath
escape t Char
s = FilePath
"\"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Char -> FilePath) -> t Char -> FilePath
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> FilePath
escChar t Char
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\""
    escChar :: Char -> FilePath
escChar Char
'"' = FilePath
"\\\""
    escChar Char
'\\' = FilePath
"\\\\"
    escChar Char
c = [Char
c]