{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- MonadBase
#if __GLASGOW_HASKELL__ < 802
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#endif
module Hedgehog.Internal.Tree (
    Tree
  , pattern Tree
  , TreeT(..)
  , runTree
  , mapTreeT
  , treeValue
  , treeChildren

  , Node
  , pattern Node
  , NodeT(..)
  , fromNodeT

  , unfold
  , unfoldForest

  , expand
  , prune

  , catMaybes
  , filter
  , mapMaybe
  , filterMaybeT
  , mapMaybeMaybeT
  , filterT
  , mapMaybeT
  , depth
  , interleave

  , render
  , renderT
  ) where

import           Control.Applicative (Alternative(..), liftA2)
import           Control.Monad (MonadPlus(..), guard, join)
import           Control.Monad.Base (MonadBase(..))
import           Control.Monad.Trans.Control ()
import           Control.Monad.Catch (MonadThrow(..), MonadCatch(..), Exception)
import           Control.Monad.Error.Class (MonadError(..))
import           Control.Monad.IO.Class (MonadIO(..))
import           Control.Monad.Morph (MFunctor(..), MMonad(..), generalize)
import           Control.Monad.Primitive (PrimMonad(..))
import           Control.Monad.Reader.Class (MonadReader(..))
import           Control.Monad.State.Class (MonadState(..))
import           Control.Monad.Trans.Class (MonadTrans(..))
import           Control.Monad.Trans.Maybe (MaybeT(..))
import           Control.Monad.Trans.Resource (MonadResource(..))
import           Control.Monad.Writer.Class (MonadWriter(..))
import           Control.Monad.Zip (MonadZip(..))

import           Data.Functor.Identity (Identity(..))
import           Data.Functor.Classes (Eq1(..))
import           Data.Functor.Classes (Show1(..), showsPrec1)
import           Data.Functor.Classes (showsUnaryWith, showsBinaryWith)
import qualified Data.List as List
import qualified Data.Maybe as Maybe

import           Hedgehog.Internal.Distributive
import           Control.Monad.Trans.Control (MonadBaseControl (..))

import           Prelude hiding (filter)

------------------------------------------------------------------------

-- | A rose tree.
--
type Tree =
  TreeT Identity

-- | Pattern to ease construction / deconstruction of pure trees.
--
pattern Tree :: NodeT Identity a -> Tree a
pattern $bTree :: NodeT Identity a -> Tree a
$mTree :: forall r a. Tree a -> (NodeT Identity a -> r) -> (Void# -> r) -> r
Tree node =
  TreeT (Identity node)
#if __GLASGOW_HASKELL__ >= 802
{-# COMPLETE Tree #-}
#endif

-- | An effectful tree, each node in the tree can have an effect before it is
--   produced.
--
newtype TreeT m a =
  TreeT {
      TreeT m a -> m (NodeT m a)
runTreeT :: m (NodeT m a)
    }

instance MonadBaseControl b m => MonadBaseControl b (TreeT m) where
  type StM (TreeT m) a = StM m (NodeT m a)
  liftBaseWith :: (RunInBase (TreeT m) b -> b a) -> TreeT m a
liftBaseWith f :: RunInBase (TreeT m) b -> b a
f = m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a) -> m (NodeT m a) -> TreeT m a
forall a b. (a -> b) -> a -> b
$ (RunInBase m b -> b (NodeT m a)) -> m (NodeT m a)
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith (\g :: RunInBase m b
g -> a -> NodeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> NodeT m a) -> b a -> b (NodeT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunInBase (TreeT m) b -> b a
f (m (NodeT m a) -> b (StM m (NodeT m a))
RunInBase m b
g (m (NodeT m a) -> b (StM m (NodeT m a)))
-> (TreeT m a -> m (NodeT m a))
-> TreeT m a
-> b (StM m (NodeT m a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT))
  restoreM :: StM (TreeT m) a -> TreeT m a
restoreM = m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a)
-> (StM m (NodeT m a) -> m (NodeT m a))
-> StM m (NodeT m a)
-> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StM m (NodeT m a) -> m (NodeT m a)
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM

-- | A node in a rose tree.
--
type Node =
  NodeT Identity
#if __GLASGOW_HASKELL__ >= 802
{-# COMPLETE Node #-}
#endif

-- | Pattern to ease construction / deconstruction of pure nodes.
--
pattern Node :: a -> [Tree a] -> Node a
pattern $bNode :: a -> [Tree a] -> Node a
$mNode :: forall r a. Node a -> (a -> [Tree a] -> r) -> (Void# -> r) -> r
Node x xs =
  NodeT x xs

-- | A node in an effectful tree, as well as its unevaluated children.
--
data NodeT m a =
  NodeT {
      -- | The value at this 'NodeT' in the 'TreeT'.
      NodeT m a -> a
nodeValue :: a

      -- | The children of this 'NodeT'.
    , NodeT m a -> [TreeT m a]
nodeChildren :: [TreeT m a]
    } deriving (NodeT m a -> NodeT m a -> Bool
(NodeT m a -> NodeT m a -> Bool)
-> (NodeT m a -> NodeT m a -> Bool) -> Eq (NodeT m a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (m :: * -> *) a.
(Eq a, Eq1 m) =>
NodeT m a -> NodeT m a -> Bool
/= :: NodeT m a -> NodeT m a -> Bool
$c/= :: forall (m :: * -> *) a.
(Eq a, Eq1 m) =>
NodeT m a -> NodeT m a -> Bool
== :: NodeT m a -> NodeT m a -> Bool
$c== :: forall (m :: * -> *) a.
(Eq a, Eq1 m) =>
NodeT m a -> NodeT m a -> Bool
Eq)

-- | Extracts the 'Node' from a 'Tree'.
--
runTree :: Tree a -> Node a
runTree :: Tree a -> Node a
runTree =
  Identity (Node a) -> Node a
forall a. Identity a -> a
runIdentity (Identity (Node a) -> Node a)
-> (Tree a -> Identity (Node a)) -> Tree a -> Node a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree a -> Identity (Node a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT

-- | Map between 'TreeT' computations.
--
mapTreeT :: (m (NodeT m a) -> m (NodeT m a)) -> TreeT m a -> TreeT m a
mapTreeT :: (m (NodeT m a) -> m (NodeT m a)) -> TreeT m a -> TreeT m a
mapTreeT f :: m (NodeT m a) -> m (NodeT m a)
f =
  m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a)
-> (TreeT m a -> m (NodeT m a)) -> TreeT m a -> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (NodeT m a) -> m (NodeT m a)
f (m (NodeT m a) -> m (NodeT m a))
-> (TreeT m a -> m (NodeT m a)) -> TreeT m a -> m (NodeT m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT

-- | Create a 'TreeT' from a 'NodeT'
--
fromNodeT :: Applicative m => NodeT m a -> TreeT m a
fromNodeT :: NodeT m a -> TreeT m a
fromNodeT =
  m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a)
-> (NodeT m a -> m (NodeT m a)) -> NodeT m a -> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeT m a -> m (NodeT m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | The value at the root of the 'Tree'.
--
treeValue :: Tree a -> a
treeValue :: Tree a -> a
treeValue =
  NodeT Identity a -> a
forall (m :: * -> *) a. NodeT m a -> a
nodeValue (NodeT Identity a -> a)
-> (Tree a -> NodeT Identity a) -> Tree a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree a -> NodeT Identity a
forall a. Tree a -> Node a
runTree

-- | The children of the 'Tree'.
--
treeChildren :: Tree a -> [Tree a]
treeChildren :: Tree a -> [Tree a]
treeChildren =
  NodeT Identity a -> [Tree a]
forall (m :: * -> *) a. NodeT m a -> [TreeT m a]
nodeChildren (NodeT Identity a -> [Tree a])
-> (Tree a -> NodeT Identity a) -> Tree a -> [Tree a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree a -> NodeT Identity a
forall a. Tree a -> Node a
runTree

-- | Create a tree from a value and an unfolding function.
--
unfold :: Monad m => (a -> [a]) -> a -> TreeT m a
unfold :: (a -> [a]) -> a -> TreeT m a
unfold f :: a -> [a]
f x :: a
x =
  m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a)
-> (NodeT m a -> m (NodeT m a)) -> NodeT m a -> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeT m a -> m (NodeT m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeT m a -> TreeT m a) -> NodeT m a -> TreeT m a
forall a b. (a -> b) -> a -> b
$
    a -> [TreeT m a] -> NodeT m a
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT a
x ((a -> [a]) -> a -> [TreeT m a]
forall (m :: * -> *) a. Monad m => (a -> [a]) -> a -> [TreeT m a]
unfoldForest a -> [a]
f a
x)

-- | Create a forest from a value and an unfolding function.
--
unfoldForest :: Monad m => (a -> [a]) -> a -> [TreeT m a]
unfoldForest :: (a -> [a]) -> a -> [TreeT m a]
unfoldForest f :: a -> [a]
f =
  (a -> TreeT m a) -> [a] -> [TreeT m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> [a]) -> a -> TreeT m a
forall (m :: * -> *) a. Monad m => (a -> [a]) -> a -> TreeT m a
unfold a -> [a]
f) ([a] -> [TreeT m a]) -> (a -> [a]) -> a -> [TreeT m a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
f

-- | Expand a tree using an unfolding function.
--
expand :: Monad m => (a -> [a]) -> TreeT m a -> TreeT m a
expand :: (a -> [a]) -> TreeT m a -> TreeT m a
expand f :: a -> [a]
f m :: TreeT m a
m =
  m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a) -> m (NodeT m a) -> TreeT m a
forall a b. (a -> b) -> a -> b
$ do
    NodeT x :: a
x xs :: [TreeT m a]
xs <- TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m a
m
    NodeT m a -> m (NodeT m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeT m a -> m (NodeT m a))
-> ([TreeT m a] -> NodeT m a) -> [TreeT m a] -> m (NodeT m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [TreeT m a] -> NodeT m a
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT a
x ([TreeT m a] -> m (NodeT m a)) -> [TreeT m a] -> m (NodeT m a)
forall a b. (a -> b) -> a -> b
$
      (TreeT m a -> TreeT m a) -> [TreeT m a] -> [TreeT m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> [a]) -> TreeT m a -> TreeT m a
forall (m :: * -> *) a.
Monad m =>
(a -> [a]) -> TreeT m a -> TreeT m a
expand a -> [a]
f) [TreeT m a]
xs [TreeT m a] -> [TreeT m a] -> [TreeT m a]
forall a. [a] -> [a] -> [a]
++ (a -> [a]) -> a -> [TreeT m a]
forall (m :: * -> *) a. Monad m => (a -> [a]) -> a -> [TreeT m a]
unfoldForest a -> [a]
f a
x

-- | Throw away @n@ levels of a tree's children.
--
--   /@prune 0@ will throw away all of a tree's children./
--
prune :: Monad m => Int -> TreeT m a -> TreeT m a
prune :: Int -> TreeT m a -> TreeT m a
prune n :: Int
n m :: TreeT m a
m =
  if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 then
    m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a) -> m (NodeT m a) -> TreeT m a
forall a b. (a -> b) -> a -> b
$ do
      NodeT x :: a
x _ <- TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m a
m
      NodeT m a -> m (NodeT m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeT m a -> m (NodeT m a)) -> NodeT m a -> m (NodeT m a)
forall a b. (a -> b) -> a -> b
$ a -> [TreeT m a] -> NodeT m a
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT a
x []
  else
    m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a) -> m (NodeT m a) -> TreeT m a
forall a b. (a -> b) -> a -> b
$ do
      NodeT x :: a
x xs0 :: [TreeT m a]
xs0 <- TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m a
m
      NodeT m a -> m (NodeT m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeT m a -> m (NodeT m a))
-> ([TreeT m a] -> NodeT m a) -> [TreeT m a] -> m (NodeT m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [TreeT m a] -> NodeT m a
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT a
x ([TreeT m a] -> m (NodeT m a)) -> [TreeT m a] -> m (NodeT m a)
forall a b. (a -> b) -> a -> b
$
        (TreeT m a -> TreeT m a) -> [TreeT m a] -> [TreeT m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> TreeT m a -> TreeT m a
forall (m :: * -> *) a. Monad m => Int -> TreeT m a -> TreeT m a
prune (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)) [TreeT m a]
xs0

-- | Returns the depth of the deepest leaf node in the tree.
--
depth :: Tree a -> Int
depth :: Tree a -> Int
depth m :: Tree a
m =
  let
    NodeT _ xs :: [Tree a]
xs =
      Tree a -> NodeT Identity a
forall a. Tree a -> Node a
runTree Tree a
m

    n :: Int
n =
      if [Tree a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tree a]
xs then
        0
      else
        [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Tree a -> Int) -> [Tree a] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree a -> Int
forall a. Tree a -> Int
depth [Tree a]
xs)
  in
    1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n

-- | Takes a tree of 'Maybe's and returns a tree of all the 'Just' values.
--
--   If the root of the tree is 'Nothing' then 'Nothing' is returned.
--
catMaybes :: Tree (Maybe a) -> Maybe (Tree a)
catMaybes :: Tree (Maybe a) -> Maybe (Tree a)
catMaybes m :: Tree (Maybe a)
m =
  let
    NodeT mx :: Maybe a
mx mxs :: [Tree (Maybe a)]
mxs =
      Tree (Maybe a) -> NodeT Identity (Maybe a)
forall a. Tree a -> Node a
runTree Tree (Maybe a)
m
  in
    case Maybe a
mx of
      Nothing -> do
        case (Tree (Maybe a) -> Maybe (Tree a)) -> [Tree (Maybe a)] -> [Tree a]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe Tree (Maybe a) -> Maybe (Tree a)
forall a. Tree (Maybe a) -> Maybe (Tree a)
catMaybes [Tree (Maybe a)]
mxs of
          [] ->
            Maybe (Tree a)
forall a. Maybe a
Nothing
          Tree (NodeT x :: a
x xs0 :: [Tree a]
xs0) : xs1 :: [Tree a]
xs1 ->
            Tree a -> Maybe (Tree a)
forall a. a -> Maybe a
Just (Tree a -> Maybe (Tree a))
-> (NodeT Identity a -> Tree a)
-> NodeT Identity a
-> Maybe (Tree a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeT Identity a -> Tree a
forall a. NodeT Identity a -> Tree a
Tree (NodeT Identity a -> Maybe (Tree a))
-> NodeT Identity a -> Maybe (Tree a)
forall a b. (a -> b) -> a -> b
$
              a -> [Tree a] -> NodeT Identity a
forall a. a -> [Tree a] -> Node a
Node a
x ([Tree a]
xs0 [Tree a] -> [Tree a] -> [Tree a]
forall a. [a] -> [a] -> [a]
++ [Tree a]
xs1)
      Just x :: a
x ->
        Tree a -> Maybe (Tree a)
forall a. a -> Maybe a
Just (Tree a -> Maybe (Tree a))
-> (NodeT Identity a -> Tree a)
-> NodeT Identity a
-> Maybe (Tree a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeT Identity a -> Tree a
forall a. NodeT Identity a -> Tree a
Tree (NodeT Identity a -> Maybe (Tree a))
-> NodeT Identity a -> Maybe (Tree a)
forall a b. (a -> b) -> a -> b
$
          a -> [Tree a] -> NodeT Identity a
forall a. a -> [Tree a] -> Node a
Node a
x ((Tree (Maybe a) -> Maybe (Tree a)) -> [Tree (Maybe a)] -> [Tree a]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe Tree (Maybe a) -> Maybe (Tree a)
forall a. Tree (Maybe a) -> Maybe (Tree a)
catMaybes [Tree (Maybe a)]
mxs)

fromPred :: (a -> Bool) -> a -> Maybe a
fromPred :: (a -> Bool) -> a -> Maybe a
fromPred p :: a -> Bool
p a :: a
a = a
a a -> Maybe () -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a -> Bool
p a
a)

-- | Returns a tree containing only elements that match the predicate.
--
--   If the root of the tree does not match the predicate then 'Nothing' is
--   returned.
--
filter :: (a -> Bool) -> Tree a -> Maybe (Tree a)
filter :: (a -> Bool) -> Tree a -> Maybe (Tree a)
filter p :: a -> Bool
p = (a -> Maybe a) -> Tree a -> Maybe (Tree a)
forall a b. (a -> Maybe b) -> Tree a -> Maybe (Tree b)
mapMaybe ((a -> Bool) -> a -> Maybe a
forall a. (a -> Bool) -> a -> Maybe a
fromPred a -> Bool
p)

mapMaybe :: (a -> Maybe b) -> Tree a -> Maybe (Tree b)
mapMaybe :: (a -> Maybe b) -> Tree a -> Maybe (Tree b)
mapMaybe p :: a -> Maybe b
p =
  Tree (Maybe b) -> Maybe (Tree b)
forall a. Tree (Maybe a) -> Maybe (Tree a)
catMaybes (Tree (Maybe b) -> Maybe (Tree b))
-> (Tree a -> Tree (Maybe b)) -> Tree a -> Maybe (Tree b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  TreeT (MaybeT Identity) b -> Tree (Maybe b)
forall (m :: * -> *) a.
Monad m =>
TreeT (MaybeT m) a -> TreeT m (Maybe a)
runTreeMaybeT (TreeT (MaybeT Identity) b -> Tree (Maybe b))
-> (Tree a -> TreeT (MaybeT Identity) b)
-> Tree a
-> Tree (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (a -> Maybe b)
-> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) b
forall a b.
(a -> Maybe b)
-> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) b
mapMaybeMaybeT a -> Maybe b
p (TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) b)
-> (Tree a -> TreeT (MaybeT Identity) a)
-> Tree a
-> TreeT (MaybeT Identity) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (forall a. Identity a -> MaybeT Identity a)
-> Tree a -> TreeT (MaybeT Identity) a
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. Identity a -> MaybeT Identity a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

runTreeMaybeT :: Monad m => TreeT (MaybeT m) a -> TreeT m (Maybe a)
runTreeMaybeT :: TreeT (MaybeT m) a -> TreeT m (Maybe a)
runTreeMaybeT =
  MaybeT (TreeT m) a -> TreeT m (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (TreeT m) a -> TreeT m (Maybe a))
-> (TreeT (MaybeT m) a -> MaybeT (TreeT m) a)
-> TreeT (MaybeT m) a
-> TreeT m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  TreeT (MaybeT m) a -> MaybeT (TreeT m) a
forall (g :: (* -> *) -> * -> *) (f :: (* -> *) -> * -> *)
       (m :: * -> *) a.
(MonadTransDistributive g, Transformer f g m) =>
g (f m) a -> f (g m) a
distributeT

-- | Returns a tree containing only elements that match the predicate.
--
--   If the root of the tree does not match the predicate then 'Nothing' is
--   returned.
--
filterMaybeT :: (a -> Bool) -> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) a
filterMaybeT :: (a -> Bool)
-> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) a
filterMaybeT p :: a -> Bool
p = (a -> Maybe a)
-> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) a
forall a b.
(a -> Maybe b)
-> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) b
mapMaybeMaybeT ((a -> Bool) -> a -> Maybe a
forall a. (a -> Bool) -> a -> Maybe a
fromPred a -> Bool
p)

mapMaybeMaybeT :: (a -> Maybe b) -> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) b
mapMaybeMaybeT :: (a -> Maybe b)
-> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) b
mapMaybeMaybeT p :: a -> Maybe b
p t :: TreeT (MaybeT Identity) a
t =
  case TreeT (MaybeT Identity) a -> TreeT Identity (Maybe a)
forall (m :: * -> *) a.
Monad m =>
TreeT (MaybeT m) a -> TreeT m (Maybe a)
runTreeMaybeT TreeT (MaybeT Identity) a
t of
    Tree (Node Nothing _) ->
      MaybeT Identity (NodeT (MaybeT Identity) b)
-> TreeT (MaybeT Identity) b
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (MaybeT Identity (NodeT (MaybeT Identity) b)
 -> TreeT (MaybeT Identity) b)
-> (Maybe (NodeT (MaybeT Identity) b)
    -> MaybeT Identity (NodeT (MaybeT Identity) b))
-> Maybe (NodeT (MaybeT Identity) b)
-> TreeT (MaybeT Identity) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (Maybe (NodeT (MaybeT Identity) b))
-> MaybeT Identity (NodeT (MaybeT Identity) b)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Identity (Maybe (NodeT (MaybeT Identity) b))
 -> MaybeT Identity (NodeT (MaybeT Identity) b))
-> (Maybe (NodeT (MaybeT Identity) b)
    -> Identity (Maybe (NodeT (MaybeT Identity) b)))
-> Maybe (NodeT (MaybeT Identity) b)
-> MaybeT Identity (NodeT (MaybeT Identity) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (NodeT (MaybeT Identity) b)
-> Identity (Maybe (NodeT (MaybeT Identity) b))
forall a. a -> Identity a
Identity (Maybe (NodeT (MaybeT Identity) b) -> TreeT (MaybeT Identity) b)
-> Maybe (NodeT (MaybeT Identity) b) -> TreeT (MaybeT Identity) b
forall a b. (a -> b) -> a -> b
$ Maybe (NodeT (MaybeT Identity) b)
forall a. Maybe a
Nothing
    Tree (Node (Just x :: a
x) xs :: [TreeT Identity (Maybe a)]
xs) ->
      case a -> Maybe b
p a
x of
        Nothing -> MaybeT Identity (NodeT (MaybeT Identity) b)
-> TreeT (MaybeT Identity) b
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (MaybeT Identity (NodeT (MaybeT Identity) b)
 -> TreeT (MaybeT Identity) b)
-> (Maybe (NodeT (MaybeT Identity) b)
    -> MaybeT Identity (NodeT (MaybeT Identity) b))
-> Maybe (NodeT (MaybeT Identity) b)
-> TreeT (MaybeT Identity) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (Maybe (NodeT (MaybeT Identity) b))
-> MaybeT Identity (NodeT (MaybeT Identity) b)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Identity (Maybe (NodeT (MaybeT Identity) b))
 -> MaybeT Identity (NodeT (MaybeT Identity) b))
-> (Maybe (NodeT (MaybeT Identity) b)
    -> Identity (Maybe (NodeT (MaybeT Identity) b)))
-> Maybe (NodeT (MaybeT Identity) b)
-> MaybeT Identity (NodeT (MaybeT Identity) b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (NodeT (MaybeT Identity) b)
-> Identity (Maybe (NodeT (MaybeT Identity) b))
forall a. a -> Identity a
Identity (Maybe (NodeT (MaybeT Identity) b) -> TreeT (MaybeT Identity) b)
-> Maybe (NodeT (MaybeT Identity) b) -> TreeT (MaybeT Identity) b
forall a b. (a -> b) -> a -> b
$ Maybe (NodeT (MaybeT Identity) b)
forall a. Maybe a
Nothing
        Just x' :: b
x' ->
          (forall a. Identity a -> MaybeT Identity a)
-> TreeT Identity b -> TreeT (MaybeT Identity) b
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. Identity a -> MaybeT Identity a
forall (m :: * -> *) a. Monad m => Identity a -> m a
generalize (TreeT Identity b -> TreeT (MaybeT Identity) b)
-> TreeT Identity b -> TreeT (MaybeT Identity) b
forall a b. (a -> b) -> a -> b
$
            NodeT Identity b -> TreeT Identity b
forall a. NodeT Identity a -> Tree a
Tree (NodeT Identity b -> TreeT Identity b)
-> ([TreeT Identity b] -> NodeT Identity b)
-> [TreeT Identity b]
-> TreeT Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> [TreeT Identity b] -> NodeT Identity b
forall a. a -> [Tree a] -> Node a
Node b
x' ([TreeT Identity b] -> TreeT Identity b)
-> [TreeT Identity b] -> TreeT Identity b
forall a b. (a -> b) -> a -> b
$
              (TreeT Identity (Maybe a) -> [TreeT Identity b])
-> [TreeT Identity (Maybe a)] -> [TreeT Identity b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((a -> Maybe b) -> TreeT Identity (Maybe a) -> [TreeT Identity b]
forall a b. (a -> Maybe b) -> Tree (Maybe a) -> [Tree b]
flattenTree a -> Maybe b
p) [TreeT Identity (Maybe a)]
xs

flattenTree :: (a -> Maybe b) -> Tree (Maybe a) -> [Tree b]
flattenTree :: (a -> Maybe b) -> Tree (Maybe a) -> [Tree b]
flattenTree p :: a -> Maybe b
p (Tree (Node mx :: Maybe a
mx mxs0 :: [Tree (Maybe a)]
mxs0)) =
  let
    mxs :: [Tree b]
mxs =
      (Tree (Maybe a) -> [Tree b]) -> [Tree (Maybe a)] -> [Tree b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((a -> Maybe b) -> Tree (Maybe a) -> [Tree b]
forall a b. (a -> Maybe b) -> Tree (Maybe a) -> [Tree b]
flattenTree a -> Maybe b
p) [Tree (Maybe a)]
mxs0
  in
    case Maybe a
mx of
      Nothing -> [Tree b]
mxs
      Just x :: a
x ->
        case a -> Maybe b
p a
x of
          Just x' :: b
x' ->
            [NodeT Identity b -> Tree b
forall a. NodeT Identity a -> Tree a
Tree (b -> [Tree b] -> NodeT Identity b
forall a. a -> [Tree a] -> Node a
Node b
x' [Tree b]
mxs)]
          Nothing ->
            [Tree b]
mxs

-- | Returns a tree containing only elements that match the predicate.
--
--   When an element does not match the predicate its node is replaced with
--   'empty'.
--
filterT :: (Monad m, Alternative m) => (a -> Bool) -> TreeT m a -> TreeT m a
filterT :: (a -> Bool) -> TreeT m a -> TreeT m a
filterT p :: a -> Bool
p =
  (a -> Maybe a) -> TreeT m a -> TreeT m a
forall (m :: * -> *) a b.
(Monad m, Alternative m) =>
(a -> Maybe b) -> TreeT m a -> TreeT m b
mapMaybeT ((a -> Bool) -> a -> Maybe a
forall a. (a -> Bool) -> a -> Maybe a
fromPred a -> Bool
p)

mapMaybeT :: (Monad m, Alternative m) => (a -> Maybe b) -> TreeT m a -> TreeT m b
mapMaybeT :: (a -> Maybe b) -> TreeT m a -> TreeT m b
mapMaybeT p :: a -> Maybe b
p m :: TreeT m a
m =
  m (NodeT m b) -> TreeT m b
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m b) -> TreeT m b) -> m (NodeT m b) -> TreeT m b
forall a b. (a -> b) -> a -> b
$ do
    NodeT x :: a
x xs :: [TreeT m a]
xs <- TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m a
m
    case a -> Maybe b
p a
x of
      Just x' :: b
x' ->
        NodeT m b -> m (NodeT m b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeT m b -> m (NodeT m b)) -> NodeT m b -> m (NodeT m b)
forall a b. (a -> b) -> a -> b
$
          b -> [TreeT m b] -> NodeT m b
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT b
x' ((TreeT m a -> TreeT m b) -> [TreeT m a] -> [TreeT m b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Maybe b) -> TreeT m a -> TreeT m b
forall (m :: * -> *) a b.
(Monad m, Alternative m) =>
(a -> Maybe b) -> TreeT m a -> TreeT m b
mapMaybeT a -> Maybe b
p) [TreeT m a]
xs)
      Nothing ->
        m (NodeT m b)
forall (f :: * -> *) a. Alternative f => f a
empty

------------------------------------------------------------------------

-- | All ways a list can be split
--
-- > splits [1,2,3]
-- > ==
-- > [ ([], 1, [2, 3])
--   , ([1], 2, [3])
--   , ([1, 2], 3, [])
--   ]
--
splits :: [a] -> [([a], a, [a])]
splits :: [a] -> [([a], a, [a])]
splits xs0 :: [a]
xs0 =
  let
    go :: [a] -> [b] -> [(a, b, [b])]
go (front :: a
front : fronts :: [a]
fronts) (x :: b
x : xs :: [b]
xs) =
      (a
front, b
x, [b]
xs) (a, b, [b]) -> [(a, b, [b])] -> [(a, b, [b])]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [(a, b, [b])]
go [a]
fronts [b]
xs
    go _ _ =
      []
  in
    [[a]] -> [a] -> [([a], a, [a])]
forall a b. [a] -> [b] -> [(a, b, [b])]
go ([a] -> [[a]]
forall a. [a] -> [[a]]
List.inits [a]
xs0) [a]
xs0

-- | @removes n@ computes all ways we can remove chunks of size @n@ from a list
--
-- Examples
--
-- > removes 1 [1..3] == [[2,3],[1,3],[1,2]]
-- > removes 2 [1..4] == [[3,4],[1,2]]
-- > removes 2 [1..5] == [[3,4,5],[1,2,5],[1,2,3,4]]
-- > removes 3 [1..5] == [[4,5],[1,2,3]]
--
-- Note that the last chunk we delete might have fewer elements than @n@.
removes :: forall a. Int -> [a] -> [[a]]
removes :: Int -> [a] -> [[a]]
removes k :: Int
k = \xs :: [a]
xs -> [a] -> [[a]]
go [a]
xs
  where
    go :: [a] -> [[a]]
    go :: [a] -> [[a]]
go [] = []
    go xs :: [a]
xs = [a]
xs2 [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map ([a]
xs1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++) ([a] -> [[a]]
go [a]
xs2)
      where
        (xs1 :: [a]
xs1, xs2 :: [a]
xs2) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
k [a]
xs

dropSome :: Monad m => [NodeT m a] -> [TreeT m [a]]
dropSome :: [NodeT m a] -> [TreeT m [a]]
dropSome ts :: [NodeT m a]
ts = do
  Int
n   <- (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> Int -> [Int]
forall a. (a -> a) -> a -> [a]
iterate (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2) ([NodeT m a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NodeT m a]
ts)
  [NodeT m a]
ts' <- Int -> [NodeT m a] -> [[NodeT m a]]
forall a. Int -> [a] -> [[a]]
removes Int
n [NodeT m a]
ts
  TreeT m [a] -> [TreeT m [a]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TreeT m [a] -> [TreeT m [a]])
-> (NodeT m [a] -> TreeT m [a]) -> NodeT m [a] -> [TreeT m [a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (NodeT m [a]) -> TreeT m [a]
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m [a]) -> TreeT m [a])
-> (NodeT m [a] -> m (NodeT m [a])) -> NodeT m [a] -> TreeT m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeT m [a] -> m (NodeT m [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeT m [a] -> [TreeT m [a]]) -> NodeT m [a] -> [TreeT m [a]]
forall a b. (a -> b) -> a -> b
$ [NodeT m a] -> NodeT m [a]
forall (m :: * -> *) a. Monad m => [NodeT m a] -> NodeT m [a]
interleave [NodeT m a]
ts'

shrinkOne :: Monad m => [NodeT m a] -> [TreeT m [a]]
shrinkOne :: [NodeT m a] -> [TreeT m [a]]
shrinkOne ts :: [NodeT m a]
ts = do
  (xs :: [NodeT m a]
xs, y0 :: NodeT m a
y0, zs :: [NodeT m a]
zs) <- [NodeT m a] -> [([NodeT m a], NodeT m a, [NodeT m a])]
forall a. [a] -> [([a], a, [a])]
splits [NodeT m a]
ts
  TreeT m a
y1 <- NodeT m a -> [TreeT m a]
forall (m :: * -> *) a. NodeT m a -> [TreeT m a]
nodeChildren NodeT m a
y0
  TreeT m [a] -> [TreeT m [a]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TreeT m [a] -> [TreeT m [a]])
-> (m (NodeT m [a]) -> TreeT m [a])
-> m (NodeT m [a])
-> [TreeT m [a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (NodeT m [a]) -> TreeT m [a]
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m [a]) -> [TreeT m [a]])
-> m (NodeT m [a]) -> [TreeT m [a]]
forall a b. (a -> b) -> a -> b
$ do
    NodeT m a
y2 <- TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m a
y1
    NodeT m [a] -> m (NodeT m [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeT m [a] -> m (NodeT m [a])) -> NodeT m [a] -> m (NodeT m [a])
forall a b. (a -> b) -> a -> b
$
      [NodeT m a] -> NodeT m [a]
forall (m :: * -> *) a. Monad m => [NodeT m a] -> NodeT m [a]
interleave ([NodeT m a]
xs [NodeT m a] -> [NodeT m a] -> [NodeT m a]
forall a. [a] -> [a] -> [a]
++ [NodeT m a
y2] [NodeT m a] -> [NodeT m a] -> [NodeT m a]
forall a. [a] -> [a] -> [a]
++ [NodeT m a]
zs)

interleave :: forall m a. Monad m => [NodeT m a] -> NodeT m [a]
interleave :: [NodeT m a] -> NodeT m [a]
interleave ts :: [NodeT m a]
ts =
  [a] -> [TreeT m [a]] -> NodeT m [a]
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT ((NodeT m a -> a) -> [NodeT m a] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NodeT m a -> a
forall (m :: * -> *) a. NodeT m a -> a
nodeValue [NodeT m a]
ts) ([TreeT m [a]] -> NodeT m [a]) -> [TreeT m [a]] -> NodeT m [a]
forall a b. (a -> b) -> a -> b
$
    [[TreeT m [a]]] -> [TreeT m [a]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
        [NodeT m a] -> [TreeT m [a]]
forall (m :: * -> *) a. Monad m => [NodeT m a] -> [TreeT m [a]]
dropSome [NodeT m a]
ts
      , [NodeT m a] -> [TreeT m [a]]
forall (m :: * -> *) a. Monad m => [NodeT m a] -> [TreeT m [a]]
shrinkOne [NodeT m a]
ts
      ]

------------------------------------------------------------------------

instance Foldable Tree where
  foldMap :: (a -> m) -> Tree a -> m
foldMap f :: a -> m
f (TreeT mx :: Identity (NodeT Identity a)
mx) =
    (a -> m) -> NodeT Identity a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f (Identity (NodeT Identity a) -> NodeT Identity a
forall a. Identity a -> a
runIdentity Identity (NodeT Identity a)
mx)

instance Foldable Node where
  foldMap :: (a -> m) -> Node a -> m
foldMap f :: a -> m
f (NodeT x :: a
x xs :: [TreeT Identity a]
xs) =
    a -> m
f a
x m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` [m] -> m
forall a. Monoid a => [a] -> a
mconcat ((TreeT Identity a -> m) -> [TreeT Identity a] -> [m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> m) -> TreeT Identity a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) [TreeT Identity a]
xs)

instance Traversable Tree where
  traverse :: (a -> f b) -> Tree a -> f (Tree b)
traverse f :: a -> f b
f (TreeT mx :: Identity (NodeT Identity a)
mx) =
    Identity (NodeT Identity b) -> Tree b
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (Identity (NodeT Identity b) -> Tree b)
-> f (Identity (NodeT Identity b)) -> f (Tree b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NodeT Identity a -> f (NodeT Identity b))
-> Identity (NodeT Identity a) -> f (Identity (NodeT Identity b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f b) -> NodeT Identity a -> f (NodeT Identity b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) Identity (NodeT Identity a)
mx

instance Traversable Node where
  traverse :: (a -> f b) -> Node a -> f (Node b)
traverse f :: a -> f b
f (NodeT x :: a
x xs :: [TreeT Identity a]
xs) =
    b -> [TreeT Identity b] -> Node b
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT (b -> [TreeT Identity b] -> Node b)
-> f b -> f ([TreeT Identity b] -> Node b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x f ([TreeT Identity b] -> Node b)
-> f [TreeT Identity b] -> f (Node b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TreeT Identity a -> f (TreeT Identity b))
-> [TreeT Identity a] -> f [TreeT Identity b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f b) -> TreeT Identity a -> f (TreeT Identity b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) [TreeT Identity a]
xs

------------------------------------------------------------------------
-- NodeT/TreeT instances

instance (Eq1 m, Eq a) => Eq (TreeT m a) where
  TreeT m0 :: m (NodeT m a)
m0 == :: TreeT m a -> TreeT m a -> Bool
== TreeT m1 :: m (NodeT m a)
m1 =
    (NodeT m a -> NodeT m a -> Bool)
-> m (NodeT m a) -> m (NodeT m a) -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq NodeT m a -> NodeT m a -> Bool
forall a. Eq a => a -> a -> Bool
(==) m (NodeT m a)
m0 m (NodeT m a)
m1

instance Functor m => Functor (NodeT m) where
  fmap :: (a -> b) -> NodeT m a -> NodeT m b
fmap f :: a -> b
f (NodeT x :: a
x xs :: [TreeT m a]
xs) =
    b -> [TreeT m b] -> NodeT m b
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT (a -> b
f a
x) ((TreeT m a -> TreeT m b) -> [TreeT m a] -> [TreeT m b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> TreeT m a -> TreeT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [TreeT m a]
xs)

instance Functor m => Functor (TreeT m) where
  fmap :: (a -> b) -> TreeT m a -> TreeT m b
fmap f :: a -> b
f =
    m (NodeT m b) -> TreeT m b
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m b) -> TreeT m b)
-> (TreeT m a -> m (NodeT m b)) -> TreeT m a -> TreeT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeT m a -> NodeT m b) -> m (NodeT m a) -> m (NodeT m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> NodeT m a -> NodeT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (m (NodeT m a) -> m (NodeT m b))
-> (TreeT m a -> m (NodeT m a)) -> TreeT m a -> m (NodeT m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT

instance Applicative m => Applicative (NodeT m) where
  pure :: a -> NodeT m a
pure x :: a
x =
    a -> [TreeT m a] -> NodeT m a
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT a
x []
  <*> :: NodeT m (a -> b) -> NodeT m a -> NodeT m b
(<*>) (NodeT ab :: a -> b
ab tabs :: [TreeT m (a -> b)]
tabs) na :: NodeT m a
na@(NodeT a :: a
a tas :: [TreeT m a]
tas) =
    b -> [TreeT m b] -> NodeT m b
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT (a -> b
ab a
a) ([TreeT m b] -> NodeT m b) -> [TreeT m b] -> NodeT m b
forall a b. (a -> b) -> a -> b
$
      (TreeT m (a -> b) -> TreeT m b)
-> [TreeT m (a -> b)] -> [TreeT m b]
forall a b. (a -> b) -> [a] -> [b]
map (TreeT m (a -> b) -> TreeT m a -> TreeT m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (NodeT m a -> TreeT m a
forall (m :: * -> *) a. Applicative m => NodeT m a -> TreeT m a
fromNodeT NodeT m a
na)) [TreeT m (a -> b)]
tabs [TreeT m b] -> [TreeT m b] -> [TreeT m b]
forall a. [a] -> [a] -> [a]
++ (TreeT m a -> TreeT m b) -> [TreeT m a] -> [TreeT m b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> TreeT m a -> TreeT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
ab) [TreeT m a]
tas

instance Applicative m => Applicative (TreeT m) where
  pure :: a -> TreeT m a
pure =
    m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a)
-> (a -> m (NodeT m a)) -> a -> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeT m a -> m (NodeT m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeT m a -> m (NodeT m a))
-> (a -> NodeT m a) -> a -> m (NodeT m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NodeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  <*> :: TreeT m (a -> b) -> TreeT m a -> TreeT m b
(<*>) (TreeT mab :: m (NodeT m (a -> b))
mab) (TreeT ma :: m (NodeT m a)
ma) =
    m (NodeT m b) -> TreeT m b
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m b) -> TreeT m b) -> m (NodeT m b) -> TreeT m b
forall a b. (a -> b) -> a -> b
$
      (NodeT m (a -> b) -> NodeT m a -> NodeT m b)
-> m (NodeT m (a -> b)) -> m (NodeT m a) -> m (NodeT m b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 NodeT m (a -> b) -> NodeT m a -> NodeT m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) m (NodeT m (a -> b))
mab m (NodeT m a)
ma

instance Monad m => Monad (NodeT m) where
  return :: a -> NodeT m a
return =
    a -> NodeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  >>= :: NodeT m a -> (a -> NodeT m b) -> NodeT m b
(>>=) (NodeT x :: a
x xs :: [TreeT m a]
xs) k :: a -> NodeT m b
k =
    case a -> NodeT m b
k a
x of
      NodeT y :: b
y ys :: [TreeT m b]
ys ->
        b -> [TreeT m b] -> NodeT m b
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT b
y ([TreeT m b] -> NodeT m b) -> [TreeT m b] -> NodeT m b
forall a b. (a -> b) -> a -> b
$
          (TreeT m a -> TreeT m b) -> [TreeT m a] -> [TreeT m b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (m (NodeT m b) -> TreeT m b
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m b) -> TreeT m b)
-> (TreeT m a -> m (NodeT m b)) -> TreeT m a -> TreeT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeT m a -> NodeT m b) -> m (NodeT m a) -> m (NodeT m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NodeT m a -> (a -> NodeT m b) -> NodeT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> NodeT m b
k) (m (NodeT m a) -> m (NodeT m b))
-> (TreeT m a -> m (NodeT m a)) -> TreeT m a -> m (NodeT m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT) [TreeT m a]
xs [TreeT m b] -> [TreeT m b] -> [TreeT m b]
forall a. [a] -> [a] -> [a]
++ [TreeT m b]
ys

instance Monad m => Monad (TreeT m) where
  return :: a -> TreeT m a
return =
    a -> TreeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  >>= :: TreeT m a -> (a -> TreeT m b) -> TreeT m b
(>>=) m :: TreeT m a
m k :: a -> TreeT m b
k =
    m (NodeT m b) -> TreeT m b
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m b) -> TreeT m b) -> m (NodeT m b) -> TreeT m b
forall a b. (a -> b) -> a -> b
$ do
      NodeT x :: a
x xs :: [TreeT m a]
xs <- TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m a
m
      NodeT y :: b
y ys :: [TreeT m b]
ys <- TreeT m b -> m (NodeT m b)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT (a -> TreeT m b
k a
x)
      NodeT m b -> m (NodeT m b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeT m b -> m (NodeT m b))
-> ([TreeT m b] -> NodeT m b) -> [TreeT m b] -> m (NodeT m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> [TreeT m b] -> NodeT m b
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT b
y ([TreeT m b] -> m (NodeT m b)) -> [TreeT m b] -> m (NodeT m b)
forall a b. (a -> b) -> a -> b
$
        (TreeT m a -> TreeT m b) -> [TreeT m a] -> [TreeT m b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TreeT m a -> (a -> TreeT m b) -> TreeT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> TreeT m b
k) [TreeT m a]
xs [TreeT m b] -> [TreeT m b] -> [TreeT m b]
forall a. [a] -> [a] -> [a]
++ [TreeT m b]
ys

instance Alternative m => Alternative (TreeT m) where
  empty :: TreeT m a
empty =
    m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT m (NodeT m a)
forall (f :: * -> *) a. Alternative f => f a
empty
  <|> :: TreeT m a -> TreeT m a -> TreeT m a
(<|>) x :: TreeT m a
x y :: TreeT m a
y =
    m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m a
x m (NodeT m a) -> m (NodeT m a) -> m (NodeT m a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m a
y)

instance MonadPlus m => MonadPlus (TreeT m) where
  mzero :: TreeT m a
mzero =
    m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT m (NodeT m a)
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  mplus :: TreeT m a -> TreeT m a -> TreeT m a
mplus x :: TreeT m a
x y :: TreeT m a
y =
    m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m a
x m (NodeT m a) -> m (NodeT m a) -> m (NodeT m a)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m a
y)

zipTreeT :: forall f a b. Applicative f => TreeT f a -> TreeT f b -> TreeT f (a, b)
zipTreeT :: TreeT f a -> TreeT f b -> TreeT f (a, b)
zipTreeT l0 :: TreeT f a
l0@(TreeT left :: f (NodeT f a)
left) r0 :: TreeT f b
r0@(TreeT right :: f (NodeT f b)
right) =
  f (NodeT f (a, b)) -> TreeT f (a, b)
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (f (NodeT f (a, b)) -> TreeT f (a, b))
-> f (NodeT f (a, b)) -> TreeT f (a, b)
forall a b. (a -> b) -> a -> b
$
    let
      zipNodeT :: NodeT f a -> NodeT f b -> NodeT f (a, b)
      zipNodeT :: NodeT f a -> NodeT f b -> NodeT f (a, b)
zipNodeT (NodeT a :: a
a ls :: [TreeT f a]
ls) (NodeT b :: b
b rs :: [TreeT f b]
rs) =
          (a, b) -> [TreeT f (a, b)] -> NodeT f (a, b)
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT (a
a, b
b) ([TreeT f (a, b)] -> NodeT f (a, b))
-> [TreeT f (a, b)] -> NodeT f (a, b)
forall a b. (a -> b) -> a -> b
$
            [[TreeT f (a, b)]] -> [TreeT f (a, b)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
                [TreeT f a -> TreeT f b -> TreeT f (a, b)
forall (f :: * -> *) a b.
Applicative f =>
TreeT f a -> TreeT f b -> TreeT f (a, b)
zipTreeT TreeT f a
l1 TreeT f b
r0 | TreeT f a
l1 <- [TreeT f a]
ls]
              , [TreeT f a -> TreeT f b -> TreeT f (a, b)
forall (f :: * -> *) a b.
Applicative f =>
TreeT f a -> TreeT f b -> TreeT f (a, b)
zipTreeT TreeT f a
l0 TreeT f b
r1 | TreeT f b
r1 <- [TreeT f b]
rs]
              ]
    in
      NodeT f a -> NodeT f b -> NodeT f (a, b)
zipNodeT (NodeT f a -> NodeT f b -> NodeT f (a, b))
-> f (NodeT f a) -> f (NodeT f b -> NodeT f (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (NodeT f a)
left f (NodeT f b -> NodeT f (a, b))
-> f (NodeT f b) -> f (NodeT f (a, b))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (NodeT f b)
right

instance Monad m => MonadZip (TreeT m) where
  mzip :: TreeT m a -> TreeT m b -> TreeT m (a, b)
mzip =
    TreeT m a -> TreeT m b -> TreeT m (a, b)
forall (f :: * -> *) a b.
Applicative f =>
TreeT f a -> TreeT f b -> TreeT f (a, b)
zipTreeT

instance MonadTrans TreeT where
  lift :: m a -> TreeT m a
lift f :: m a
f =
    m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a) -> m (NodeT m a) -> TreeT m a
forall a b. (a -> b) -> a -> b
$
      (a -> NodeT m a) -> m a -> m (NodeT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\x :: a
x -> a -> [TreeT m a] -> NodeT m a
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT a
x []) m a
f

instance MFunctor NodeT where
  hoist :: (forall a. m a -> n a) -> NodeT m b -> NodeT n b
hoist f :: forall a. m a -> n a
f (NodeT x :: b
x xs :: [TreeT m b]
xs) =
    b -> [TreeT n b] -> NodeT n b
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT b
x ((TreeT m b -> TreeT n b) -> [TreeT m b] -> [TreeT n b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. m a -> n a) -> TreeT m b -> TreeT n b
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. m a -> n a
f) [TreeT m b]
xs)

instance MFunctor TreeT where
  hoist :: (forall a. m a -> n a) -> TreeT m b -> TreeT n b
hoist f :: forall a. m a -> n a
f (TreeT m :: m (NodeT m b)
m) =
    n (NodeT n b) -> TreeT n b
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (n (NodeT n b) -> TreeT n b)
-> (m (NodeT n b) -> n (NodeT n b)) -> m (NodeT n b) -> TreeT n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (NodeT n b) -> n (NodeT n b)
forall a. m a -> n a
f (m (NodeT n b) -> TreeT n b) -> m (NodeT n b) -> TreeT n b
forall a b. (a -> b) -> a -> b
$ (NodeT m b -> NodeT n b) -> m (NodeT m b) -> m (NodeT n b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. m a -> n a) -> NodeT m b -> NodeT n b
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. m a -> n a
f) m (NodeT m b)
m

embedNodeT :: Monad m => (t (NodeT t b) -> TreeT m (NodeT t b)) -> NodeT t b -> NodeT m b
embedNodeT :: (t (NodeT t b) -> TreeT m (NodeT t b)) -> NodeT t b -> NodeT m b
embedNodeT f :: t (NodeT t b) -> TreeT m (NodeT t b)
f (NodeT x :: b
x xs :: [TreeT t b]
xs) =
  b -> [TreeT m b] -> NodeT m b
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT b
x ((TreeT t b -> TreeT m b) -> [TreeT t b] -> [TreeT m b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((t (NodeT t b) -> TreeT m (NodeT t b)) -> TreeT t b -> TreeT m b
forall (m :: * -> *) (t :: * -> *) b.
Monad m =>
(t (NodeT t b) -> TreeT m (NodeT t b)) -> TreeT t b -> TreeT m b
embedTreeT t (NodeT t b) -> TreeT m (NodeT t b)
f) [TreeT t b]
xs)

embedTreeT :: Monad m => (t (NodeT t b) -> TreeT m (NodeT t b)) -> TreeT t b -> TreeT m b
embedTreeT :: (t (NodeT t b) -> TreeT m (NodeT t b)) -> TreeT t b -> TreeT m b
embedTreeT f :: t (NodeT t b) -> TreeT m (NodeT t b)
f (TreeT m :: t (NodeT t b)
m) =
  m (NodeT m b) -> TreeT m b
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m b) -> TreeT m b)
-> (NodeT t b -> m (NodeT m b)) -> NodeT t b -> TreeT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeT m b -> m (NodeT m b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeT m b -> m (NodeT m b))
-> (NodeT t b -> NodeT m b) -> NodeT t b -> m (NodeT m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t (NodeT t b) -> TreeT m (NodeT t b)) -> NodeT t b -> NodeT m b
forall (m :: * -> *) (t :: * -> *) b.
Monad m =>
(t (NodeT t b) -> TreeT m (NodeT t b)) -> NodeT t b -> NodeT m b
embedNodeT t (NodeT t b) -> TreeT m (NodeT t b)
f (NodeT t b -> TreeT m b) -> TreeT m (NodeT t b) -> TreeT m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< t (NodeT t b) -> TreeT m (NodeT t b)
f t (NodeT t b)
m

instance MMonad TreeT where
  embed :: (forall a. m a -> TreeT n a) -> TreeT m b -> TreeT n b
embed f :: forall a. m a -> TreeT n a
f m :: TreeT m b
m =
    (m (NodeT m b) -> TreeT n (NodeT m b)) -> TreeT m b -> TreeT n b
forall (m :: * -> *) (t :: * -> *) b.
Monad m =>
(t (NodeT t b) -> TreeT m (NodeT t b)) -> TreeT t b -> TreeT m b
embedTreeT m (NodeT m b) -> TreeT n (NodeT m b)
forall a. m a -> TreeT n a
f TreeT m b
m

distributeNodeT :: Transformer t TreeT m => NodeT (t m) a -> t (TreeT m) a
distributeNodeT :: NodeT (t m) a -> t (TreeT m) a
distributeNodeT (NodeT x :: a
x xs :: [TreeT (t m) a]
xs) =
  t (TreeT m) (t (TreeT m) a) -> t (TreeT m) a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (t (TreeT m) (t (TreeT m) a) -> t (TreeT m) a)
-> ([TreeT m (t (TreeT m) a)] -> t (TreeT m) (t (TreeT m) a))
-> [TreeT m (t (TreeT m) a)]
-> t (TreeT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeT m (t (TreeT m) a) -> t (TreeT m) (t (TreeT m) a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TreeT m (t (TreeT m) a) -> t (TreeT m) (t (TreeT m) a))
-> ([TreeT m (t (TreeT m) a)] -> TreeT m (t (TreeT m) a))
-> [TreeT m (t (TreeT m) a)]
-> t (TreeT m) (t (TreeT m) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeT m (t (TreeT m) a) -> TreeT m (t (TreeT m) a)
forall (m :: * -> *) a. Applicative m => NodeT m a -> TreeT m a
fromNodeT (NodeT m (t (TreeT m) a) -> TreeT m (t (TreeT m) a))
-> ([TreeT m (t (TreeT m) a)] -> NodeT m (t (TreeT m) a))
-> [TreeT m (t (TreeT m) a)]
-> TreeT m (t (TreeT m) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (TreeT m) a
-> [TreeT m (t (TreeT m) a)] -> NodeT m (t (TreeT m) a)
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT (a -> t (TreeT m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) ([TreeT m (t (TreeT m) a)] -> t (TreeT m) a)
-> [TreeT m (t (TreeT m) a)] -> t (TreeT m) a
forall a b. (a -> b) -> a -> b
$
    (TreeT (t m) a -> TreeT m (t (TreeT m) a))
-> [TreeT (t m) a] -> [TreeT m (t (TreeT m) a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t (TreeT m) a -> TreeT m (t (TreeT m) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t (TreeT m) a -> TreeT m (t (TreeT m) a))
-> (TreeT (t m) a -> t (TreeT m) a)
-> TreeT (t m) a
-> TreeT m (t (TreeT m) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeT (t m) a -> t (TreeT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Transformer t TreeT m =>
TreeT (t m) a -> t (TreeT m) a
distributeTreeT) [TreeT (t m) a]
xs

distributeTreeT :: Transformer t TreeT m => TreeT (t m) a -> t (TreeT m) a
distributeTreeT :: TreeT (t m) a -> t (TreeT m) a
distributeTreeT x :: TreeT (t m) a
x =
  NodeT (t m) a -> t (TreeT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Transformer t TreeT m =>
NodeT (t m) a -> t (TreeT m) a
distributeNodeT (NodeT (t m) a -> t (TreeT m) a)
-> t (TreeT m) (NodeT (t m) a) -> t (TreeT m) a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall a. m a -> TreeT m a)
-> t m (NodeT (t m) a) -> t (TreeT m) (NodeT (t m) a)
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. m a -> TreeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TreeT (t m) a -> t m (NodeT (t m) a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT (t m) a
x)

instance MonadTransDistributive TreeT where
  distributeT :: TreeT (f m) a -> f (TreeT m) a
distributeT =
    TreeT (f m) a -> f (TreeT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
Transformer t TreeT m =>
TreeT (t m) a -> t (TreeT m) a
distributeTreeT

instance PrimMonad m => PrimMonad (TreeT m) where
  type PrimState (TreeT m) =
    PrimState m
  primitive :: (State# (PrimState (TreeT m))
 -> (# State# (PrimState (TreeT m)), a #))
-> TreeT m a
primitive =
    m a -> TreeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> TreeT m a)
-> ((State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a)
-> (State# (PrimState m) -> (# State# (PrimState m), a #))
-> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive

instance MonadIO m => MonadIO (TreeT m) where
  liftIO :: IO a -> TreeT m a
liftIO =
    m a -> TreeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> TreeT m a) -> (IO a -> m a) -> IO a -> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance MonadBase b m => MonadBase b (TreeT m) where
  liftBase :: b α -> TreeT m α
liftBase =
    m α -> TreeT m α
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m α -> TreeT m α) -> (b α -> m α) -> b α -> TreeT m α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase

instance MonadThrow m => MonadThrow (TreeT m) where
  throwM :: e -> TreeT m a
throwM =
    m a -> TreeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> TreeT m a) -> (e -> m a) -> e -> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM

handleNodeT :: (Exception e, MonadCatch m) => (e -> TreeT m a) -> NodeT m a -> NodeT m a
handleNodeT :: (e -> TreeT m a) -> NodeT m a -> NodeT m a
handleNodeT onErr :: e -> TreeT m a
onErr (NodeT x :: a
x xs :: [TreeT m a]
xs) =
  a -> [TreeT m a] -> NodeT m a
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT a
x ([TreeT m a] -> NodeT m a) -> [TreeT m a] -> NodeT m a
forall a b. (a -> b) -> a -> b
$
    (TreeT m a -> TreeT m a) -> [TreeT m a] -> [TreeT m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((e -> TreeT m a) -> TreeT m a -> TreeT m a
forall e (m :: * -> *) a.
(Exception e, MonadCatch m) =>
(e -> TreeT m a) -> TreeT m a -> TreeT m a
handleTreeT e -> TreeT m a
onErr) [TreeT m a]
xs

handleTreeT :: (Exception e, MonadCatch m) => (e -> TreeT m a) -> TreeT m a -> TreeT m a
handleTreeT :: (e -> TreeT m a) -> TreeT m a -> TreeT m a
handleTreeT onErr :: e -> TreeT m a
onErr m :: TreeT m a
m =
  m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a)
-> (m (NodeT m a) -> m (NodeT m a)) -> m (NodeT m a) -> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeT m a -> NodeT m a) -> m (NodeT m a) -> m (NodeT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((e -> TreeT m a) -> NodeT m a -> NodeT m a
forall e (m :: * -> *) a.
(Exception e, MonadCatch m) =>
(e -> TreeT m a) -> NodeT m a -> NodeT m a
handleNodeT e -> TreeT m a
onErr) (m (NodeT m a) -> TreeT m a) -> m (NodeT m a) -> TreeT m a
forall a b. (a -> b) -> a -> b
$
    m (NodeT m a) -> (e -> m (NodeT m a)) -> m (NodeT m a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m a
m) (TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT (TreeT m a -> m (NodeT m a))
-> (e -> TreeT m a) -> e -> m (NodeT m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> TreeT m a
onErr)

instance MonadCatch m => MonadCatch (TreeT m) where
  catch :: TreeT m a -> (e -> TreeT m a) -> TreeT m a
catch =
    ((e -> TreeT m a) -> TreeT m a -> TreeT m a)
-> TreeT m a -> (e -> TreeT m a) -> TreeT m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (e -> TreeT m a) -> TreeT m a -> TreeT m a
forall e (m :: * -> *) a.
(Exception e, MonadCatch m) =>
(e -> TreeT m a) -> TreeT m a -> TreeT m a
handleTreeT

localNodeT :: MonadReader r m => (r -> r) -> NodeT m a -> NodeT m a
localNodeT :: (r -> r) -> NodeT m a -> NodeT m a
localNodeT f :: r -> r
f (NodeT x :: a
x xs :: [TreeT m a]
xs) =
  a -> [TreeT m a] -> NodeT m a
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT a
x ([TreeT m a] -> NodeT m a) -> [TreeT m a] -> NodeT m a
forall a b. (a -> b) -> a -> b
$
    (TreeT m a -> TreeT m a) -> [TreeT m a] -> [TreeT m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((r -> r) -> TreeT m a -> TreeT m a
forall r (m :: * -> *) a.
MonadReader r m =>
(r -> r) -> TreeT m a -> TreeT m a
localTreeT r -> r
f) [TreeT m a]
xs

localTreeT :: MonadReader r m => (r -> r) -> TreeT m a -> TreeT m a
localTreeT :: (r -> r) -> TreeT m a -> TreeT m a
localTreeT f :: r -> r
f (TreeT m :: m (NodeT m a)
m) =
  m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a) -> m (NodeT m a) -> TreeT m a
forall a b. (a -> b) -> a -> b
$
    NodeT m a -> m (NodeT m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeT m a -> m (NodeT m a))
-> (NodeT m a -> NodeT m a) -> NodeT m a -> m (NodeT m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> r) -> NodeT m a -> NodeT m a
forall r (m :: * -> *) a.
MonadReader r m =>
(r -> r) -> NodeT m a -> NodeT m a
localNodeT r -> r
f (NodeT m a -> m (NodeT m a)) -> m (NodeT m a) -> m (NodeT m a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (r -> r) -> m (NodeT m a) -> m (NodeT m a)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f m (NodeT m a)
m

instance MonadReader r m => MonadReader r (TreeT m) where
  ask :: TreeT m r
ask =
    m r -> TreeT m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: (r -> r) -> TreeT m a -> TreeT m a
local =
    (r -> r) -> TreeT m a -> TreeT m a
forall r (m :: * -> *) a.
MonadReader r m =>
(r -> r) -> TreeT m a -> TreeT m a
localTreeT

instance MonadState s m => MonadState s (TreeT m) where
  get :: TreeT m s
get =
    m s -> TreeT m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). MonadState s m => m s
get
  put :: s -> TreeT m ()
put =
    m () -> TreeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> TreeT m ()) -> (s -> m ()) -> s -> TreeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
  state :: (s -> (a, s)) -> TreeT m a
state =
    m a -> TreeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> TreeT m a)
-> ((s -> (a, s)) -> m a) -> (s -> (a, s)) -> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> (a, s)) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state

listenNodeT :: MonadWriter w m => w -> NodeT m a -> NodeT m (a, w)
listenNodeT :: w -> NodeT m a -> NodeT m (a, w)
listenNodeT w :: w
w (NodeT x :: a
x xs :: [TreeT m a]
xs) =
  (a, w) -> [TreeT m (a, w)] -> NodeT m (a, w)
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT (a
x, w
w) ([TreeT m (a, w)] -> NodeT m (a, w))
-> [TreeT m (a, w)] -> NodeT m (a, w)
forall a b. (a -> b) -> a -> b
$
    (TreeT m a -> TreeT m (a, w)) -> [TreeT m a] -> [TreeT m (a, w)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (w -> TreeT m a -> TreeT m (a, w)
forall w (m :: * -> *) a.
MonadWriter w m =>
w -> TreeT m a -> TreeT m (a, w)
listenTreeT w
w) [TreeT m a]
xs

listenTreeT :: MonadWriter w m => w -> TreeT m a -> TreeT m (a, w)
listenTreeT :: w -> TreeT m a -> TreeT m (a, w)
listenTreeT w0 :: w
w0 (TreeT m :: m (NodeT m a)
m) =
  m (NodeT m (a, w)) -> TreeT m (a, w)
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m (a, w)) -> TreeT m (a, w))
-> m (NodeT m (a, w)) -> TreeT m (a, w)
forall a b. (a -> b) -> a -> b
$ do
    (x :: NodeT m a
x, w :: w
w) <- m (NodeT m a) -> m (NodeT m a, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen m (NodeT m a)
m
    NodeT m (a, w) -> m (NodeT m (a, w))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeT m (a, w) -> m (NodeT m (a, w)))
-> NodeT m (a, w) -> m (NodeT m (a, w))
forall a b. (a -> b) -> a -> b
$ w -> NodeT m a -> NodeT m (a, w)
forall w (m :: * -> *) a.
MonadWriter w m =>
w -> NodeT m a -> NodeT m (a, w)
listenNodeT (w -> w -> w
forall a. Monoid a => a -> a -> a
mappend w
w0 w
w) NodeT m a
x

-- FIXME This just throws away the writer modification function.
passNodeT :: MonadWriter w m => NodeT m (a, w -> w) -> NodeT m a
passNodeT :: NodeT m (a, w -> w) -> NodeT m a
passNodeT (NodeT (x :: a
x, _) xs :: [TreeT m (a, w -> w)]
xs) =
  a -> [TreeT m a] -> NodeT m a
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT a
x ([TreeT m a] -> NodeT m a) -> [TreeT m a] -> NodeT m a
forall a b. (a -> b) -> a -> b
$
    (TreeT m (a, w -> w) -> TreeT m a)
-> [TreeT m (a, w -> w)] -> [TreeT m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TreeT m (a, w -> w) -> TreeT m a
forall w (m :: * -> *) a.
MonadWriter w m =>
TreeT m (a, w -> w) -> TreeT m a
passTreeT [TreeT m (a, w -> w)]
xs

passTreeT :: MonadWriter w m => TreeT m (a, w -> w) -> TreeT m a
passTreeT :: TreeT m (a, w -> w) -> TreeT m a
passTreeT (TreeT m :: m (NodeT m (a, w -> w))
m) =
  m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a) -> m (NodeT m a) -> TreeT m a
forall a b. (a -> b) -> a -> b
$
    NodeT m a -> m (NodeT m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeT m a -> m (NodeT m a))
-> (NodeT m (a, w -> w) -> NodeT m a)
-> NodeT m (a, w -> w)
-> m (NodeT m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeT m (a, w -> w) -> NodeT m a
forall w (m :: * -> *) a.
MonadWriter w m =>
NodeT m (a, w -> w) -> NodeT m a
passNodeT (NodeT m (a, w -> w) -> m (NodeT m a))
-> m (NodeT m (a, w -> w)) -> m (NodeT m a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (NodeT m (a, w -> w))
m

instance MonadWriter w m => MonadWriter w (TreeT m) where
  writer :: (a, w) -> TreeT m a
writer =
    m a -> TreeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> TreeT m a) -> ((a, w) -> m a) -> (a, w) -> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, w) -> m a
forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer
  tell :: w -> TreeT m ()
tell =
    m () -> TreeT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> TreeT m ()) -> (w -> m ()) -> w -> TreeT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  listen :: TreeT m a -> TreeT m (a, w)
listen =
    w -> TreeT m a -> TreeT m (a, w)
forall w (m :: * -> *) a.
MonadWriter w m =>
w -> TreeT m a -> TreeT m (a, w)
listenTreeT w
forall a. Monoid a => a
mempty
  pass :: TreeT m (a, w -> w) -> TreeT m a
pass =
    TreeT m (a, w -> w) -> TreeT m a
forall w (m :: * -> *) a.
MonadWriter w m =>
TreeT m (a, w -> w) -> TreeT m a
passTreeT

handleErrorNodeT :: MonadError e m => (e -> TreeT m a) -> NodeT m a -> NodeT m a
handleErrorNodeT :: (e -> TreeT m a) -> NodeT m a -> NodeT m a
handleErrorNodeT onErr :: e -> TreeT m a
onErr (NodeT x :: a
x xs :: [TreeT m a]
xs) =
  a -> [TreeT m a] -> NodeT m a
forall (m :: * -> *) a. a -> [TreeT m a] -> NodeT m a
NodeT a
x ([TreeT m a] -> NodeT m a) -> [TreeT m a] -> NodeT m a
forall a b. (a -> b) -> a -> b
$
    (TreeT m a -> TreeT m a) -> [TreeT m a] -> [TreeT m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((e -> TreeT m a) -> TreeT m a -> TreeT m a
forall e (m :: * -> *) a.
MonadError e m =>
(e -> TreeT m a) -> TreeT m a -> TreeT m a
handleErrorTreeT e -> TreeT m a
onErr) [TreeT m a]
xs

handleErrorTreeT :: MonadError e m => (e -> TreeT m a) -> TreeT m a -> TreeT m a
handleErrorTreeT :: (e -> TreeT m a) -> TreeT m a -> TreeT m a
handleErrorTreeT onErr :: e -> TreeT m a
onErr m :: TreeT m a
m =
  m (NodeT m a) -> TreeT m a
forall (m :: * -> *) a. m (NodeT m a) -> TreeT m a
TreeT (m (NodeT m a) -> TreeT m a)
-> (m (NodeT m a) -> m (NodeT m a)) -> m (NodeT m a) -> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeT m a -> NodeT m a) -> m (NodeT m a) -> m (NodeT m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((e -> TreeT m a) -> NodeT m a -> NodeT m a
forall e (m :: * -> *) a.
MonadError e m =>
(e -> TreeT m a) -> NodeT m a -> NodeT m a
handleErrorNodeT e -> TreeT m a
onErr) (m (NodeT m a) -> TreeT m a) -> m (NodeT m a) -> TreeT m a
forall a b. (a -> b) -> a -> b
$
    m (NodeT m a) -> (e -> m (NodeT m a)) -> m (NodeT m a)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m a
m) (TreeT m a -> m (NodeT m a)
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT (TreeT m a -> m (NodeT m a))
-> (e -> TreeT m a) -> e -> m (NodeT m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> TreeT m a
onErr)

instance MonadError e m => MonadError e (TreeT m) where
  throwError :: e -> TreeT m a
throwError =
    m a -> TreeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> TreeT m a) -> (e -> m a) -> e -> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: TreeT m a -> (e -> TreeT m a) -> TreeT m a
catchError =
    ((e -> TreeT m a) -> TreeT m a -> TreeT m a)
-> TreeT m a -> (e -> TreeT m a) -> TreeT m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (e -> TreeT m a) -> TreeT m a -> TreeT m a
forall e (m :: * -> *) a.
MonadError e m =>
(e -> TreeT m a) -> TreeT m a -> TreeT m a
handleErrorTreeT

instance MonadResource m => MonadResource (TreeT m) where
  liftResourceT :: ResourceT IO a -> TreeT m a
liftResourceT =
    m a -> TreeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> TreeT m a)
-> (ResourceT IO a -> m a) -> ResourceT IO a -> TreeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResourceT IO a -> m a
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT

------------------------------------------------------------------------
-- Show/Show1 instances

instance (Show1 m, Show a) => Show (NodeT m a) where
  showsPrec :: Int -> NodeT m a -> ShowS
showsPrec =
    Int -> NodeT m a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1

instance (Show1 m, Show a) => Show (TreeT m a) where
  showsPrec :: Int -> TreeT m a -> ShowS
showsPrec =
    Int -> TreeT m a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1

instance Show1 m => Show1 (NodeT m) where
  liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> NodeT m a -> ShowS
liftShowsPrec sp :: Int -> a -> ShowS
sp sl :: [a] -> ShowS
sl d :: Int
d (NodeT x :: a
x xs :: [TreeT m a]
xs) =
    let
      sp1 :: Int -> TreeT m a -> ShowS
sp1 =
        (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> TreeT m a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl

      sl1 :: [TreeT m a] -> ShowS
sl1 =
        (Int -> a -> ShowS) -> ([a] -> ShowS) -> [TreeT m a] -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
sp [a] -> ShowS
sl

      sp2 :: Int -> [TreeT m a] -> ShowS
sp2 =
        (Int -> TreeT m a -> ShowS)
-> ([TreeT m a] -> ShowS) -> Int -> [TreeT m a] -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> TreeT m a -> ShowS
sp1 [TreeT m a] -> ShowS
sl1
    in
      (Int -> a -> ShowS)
-> (Int -> [TreeT m a] -> ShowS)
-> String
-> Int
-> a
-> [TreeT m a]
-> ShowS
forall a b.
(Int -> a -> ShowS)
-> (Int -> b -> ShowS) -> String -> Int -> a -> b -> ShowS
showsBinaryWith Int -> a -> ShowS
sp Int -> [TreeT m a] -> ShowS
sp2 "NodeT" Int
d a
x [TreeT m a]
xs

instance Show1 m => Show1 (TreeT m) where
  liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> TreeT m a -> ShowS
liftShowsPrec sp :: Int -> a -> ShowS
sp sl :: [a] -> ShowS
sl d :: Int
d (TreeT m :: m (NodeT m a)
m) =
    let
      sp1 :: Int -> NodeT m a -> ShowS
sp1 =
        (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> NodeT m a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl

      sl1 :: [NodeT m a] -> ShowS
sl1 =
        (Int -> a -> ShowS) -> ([a] -> ShowS) -> [NodeT m a] -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
sp [a] -> ShowS
sl

      sp2 :: Int -> m (NodeT m a) -> ShowS
sp2 =
        (Int -> NodeT m a -> ShowS)
-> ([NodeT m a] -> ShowS) -> Int -> m (NodeT m a) -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> NodeT m a -> ShowS
sp1 [NodeT m a] -> ShowS
sl1
    in
      (Int -> m (NodeT m a) -> ShowS)
-> String -> Int -> m (NodeT m a) -> ShowS
forall a. (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith Int -> m (NodeT m a) -> ShowS
sp2 "TreeT" Int
d m (NodeT m a)
m

------------------------------------------------------------------------
-- Pretty Printing

--
-- Rendering implementation based on the one from containers/Data.Tree
--

renderTreeTLines :: Monad m => TreeT m String -> m [String]
renderTreeTLines :: TreeT m String -> m [String]
renderTreeTLines (TreeT m :: m (NodeT m String)
m) = do
  NodeT x :: String
x xs0 :: [TreeT m String]
xs0 <- m (NodeT m String)
m
  [String]
xs <- [TreeT m String] -> m [String]
forall (m :: * -> *). Monad m => [TreeT m String] -> m [String]
renderForestLines [TreeT m String]
xs0
  [String] -> m [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$
    String -> [String]
lines (ShowS
renderNodeT String
x) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
xs

renderNodeT :: String -> String
renderNodeT :: ShowS
renderNodeT xs :: String
xs =
  case String
xs of
    [_] ->
      ' ' Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs
    _ ->
      String
xs

renderForestLines :: Monad m => [TreeT m String] -> m [String]
renderForestLines :: [TreeT m String] -> m [String]
renderForestLines xs0 :: [TreeT m String]
xs0 =
  let
    shift :: [a] -> [a] -> [[a]] -> [[a]]
shift hd :: [a]
hd other :: [a]
other =
      ([a] -> [a] -> [a]) -> [[a]] -> [[a]] -> [[a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([a]
hd [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]]
forall a. a -> [a]
repeat [a]
other)
  in
    case [TreeT m String]
xs0 of
      [] ->
        [String] -> m [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

      [x :: TreeT m String
x] -> do
        [String]
s <- TreeT m String -> m [String]
forall (m :: * -> *). Monad m => TreeT m String -> m [String]
renderTreeTLines TreeT m String
x
        [String] -> m [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$
          String -> String -> [String] -> [String]
forall a. [a] -> [a] -> [[a]] -> [[a]]
shift " └╼" "   " [String]
s

      x :: TreeT m String
x : xs :: [TreeT m String]
xs -> do
        [String]
s <- TreeT m String -> m [String]
forall (m :: * -> *). Monad m => TreeT m String -> m [String]
renderTreeTLines TreeT m String
x
        [String]
ss <- [TreeT m String] -> m [String]
forall (m :: * -> *). Monad m => [TreeT m String] -> m [String]
renderForestLines [TreeT m String]
xs
        [String] -> m [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$
          String -> String -> [String] -> [String]
forall a. [a] -> [a] -> [[a]] -> [[a]]
shift " ├╼" " │ " [String]
s [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ss

-- | Render a tree of strings.
--
render :: Tree String -> String
render :: Tree String -> String
render =
  Identity String -> String
forall a. Identity a -> a
runIdentity (Identity String -> String)
-> (Tree String -> Identity String) -> Tree String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree String -> Identity String
forall (m :: * -> *). Monad m => TreeT m String -> m String
renderT

-- | Render a tree of strings, note that this forces all the delayed effects in
--   the tree.
--
renderT :: Monad m => TreeT m String -> m String
renderT :: TreeT m String -> m String
renderT =
  ([String] -> String) -> m [String] -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> String
unlines (m [String] -> m String)
-> (TreeT m String -> m [String]) -> TreeT m String -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeT m String -> m [String]
forall (m :: * -> *). Monad m => TreeT m String -> m [String]
renderTreeTLines