{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
module Cursor.Tree.Promote
( treeCursorPromoteElem
, PromoteElemResult(..)
, treeCursorPromoteSubTree
, PromoteResult(..)
) where
import GHC.Generics (Generic)
import Data.Validity
import Control.DeepSeq
import Cursor.Tree.Base
import Cursor.Tree.Types
treeCursorPromoteElem ::
(a -> b) -> (b -> a) -> TreeCursor a b -> PromoteElemResult (TreeCursor a b)
treeCursorPromoteElem f g tc = do
ta <- maybe CannotPromoteTopElem pure $ treeAbove tc
lefts <-
case treeBelow tc of
EmptyCForest -> pure $ treeAboveLefts ta
_ ->
case treeAboveLefts ta of
[] -> NoSiblingsToAdoptChildren
(CNode t ls:ts) ->
pure $ CNode t (openForest $ unpackCForest ls ++ unpackCForest (treeBelow tc)) : ts
taa <- maybe NoGrandparentToPromoteElemUnder pure $ treeAboveAbove ta
pure $
makeTreeCursorWithAbove g (CNode (f $ treeCurrent tc) emptyCForest) $
Just $
taa
{ treeAboveLefts =
CNode (treeAboveNode ta) (openForest $ reverse lefts ++ treeAboveRights ta) :
treeAboveLefts taa
}
data PromoteElemResult a
= CannotPromoteTopElem
| NoGrandparentToPromoteElemUnder
| NoSiblingsToAdoptChildren
| PromotedElem a
deriving (Show, Eq, Generic, Functor)
instance Validity a => Validity (PromoteElemResult a)
instance NFData a => NFData (PromoteElemResult a)
instance Applicative PromoteElemResult where
pure = PromotedElem
CannotPromoteTopElem <*> _ = CannotPromoteTopElem
NoGrandparentToPromoteElemUnder <*> _ = NoGrandparentToPromoteElemUnder
NoSiblingsToAdoptChildren <*> _ = NoSiblingsToAdoptChildren
PromotedElem f <*> PromotedElem a = PromotedElem $ f a
PromotedElem _ <*> CannotPromoteTopElem = CannotPromoteTopElem
PromotedElem _ <*> NoSiblingsToAdoptChildren = NoSiblingsToAdoptChildren
PromotedElem _ <*> NoGrandparentToPromoteElemUnder = NoGrandparentToPromoteElemUnder
instance Monad PromoteElemResult where
CannotPromoteTopElem >>= _ = CannotPromoteTopElem
NoGrandparentToPromoteElemUnder >>= _ = NoGrandparentToPromoteElemUnder
NoSiblingsToAdoptChildren >>= _ = NoSiblingsToAdoptChildren
PromotedElem a >>= f = f a
treeCursorPromoteSubTree :: (a -> b) -> (b -> a) -> TreeCursor a b -> PromoteResult (TreeCursor a b)
treeCursorPromoteSubTree f g tc = do
ta <- maybe CannotPromoteTopNode pure $ treeAbove tc
taa <- maybe NoGrandparentToPromoteUnder pure $ treeAboveAbove ta
pure $
makeTreeCursorWithAbove g (currentTree f tc) $
Just $
taa
{ treeAboveLefts =
CNode (treeAboveNode ta) (openForest $ reverse (treeAboveLefts ta) ++ treeAboveRights ta) :
treeAboveLefts taa
}
data PromoteResult a
= CannotPromoteTopNode
| NoGrandparentToPromoteUnder
| Promoted a
deriving (Show, Eq, Generic, Functor)
instance Validity a => Validity (PromoteResult a)
instance NFData a => NFData (PromoteResult a)
instance Applicative PromoteResult where
pure = Promoted
CannotPromoteTopNode <*> _ = CannotPromoteTopNode
NoGrandparentToPromoteUnder <*> _ = NoGrandparentToPromoteUnder
Promoted f <*> Promoted a = Promoted $ f a
Promoted _ <*> CannotPromoteTopNode = CannotPromoteTopNode
Promoted _ <*> NoGrandparentToPromoteUnder = NoGrandparentToPromoteUnder
instance Monad PromoteResult where
CannotPromoteTopNode >>= _ = CannotPromoteTopNode
NoGrandparentToPromoteUnder >>= _ = NoGrandparentToPromoteUnder
Promoted a >>= f = f a