-- |
--  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,) (Value -> (Value, Value)) -> [Value] -> [(Value, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
ins) [(Value, Value)] -> [(Value, Value)] -> [(Value, Value)]
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
(Dot -> Dot -> Bool) -> (Dot -> Dot -> Bool) -> Eq Dot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Dot -> Dot -> Bool
== :: Dot -> Dot -> Bool
$c/= :: Dot -> Dot -> Bool
/= :: Dot -> Dot -> Bool
Eq, Int -> Dot -> ShowS
[Dot] -> ShowS
Dot -> String
(Int -> Dot -> ShowS)
-> (Dot -> String) -> ([Dot] -> ShowS) -> Show Dot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dot -> ShowS
showsPrec :: Int -> Dot -> ShowS
$cshow :: Dot -> String
show :: Dot -> String
$cshowList :: [Dot] -> ShowS
showList :: [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 [(Value, Value)] -> ((Value, Value) -> [Value]) -> [Value]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(Value
v1, Value
v2) -> [Value
v1, Value
v2])
      valueTypes :: ValuesByType
valueTypes = State ValuesByType [()] -> ValuesByType -> ValuesByType
forall s a. State s a -> s -> s
execState ((Value -> StateT ValuesByType Identity ())
-> [Value] -> State ValuesByType [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Value -> StateT ValuesByType Identity ()
countValueTypes [Value]
allValues) ValuesByType
forall a. Monoid a => a
mempty
   in Text -> Dot
Dot (Text -> Dot) -> Text -> Dot
forall a b. (a -> b) -> a -> b
$
        [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
          [ Text
"strict digraph {",
            Text
"  node [shape=record]"
          ]
            [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (ValuesByType -> (Value, Value) -> Text
toDotEdge ValuesByType
valueTypes ((Value, Value) -> Text) -> [(Value, Value)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Value, Value)]
edges)
            [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"}"]

-- | Update a map classifying values by type
countValueTypes :: Value -> DotState ()
countValueTypes :: Value -> StateT ValuesByType Identity ()
countValueTypes Value
value = do
  ValuesByType
maps <- StateT ValuesByType Identity ValuesByType
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 SomeTypeRep -> ValuesByType -> Maybe [Int]
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 -> ValuesByType -> StateT ValuesByType Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ValuesByType -> StateT ValuesByType Identity ())
-> ValuesByType -> StateT ValuesByType Identity ()
forall a b. (a -> b) -> a -> b
$ SomeTypeRep -> [Int] -> ValuesByType -> ValuesByType
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 Int -> [Int] -> Maybe Int
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 [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> [Int
valueHash]
          ValuesByType -> StateT ValuesByType Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ValuesByType -> StateT ValuesByType Identity ())
-> ValuesByType -> StateT ValuesByType Identity ()
forall a b. (a -> b) -> a -> b
$ SomeTypeRep -> [Int] -> ValuesByType -> ValuesByType
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
_ -> () -> StateT ValuesByType Identity ()
forall a. a -> StateT ValuesByType Identity a
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v2 Text -> Text -> Text
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 SomeTypeRep -> ValuesByType -> Maybe [Int]
forall k a. Ord k => k -> Map k a -> Maybe a
lookup SomeTypeRep
key ValuesByType
valuesByType of
          Maybe [Int]
Nothing -> Maybe Int
forall a. Maybe a
Nothing -- this case should not happen given how the map is built
          Just [Int]
hashes ->
            case [Int]
hashes of
              [Int
_] -> Maybe Int
forall a. Maybe a
Nothing
              [Int]
_ -> (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Int] -> Maybe Int
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 =
  ([Value], ValueDescription) -> Int
forall a. Hashable a => a -> Int
hash
    (Dependencies -> [Value]
unDependencies (Dependencies -> [Value])
-> (Value -> Dependencies) -> Value -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Dependencies
valueDependencies (Value -> [Value]) -> Value -> [Value]
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 Text -> Text -> Text
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 Maybe Text
forall a. Maybe a
Nothing) Maybe Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
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
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
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
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
escapeNewlines (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
removeQuotes) Text
node Text -> Text -> Text
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 = HasCallStack => Text -> Text -> Text -> Text
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 = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\n" Text
"\\n"