{-# LANGUAGE QuasiQuotes #-}

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

import Prelude hiding ((<>))

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

import Drasil.Database (UID)
import Drasil.FileHandling (FileLayout, directory, file, ps)
import Drasil.Metadata.TraceabilityGraphs (GraphInfo(..), NodeFamily(..),
  Label)

-- | Creates a `FileLayout`s for the generated TraceyGraph directory.
outputDot :: GraphInfo -> FileLayout
outputDot :: GraphInfo -> FileLayout
outputDot GraphInfo
gi =
  PathSegment -> [FileLayout] -> FileLayout
forall (f :: * -> *).
Foldable f =>
PathSegment -> f FileLayout -> FileLayout
directory
  [ps|TraceyGraph|]
  [ GraphInfo
-> String
-> (GraphInfo -> [(UID, [UID])])
-> [GraphInfo -> NodeFamily]
-> FileLayout
mkOutput GraphInfo
gi String
"avsa" GraphInfo -> [(UID, [UID])]
edgesAvsA [GraphInfo -> NodeFamily
assumpNF],
    GraphInfo
-> String
-> (GraphInfo -> [(UID, [UID])])
-> [GraphInfo -> NodeFamily]
-> FileLayout
mkOutput GraphInfo
gi String
"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
-> String
-> (GraphInfo -> [(UID, [UID])])
-> [GraphInfo -> NodeFamily]
-> FileLayout
mkOutput GraphInfo
gi String
"refvsref" GraphInfo -> [(UID, [UID])]
edgesRefvsRef [GraphInfo -> NodeFamily
ddNF, GraphInfo -> NodeFamily
tmNF, GraphInfo -> NodeFamily
gdNF, GraphInfo -> NodeFamily
imNF],
    GraphInfo
-> String
-> (GraphInfo -> [(UID, [UID])])
-> [GraphInfo -> NodeFamily]
-> FileLayout
mkOutput GraphInfo
gi String
"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
-> String
-> (GraphInfo -> [(UID, [UID])])
-> [GraphInfo -> NodeFamily]
-> FileLayout
mkOutput GraphInfo
gi String
"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] -> FileLayout
mkOutput :: GraphInfo
-> String
-> (GraphInfo -> [(UID, [UID])])
-> [GraphInfo -> NodeFamily]
-> FileLayout
mkOutput GraphInfo
gi String
ttl GraphInfo -> [(UID, [UID])]
getDirections [GraphInfo -> NodeFamily]
getLabels =
  PathSegment -> Doc -> FileLayout
forall doc. Writeable doc => PathSegment -> doc -> FileLayout
file [ps|{ttl}.dot|] (String -> [(UID, [UID])] -> [NodeFamily] -> Doc
mkDot String
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 :: String -> [(UID, [UID])] -> [NodeFamily] -> Doc
mkDot String
title [(UID, [UID])]
edges [NodeFamily]
families =
  [Doc] -> Doc
vcat
    [ String -> Doc
text String
"digraph" Doc -> Doc -> Doc
<+> String -> Doc
quote String
title Doc -> Doc -> Doc
<+> String -> Doc
text String
"{",
      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],
      String -> Doc
text String
"}"
    ]

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
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (UID -> String) -> UID -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UID -> String
forall a. Show a => a -> String
show) [UID]
deps)
  where
    mkEdge :: a -> a -> Doc
mkEdge a
src a
dest = String -> Doc
quote (a -> String
forall a. Show a => a -> String
show a
src) Doc -> Doc -> Doc
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> String -> Doc
quote (a -> String
forall a. Show a => a -> String
show a
dest) Doc -> Doc -> Doc
<> String -> Doc
text String
";"

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

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

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