diff --git a/monoidal-functors.cabal b/monoidal-functors.cabal index 70a8e6e..a30eec6 100644 --- a/monoidal-functors.cabal +++ b/monoidal-functors.cabal @@ -78,6 +78,7 @@ library Data.Functor.Module Data.Functor.Monoidal Data.Functor.Monoidal.Specialized + Data.Functor.Traversable Data.Trifunctor.Module Data.Trifunctor.Monoidal diff --git a/src/Data/Functor/Traversable.hs b/src/Data/Functor/Traversable.hs new file mode 100644 index 0000000..b6e350d --- /dev/null +++ b/src/Data/Functor/Traversable.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module Data.Functor.Traversable + ( Traversable (..), + ) +where + +-------------------------------------------------------------------------------- + +import Control.Monad.Identity (Identity (..)) +import Data.Functor.Monoidal (Monoidal, Semigroupal (..), Unital (..)) +import Data.Kind (Constraint, Type) +import GHC.Generics +import Prelude hiding (Traversable (..)) + +-------------------------------------------------------------------------------- + +class Traversable hkd where + sequence :: forall f. (Functor f, Monoidal (->) (,) () (,) () f) => hkd f -> f (hkd Identity) + default sequence :: forall p. (Functor p, Monoidal (->) (,) () (,) () p, Generic (hkd p), Generic (hkd Identity), GTraversable p (Rep (hkd p)) (Rep (hkd Identity))) => hkd p -> p (hkd Identity) + sequence = fmap to . gsequence @p @(Rep (hkd p)) @(Rep (hkd Identity)) . from + +type GTraversable :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) -> Constraint +class GTraversable f g h where + gsequence :: g x -> f (h x) + +instance (Functor f, GTraversable f g h) => GTraversable f (M1 _1 _2 g) (M1 _1 _2 h) where + gsequence :: M1 _1 _2 g x -> f (M1 _1 _2 h x) + gsequence (M1 f) = M1 <$> gsequence @f @g @h f + +instance (Functor f) => GTraversable f (K1 _1 (f a)) (K1 _1 (Identity a)) where + gsequence :: K1 _1 (f a) x -> f (K1 _1 (Identity a) x) + gsequence (K1 f) = fmap (K1 . Identity) f + +instance (Functor f, Monoidal (->) (,) () (,) () f) => GTraversable f U1 U1 where + gsequence :: U1 x -> f (U1 x) + gsequence U1 = U1 <$ introduce @_ @() () + +instance (Functor f, Monoidal (->) (,) () (,) () f, GTraversable f g1 h1, GTraversable f g2 h2) => GTraversable f (g1 :*: g2) (h1 :*: h2) where + gsequence :: (:*:) g1 g2 x -> f ((:*:) h1 h2 x) + gsequence (hkd1 :*: hkd2) = uncurry (:*:) <$> combine @_ @(,) (gsequence hkd1, gsequence hkd2)