{-# LANGUAGE TypeFamilies #-}
module Data.Barbie.Internal.Traversable
( TraversableB(..)
, btraverse_
, bsequence
, bsequence'
, bfoldMap
, CanDeriveTraversableB
, GTraversableB(..)
, gbtraverseDefault
)
where
import Data.Barbie.Internal.Functor (FunctorB(..))
import Data.Functor (void)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Const (Const(..))
import Data.Functor.Identity (Identity(..))
import Data.Generics.GenericN
class FunctorB b => TraversableB b where
btraverse :: Applicative t => (forall a . f a -> t (g a)) -> b f -> t (b g)
default btraverse
:: ( Applicative t, CanDeriveTraversableB b f g)
=> (forall a . f a -> t (g a)) -> b f -> t (b g)
btraverse = gbtraverseDefault
btraverse_ :: (TraversableB b, Applicative t) => (forall a. f a -> t c) -> b f -> t ()
btraverse_ f
= void . btraverse (fmap (const $ Const ()) . f)
bsequence :: (Applicative f, TraversableB b) => b (Compose f g) -> f (b g)
bsequence
= btraverse getCompose
bsequence' :: (Applicative f, TraversableB b) => b f -> f (b Identity)
bsequence'
= btraverse (fmap Identity)
bfoldMap :: (TraversableB b, Monoid m) => (forall a. f a -> m) -> b f -> m
bfoldMap f
= execWr . btraverse_ (tell . f)
type CanDeriveTraversableB b f g
= ( GenericN (b f)
, GenericN (b g)
, GTraversableB f g (RepN (b f)) (RepN (b g))
)
gbtraverseDefault
:: forall b f g t
. (Applicative t, CanDeriveTraversableB b f g)
=> (forall a . f a -> t (g a))
-> b f -> t (b g)
gbtraverseDefault h
= fmap toN . gbtraverse h . fromN
{-# INLINE gbtraverseDefault #-}
class GTraversableB f g repbf repbg where
gbtraverse
:: Applicative t => (forall a . f a -> t (g a)) -> repbf x -> t (repbg x)
instance GTraversableB f g bf bg => GTraversableB f g (M1 i c bf) (M1 i c bg) where
gbtraverse h = fmap M1 . gbtraverse h . unM1
{-# INLINE gbtraverse #-}
instance GTraversableB f g V1 V1 where
gbtraverse _ _ = undefined
{-# INLINE gbtraverse #-}
instance GTraversableB f g U1 U1 where
gbtraverse _ = pure
{-# INLINE gbtraverse #-}
instance (GTraversableB f g l l', GTraversableB f g r r') => GTraversableB f g (l :*: r) (l' :*: r') where
gbtraverse h (l :*: r) = (:*:) <$> gbtraverse h l <*> gbtraverse h r
{-# INLINE gbtraverse #-}
instance (GTraversableB f g l l', GTraversableB f g r r') => GTraversableB f g (l :+: r) (l' :+: r') where
gbtraverse h = \case
L1 l -> L1 <$> gbtraverse h l
R1 r -> R1 <$> gbtraverse h r
{-# INLINE gbtraverse #-}
type P0 = Param 0
instance GTraversableB f g (Rec (P0 f a) (f a))
(Rec (P0 g a) (g a)) where
gbtraverse h = fmap (Rec . K1) . h . unK1 . unRec
{-# INLINE gbtraverse #-}
instance
( SameOrParam b b'
, TraversableB b'
) => GTraversableB f g (Rec (b (P0 f)) (b' f))
(Rec (b (P0 g)) (b' g)) where
gbtraverse h
= fmap (Rec . K1) . btraverse h . unK1 . unRec
{-# INLINE gbtraverse #-}
instance
( SameOrParam h h'
, SameOrParam b b'
, Traversable h'
, TraversableB b'
) => GTraversableB f g (Rec (h (b (P0 f))) (h' (b' f)))
(Rec (h (b (P0 g))) (h' (b' g))) where
gbtraverse h
= fmap (Rec . K1) . traverse (btraverse h) . unK1 . unRec
{-# INLINE gbtraverse #-}
instance GTraversableB f g (Rec a a) (Rec a a) where
gbtraverse _ = pure
{-# INLINE gbtraverse #-}
newtype St s a
= St (s -> (a, s))
runSt :: s -> St s a -> (a, s)
runSt s (St f)
= f s
instance Functor (St s) where
fmap f (St g)
= St $ (\(a, s') -> (f a, s')) . g
{-# INLINE fmap #-}
instance Applicative (St s) where
pure
= St . (,)
{-# INLINE pure #-}
St l <*> St r
= St $ \s ->
let (f, s') = l s
(x, s'') = r s'
in (f x, s'')
{-# INLINE (<*>) #-}
type Wr = St
execWr :: Monoid w => Wr w a -> w
execWr
= snd . runSt mempty
tell :: Monoid w => w -> Wr w ()
tell w
= St (\s -> ((), s `mappend` w))