module Data.Registry.Internal.Dot where
import Data.Hashable
import Data.List (elemIndex)
import Data.Map.Strict hiding (adjust)
import Data.Registry.Internal.Statistics
import Data.Registry.Internal.Types
import Data.Text as T
import Protolude as P
import Type.Reflection
makeEdges :: Operations -> [(Value, Value)]
makeEdges [] = []
makeEdges (AppliedFunction out ins : rest) = ((out,) <$> ins) <> makeEdges rest
newtype Dot = Dot {
unDot :: Text
} deriving (Eq, Show)
type DotState = State ValuesByType
type ValuesByType = Map SomeTypeRep ValueHashes
type Hash = Int
type ValueId = Int
type ValueHashes = [Hash]
type Edge = (Value, Value)
type Edges = [Edge]
type ValueCounter = Maybe Int
toDot :: Operations -> Dot
toDot op =
let edges = makeEdges op
allValues = join $ (\(v1, v2) -> [v1, v2]) <$> edges
valueTypes = execState (traverse countValueTypes allValues) mempty
in Dot $
T.unlines $
[ "strict digraph {"
, " node [shape=record]"
]
<> (toDotEdge valueTypes <$> edges)
<> ["}"]
countValueTypes :: Value -> DotState ()
countValueTypes value = do
maps <- get
let key = valueDynTypeRep value
let valueHash = hashOf value
case lookup key maps of
Nothing -> put $ insert key [valueHash] maps
Just hashes ->
case elemIndex valueHash hashes of
Nothing -> do
let newHashes = hashes <> [valueHash]
put $ insert key newHashes maps
Just _ -> pure ()
toDotEdge :: ValuesByType -> (Value, Value) -> Text
toDotEdge valuesByType (value1, value2) =
let v1 = toDotVertex valuesByType value1
v2 = toDotVertex valuesByType value2
in v1 <> " -> " <> v2 <> ";"
toDotVertex :: ValuesByType -> Value -> Text
toDotVertex valuesByType value =
let key = valueDynTypeRep value
valueHash = hashOf value
valueCounter =
case lookup key valuesByType of
Nothing -> Nothing
Just hashes ->
if P.length hashes == 1 then Nothing
else (+1) <$> elemIndex valueHash hashes
in adjust (nodeDescription (valDescription value) valueCounter)
hashOf :: Value -> Int
hashOf value = hash
(unDependencies . valDependencies $ value, valDescription value)
nodeDescription :: ValueDescription -> ValueCounter -> Text
nodeDescription (ValueDescription t Nothing) n =
t <> showValueCounter n
nodeDescription (ValueDescription t (Just v)) n =
nodeDescription (ValueDescription t Nothing) n <> "\n" <> v
showValueCounter :: ValueCounter -> Text
showValueCounter Nothing = ""
showValueCounter (Just n) = "-" <> show n
adjust :: Text -> Text
adjust node = "\"" <> (escapeNewlines . removeQuotes) node <> "\""
removeQuotes :: Text -> Text
removeQuotes = T.replace "\"" ""
escapeNewlines :: Text -> Text
escapeNewlines = T.replace "\n" "\\n"