-- |
--  Nested datatype to track the resolution algorithm
--
--  From this data type we can draw a graph of the full
--  instantiation of a value
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

-- | Make a list of graph edges from the list of function applications
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

-- * DOT GRAPH

-- | A DOT graph
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)

-- | Use a State type to get the current index of a value
-- when there are values of the same type and different
-- hash values
type DotState = State ValuesByType

-- | List of value hashes by value type
type ValuesByType = Map SomeTypeRep ValueHashes

-- | Type alias for a Hash
type Hash = Int

-- | Type alias for a ValueId
type ValueId = Int

-- | Type alias for a list of hashes
type ValueHashes = [Hash]

-- | Type alias for a list of an edge in the graph
type Edge = (Value, Value)

-- | Type alias for a list of edges
type Edges = [Edge]

-- | Type alias for associating a number to a value
type ValueCounter = Maybe Int

-- | Make a DOT graph out of all the function applications
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
"}"]

-- | Update a map classifying values by type
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
    -- there were no values for that type, create a list with the value hash
    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
    -- there is a list of hashes for that type
    Just [Int]
hashes ->
      case forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Int
valueHash [Int]
hashes of
        -- that value hasn't been seen before
        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

        -- the value has been seen before
        Just Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | A DOT edge representing the dependency between 2 values
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
";"

-- | Represent a value as a vertex in a dot graph
--   we use some state to keep track of values of the
--   same type
--   The values are numbered starting from 1 when there are
--   several of them for the same type
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 -- this case should not happen given how the map is built
          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)

-- | Return the hash of a value based on its dependencies
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)

-- | Description of a Value in the DOT graph
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

-- | Don't show the counter if there
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

-- | We need to process the node descriptions
--     - we add quotes arountd the text
--     - we remove quotes (") inside the text
--     - we escape newlines
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
"\""

-- | Remove quotes from a textual description to avoid breaking the DOT format
removeQuotes :: Text -> Text
removeQuotes :: Text -> Text
removeQuotes = Text -> Text -> Text -> Text
T.replace Text
"\"" Text
""

-- | Replace \n with \\n so that newlines are kept in
--   node descriptions
escapeNewlines :: Text -> Text
escapeNewlines :: Text -> Text
escapeNewlines = Text -> Text -> Text -> Text
T.replace Text
"\n" Text
"\\n"