{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
module Cursor.Tree.Promote
( treeCursorPromoteElem
, PromoteElemResult(..)
, treeCursorPromoteSubTree
, PromoteResult(..)
) where
import Data.Validity
import GHC.Generics (Generic)
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 <-
case treeAbove tc of
Nothing -> CannotPromoteTopElem
Just ta -> pure ta
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 <-
case treeAboveAbove ta of
Nothing -> NoGrandparentToPromoteElemUnder
Just taa -> pure taa
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 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 <-
case treeAbove tc of
Nothing -> CannotPromoteTopNode
Just ta -> pure ta
taa <-
case treeAboveAbove ta of
Nothing -> NoGrandparentToPromoteUnder
Just taa -> pure taa
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 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