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

A Node Story is a Map between NodeId and an Archive (with state,
version and history) for that node.

Couple of words on how this is implemented.

First version used files which stored Archive for each NodeId in a
separate .cbor file.

For performance reasons, it is rewritten to use the DB.

The table `node_stories` contains two columns: `node_id` and
`archive`.

Next, it was observed that `a_history` in `Archive` takes much
space. So a new table was created, `node_story_archive_history` with
columns: `node_id`, `ngrams_type_id`, `patch`. This is because each
history item is in fact a map from `NgramsType` to `NgramsTablePatch`
(see the `NgramsStatePatch'` type).

Moreover, since in `G.A.Ngrams.commitStatePatch` we use current state
only, with only recent history items, I concluded that it is not
necessary to load whole history into memory. Instead, it is kept in DB
(history is immutable) and only recent changes are added to
`a_history`. Then that record is cleared whenever `Archive` is saved.

Please note that

TODO:
- remove
- filter
- charger les listes
-}

{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE QuasiQuotes         #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE LambdaCase          #-}

module Gargantext.Core.NodeStory
  ( module Gargantext.Core.NodeStory.Types
  , getNodesArchiveHistory
  , Archive(..)
  , ArchiveStateForest
  , nodeExists
  , getNodesIdWithType
  , mkNodeStoryEnv
  , upsertNodeStories
  , getNodeStory'
  , nodeStoriesQuery
  , currentVersion
  , archiveStateFromList
  , archiveStateToList
  , fixNodeStoryVersions
  , getParentsChildren
  -- * Operations on trees and forests
  , TreeNode
  , BuildForestError(..)
  , VisitedNode(..)
  , OnLoopDetectedStrategy(..)
  , LoopBreakAlgorithm(..)
  , buildForest
  , pruneForest
  ) where

import Control.Lens ((%~), non, _Just, at, over, Lens', (#), view)
import Data.Graph
import Data.Graph qualified as G
import Data.List qualified as L
import Data.ListZipper
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Tree
import Database.PostgreSQL.Simple qualified as PGS
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.ToField qualified as PGS
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory.DB
import Gargantext.Core.NodeStory.Types
import Gargantext.Core.Text.Ngrams qualified as Ngrams
import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Admin.Types.Node ( ListId, NodeId(..) )
import Gargantext.Database.Prelude
import Gargantext.Prelude hiding (to)

class HasNgramChildren e where
  ngramsElementChildren :: Lens' e (MSet NgramsTerm)

instance HasNgramChildren NgramsRepoElement where
  ngramsElementChildren = nre_children

instance HasNgramChildren NgramsElement where
  ngramsElementChildren = ne_children

class HasNgramParent e where
  ngramsElementParent :: Lens' e (Maybe NgramsTerm)

instance HasNgramParent NgramsRepoElement where
  ngramsElementParent = nre_parent

instance HasNgramParent NgramsElement where
  ngramsElementParent = ne_parent

class HasNgramRoot e where
  ngramsElementRoot :: Lens' e (Maybe NgramsTerm)

instance HasNgramRoot NgramsRepoElement where
  ngramsElementRoot = nre_root

instance HasNgramRoot NgramsElement where
  ngramsElementRoot = ne_root

-- | A 'Forest' (i.e. a list of trees) that models a hierarchy of ngrams terms, possibly grouped in
-- a nested fashion, all wrapped in a 'Zipper'. Why using a 'Zipper'? Because when traversing the
-- forest (for example to fix the children in case of dangling imports) we need sometimes to search
-- things into the forest, but crucially we do not want to search also inside the tree we are
-- currently iterating on! A zipper gives exactly that, i.e. a way to \"focus\" only on a particular
-- piece of a data structure.
type ArchiveStateForest = ListZipper (Tree (NgramsTerm, NgramsRepoElement))

type TreeNode e = (NgramsTerm, e)

-- | A 'NodeWithKey' is morally a 'TreeNode' but with custom 'Eq' and 'Ord' instances
-- which indexes everything on the 'NgramsTerm', which is our unique key.
data NodeWithKey e = NWK { _nwk_key :: NgramsTerm, _nwk_value :: e }
  deriving Show

instance Eq (NodeWithKey e) where
  (NWK k1 _) == (NWK k2 _) = k1 == k2

instance Ord (NodeWithKey e) where
  compare = comparing _nwk_key

-- | An algorithm to break loops in a graph.
data LoopBreakAlgorithm
  = -- | Just break the loop the easiest possible way
    LBA_just_do_it
    -- | break the loop such that we preserve the longest possible chain of children.
    -- (CURRENTLY UNIMPLEMENTED)
  | LBA_prefer_longest_children_chain
    -- | break the loop such that we preserve the largest occurrences chain (i.e. the score).
    -- (CURRENTLY UNIMPLEMENTED)
  | LBA_prefer_largest_occurrences_chain

-- | A user preference on what to do if a loop is detected in a graph.
data OnLoopDetectedStrategy
  = -- When a loop is detected don't do anything, just fail.
    FailOnLoop
  | BreakLoop LoopBreakAlgorithm

--
-- Dealing with loops
--
-- For dealing with loops (which it would be the case even for externally-sourced data)
-- we need something more than just Forests, we need a full blown graph, out of which we
-- can compute the strongly-connected-components, remove the loops with one of
-- the given strategies, find the spanning forest and finally materialise it.
--

sccsOf
  :: forall e. HasNgramChildren e
  => Map.Map NgramsTerm e
  -> [SCC (NodeWithKey e)]
sccsOf mp =
  let triples =
        [ (NWK t e
           , t
           , fromMaybe [] $ childrenOf <$> Map.lookup t mp)
        | (t, e) <- Map.toList mp
        ]
  in G.stronglyConnComp triples
  where
    childrenOf :: HasNgramChildren e => e -> [NgramsTerm]
    childrenOf e = mSetToList (e ^. ngramsElementChildren)

-- Deterministic DFS spanning forest inside a set of nodes.
-- We return the set of *kept* edges (u -> v) that form a forest.
spanningEdges
  :: (Ord k)
  => Map.Map k [k]
     -- adjacency restricted to the SCC
  -> [(k, k)]
spanningEdges adjScc =
  let -- make the starting order deterministic
      order = L.sort (Map.keys adjScc)
      go seen u acc =
        let nbrs = L.sort (Map.findWithDefault [] u adjScc)
            -- if we have already seen this, skip it (or it would form a cycle)
            step (s, edges_) v
              | v `Set.member` s = (s, edges_)
              | otherwise      =
                  let (s', edges') = go (Set.insert v s) v edges_
                  in (s', (u,v):edges')
        in L.foldl' step (seen, acc) nbrs

      finalEdges =
        snd $ L.foldl'
                (\(seen, edges_) u ->
                   if u `Set.member` seen
                     then (seen, edges_)
                     else go (Set.insert u seen) u edges_)
                (Set.empty, [])
                order
  in finalEdges

-- Given a map whose children have been rewritten to be acyclic (DAG),
-- set each node’s parent and roots from incoming edges.
syncAncestorshipFromChildren
  :: (HasNgramChildren e, HasNgramParent e, HasNgramRoot e)
  => Map.Map NgramsTerm e
  -> Map.Map NgramsTerm e
syncAncestorshipFromChildren mp =
  let children_Of t =
        maybe [] (mSetToList . view ngramsElementChildren) (Map.lookup t mp)

      incoming :: Map.Map NgramsTerm [NgramsTerm]
      incoming =
        Map.fromListWith (<>)
          [ (v, [u])
          | (u, _) <- Map.toList mp
          , v <- children_Of u
          , Map.member v mp
          ]

      -- Pick a parent out of the incoming edges
      selectParent :: [NgramsTerm] -> Maybe NgramsTerm
      selectParent []  = Nothing
      selectParent [p] = Just p
      selectParent ps  = Just (minimum ps)

      -- Pick the root by feeding the /parent/, and if
      -- the parent has no root either (because it *is* the root)
      -- then the root is the parent itself.
      selectRoot :: NgramsTerm -> Maybe NgramsTerm
      selectRoot currentParentId = case Map.lookup currentParentId mp of
        Nothing            -> Nothing
        Just currentParent -> view ngramsElementRoot currentParent <|> Just currentParentId
  in
    Map.mapWithKey
      (\t e -> let e' = e & ngramsElementParent .~ selectParent (Map.findWithDefault [] t incoming)
                   in  e' & ngramsElementRoot   .~ (view ngramsElementParent e' >>= selectRoot)
      )
      mp

-- | Break cycles just by "doing it", i.e. pick the simplest loop breaker possible.
breakCycles_justDoIt
  :: forall e. (HasNgramChildren e, Ord NgramsTerm)
  => Map.Map NgramsTerm e
  -> [SCC (NodeWithKey e)]
  -> Map.Map NgramsTerm e
breakCycles_justDoIt mp0 sccs =
  foldl' rewriteOneScc mp0 cyclicSets
 where
  cyclicSets :: [Set.Set NgramsTerm]
  cyclicSets =
    [ Set.fromList (map _nwk_key xs)
    | CyclicSCC xs <- sccs
    ]

  -- Rewrite exactly one SCC
  rewriteOneScc :: Map.Map NgramsTerm e -> Set.Set NgramsTerm -> Map.Map NgramsTerm e
  rewriteOneScc cur sccSet
    | Set.null sccSet = cur
    | otherwise       =
        let nodes = sort (Set.toList sccSet)

            -- Snapshot children from *cur* for nodes in this SCC
            oldChildren :: Map.Map NgramsTerm [NgramsTerm]
            oldChildren =
              Map.fromList
                [ (u
                  , filter (/= u)         -- drop self-loops proactively
                    $ maybe [] (mSetToList . (^. ngramsElementChildren)) (Map.lookup u cur)
                  )
                | u <- nodes
                ]

            -- Adjacency restricted to the SCC (used for DFS)
            insideAdj :: Map.Map NgramsTerm [NgramsTerm]
            insideAdj =
              Map.fromList
                [ (u, [ v | v <- Map.findWithDefault [] u oldChildren
                          , v `Set.member` sccSet ])
                | u <- nodes
                ]

            keptIn :: Map.Map NgramsTerm [NgramsTerm]
            keptIn = Map.fromListWith (++)
                      [ (u, [v]) | (u,v) <- spanningEdges insideAdj ]

            -- For each node, replace children with: (outside edges) ++ (kept inside edges)
            cur' :: Map.Map NgramsTerm e
            cur' =
              foldl'
                (\m u ->
                   let olds   = Map.findWithDefault [] u oldChildren
                       outs   = [ v | v <- olds, not (v `Set.member` sccSet) ]
                       kept   = Map.findWithDefault [] u keptIn
                       -- keep a stable order: outs first (as in original), then kept (both sorted)
                       newKs  = L.nub (sort outs ++ sort kept)
                   in Map.adjust (\e -> e & ngramsElementChildren .~ mSetFromList newKs) u m
                )
                cur
                nodes

        in cur'

-- | Find all the loops given the strongly connected components.
findLoops :: [SCC (NodeWithKey e)] -> [[NgramsTerm]]
findLoops sccs = [ [ t | NWK t _ <- xs ] | CyclicSCC xs <- sccs ]

-- | Builds an ngrams forest from the input ngrams table map. Under the hood
-- this function does a few things:
--
-- * Given that the input map can contain loops, we need to turn the map
--   (which is, in fact, an adjacency map for a graph) into a full blown graph
--   or rather its strongly connected components;
-- * Find any loop in the SCCs and, if there are any, we apply the input 'OnLoopDetectedStrategy';
-- * Once the graph has been made cycle-free,i.e. it's a DAG again we can convert
--   it into a 'Forest'.
buildForest
  :: forall e. (Show e, HasNgramChildren e, HasNgramParent e, HasNgramRoot e)
  => OnLoopDetectedStrategy
  -> Map.Map NgramsTerm e
  -> Either BuildForestError (Forest (TreeNode e))
buildForest strat mp = case findLoops sccs of
  []         -> pure $ unfoldForest (mkTreeNode mp) $ Map.toList mp
  (l:_loops) -> do

    dag <- case strat of
      FailOnLoop -> Left $ BFE_loop_detected (Set.fromList $ map (uncurry VN) (zip [1..] l))

      BreakLoop LBA_just_do_it ->
        pure $ syncAncestorshipFromChildren $ breakCycles_justDoIt mp sccs

      -- Future work: the other two algorithms
      BreakLoop _other ->
        pure $ syncAncestorshipFromChildren $ breakCycles_justDoIt mp sccs

    pure $ unfoldForest (mkTreeNode dag) $ Map.toList dag
  where
    sccs :: [ SCC (NodeWithKey e) ]
    sccs = sccsOf mp

    mkTreeNode :: Map.Map NgramsTerm e -> TreeNode e -> (TreeNode e, [TreeNode e])
    mkTreeNode dag (k, el) = ((k, el), mapMaybe (findChildren dag) $ mSetToList (el ^. ngramsElementChildren))

    findChildren :: Map.Map NgramsTerm e -> NgramsTerm -> Maybe (TreeNode e)
    findChildren dag t = Map.lookup t dag <&> \el -> (t, el)

buildForestsFromArchiveState :: NgramsState'
                             -> Either BuildForestError (Map Ngrams.NgramsType (Forest (TreeNode NgramsRepoElement)))
buildForestsFromArchiveState = traverse (buildForest (BreakLoop LBA_just_do_it))

destroyArchiveStateForest :: Map Ngrams.NgramsType (Forest (TreeNode NgramsRepoElement)) -> NgramsState'
destroyArchiveStateForest = Map.map destroyForest

-- | Folds an Ngrams forest back to a table map.
-- This function doesn't aggregate information, but merely just recostructs the original
-- map without loss of information. To perform operations on the forest, use the appropriate
-- functions.
destroyForest :: Forest (TreeNode NgramsRepoElement) -> Map NgramsTerm NgramsRepoElement
destroyForest f = Map.fromList . map (foldTree destroyTree) $ f
  where
    destroyTree :: TreeNode NgramsRepoElement
                -> [TreeNode NgramsRepoElement]
                -> TreeNode NgramsRepoElement
    destroyTree (k, rootEl) childrenEl = (k, squashElements rootEl childrenEl)

    squashElements :: e -> [TreeNode e] -> e
    squashElements r _ = r

-- | Prunes the input 'Forest' of 'NgramsElement' by keeping only the roots, i.e. the
-- nodes which has no children /AND/ they do not appear in any other 'children' relationship.
-- /NOTE ON IMPLEMENTATION:/ The fast way to do this is to simply filter each tree, ensuring
-- that we keep only trees which root has no parent or root (i.e. it's a root itself!) and this
-- will work only under the assumption that the input 'Forest' has been built correctly, i.e.
-- with the correct relationships specified, or this will break.
pruneForest :: HasNgramParent e => Forest e -> Forest e
pruneForest = filter (\(Node r _) -> isNothing (r ^. ngramsElementParent))


getNodeStory' :: NodeId -> DBQuery err x ArchiveList
getNodeStory' nId = do
  --res <- withResource pool $ \c -> runSelect c query :: IO [NodeStoryPoly NodeId Version Int Int NgramsRepoElement]
  res <- mkPGQuery nodeStoriesQuery (PGS.Only $ PGS.toField nId) :: DBQuery err x [(Version, Ngrams.NgramsType, NgramsTerm, NgramsRepoElement)]
  -- We have multiple rows with same node_id and different (ngrams_type_id, ngrams_id).
  -- Need to create a map: {<node_id>: {<ngrams_type_id>: {<ngrams_id>: <data>}}}
  let dbData = map (\(version, ngramsType, ngrams, ngrams_repo_element) ->
                      Archive { _a_version = version
                              , _a_history = []
                              , _a_state   = Map.singleton ngramsType $ Map.singleton ngrams ngrams_repo_element }) res
  -- NOTE Sanity check: all versions in the DB should be the same
   -- TODO Maybe redesign the DB so that `node_stories` has only
   -- `node_id`, `version` and there is a M2M table
   -- `node_stories_ngrams` without the `version` colum? Then we would
   -- have `version` in only one place.
  pure $ foldl' combine initArchive dbData
  where
    -- NOTE (<>) for Archive doesn't concatenate states, so we have to use `combine`
    combine a1 a2 = a1 & a_state %~ combineState (a2 ^. a_state)
                       & a_version .~ (a2 ^. a_version)  -- version should be updated from list, not taken from the empty Archive


getNodeStory :: NodeId -> DBQuery err x NodeListStory
getNodeStory nId = do
  a <- getNodeStory' nId
  pure $ NodeStory $ Map.singleton nId a

-- |Functions to convert archive state (which is a `Map NgramsType
--  (Map NgramsTerm NgramsRepoElement`)) to/from a flat list
archiveStateToList :: NgramsState' -> ArchiveStateList
archiveStateToList s = mconcat $ (\(nt, ntm) -> (\(n, nre) -> (nt, n, nre)) <$> Map.toList ntm) <$> Map.toList s

archiveStateFromList :: ArchiveStateList -> NgramsState'
archiveStateFromList l = Map.fromListWith (<>) $ (\(nt, t, nre) -> (nt, Map.singleton t nre)) <$> l

archiveStateSet :: ArchiveStateList -> ArchiveStateSet
archiveStateSet lst = Set.fromList $ (\(nt, term, _) -> (nt, term)) <$> lst

archiveStateListFilterFromSet :: ArchiveStateSet -> ArchiveStateList -> ArchiveStateList
archiveStateListFilterFromSet set =
  filter (\(nt, term, _) -> Set.member (nt, term) set)

-- | This function inserts whole new node story and archive for given node_id.
insertNodeStory :: NodeId -> ArchiveList -> DBUpdate err ()
insertNodeStory nId a = do
  insertArchiveStateList nId (a ^. a_version) (archiveStateToList $ a ^. a_state)

-- | This function updates the node story and archive for given node_id.
updateNodeStory :: NodeId -> ArchiveList -> ArchiveList -> DBUpdate err ()
updateNodeStory nodeId currentArchive newArchive = do
  -- STEPS

  -- 0. We assume we're inside an advisory lock

  -- 1. Find differences (inserts/updates/deletes)
  let currentList = archiveStateToList $ currentArchive ^. a_state
  let newList = archiveStateToList $ newArchive ^. a_state
  let currentSet = archiveStateSet currentList
  let newSet = archiveStateSet newList

  -- printDebug "[updateNodeStory] new - current = " $ Set.difference newSet currentSet
  let inserts = archiveStateListFilterFromSet (Set.difference newSet currentSet) newList
  -- printDebug "[updateNodeStory] inserts" inserts

  -- printDebug "[updateNodeStory] current - new" $ Set.difference currentSet newSet
  let deletes = archiveStateListFilterFromSet (Set.difference currentSet newSet) currentList
  -- printDebug "[updateNodeStory] deletes" deletes

  -- updates are the things that are in new but not in current
  let commonSet = Set.intersection currentSet newSet
  let commonNewList = archiveStateListFilterFromSet commonSet newList
  let commonCurrentList = archiveStateListFilterFromSet commonSet currentList
  let updates = Set.toList $ Set.difference (Set.fromList commonNewList) (Set.fromList commonCurrentList)
  -- printDebug "[updateNodeStory] updates" $ Text.unlines $ (Text.pack . show) <$> updates

  -- 2. Perform inserts/deletes/updates
  -- printDebug "[updateNodeStory] applying inserts" inserts
  insertArchiveStateList nodeId (newArchive ^. a_version) inserts
  --printDebug "[updateNodeStory] insert applied" ()
    --TODO Use currentArchive ^. a_version in delete and report error
  -- if entries with (node_id, ngrams_type_id, ngrams_id) but
  -- different version are found.
  deleteArchiveStateList nodeId deletes
  --printDebug "[updateNodeStory] delete applied" ()
  updateArchiveStateList nodeId (newArchive ^. a_version) updates
  --printDebug "[updateNodeStory] update applied" ()
  pure ()

upsertNodeStories :: NodeId -> ArchiveList -> DBUpdate err ()
upsertNodeStories nodeId newArchive = do
  -- printDebug "[upsertNodeStories] START nId" nId
  -- printDebug "[upsertNodeStories] locking nId" nId
  (NodeStory m) <- getNodeStory nodeId
  case Map.lookup nodeId m of
    Nothing ->
      void $ insertNodeStory nodeId newArchive
    Just currentArchive ->
      void $ updateNodeStory nodeId currentArchive newArchive

  -- 3. Now we need to set versions of all node state to be the same
  updateNodeStoryVersion nodeId newArchive

  -- printDebug "[upsertNodeStories] STOP nId" nId

-- | Returns a `NodeListStory`, updating the given one for given `NodeId`
nodeStoryInc :: NodeListStory -> NodeId -> DBQuery err x NodeListStory
nodeStoryInc ns@(NodeStory nls) nId = do
  case Map.lookup nId nls of
    Nothing -> do
      NodeStory nls' <- getNodeStory nId
      pure $ NodeStory $ Map.unionWith archiveAdvance nls' nls
    Just _ -> pure ns

-- | NgramsRepoElement contains, in particular, `nre_list`,
-- `nre_parent` and `nre_children`. We want to make sure that all
-- children entries (i.e. ones that have `nre_parent`) have the same
-- `list` as their parent entry.
-- NOTE(adn) Currently unused, see !424 for context.
_fixChildrenInNgrams :: NgramsState' -> NgramsState'
_fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed
  where
    (nsParents, nsChildren) = getParentsChildren ns
    parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_list)) <$> nsParents

    nsChildrenFixed = (\(nt, t, nre) ->
                         ( nt
                         , t
                         , nre & nre_list %~
                            (\l -> parentNtMap ^. at (nre ^. nre_parent . _Just) . non l)
                         )
                      ) <$> nsChildren

-- | (#281) Sometimes, when we upload a new list, a child can be left
-- without a parent. Find such ngrams and set their 'root' and
-- 'parent' to 'Nothing'.
fixChildrenWithNoParent :: Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
                        -> Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
fixChildrenWithNoParent = Map.map go
  where
    -- If the forest is somehow empty, do nothing. Otherwise, build a zipper and run
    -- the algorithm.
    go :: Forest (NgramsTerm, NgramsRepoElement)
       -> Forest (NgramsTerm, NgramsRepoElement)
    go fs = case zipper fs of
      Nothing  -> fs
      Just zfs -> maybe mempty toList $ execListZipperOp fixDanglingChildrenInForest zfs

    fixDanglingChildrenInForest :: ListZipperOp (Tree (NgramsTerm, NgramsRepoElement)) ()
    fixDanglingChildrenInForest = do
      z@(ListZipper l a r) <- get
      when (isOrphan (l <> r) a) $ void $ modifyFocus detachFromParent
      unless (atEnd z) $ do
        moveRight
        fixDanglingChildrenInForest

    detachFromParent :: Tree (NgramsTerm, NgramsRepoElement) -> Tree (NgramsTerm, NgramsRepoElement)
    detachFromParent (Node (k,v) el) = Node (k, v & nre_root   .~ Nothing & nre_parent .~ Nothing) el

    isOrphan :: Forest (NgramsTerm, NgramsRepoElement)
             -- ^ The rest of the forest, i.e. the list of trees
             -- except the input one.
             -> Tree (NgramsTerm, NgramsRepoElement)
             -- ^ The tree we are currently focusing.
             -> Bool
             -- ^ True if the root of the tree refers to
             -- a node that is not listed as any children of
             -- the subtrees, and yet it has a non-null parent
             -- or root.
    isOrphan restOfTheForest (Node (k,v) _) =
      (isJust (_nre_parent v) || isJust (_nre_root v)) &&
      not (isChildInForest (k,v) restOfTheForest)

    -- | Returns 'True' if the input child can be found in the tree.
    isChildInForest :: Eq e => e -> Forest e -> Bool
    isChildInForest _ []     = False
    isChildInForest e (x:xs) =
      case e == rootLabel x of
        True  -> True
        False -> isChildInForest e (subForest x) || isChildInForest e xs

-- | Sometimes children can also become parents (e.g. #313). Find such
-- | children and remove them from the list.
-- NOTE(adn) Currently unused, see !424 for context.
_fixChildrenDuplicatedAsParents :: NgramsState' -> NgramsState'
_fixChildrenDuplicatedAsParents ns = archiveStateFromList $ nsChildren <> nsParentsFixed
  where
    (nsParents, nsChildren) = getParentsChildren ns
    parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_children & mSetToSet)) <$> nsParents
    parentsSet = Set.fromList $ Map.keys parentNtMap

    nsParentsFixed = (\(nt, t, nre) ->
                       ( nt
                       , t
                       , over nre_children
                             (\c -> mSetFromSet $ Set.difference (mSetToSet c) parentsSet)
                             nre ) ) <$> nsParents

getParentsChildren :: NgramsState' -> (ArchiveStateList, ArchiveStateList)
getParentsChildren ns = (nsParents, nsChildren)
  where
    nls = archiveStateToList ns

    nsParents = filter (\(_nt, _t, nre) -> isNothing $ nre ^. nre_parent) nls
    nsChildren = filter (\(_nt, _t, nre) -> isJust $ nre ^. nre_parent) nls

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

mkNodeStoryEnv :: HasNodeStoryError err => NodeStoryEnv err
mkNodeStoryEnv = do
  let saver_immediate nId a = do
        -- |NOTE Fixing a_state is kinda a hack. We shouldn't land
        -- |with bad state in the first place.
        forests <- dbCheckOrFail (first (\e -> _NodeStoryError # NodeStoryUpsertFailed e) $ buildForestsFromArchiveState $ a ^. a_state)
        upsertNodeStories nId $ do
          a & a_state .~ (destroyArchiveStateForest . fixChildrenWithNoParent $ forests)
  let archive_saver_immediate nId a = do
        insertNodeArchiveHistory nId (a ^. a_version) $ reverse $ a ^. a_history
        pure $ a & a_history .~ []

  NodeStoryEnv { _nse_saver = saver_immediate
               , _nse_archive_saver = archive_saver_immediate
               , _nse_getter = getNodeStory'
               , _nse_getter_multi = \nIds -> foldM nodeStoryInc (NodeStory Map.empty) nIds
               }

currentVersion :: ListId -> DBQuery err x Version
currentVersion listId = do
  nls <- getNodeStory listId
  pure $ nls ^. unNodeStory . at listId . _Just . a_version


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

-- | To be called from the REPL
fixNodeStoryVersions :: (HasNodeStory env err m, IsDBCmd env err m) => m ()
fixNodeStoryVersions = runDBTx $ do
  nIds <- mkPGQuery [sql| SELECT id FROM nodes WHERE ? |] (PGS.Only True) :: DBQuery err x [PGS.Only Int64]
  -- printDebug "[fixNodeStoryVersions] nIds" nIds
  mapM_ (\(PGS.Only nId) -> do
      -- printDebug "[fixNodeStoryVersions] nId" nId
      updateVer Ngrams.Authors nId
      updateVer Ngrams.Institutes nId
      updateVer Ngrams.Sources nId
      updateVer Ngrams.NgramsTerms nId
    ) nIds
  where
    maxVerQuery :: PGS.Query
    maxVerQuery = [sql| SELECT max(version)
                      FROM node_stories
                      WHERE node_id = ?
                        AND ngrams_type_id = ? |]
    updateVerQuery :: PGS.Query
    updateVerQuery = [sql| UPDATE node_stories
                         SET version = ?
                         WHERE node_id = ?
                           AND ngrams_type_id = ? |]
    updateVer :: Ngrams.NgramsType -> Int64 -> DBUpdate err ()
    updateVer ngramsType nId = do
      maxVer <- mkPGQuery maxVerQuery (nId, ngramsType) :: DBUpdate err [PGS.Only (Maybe Int64)]
      case maxVer of
        [] -> pure ()
        [PGS.Only Nothing] -> pure ()
        [PGS.Only (Just maxVersion)] -> do
          void $ mkPGUpdate updateVerQuery (maxVersion, nId, ngramsType)
        _ -> panicTrace "Should get only 1 result!"
