-- To generalize the use of dot printers in generating graphs
module Drasil.Meta.Analysis.DataPrinters.Dot (digraph, subgraph,
  makeEdgesDi, makeEdgesSub, makeNodesDi, makeNodesSub, replaceInvalidChars) where

import System.IO

-- type synonyms for clarity.
type Name = String
type Nodes = (Colour, [String])
type Edges = (String, [String])

-- Make a simple directional graph.
-- Takes in a file handle, name of directional graph, nodes and edges.
digraph :: Handle -> Name -> [Nodes] -> [Edges] -> IO ()
digraph :: Handle -> Name -> [Nodes] -> [Nodes] -> IO ()
digraph Handle
handle Name
nm [Nodes]
nds [Nodes]
edgs = do
    Handle -> Name -> IO ()
hPutStrLn Handle
handle (Name -> IO ()) -> Name -> IO ()
forall a b. (a -> b) -> a -> b
$ Name
"digraph " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name -> Name
replaceInvalidChars Name
nm Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"{"
    (Name -> IO ()) -> [Name] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Name -> IO ()
hPutStrLn Handle
handle) ([Name] -> IO ()) -> [Name] -> IO ()
forall a b. (a -> b) -> a -> b
$ (Nodes -> [Name]) -> [Nodes] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Nodes
ns -> (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Name -> Name
makeNodesDi (Name -> Name -> Name) -> Name -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Nodes -> Name
forall a b. (a, b) -> a
fst Nodes
ns) ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Nodes -> [Name]
forall a b. (a, b) -> b
snd Nodes
ns) [Nodes]
nds
    (Name -> IO ()) -> [Name] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Name -> IO ()
hPutStrLn Handle
handle) ([Name] -> IO ()) -> [Name] -> IO ()
forall a b. (a -> b) -> a -> b
$ (Nodes -> [Name]) -> [Nodes] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Name -> [Name] -> [Name]) -> Nodes -> [Name]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> [Name] -> [Name]
makeEdgesDi) [Nodes]
edgs
    Handle -> Name -> IO ()
hPutStrLn Handle
handle Name
"}"
    Handle -> IO ()
hClose Handle
handle

-- Similar to digraph, but makes a subgraph and indents each line to look nicer.
-- Does not close the handle when done.
subgraph :: Handle -> Name -> [Nodes] -> [Edges] -> IO ()
subgraph :: Handle -> Name -> [Nodes] -> [Nodes] -> IO ()
subgraph Handle
handle Name
nm [Nodes]
nds [Nodes]
edgs = do
    Handle -> Name -> IO ()
hPutStrLn Handle
handle (Name -> IO ()) -> Name -> IO ()
forall a b. (a -> b) -> a -> b
$ Name
"\t\tsubgraph " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name -> Name
replaceInvalidChars Name
nm Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"{"
    (Name -> IO ()) -> [Name] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Name -> IO ()
hPutStrLn Handle
handle) ([Name] -> IO ()) -> [Name] -> IO ()
forall a b. (a -> b) -> a -> b
$ (Nodes -> [Name]) -> [Nodes] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Nodes
ns -> (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Name -> Name
makeNodesSub (Name -> Name -> Name) -> Name -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Nodes -> Name
forall a b. (a, b) -> a
fst Nodes
ns) ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Nodes -> [Name]
forall a b. (a, b) -> b
snd Nodes
ns) [Nodes]
nds
    (Name -> IO ()) -> [Name] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Name -> IO ()
hPutStrLn Handle
handle) ([Name] -> IO ()) -> [Name] -> IO ()
forall a b. (a -> b) -> a -> b
$ (Nodes -> [Name]) -> [Nodes] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Name -> [Name] -> [Name]) -> Nodes -> [Name]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> [Name] -> [Name]
makeEdgesSub) [Nodes]
edgs
    Handle -> Name -> IO ()
hPutStrLn Handle
handle Name
"\t\t}"

------------------
-- Graph-related functions
------------------
type Colour = String

-- Creates an edge between a type and its dependency
makeEdgesDi :: String -> [String] -> [String]
makeEdgesDi :: Name -> [Name] -> [Name]
makeEdgesDi Name
nm = (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
c -> Name -> Name
replaceInvalidChars Name
nm Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" -> " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name -> Name
replaceInvalidChars Name
c Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
";")

-- Creates an edge between a type and its dependency (indented for subgraphs)
makeEdgesSub :: String -> [String] -> [String]
makeEdgesSub :: Name -> [Name] -> [Name]
makeEdgesSub Name
nm = (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
c -> Name
"\t\t" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name -> Name
replaceInvalidChars Name
nm Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" -> " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name -> Name
replaceInvalidChars Name
c Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
";")

-- Creates a node based on the kind of datatype
makeNodesDi :: Colour -> String -> String
makeNodesDi :: Name -> Name -> Name
makeNodesDi Name
c Name
nm = Name -> Name
replaceInvalidChars Name
nm Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"\t[shape=oval, color=" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
c Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
", label=\"" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
nm Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"\"];"

-- Creates a node based on the kind of datatype (indented for subgraphs)
makeNodesSub :: Colour -> String -> String
makeNodesSub :: Name -> Name -> Name
makeNodesSub Name
c Name
nm = Name
"\t\t" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name -> Name
replaceInvalidChars Name
nm Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"\t[shape=oval, color=" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
c Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
", label=\"" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
nm Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"\"];"

-- Filter out invalid characters and replace them with an underscore.
replaceInvalidChars :: String -> String
replaceInvalidChars :: Name -> Name
replaceInvalidChars = (Char -> Char) -> Name -> Name
forall a b. (a -> b) -> [a] -> [b]
map (\Char
x -> if Char
x Char -> Name -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Name
invalidChars then Char
'_' else Char
x)
  where
    invalidChars :: Name
invalidChars = Name
"[]!} (){->,$'"