{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
module Cursor.Tree.Demote
( treeCursorDemoteElem
, treeCursorDemoteSubTree
, DemoteResult(..)
, treeCursorDemoteElemUnder
, treeCursorDemoteSubTreeUnder
) where
import GHC.Generics (Generic)
import Data.Validity
import Control.DeepSeq
import Cursor.Tree.Base
import Cursor.Tree.Types
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
}
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)
instance NFData a => NFData (DemoteResult a)
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
}
treeCursorDemoteSubTreeUnder :: b -> TreeCursor a b -> TreeCursor a b
treeCursorDemoteSubTreeUnder b tc =
tc
{ treeAbove =
Just
TreeAbove
{ treeAboveLefts = []
, treeAboveAbove = treeAbove tc
, treeAboveNode = b
, treeAboveRights = []
}
}