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

module Cursor.Tree.Promote
  ( treeCursorPromoteElem,
    PromoteElemResult (..),
    treeCursorPromoteSubTree,
    PromoteResult (..),
  )
where

import Control.DeepSeq
import Cursor.Tree.Base
import Cursor.Tree.Types
import Data.Validity
import GHC.Generics (Generic)

-- | Promotes the current node to the level of its parent.
--
-- Example:
--
-- Before:
--
-- >  p
-- >  |- a
-- >  |  |- b
-- >  |  |  |- c
-- >  |  |- d <--
-- >  |  |  |- e
-- >  |  |- f
-- >  |     |- g
-- >  |- h
--
-- After:
--
-- >  p
-- >  |- a
-- >  |  |- b
-- >  |  |  |- c
-- >  |  |  |- e
-- >  |  |- f
-- >  |     |- g
-- >  |- d <--
-- >  |- h
treeCursorPromoteElem ::
  (a -> b) -> (b -> a) -> TreeCursor a b -> PromoteElemResult (TreeCursor a b)
treeCursorPromoteElem :: (a -> b)
-> (b -> a) -> TreeCursor a b -> PromoteElemResult (TreeCursor a b)
treeCursorPromoteElem a -> b
f b -> a
g TreeCursor a b
tc = do
  TreeAbove b
ta <- PromoteElemResult (TreeAbove b)
-> (TreeAbove b -> PromoteElemResult (TreeAbove b))
-> Maybe (TreeAbove b)
-> PromoteElemResult (TreeAbove b)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PromoteElemResult (TreeAbove b)
forall a. PromoteElemResult a
CannotPromoteTopElem TreeAbove b -> PromoteElemResult (TreeAbove b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TreeAbove b) -> PromoteElemResult (TreeAbove b))
-> Maybe (TreeAbove b) -> PromoteElemResult (TreeAbove b)
forall a b. (a -> b) -> a -> b
$ TreeCursor a b -> Maybe (TreeAbove b)
forall a b. TreeCursor a b -> Maybe (TreeAbove b)
treeAbove TreeCursor a b
tc
  -- We need to put the below under the above lefts at the end
  [CTree b]
lefts <-
    case TreeCursor a b -> CForest b
forall a b. TreeCursor a b -> CForest b
treeBelow TreeCursor a b
tc of
      CForest b
EmptyCForest -> [CTree b] -> PromoteElemResult [CTree b]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CTree b] -> PromoteElemResult [CTree b])
-> [CTree b] -> PromoteElemResult [CTree b]
forall a b. (a -> b) -> a -> b
$ TreeAbove b -> [CTree b]
forall b. TreeAbove b -> [CTree b]
treeAboveLefts TreeAbove b
ta
      CForest b
_ ->
        case TreeAbove b -> [CTree b]
forall b. TreeAbove b -> [CTree b]
treeAboveLefts TreeAbove b
ta of
          [] -> PromoteElemResult [CTree b]
forall a. PromoteElemResult a
NoSiblingsToAdoptChildren
          (CNode b
t CForest b
ls : [CTree b]
ts) ->
            [CTree b] -> PromoteElemResult [CTree b]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CTree b] -> PromoteElemResult [CTree b])
-> [CTree b] -> PromoteElemResult [CTree b]
forall a b. (a -> b) -> a -> b
$ b -> CForest b -> CTree b
forall a. a -> CForest a -> CTree a
CNode b
t ([CTree b] -> CForest b
forall a. [CTree a] -> CForest a
openForest ([CTree b] -> CForest b) -> [CTree b] -> CForest b
forall a b. (a -> b) -> a -> b
$ CForest b -> [CTree b]
forall a. CForest a -> [CTree a]
unpackCForest CForest b
ls [CTree b] -> [CTree b] -> [CTree b]
forall a. [a] -> [a] -> [a]
++ CForest b -> [CTree b]
forall a. CForest a -> [CTree a]
unpackCForest (TreeCursor a b -> CForest b
forall a b. TreeCursor a b -> CForest b
treeBelow TreeCursor a b
tc)) CTree b -> [CTree b] -> [CTree b]
forall a. a -> [a] -> [a]
: [CTree b]
ts
  TreeAbove b
taa <- PromoteElemResult (TreeAbove b)
-> (TreeAbove b -> PromoteElemResult (TreeAbove b))
-> Maybe (TreeAbove b)
-> PromoteElemResult (TreeAbove b)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PromoteElemResult (TreeAbove b)
forall a. PromoteElemResult a
NoGrandparentToPromoteElemUnder TreeAbove b -> PromoteElemResult (TreeAbove b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TreeAbove b) -> PromoteElemResult (TreeAbove b))
-> Maybe (TreeAbove b) -> PromoteElemResult (TreeAbove b)
forall a b. (a -> b) -> a -> b
$ TreeAbove b -> Maybe (TreeAbove b)
forall b. TreeAbove b -> Maybe (TreeAbove b)
treeAboveAbove TreeAbove b
ta
  TreeCursor a b -> PromoteElemResult (TreeCursor a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TreeCursor a b -> PromoteElemResult (TreeCursor a b))
-> TreeCursor a b -> PromoteElemResult (TreeCursor a b)
forall a b. (a -> b) -> a -> b
$
    (b -> a) -> CTree b -> Maybe (TreeAbove b) -> TreeCursor a b
forall b a.
(b -> a) -> CTree b -> Maybe (TreeAbove b) -> TreeCursor a b
makeTreeCursorWithAbove b -> a
g (b -> CForest b -> CTree b
forall a. a -> CForest a -> CTree a
CNode (a -> b
f (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
$ TreeCursor a b -> a
forall a b. TreeCursor a b -> a
treeCurrent TreeCursor a b
tc) CForest b
forall a. CForest a
emptyCForest) (Maybe (TreeAbove b) -> TreeCursor a b)
-> Maybe (TreeAbove b) -> TreeCursor a b
forall a b. (a -> b) -> a -> b
$
      TreeAbove b -> Maybe (TreeAbove b)
forall a. a -> Maybe a
Just (TreeAbove b -> Maybe (TreeAbove b))
-> TreeAbove b -> Maybe (TreeAbove b)
forall a b. (a -> b) -> a -> b
$
        TreeAbove b
taa
          { treeAboveLefts :: [CTree b]
treeAboveLefts =
              b -> CForest b -> CTree b
forall a. a -> CForest a -> CTree a
CNode (TreeAbove b -> b
forall b. TreeAbove b -> b
treeAboveNode TreeAbove b
ta) ([CTree b] -> CForest b
forall a. [CTree a] -> CForest a
openForest ([CTree b] -> CForest b) -> [CTree b] -> CForest b
forall a b. (a -> b) -> a -> b
$ [CTree b] -> [CTree b]
forall a. [a] -> [a]
reverse [CTree b]
lefts [CTree b] -> [CTree b] -> [CTree b]
forall a. [a] -> [a] -> [a]
++ TreeAbove b -> [CTree b]
forall b. TreeAbove b -> [CTree b]
treeAboveRights TreeAbove b
ta) CTree b -> [CTree b] -> [CTree b]
forall a. a -> [a] -> [a]
:
              TreeAbove b -> [CTree b]
forall b. TreeAbove b -> [CTree b]
treeAboveLefts TreeAbove b
taa
          }

data PromoteElemResult a
  = CannotPromoteTopElem
  | NoGrandparentToPromoteElemUnder
  | NoSiblingsToAdoptChildren
  | PromotedElem a
  deriving (Int -> PromoteElemResult a -> ShowS
[PromoteElemResult a] -> ShowS
PromoteElemResult a -> String
(Int -> PromoteElemResult a -> ShowS)
-> (PromoteElemResult a -> String)
-> ([PromoteElemResult a] -> ShowS)
-> Show (PromoteElemResult a)
forall a. Show a => Int -> PromoteElemResult a -> ShowS
forall a. Show a => [PromoteElemResult a] -> ShowS
forall a. Show a => PromoteElemResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PromoteElemResult a] -> ShowS
$cshowList :: forall a. Show a => [PromoteElemResult a] -> ShowS
show :: PromoteElemResult a -> String
$cshow :: forall a. Show a => PromoteElemResult a -> String
showsPrec :: Int -> PromoteElemResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PromoteElemResult a -> ShowS
Show, PromoteElemResult a -> PromoteElemResult a -> Bool
(PromoteElemResult a -> PromoteElemResult a -> Bool)
-> (PromoteElemResult a -> PromoteElemResult a -> Bool)
-> Eq (PromoteElemResult a)
forall a.
Eq a =>
PromoteElemResult a -> PromoteElemResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PromoteElemResult a -> PromoteElemResult a -> Bool
$c/= :: forall a.
Eq a =>
PromoteElemResult a -> PromoteElemResult a -> Bool
== :: PromoteElemResult a -> PromoteElemResult a -> Bool
$c== :: forall a.
Eq a =>
PromoteElemResult a -> PromoteElemResult a -> Bool
Eq, (forall x. PromoteElemResult a -> Rep (PromoteElemResult a) x)
-> (forall x. Rep (PromoteElemResult a) x -> PromoteElemResult a)
-> Generic (PromoteElemResult a)
forall x. Rep (PromoteElemResult a) x -> PromoteElemResult a
forall x. PromoteElemResult a -> Rep (PromoteElemResult a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (PromoteElemResult a) x -> PromoteElemResult a
forall a x. PromoteElemResult a -> Rep (PromoteElemResult a) x
$cto :: forall a x. Rep (PromoteElemResult a) x -> PromoteElemResult a
$cfrom :: forall a x. PromoteElemResult a -> Rep (PromoteElemResult a) x
Generic, a -> PromoteElemResult b -> PromoteElemResult a
(a -> b) -> PromoteElemResult a -> PromoteElemResult b
(forall a b.
 (a -> b) -> PromoteElemResult a -> PromoteElemResult b)
-> (forall a b. a -> PromoteElemResult b -> PromoteElemResult a)
-> Functor PromoteElemResult
forall a b. a -> PromoteElemResult b -> PromoteElemResult a
forall a b. (a -> b) -> PromoteElemResult a -> PromoteElemResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PromoteElemResult b -> PromoteElemResult a
$c<$ :: forall a b. a -> PromoteElemResult b -> PromoteElemResult a
fmap :: (a -> b) -> PromoteElemResult a -> PromoteElemResult b
$cfmap :: forall a b. (a -> b) -> PromoteElemResult a -> PromoteElemResult b
Functor)

instance Validity a => Validity (PromoteElemResult a)

instance NFData a => NFData (PromoteElemResult a)

instance Applicative PromoteElemResult where
  pure :: a -> PromoteElemResult a
pure = a -> PromoteElemResult a
forall a. a -> PromoteElemResult a
PromotedElem
  PromoteElemResult (a -> b)
CannotPromoteTopElem <*> :: PromoteElemResult (a -> b)
-> PromoteElemResult a -> PromoteElemResult b
<*> PromoteElemResult a
_ = PromoteElemResult b
forall a. PromoteElemResult a
CannotPromoteTopElem
  PromoteElemResult (a -> b)
NoGrandparentToPromoteElemUnder <*> PromoteElemResult a
_ = PromoteElemResult b
forall a. PromoteElemResult a
NoGrandparentToPromoteElemUnder
  PromoteElemResult (a -> b)
NoSiblingsToAdoptChildren <*> PromoteElemResult a
_ = PromoteElemResult b
forall a. PromoteElemResult a
NoSiblingsToAdoptChildren
  PromotedElem a -> b
f <*> PromotedElem a
a = b -> PromoteElemResult b
forall a. a -> PromoteElemResult a
PromotedElem (b -> PromoteElemResult b) -> b -> PromoteElemResult b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
  PromotedElem a -> b
_ <*> PromoteElemResult a
CannotPromoteTopElem = PromoteElemResult b
forall a. PromoteElemResult a
CannotPromoteTopElem
  PromotedElem a -> b
_ <*> PromoteElemResult a
NoSiblingsToAdoptChildren = PromoteElemResult b
forall a. PromoteElemResult a
NoSiblingsToAdoptChildren
  PromotedElem a -> b
_ <*> PromoteElemResult a
NoGrandparentToPromoteElemUnder = PromoteElemResult b
forall a. PromoteElemResult a
NoGrandparentToPromoteElemUnder

instance Monad PromoteElemResult where
  PromoteElemResult a
CannotPromoteTopElem >>= :: PromoteElemResult a
-> (a -> PromoteElemResult b) -> PromoteElemResult b
>>= a -> PromoteElemResult b
_ = PromoteElemResult b
forall a. PromoteElemResult a
CannotPromoteTopElem
  PromoteElemResult a
NoGrandparentToPromoteElemUnder >>= a -> PromoteElemResult b
_ = PromoteElemResult b
forall a. PromoteElemResult a
NoGrandparentToPromoteElemUnder
  PromoteElemResult a
NoSiblingsToAdoptChildren >>= a -> PromoteElemResult b
_ = PromoteElemResult b
forall a. PromoteElemResult a
NoSiblingsToAdoptChildren
  PromotedElem a
a >>= a -> PromoteElemResult b
f = a -> PromoteElemResult b
f a
a

-- | Promotes the current node to the level of its parent.
--
-- Example:
--
-- Before:
--
-- >  p
-- >  |- a
-- >  |  |- b
-- >  |  |  |- c
-- >  |  |- d <--
-- >  |  |  |- e
-- >  |  |- f
-- >  |     |- g
-- >  |- h
--
-- After:
--
-- >  p
-- >  |- a
-- >  |  |- b
-- >  |  |  |- c
-- >  |  |- f
-- >  |     |- g
-- >  |- d <--
-- >  |  |- e
-- >  |- h
treeCursorPromoteSubTree :: (a -> b) -> (b -> a) -> TreeCursor a b -> PromoteResult (TreeCursor a b)
treeCursorPromoteSubTree :: (a -> b)
-> (b -> a) -> TreeCursor a b -> PromoteResult (TreeCursor a b)
treeCursorPromoteSubTree a -> b
f b -> a
g TreeCursor a b
tc = do
  TreeAbove b
ta <- PromoteResult (TreeAbove b)
-> (TreeAbove b -> PromoteResult (TreeAbove b))
-> Maybe (TreeAbove b)
-> PromoteResult (TreeAbove b)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PromoteResult (TreeAbove b)
forall a. PromoteResult a
CannotPromoteTopNode TreeAbove b -> PromoteResult (TreeAbove b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TreeAbove b) -> PromoteResult (TreeAbove b))
-> Maybe (TreeAbove b) -> PromoteResult (TreeAbove b)
forall a b. (a -> b) -> a -> b
$ TreeCursor a b -> Maybe (TreeAbove b)
forall a b. TreeCursor a b -> Maybe (TreeAbove b)
treeAbove TreeCursor a b
tc
  TreeAbove b
taa <- PromoteResult (TreeAbove b)
-> (TreeAbove b -> PromoteResult (TreeAbove b))
-> Maybe (TreeAbove b)
-> PromoteResult (TreeAbove b)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PromoteResult (TreeAbove b)
forall a. PromoteResult a
NoGrandparentToPromoteUnder TreeAbove b -> PromoteResult (TreeAbove b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (TreeAbove b) -> PromoteResult (TreeAbove b))
-> Maybe (TreeAbove b) -> PromoteResult (TreeAbove b)
forall a b. (a -> b) -> a -> b
$ TreeAbove b -> Maybe (TreeAbove b)
forall b. TreeAbove b -> Maybe (TreeAbove b)
treeAboveAbove TreeAbove b
ta
  TreeCursor a b -> PromoteResult (TreeCursor a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TreeCursor a b -> PromoteResult (TreeCursor a b))
-> TreeCursor a b -> PromoteResult (TreeCursor a b)
forall a b. (a -> b) -> a -> b
$
    (b -> a) -> CTree b -> Maybe (TreeAbove b) -> TreeCursor a b
forall b a.
(b -> a) -> CTree b -> Maybe (TreeAbove b) -> TreeCursor a b
makeTreeCursorWithAbove b -> a
g ((a -> b) -> TreeCursor a b -> CTree b
forall a b. (a -> b) -> TreeCursor a b -> CTree b
currentTree a -> b
f TreeCursor a b
tc) (Maybe (TreeAbove b) -> TreeCursor a b)
-> Maybe (TreeAbove b) -> TreeCursor a b
forall a b. (a -> b) -> a -> b
$
      TreeAbove b -> Maybe (TreeAbove b)
forall a. a -> Maybe a
Just (TreeAbove b -> Maybe (TreeAbove b))
-> TreeAbove b -> Maybe (TreeAbove b)
forall a b. (a -> b) -> a -> b
$
        TreeAbove b
taa
          { treeAboveLefts :: [CTree b]
treeAboveLefts =
              b -> CForest b -> CTree b
forall a. a -> CForest a -> CTree a
CNode (TreeAbove b -> b
forall b. TreeAbove b -> b
treeAboveNode TreeAbove b
ta) ([CTree b] -> CForest b
forall a. [CTree a] -> CForest a
openForest ([CTree b] -> CForest b) -> [CTree b] -> CForest b
forall a b. (a -> b) -> a -> b
$ [CTree b] -> [CTree b]
forall a. [a] -> [a]
reverse (TreeAbove b -> [CTree b]
forall b. TreeAbove b -> [CTree b]
treeAboveLefts TreeAbove b
ta) [CTree b] -> [CTree b] -> [CTree b]
forall a. [a] -> [a] -> [a]
++ TreeAbove b -> [CTree b]
forall b. TreeAbove b -> [CTree b]
treeAboveRights TreeAbove b
ta) CTree b -> [CTree b] -> [CTree b]
forall a. a -> [a] -> [a]
:
              TreeAbove b -> [CTree b]
forall b. TreeAbove b -> [CTree b]
treeAboveLefts TreeAbove b
taa
          }

data PromoteResult a
  = CannotPromoteTopNode
  | NoGrandparentToPromoteUnder
  | Promoted a
  deriving (Int -> PromoteResult a -> ShowS
[PromoteResult a] -> ShowS
PromoteResult a -> String
(Int -> PromoteResult a -> ShowS)
-> (PromoteResult a -> String)
-> ([PromoteResult a] -> ShowS)
-> Show (PromoteResult a)
forall a. Show a => Int -> PromoteResult a -> ShowS
forall a. Show a => [PromoteResult a] -> ShowS
forall a. Show a => PromoteResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PromoteResult a] -> ShowS
$cshowList :: forall a. Show a => [PromoteResult a] -> ShowS
show :: PromoteResult a -> String
$cshow :: forall a. Show a => PromoteResult a -> String
showsPrec :: Int -> PromoteResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PromoteResult a -> ShowS
Show, PromoteResult a -> PromoteResult a -> Bool
(PromoteResult a -> PromoteResult a -> Bool)
-> (PromoteResult a -> PromoteResult a -> Bool)
-> Eq (PromoteResult a)
forall a. Eq a => PromoteResult a -> PromoteResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PromoteResult a -> PromoteResult a -> Bool
$c/= :: forall a. Eq a => PromoteResult a -> PromoteResult a -> Bool
== :: PromoteResult a -> PromoteResult a -> Bool
$c== :: forall a. Eq a => PromoteResult a -> PromoteResult a -> Bool
Eq, (forall x. PromoteResult a -> Rep (PromoteResult a) x)
-> (forall x. Rep (PromoteResult a) x -> PromoteResult a)
-> Generic (PromoteResult a)
forall x. Rep (PromoteResult a) x -> PromoteResult a
forall x. PromoteResult a -> Rep (PromoteResult a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (PromoteResult a) x -> PromoteResult a
forall a x. PromoteResult a -> Rep (PromoteResult a) x
$cto :: forall a x. Rep (PromoteResult a) x -> PromoteResult a
$cfrom :: forall a x. PromoteResult a -> Rep (PromoteResult a) x
Generic, a -> PromoteResult b -> PromoteResult a
(a -> b) -> PromoteResult a -> PromoteResult b
(forall a b. (a -> b) -> PromoteResult a -> PromoteResult b)
-> (forall a b. a -> PromoteResult b -> PromoteResult a)
-> Functor PromoteResult
forall a b. a -> PromoteResult b -> PromoteResult a
forall a b. (a -> b) -> PromoteResult a -> PromoteResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PromoteResult b -> PromoteResult a
$c<$ :: forall a b. a -> PromoteResult b -> PromoteResult a
fmap :: (a -> b) -> PromoteResult a -> PromoteResult b
$cfmap :: forall a b. (a -> b) -> PromoteResult a -> PromoteResult b
Functor)

instance Validity a => Validity (PromoteResult a)

instance NFData a => NFData (PromoteResult a)

instance Applicative PromoteResult where
  pure :: a -> PromoteResult a
pure = a -> PromoteResult a
forall a. a -> PromoteResult a
Promoted
  PromoteResult (a -> b)
CannotPromoteTopNode <*> :: PromoteResult (a -> b) -> PromoteResult a -> PromoteResult b
<*> PromoteResult a
_ = PromoteResult b
forall a. PromoteResult a
CannotPromoteTopNode
  PromoteResult (a -> b)
NoGrandparentToPromoteUnder <*> PromoteResult a
_ = PromoteResult b
forall a. PromoteResult a
NoGrandparentToPromoteUnder
  Promoted a -> b
f <*> Promoted a
a = b -> PromoteResult b
forall a. a -> PromoteResult a
Promoted (b -> PromoteResult b) -> b -> PromoteResult b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
  Promoted a -> b
_ <*> PromoteResult a
CannotPromoteTopNode = PromoteResult b
forall a. PromoteResult a
CannotPromoteTopNode
  Promoted a -> b
_ <*> PromoteResult a
NoGrandparentToPromoteUnder = PromoteResult b
forall a. PromoteResult a
NoGrandparentToPromoteUnder

instance Monad PromoteResult where
  PromoteResult a
CannotPromoteTopNode >>= :: PromoteResult a -> (a -> PromoteResult b) -> PromoteResult b
>>= a -> PromoteResult b
_ = PromoteResult b
forall a. PromoteResult a
CannotPromoteTopNode
  PromoteResult a
NoGrandparentToPromoteUnder >>= a -> PromoteResult b
_ = PromoteResult b
forall a. PromoteResult a
NoGrandparentToPromoteUnder
  Promoted a
a >>= a -> PromoteResult b
f = a -> PromoteResult b
f a
a