Demote.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}

module Cursor.Tree.Demote
  ( treeCursorDemoteElem
  , treeCursorDemoteSubTree
  , DemoteResult(..)
  , treeCursorDemoteElemUnder
  , treeCursorDemoteSubTreeUnder
  ) where

import Data.Validity

import GHC.Generics (Generic)

import Cursor.Tree.Base
import Cursor.Tree.Types

-- | Demotes the current node to the level of its children.
--
-- Example:
--
-- Before:
--
-- >  p
-- >  |- a
-- >  |  |- b
-- >  |- c <--
-- >  |  |- d
-- >  |- e
--
-- After:
--
-- >  p
-- >  |- a
-- >  |  |- b
-- >  |  |- c <--
-- >  |  |- d
-- >  |- e
treeCursorDemoteElem ::
     (a -> b) -> (b -> a) -> TreeCursor a b -> DemoteResult (TreeCursor a b)
treeCursorDemoteElem f g tc =
  case treeAbove tc of
    Nothing -> CannotDemoteTopNode
    Just ta ->
      case treeAboveLefts ta of
        [] -> NoSiblingsToDemoteUnder
        (CNode t ls:ts) ->
          Demoted $
          makeTreeCursorWithAbove g (CNode (f $ treeCurrent tc) emptyCForest) $
          Just
            TreeAbove
              { treeAboveLefts = reverse $ unpackCForest ls
              , treeAboveAbove = Just ta {treeAboveLefts = ts}
              , treeAboveNode = t
              , treeAboveRights = unpackCForest $ treeBelow tc
              }

-- | Demotes the current subtree to the level of its children.
--
-- Example:
--
-- Before:
--
-- >  p
-- >  |- a
-- >  |  |- b
-- >  |- c <--
-- >  |  |- d
-- >  |- e
--
-- After:
--
-- >  p
-- >  |- a
-- >  |  |- b
-- >  |  |- c <--
-- >  |     |- d
-- >  |- e
treeCursorDemoteSubTree ::
     (a -> b) -> (b -> a) -> TreeCursor a b -> DemoteResult (TreeCursor a b)
treeCursorDemoteSubTree f g tc =
  case treeAbove tc of
    Nothing -> CannotDemoteTopNode
    Just ta ->
      case treeAboveLefts ta of
        [] -> NoSiblingsToDemoteUnder
        (CNode t ls:ts) ->
          Demoted $
          makeTreeCursorWithAbove g (currentTree f tc) $
          Just
            TreeAbove
              { treeAboveLefts = reverse $ unpackCForest ls
              , treeAboveAbove = Just ta {treeAboveLefts = ts}
              , treeAboveNode = t
              , treeAboveRights = []
              }

data DemoteResult a
  = CannotDemoteTopNode
  | NoSiblingsToDemoteUnder
  | Demoted a
  deriving (Show, Eq, Generic, Functor)

instance Validity a => Validity (DemoteResult a)

-- | Demotes the current node to the level of its children, by adding two roots.
-- One for the current node and one for its children that are left behind.
--
-- Example:
--
-- Before:
--
-- >  p
-- >  |- a <--
-- >     |- b
--
-- After:
--
-- >  p
-- >  |- <given element 1>
-- >  |  |- a <--
-- >  |- <given element 2>
-- >  |  |- b
treeCursorDemoteElemUnder :: b -> b -> TreeCursor a b -> Maybe (TreeCursor a b)
treeCursorDemoteElemUnder b1 b2 tc = do
  ta <- treeAbove tc
  let ta' = ta {treeAboveRights = CNode b2 (treeBelow tc) : treeAboveRights ta}
  pure
    tc
      { treeAbove =
          Just
            TreeAbove
              { treeAboveLefts = []
              , treeAboveAbove = Just ta'
              , treeAboveNode = b1
              , treeAboveRights = []
              }
      , treeBelow = emptyCForest
      }

-- | Demotes the current subtree to the level of its children, by adding a root.
--
-- Example:
--
-- Before:
--
-- >  a <--
-- >  |- b
--
-- After:
--
-- >  <given element>
-- >  |- a <--
-- >     |- b
treeCursorDemoteSubTreeUnder :: b -> TreeCursor a b -> TreeCursor a b
treeCursorDemoteSubTreeUnder b tc =
  tc
    { treeAbove =
        Just
          TreeAbove
            { treeAboveLefts = []
            , treeAboveAbove = treeAbove tc
            , treeAboveNode = b
            , treeAboveRights = []
            }
    }