{-|
Module      : Gargantext.Core.NodeStory.Types
Description : Node API generation
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX
-}

{-# LANGUAGE ConstraintKinds   #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE ViewPatterns      #-}

module Gargantext.Core.NodeStory.Types
  ( HasNodeStory
  , HasNodeStoryEnv
  , hasNodeStory
  , NodeStory(..)
  , NgramsState'
  , NgramsStatePatch'
  , NodeListStory
  , ArchiveList
  , NodeStoryEnv(..)
  , initNodeStory
  , nse_getter
  , nse_getter_multi
  , nse_saver
  , nse_archive_saver
  , hasNodeStoryImmediateSaver
  , hasNodeArchiveStoryImmediateSaver
  -- , nse_var
  , unNodeStory
  , Archive(..)
  , initArchive
  , archiveAdvance
  , unionArchives
  , a_history
  , a_state
  , a_version
  , combineState
  , ArchiveState
  , ArchiveStateSet
  , ArchiveStateList
  , allVisitedNgramsTerms

  -- * Errors
  , HasNodeStoryError(..)
  , NodeStoryError(..)
  , BuildForestError(..)
  , VisitedNode(..)
  , renderLoop
  )
where

import Codec.Serialise.Class ( Serialise )
import Control.Lens (Getter, Lens', Prism', prism')
import Data.Aeson hiding ((.=), decode)
import Data.Map.Strict qualified as Map
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Data.Set qualified as Set
import Database.PostgreSQL.Simple.FromField (FromField(fromField), fromJSONField)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Text.Ngrams qualified as Ngrams
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Admin.Types.Node ( NodeId(..) )
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Prelude hiding (to)
import Gargantext.Utils.Jobs.Error
import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
import qualified Data.Text as T


------------------------------------------------------------------------

{- | Node Story for each NodeType where the Key of the Map is NodeId
  TODO : generalize for any NodeType, let's start with NodeList which
  is implemented already
-}
newtype NodeStory s p = NodeStory { _unNodeStory :: Map NodeId (Archive s p) }
  deriving (Generic, Show, Eq)

instance (FromJSON s, FromJSON p) => FromJSON (NodeStory s p)
instance (ToJSON s, ToJSON p) => ToJSON (NodeStory s p)
instance (Serialise s, Serialise p) => Serialise (NodeStory s p)

data Archive s p = Archive
  { _a_version           :: !Version
  , _a_state             :: !s
  , _a_history           :: ![p]
    -- first patch in the list is the most recent
    -- We use `take` in `commitStatePatch`, that's why.

    -- History is immutable, we just insert things on top of existing
    -- list.

    -- We don't need to store the whole history in memory, this
    -- structure holds only recent history, the one that will be
    -- inserted to the DB.
  }
  deriving (Generic, Show, Eq)

instance (Serialise s, Serialise p) => Serialise (Archive s p)


type NodeListStory     = NodeStory NgramsState' NgramsStatePatch'

-- NOTE: 'type NgramsTableMap = Map NgramsTerm NgramsRepoElement'
type NgramsState'      = Map       Ngrams.NgramsType NgramsTableMap
type NgramsStatePatch' = PatchMap  Ngrams.NgramsType NgramsTablePatch
-- instance Serialise NgramsStatePatch'
instance FromField (Archive NgramsState' NgramsStatePatch')
  where
    fromField = fromJSONField
instance DefaultFromField SqlJsonb (Archive NgramsState' NgramsStatePatch')
  where
    defaultFromField = fromPGSFromField


-- | Combine `NgramsState'`. This is because the structure is (Map
-- NgramsType (Map ...)) and the default `(<>)` operator is
-- left-biased
-- (https://hackage.haskell.org/package/containers-0.6.6/docs/Data-Map-Internal.html#v:union)
combineState :: NgramsState' -> NgramsState' -> NgramsState'
combineState = Map.unionWith (<>)

-- This is not a typical Semigroup instance. The state is not
-- appended, instead it is replaced with the second entry. This is
-- because state changes with each version. We have to take into
-- account the removal of terms as well.
-- instance (Semigroup s, Semigroup p) => Semigroup (Archive s p) where
--   (<>) (Archive { _a_history = p }) (Archive { _a_version = v'
--                                              , _a_state = s'
--                                              , _a_history = p' }) =
--     Archive { _a_version = v'
--             , _a_state = s'
--             , _a_history = p' <> p }
-- instance (Monoid s, Semigroup p) => Monoid (Archive s p) where
--   mempty = Archive { _a_version = 0
--                    , _a_state = mempty
--                    , _a_history = [] }
instance (FromJSON s, FromJSON p) => FromJSON (Archive s p) where
  parseJSON = genericParseJSON $ unPrefix "_a_"
instance (ToJSON s, ToJSON p) => ToJSON (Archive s p) where
  toJSON     = genericToJSON     $ unPrefix "_a_"
  toEncoding = genericToEncoding $ unPrefix "_a_"

-- | This is the normal way to update archive state, bumping the
-- version and history. Resulting state is taken directly from new
-- archive, omitting old archive completely.
archiveAdvance :: (Semigroup s, Semigroup p) => Archive s p -> Archive s p -> Archive s p
archiveAdvance aOld aNew = aNew { _a_history = _a_history aNew <> _a_history aOld }

-- | This is to merge archive states.
unionArchives :: (Semigroup s, Semigroup p) => Archive s p -> Archive s p -> Archive s p
unionArchives aOld aNew = aNew { _a_state = _a_state aOld <> _a_state aNew
                               , _a_history = _a_history aNew <> _a_history aOld }


------------------------------------------------------------------------
initNodeStory :: (Monoid s, Semigroup p) => NodeId -> NodeStory s p
initNodeStory ni = NodeStory $ Map.singleton ni initArchive

initArchive :: (Monoid s, Semigroup p) => Archive s p
initArchive = Archive { _a_version = 0
                      , _a_state = mempty
                      , _a_history = [] }

----------------------------------------------------------------------
data NodeStoryPoly nid v ngtid ngid nre =
  NodeStoryDB { node_id             :: !nid
              , version             :: !v
              , ngrams_type_id      :: !ngtid
              , ngrams_id           :: !ngid
              , ngrams_repo_element :: !nre }
  deriving (Eq)

data NodeStoryArchivePoly nid a =
  NodeStoryArchiveDB { a_node_id :: !nid
                     , archive   :: !a }
  deriving (Eq)

$(makeAdaptorAndInstance "pNodeStory" ''NodeStoryPoly)
$(makeAdaptorAndInstance "pNodeArchiveStory" ''NodeStoryArchivePoly)

-- type NodeStoryWrite = NodeStoryPoly (Column SqlInt4) (Column SqlInt4) (Column SqlInt4) (Column SqlInt4) (Column SqlJsonb)
-- type NodeStoryRead = NodeStoryPoly (Column SqlInt4) (Column SqlInt4) (Column SqlInt4) (Column SqlInt4) (Column SqlJsonb)

-- type NodeStoryArchiveWrite = NodeStoryArchivePoly (Column SqlInt4) (Column SqlJsonb)
-- type NodeStoryArchiveRead = NodeStoryArchivePoly (Column SqlInt4) (Column SqlJsonb)

type ArchiveList = Archive NgramsState' NgramsStatePatch'

-- | Errors returned by 'buildForest'.
data BuildForestError
  = -- We found a loop, something that shouldn't normally happen if the calling
    -- code is correct by construction, but if that does happen, the value will
    -- contain the full path to the cycle.
      BFE_loop_detected !(Set VisitedNode)
  deriving (Show, Eq)

instance ToHumanFriendlyError BuildForestError where
  mkHumanFriendly (BFE_loop_detected visited)
    = "Loop detected in terms: " <> renderLoop visited

renderLoop :: Set VisitedNode -> T.Text
renderLoop (sortBy (comparing _vn_position) . Set.toList -> visited) = case visited of
  [] -> mempty
  (x : _) ->
    let cycleWithoutRecursiveKnot = T.intercalate " -> " . map (unNgramsTerm . _vn_term) $ visited
    -- Pretty print the first visited node last, so that the user can "see" the full recursive knot.
    in cycleWithoutRecursiveKnot <> " -> " <> (unNgramsTerm . _vn_term $ x)

-- | Keeps track of the relative order in which visited a node, to be able to print cycles.
data VisitedNode =
  VN { _vn_position :: !Int, _vn_term :: !NgramsTerm }
  deriving (Show)

allVisitedNgramsTerms :: Set VisitedNode -> Set NgramsTerm
allVisitedNgramsTerms = Set.map _vn_term

-- /NOTA BENE/: It's important to use this custom instance for the loop detector
-- to work correctly. If we stop comparing on the terms the loop detector .. will loop.
instance Eq VisitedNode where
  (VN _ t1) == (VN _ t2) = t1 == t2

-- /NOTA BENE/: Same proviso as for the 'Eq' instance.
instance Ord VisitedNode where
  compare (VN _ t1) (VN _ t2) = t1 `compare` t2

data NodeStoryError =
  NodeStoryUpsertFailed BuildForestError
  deriving (Show, Eq)

instance ToHumanFriendlyError NodeStoryError where
  mkHumanFriendly e = case e of
    NodeStoryUpsertFailed be -> mkHumanFriendly be

------------------------------------------------------------------------
data NodeStoryEnv err = NodeStoryEnv
  { _nse_saver :: !(NodeId -> ArchiveList -> DBUpdate err ())
  , _nse_archive_saver :: !(NodeId -> ArchiveList -> DBUpdate err ArchiveList)
  , _nse_getter :: !(forall x. NodeId -> DBQuery err x ArchiveList)
  , _nse_getter_multi :: !(forall x. [NodeId] -> DBQuery err x NodeListStory)
  --, _nse_cleaner :: !(IO ()) -- every 12 hours: cleans the repos of unused NodeStories
  -- , _nse_lock  :: !FileLock -- TODO (it depends on the option: if with database or file only)
  }

class HasNodeStoryError e where
  _NodeStoryError :: Prism' e NodeStoryError

instance HasNodeStoryError NodeStoryError where
  _NodeStoryError = prism' identity Just

type HasNodeStory env err m = ( IsDBCmd env err m, HasNodeStoryEnv env err, HasNodeError err)

class HasNodeStoryEnv env err where
    hasNodeStory :: Getter env (NodeStoryEnv err)

type ArchiveState     = (Ngrams.NgramsType, NgramsTerm, NgramsRepoElement)
type ArchiveStateList = [ArchiveState]
type ArchiveStateSet = Set.Set (Ngrams.NgramsType, NgramsTerm)

------------------------------------------------------------------------
------------------------------------------------------------------------
-- | Lenses at the bottom of the file because Template Haskell would reorder order of execution in others cases
makeLenses ''NodeStoryEnv
makeLenses ''NodeStory
makeLenses ''Archive

hasNodeStoryImmediateSaver :: Lens' (NodeStoryEnv err) (NodeId -> ArchiveList -> DBUpdate err ())
hasNodeStoryImmediateSaver = nse_saver

hasNodeArchiveStoryImmediateSaver :: Lens' (NodeStoryEnv err) (NodeId -> ArchiveList -> DBUpdate err ArchiveList)
hasNodeArchiveStoryImmediateSaver = nse_archive_saver
