{-# 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
  , consChild
  , 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 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 (\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 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 a -> [a]
f 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 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 a -> [a]
f 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 a
x [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 Int
n TreeT m a
m =
  if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
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 a
x [TreeT m a]
_ <- 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 a
x [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
- Int
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 Tree a
m =
  let
    NodeT a
_ [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
        Int
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
    Int
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 Tree (Maybe a)
m =
  let
    NodeT Maybe a
mx [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
      Maybe a
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 a
x [Tree a]
xs0) : [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 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 a -> Bool
p 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 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 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 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 a -> Maybe b
p 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 Maybe a
Nothing [TreeT Identity (Maybe a)]
_) ->
      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 a
x) [TreeT Identity (Maybe a)]
xs) ->
      case a -> Maybe b
p a
x of
        Maybe b
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 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 a -> Maybe b
p (Tree (Node Maybe a
mx [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
      Maybe a
Nothing -> [Tree b]
mxs
      Just a
x ->
        case a -> Maybe b
p a
x of
          Just 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)]
          Maybe b
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 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 a -> Maybe b
p 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 a
x [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 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)
      Maybe b
Nothing ->
        m (NodeT m b)
forall (f :: * -> *) a. Alternative f => f a
empty

consChild :: (Monad m) => a -> TreeT m a -> TreeT m a
consChild :: a -> TreeT m a -> TreeT m a
consChild a
a 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 a
x [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)) -> 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 ([TreeT m a] -> NodeT m a) -> [TreeT m a] -> NodeT m a
forall a b. (a -> b) -> a -> b
$
        a -> TreeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a TreeT m a -> [TreeT m a] -> [TreeT m a]
forall a. a -> [a] -> [a]
: [TreeT m a]
xs

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

-- | 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 [a]
xs0 =
  let
    go :: [a] -> [b] -> [(a, b, [b])]
go (a
front : [a]
fronts) (b
x : [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 [a]
_ [b]
_ =
      []
  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 Int
k = \[a]
xs -> [a] -> [[a]]
go [a]
xs
  where
    go :: [a] -> [[a]]
    go :: [a] -> [[a]]
go [] = []
    go [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
        ([a]
xs1, [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 [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
> Int
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` Int
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 [NodeT m a]
ts = do
  ([NodeT m a]
xs, NodeT m a
y0, [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 [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 a -> m
f (TreeT 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 a -> m
f (NodeT a
x [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 a -> f b
f (TreeT 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 a -> f b
f (NodeT a
x [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 m (NodeT m a)
m0 == :: TreeT m a -> TreeT m a -> Bool
== TreeT 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 a -> b
f (NodeT a
x [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 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 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 a -> b
ab [TreeT m (a -> b)]
tabs) na :: NodeT m a
na@(NodeT a
a [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 m (NodeT m (a -> b))
mab) (TreeT 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 a
x [TreeT m a]
xs) a -> NodeT m b
k =
    case a -> NodeT m b
k a
x of
      NodeT b
y [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
(>>=) TreeT m a
m 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 a
x [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 b
y [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
(<|>) TreeT m a
x 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 TreeT m a
x 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 f (NodeT f a)
left) r0 :: TreeT f b
r0@(TreeT 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 [TreeT f a]
ls) (NodeT b
b [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 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 (\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 forall a. m a -> n a
f (NodeT b
x [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 forall a. m a -> n a
f (TreeT 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 t (NodeT t b) -> TreeT m (NodeT t b)
f (NodeT b
x [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 t (NodeT t b) -> TreeT m (NodeT t b)
f (TreeT 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 forall a. m a -> TreeT n a
f 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 a
x [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 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 e -> TreeT m a
onErr (NodeT a
x [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 e -> TreeT m a
onErr 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 r -> r
f (NodeT a
x [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 r -> r
f (TreeT 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 (NodeT a
x [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 w
w0 (TreeT 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
    (NodeT m a
x, 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 (a
x, w -> w
_) [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 (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 e -> TreeT m a
onErr (NodeT a
x [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 e -> TreeT m a
onErr 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 Int -> a -> ShowS
sp [a] -> ShowS
sl Int
d (NodeT a
x [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 String
"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 Int -> a -> ShowS
sp [a] -> ShowS
sl Int
d (TreeT 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 String
"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 (NodeT m String)
m) = do
  NodeT String
x [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 String
xs =
  case String
xs of
    [Char
_] ->
      Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs
    String
_ ->
      String
xs

renderForestLines :: Monad m => [TreeT m String] -> m [String]
renderForestLines :: [TreeT m String] -> m [String]
renderForestLines [TreeT m String]
xs0 =
  let
    shift :: [a] -> [a] -> [[a]] -> [[a]]
shift [a]
hd [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 []

      [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
" └╼" String
"   " [String]
s

      TreeT m String
x : [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
" ├╼" String
" │ " [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