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 :: Operations -> [(Value, Value)]
makeEdges [] = []
makeEdges (AppliedFunction Value
out [Value]
ins : Operations
rest) = ((Value
out,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
ins) forall a. Semigroup a => a -> a -> a
<> Operations -> [(Value, Value)]
makeEdges Operations
rest
newtype Dot = Dot
{ Dot -> Text
unDot :: Text
}
deriving (Dot -> Dot -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Dot -> Dot -> Bool
$c/= :: Dot -> Dot -> Bool
== :: Dot -> Dot -> Bool
$c== :: Dot -> Dot -> Bool
Eq, Int -> Dot -> ShowS
[Dot] -> ShowS
Dot -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dot] -> ShowS
$cshowList :: [Dot] -> ShowS
show :: Dot -> String
$cshow :: Dot -> String
showsPrec :: Int -> Dot -> ShowS
$cshowsPrec :: Int -> Dot -> ShowS
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 :: Operations -> Dot
toDot Operations
op =
let edges :: [(Value, Value)]
edges = Operations -> [(Value, Value)]
makeEdges Operations
op
allValues :: [Value]
allValues = [(Value, Value)]
edges forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(Value
v1, Value
v2) -> [Value
v1, Value
v2])
valueTypes :: ValuesByType
valueTypes = forall s a. State s a -> s -> s
execState (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> DotState ()
countValueTypes [Value]
allValues) forall a. Monoid a => a
mempty
in Text -> Dot
Dot forall a b. (a -> b) -> a -> b
$
[Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
[ Text
"strict digraph {",
Text
" node [shape=record]"
]
forall a. Semigroup a => a -> a -> a
<> (ValuesByType -> (Value, Value) -> Text
toDotEdge ValuesByType
valueTypes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Value, Value)]
edges)
forall a. Semigroup a => a -> a -> a
<> [Text
"}"]
countValueTypes :: Value -> DotState ()
countValueTypes :: Value -> DotState ()
countValueTypes Value
value = do
ValuesByType
maps <- forall s (m :: * -> *). MonadState s m => m s
get
let key :: SomeTypeRep
key = Value -> SomeTypeRep
valueDynTypeRep Value
value
let valueHash :: Int
valueHash = Value -> Int
hashOf Value
value
case forall k a. Ord k => k -> Map k a -> Maybe a
lookup SomeTypeRep
key ValuesByType
maps of
Maybe [Int]
Nothing -> forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
insert SomeTypeRep
key [Int
valueHash] ValuesByType
maps
Just [Int]
hashes ->
case forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Int
valueHash [Int]
hashes of
Maybe Int
Nothing -> do
let newHashes :: [Int]
newHashes = [Int]
hashes forall a. Semigroup a => a -> a -> a
<> [Int
valueHash]
forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
insert SomeTypeRep
key [Int]
newHashes ValuesByType
maps
Just Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
toDotEdge :: ValuesByType -> (Value, Value) -> Text
toDotEdge :: ValuesByType -> (Value, Value) -> Text
toDotEdge ValuesByType
valuesByType (Value
value1, Value
value2) =
let v1 :: Text
v1 = ValuesByType -> Value -> Text
toDotVertex ValuesByType
valuesByType Value
value1
v2 :: Text
v2 = ValuesByType -> Value -> Text
toDotVertex ValuesByType
valuesByType Value
value2
in Text
v1 forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> Text
v2 forall a. Semigroup a => a -> a -> a
<> Text
";"
toDotVertex :: ValuesByType -> Value -> Text
toDotVertex :: ValuesByType -> Value -> Text
toDotVertex ValuesByType
valuesByType Value
value =
let key :: SomeTypeRep
key = Value -> SomeTypeRep
valueDynTypeRep Value
value
valueHash :: Int
valueHash = Value -> Int
hashOf Value
value
valueCounter :: Maybe Int
valueCounter =
case forall k a. Ord k => k -> Map k a -> Maybe a
lookup SomeTypeRep
key ValuesByType
valuesByType of
Maybe [Int]
Nothing -> forall a. Maybe a
Nothing
Just [Int]
hashes ->
case [Int]
hashes of
[Int
_] -> forall a. Maybe a
Nothing
[Int]
_ -> (forall a. Num a => a -> a -> a
+ Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Int
valueHash [Int]
hashes
in Text -> Text
adjust (ValueDescription -> Maybe Int -> Text
nodeDescription (Value -> ValueDescription
valDescription Value
value) Maybe Int
valueCounter)
hashOf :: Value -> Int
hashOf :: Value -> Int
hashOf Value
value =
forall a. Hashable a => a -> Int
hash
(Dependencies -> [Value]
unDependencies forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Dependencies
valueDependencies forall a b. (a -> b) -> a -> b
$ Value
value, Value -> ValueDescription
valDescription Value
value)
nodeDescription :: ValueDescription -> ValueCounter -> Text
nodeDescription :: ValueDescription -> Maybe Int -> Text
nodeDescription (ValueDescription Text
t Maybe Text
Nothing) Maybe Int
n =
Text
t forall a. Semigroup a => a -> a -> a
<> Maybe Int -> Text
showValueCounter Maybe Int
n
nodeDescription (ValueDescription Text
t (Just Text
v)) Maybe Int
n =
ValueDescription -> Maybe Int -> Text
nodeDescription (Text -> Maybe Text -> ValueDescription
ValueDescription Text
t forall a. Maybe a
Nothing) Maybe Int
n forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
v
showValueCounter :: ValueCounter -> Text
showValueCounter :: Maybe Int -> Text
showValueCounter Maybe Int
Nothing = Text
""
showValueCounter (Just Int
n) = Text
"-" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
n
adjust :: Text -> Text
adjust :: Text -> Text
adjust Text
node = Text
"\"" forall a. Semigroup a => a -> a -> a
<> (Text -> Text
escapeNewlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
removeQuotes) Text
node forall a. Semigroup a => a -> a -> a
<> Text
"\""
removeQuotes :: Text -> Text
removeQuotes :: Text -> Text
removeQuotes = Text -> Text -> Text -> Text
T.replace Text
"\"" Text
""
escapeNewlines :: Text -> Text
escapeNewlines :: Text -> Text
escapeNewlines = Text -> Text -> Text -> Text
T.replace Text
"\n" Text
"\\n"