{-# LANGUAGE
DataKinds,
EmptyCase,
FlexibleContexts,
FlexibleInstances,
GADTs,
KindSignatures,
MultiParamTypeClasses,
ScopedTypeVariables,
TypeApplications,
TypeOperators,
UndecidableInstances,
UndecidableSuperClasses #-}
module Generic.Data.Internal.Traversable where
import Control.Applicative (liftA2)
import Data.Kind (Type)
import Data.Monoid
import GHC.Generics
import ApNormalize
gfoldMap :: (Generic1 f, GFoldable (Rep1 f), Monoid m) => (a -> m) -> f a -> m
gfoldMap = \f -> lowerEndoM . gfoldMap_ f . from1
{-# INLINE gfoldMap #-}
gtraverse
:: (Generic1 f, GTraversable (Rep1 f), Applicative m)
=> (a -> m b) -> f a -> m (f b)
gtraverse = \f -> lowerAps . fmap to1 . gtraverse_ (Kleisli f) . from1
{-# INLINE gtraverse #-}
gsequenceA
:: (Generic1 f, GTraversable (Rep1 f), Applicative m)
=> f (m a) -> m (f a)
gsequenceA = lowerAps . fmap to1 . gtraverse_ Refl . from1
{-# INLINE gsequenceA #-}
class GFoldable_ t => GFoldable t
instance GFoldable_ t => GFoldable t
class GTraversable_ t => GTraversable t
instance GTraversable_ t => GTraversable t
class (GFoldMap t, Foldable t) => GFoldable_ t
instance (GFoldMap t, Foldable t) => GFoldable_ t
class (GTraverse Kleisli t, GTraverse Equal t) => GTraversable_ t
instance (GTraverse Kleisli t, GTraverse Equal t) => GTraversable_ t
data Maybe' m = Nothing' | Just' m
type EndoM m = Endo (Maybe' m)
liftEndoM :: Monoid m => m -> EndoM m
liftEndoM x = Endo app where
app Nothing' = Just' x
app (Just' y) = Just' (x `mappend` y)
{-# INLINE liftEndoM #-}
lowerEndoM :: Monoid m => EndoM m -> m
lowerEndoM (Endo app) = lowerMaybe (app Nothing')
{-# INLINE lowerEndoM #-}
lowerMaybe :: Monoid m => Maybe' m -> m
lowerMaybe Nothing' = mempty
lowerMaybe (Just' x) = x
{-# INLINE lowerMaybe #-}
class GFoldMap t where
gfoldMap_ :: Monoid m => (a -> m) -> t a -> EndoM m
instance GFoldMap f => GFoldMap (M1 i c f) where
gfoldMap_ f (M1 x) = gfoldMap_ f x
{-# INLINE gfoldMap_ #-}
instance (GFoldMap f, GFoldMap g) => GFoldMap (f :+: g) where
gfoldMap_ f (L1 x) = gfoldMap_ f x
gfoldMap_ f (R1 y) = gfoldMap_ f y
{-# INLINE gfoldMap_ #-}
instance (GFoldMap f, GFoldMap g) => GFoldMap (f :*: g) where
gfoldMap_ f (x :*: y) = gfoldMap_ f x `mappend` gfoldMap_ f y
{-# INLINE gfoldMap_ #-}
instance GFoldMap U1 where
gfoldMap_ _ _ = mempty
{-# INLINE gfoldMap_ #-}
instance GFoldMap V1 where
gfoldMap_ _ v = case v of {}
{-# INLINE gfoldMap_ #-}
instance GFoldMap (K1 i a) where
gfoldMap_ _ (K1 _) = mempty
{-# INLINE gfoldMap_ #-}
instance GFoldMap Par1 where
gfoldMap_ f (Par1 x) = liftEndoM (f x)
{-# INLINE gfoldMap_ #-}
instance Foldable t => GFoldMap (Rec1 t) where
gfoldMap_ f (Rec1 x) = liftEndoM (foldMap f x)
{-# INLINE gfoldMap_ #-}
instance (Foldable t, Foldable f) => GFoldMap (t :.: f) where
gfoldMap_ f (Comp1 x) = liftEndoM (foldMap (foldMap f) x)
{-# INLINE gfoldMap_ #-}
data Equal (f :: Type -> Type) a b where
Refl :: Equal f (f b) b
newtype Kleisli f a b = Kleisli (a -> f b)
class GTraverse arr t where
gtraverse_ :: Applicative f => arr f a b -> t a -> Aps f (t b)
instance GTraverse arr f => GTraverse arr (M1 i c f) where
gtraverse_ f (M1 x) = M1 <$> gtraverse_ f x
{-# INLINE gtraverse_ #-}
instance (GTraverse arr f, GTraverse arr g) => GTraverse arr (f :+: g) where
gtraverse_ f (L1 x) = L1 <$> gtraverse_ f x
gtraverse_ f (R1 y) = R1 <$> gtraverse_ f y
{-# INLINE gtraverse_ #-}
instance (GTraverse arr f, GTraverse arr g) => GTraverse arr (f :*: g) where
gtraverse_ f (x :*: y) = liftA2 (:*:) (gtraverse_ f x) (gtraverse_ f y)
{-# INLINE gtraverse_ #-}
instance GTraverse arr U1 where
gtraverse_ _ _ = pure U1
{-# INLINE gtraverse_ #-}
instance GTraverse arr V1 where
gtraverse_ _ v = case v of {}
{-# INLINE gtraverse_ #-}
instance GTraverse arr (K1 i a) where
gtraverse_ _ (K1 x) = pure (K1 x)
{-# INLINE gtraverse_ #-}
instance GTraverse Kleisli Par1 where
gtraverse_ (Kleisli f) (Par1 x) = Par1 <$> liftAps (f x)
{-# INLINE gtraverse_ #-}
instance Traversable t => GTraverse Kleisli (Rec1 t) where
gtraverse_ (Kleisli f) (Rec1 x) = Rec1 <$> liftAps (traverse f x)
{-# INLINE gtraverse_ #-}
instance (Traversable t, Traversable f) => GTraverse Kleisli (t :.: f) where
gtraverse_ (Kleisli f) (Comp1 x) = Comp1 <$> liftAps (traverse (traverse f) x)
{-# INLINE gtraverse_ #-}
instance GTraverse Equal Par1 where
gtraverse_ Refl (Par1 x) = Par1 <$> liftAps x
{-# INLINE gtraverse_ #-}
instance Traversable t => GTraverse Equal (Rec1 t) where
gtraverse_ Refl (Rec1 x) = Rec1 <$> liftAps (sequenceA x)
{-# INLINE gtraverse_ #-}
instance (Traversable t, Traversable f) => GTraverse Equal (t :.: f) where
gtraverse_ Refl (Comp1 x) = Comp1 <$> liftAps (traverse sequenceA x)
{-# INLINE gtraverse_ #-}