{- |
  Nested datatype to track the resolution algorithm

  From this data type we can draw a graph of the full
  instantation 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 []                               = []
makeEdges (AppliedFunction out ins : rest) = ((out,) <$> ins) <> makeEdges rest

-- * DOT GRAPH

-- | A DOT graph
newtype Dot = Dot {
  unDot :: Text
} deriving (Eq, 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
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

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

-- | Update a map classifying values by type
countValueTypes :: Value -> DotState ()
countValueTypes value = do
  maps <- get
  let key = valueDynTypeRep value
  let valueHash = hashOf value

  case lookup key maps of
    -- there were no values for that type, create a list with the value hash
    Nothing -> put $ insert key [valueHash] maps

    -- there is a list of hashes for that type
    Just hashes ->
      case elemIndex valueHash hashes of
        -- that value hasn't been seen before
        Nothing -> do
          let newHashes = hashes <> [valueHash]
          put $ insert key newHashes maps

        -- the value has been seen before
        Just _ -> pure ()

-- | A DOT edge representing the dependency between 2 values
toDotEdge :: ValuesByType -> (Value, Value) -> Text
toDotEdge valuesByType (value1, value2) =
  let v1 = toDotVertex valuesByType value1
      v2 = toDotVertex valuesByType value2
  in  v1 <> " -> "  <> v2 <> ";"

-- | 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 =
  let key = valueDynTypeRep value
      valueHash = hashOf value

      valueCounter =
        case lookup key valuesByType of
          Nothing -> Nothing -- this case should not happen given how the map is built
          Just hashes ->
            if P.length hashes == 1 then Nothing
            else (+1) <$> elemIndex valueHash hashes

  in adjust (nodeDescription (valDescription value) valueCounter)

-- | Return the hash of a value based on its dependencies
hashOf :: Value -> Int
hashOf value = hash
  (unDependencies . valDependencies $ value, valDescription value)

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

-- | Don't show the counter if there
showValueCounter :: ValueCounter -> Text
showValueCounter Nothing  = ""
showValueCounter (Just n) = "-" <> show 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 node = "\"" <> (escapeNewlines . removeQuotes) node <> "\""

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

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