{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses #-}
#endif
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Data.Traversable.Constrained
( Traversable(..)
, forM
, EndoTraversable
, haskTraverse
) where
import Control.Category.Constrained
import Control.Applicative.Constrained
import Prelude hiding (
id, const, (.), ($)
, Functor(..)
, uncurry, curry
, mapM, mapM_, sequence
, Traversable(..)
, Applicative(..)
)
import qualified Control.Category.Hask as Hask
import qualified Control.Arrow as A
import qualified Data.Traversable as Hask
import Control.Arrow.Constrained
import Data.Monoid
import GHC.Exts (Constraint)
class (Category k, Category l, Functor s l l, Functor t k k)
=> Traversable s t k l | s k l -> t, t k l -> s, s t k -> l, s t l -> k where
type TraversalObject k t b :: Constraint
type TraversalObject k t b = ()
traverse :: ( Monoidal f k l, Object l a, Object l (s a)
, ObjectPair k b (t b), ObjectPair l (f b) (f (t b))
, TraversalObject k t b
) => a `l` f b -> s a `l` f (t b)
mapM :: ( k~l, s~t, Applicative m k k
, Object k a, Object k (t a), ObjectPair k b (t b), ObjectPair k (m b) (m (t b))
, TraversalObject k t b
) => a `k` m b -> t a `k` m (t b)
mapM = forall (s :: * -> *) (t :: * -> *) (k :: * -> * -> *)
(l :: * -> * -> *) (f :: * -> *) a b.
(Traversable s t k l, Monoidal f k l, Object l a, Object l (s a),
ObjectPair k b (t b), ObjectPair l (f b) (f (t b)),
TraversalObject k t b) =>
l a (f b) -> l (s a) (f (t b))
traverse
sequence :: ( k~l, s~t, Monoidal f k k
, ObjectPair k a (t a), ObjectPair k (f a) (f (t a))
, Object k (t (f a))
, TraversalObject k t a
) => t (f a) `k` f (t a)
sequence = forall (s :: * -> *) (t :: * -> *) (k :: * -> * -> *)
(l :: * -> * -> *) (f :: * -> *) a b.
(Traversable s t k l, Monoidal f k l, Object l a, Object l (s a),
ObjectPair k b (t b), ObjectPair l (f b) (f (t b)),
TraversalObject k t b) =>
l a (f b) -> l (s a) (f (t b))
traverse forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id
instance (Arrow k (->), WellPointed k, Function k, Functor [] k k)
=> Traversable [] [] k k where
type TraversalObject k [] b = PointObject k [b]
traverse :: forall (f :: * -> *) a b.
(Monoidal f k k, Object k a, Object k [a], ObjectPair k b [b],
ObjectPair k (f b) (f [b]), TraversalObject k [] b) =>
k a (f b) -> k [a] (f [b])
traverse k a (f b)
f = forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
Object a c) =>
k b c -> a b c
arr [a] -> f [b]
mM
where mM :: [a] -> f [b]
mM [] = forall (r :: * -> * -> *) (f :: * -> *) (t :: * -> * -> *) a.
(WellPointed r, Monoidal f r t, ObjectPoint r a, Object t (f a)) =>
a -> t (UnitObject t) (f a)
constPure [] forall {κ} (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ) (d :: κ).
Category k =>
k a b -> k c d -> k a b
`inCategoryOf` k a (f b)
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Monoid a => a
mempty
mM (a
x:[a]
xs) = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b c.
(Monoidal f r t, ObjectPair r a b, Object r c,
ObjectPair t (f a) (f b), Object t (f c)) =>
r (a, b) c -> t (f a, f b) (f c)
fzipWith (forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
Object a c) =>
k b c -> a b c
arr forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (k :: * -> * -> *) a b c.
(Curry k, ObjectPair k a b, ObjectMorphism k b c) =>
k a (k b c) -> k (a, b) c
uncurry(:)) forall {κ} (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ) (d :: κ).
Category k =>
k a b -> k c d -> k a b
`inCategoryOf` k a (f b)
f
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (k a (f b)
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ a
x, [a] -> f [b]
mM [a]
xs)
instance (Arrow k (->), WellPointed k, Function k, Functor Maybe k k)
=> Traversable Maybe Maybe k k where
type TraversalObject k Maybe b = PointObject k (Maybe b)
traverse :: forall (f :: * -> *) a b.
(Monoidal f k k, Object k a, Object k (Maybe a),
ObjectPair k b (Maybe b), ObjectPair k (f b) (f (Maybe b)),
TraversalObject k Maybe b) =>
k a (f b) -> k (Maybe a) (f (Maybe b))
traverse k a (f b)
f = forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
Object a c) =>
k b c -> a b c
arr Maybe a -> f (Maybe b)
mM
where mM :: Maybe a -> f (Maybe b)
mM Maybe a
Nothing = forall (r :: * -> * -> *) (f :: * -> *) (t :: * -> * -> *) a.
(WellPointed r, Monoidal f r t, ObjectPoint r a, Object t (f a)) =>
a -> t (UnitObject t) (f a)
constPure forall a. Maybe a
Nothing forall {κ} (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ) (d :: κ).
Category k =>
k a b -> k c d -> k a b
`inCategoryOf` k a (f b)
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Monoid a => a
mempty
mM (Just a
x) = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
Object a c) =>
k b c -> a b c
arr forall a. a -> Maybe a
Just) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. k a (f b)
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ a
x
forM :: forall s t k m a b l .
( Traversable s t k l, Monoidal m k l, Function l
, Object k b, Object k (t b), ObjectPair k b (t b)
, Object l a, Object l (s a), ObjectPair l (m b) (m (t b))
, TraversalObject k t b
) => s a -> (a `l` m b) -> m (t b)
forM :: forall (s :: * -> *) (t :: * -> *) (k :: * -> * -> *) (m :: * -> *)
a b (l :: * -> * -> *).
(Traversable s t k l, Monoidal m k l, Function l, Object k b,
Object k (t b), ObjectPair k b (t b), Object l a, Object l (s a),
ObjectPair l (m b) (m (t b)), TraversalObject k t b) =>
s a -> l a (m b) -> m (t b)
forM s a
v l a (m b)
f = forall (s :: * -> *) (t :: * -> *) (k :: * -> * -> *)
(l :: * -> * -> *) (f :: * -> *) a b.
(Traversable s t k l, Monoidal f k l, Object l a, Object l (s a),
ObjectPair k b (t b), ObjectPair l (f b) (f (t b)),
TraversalObject k t b) =>
l a (f b) -> l (s a) (f (t b))
traverse l a (m b)
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ s a
v
type EndoTraversable t k = Traversable t t k k
newtype HaskWrapApplicative f x = HaskWrapApplicative { forall (f :: * -> *) x. HaskWrapApplicative f x -> f x
getHWAppl :: f x }
instance (Functor f (->) (->)) => Hask.Functor (HaskWrapApplicative f) where
fmap :: forall a b.
(a -> b) -> HaskWrapApplicative f a -> HaskWrapApplicative f b
fmap a -> b
f (HaskWrapApplicative f a
c) = forall (f :: * -> *) x. f x -> HaskWrapApplicative f x
HaskWrapApplicative forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
Object t (f b)) =>
r a b -> t (f a) (f b)
fmap a -> b
f f a
c
instance (Monoidal f (->) (->)) => Hask.Applicative (HaskWrapApplicative f) where
pure :: forall a. a -> HaskWrapApplicative f a
pure a
x = forall (f :: * -> *) x. f x -> HaskWrapApplicative f x
HaskWrapApplicative forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall (a :: * -> * -> *) b x.
(WellPointed a, Object a b, ObjectPoint a x) =>
x -> a b x
const a
x) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *).
Monoidal f r t =>
t (UnitObject t) (f (UnitObject r))
pureUnit) ()
HaskWrapApplicative f (a -> b)
fs <*> :: forall a b.
HaskWrapApplicative f (a -> b)
-> HaskWrapApplicative f a -> HaskWrapApplicative f b
<*> HaskWrapApplicative f a
xs
= forall (f :: * -> *) x. f x -> HaskWrapApplicative f x
HaskWrapApplicative forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b c.
(Monoidal f r t, ObjectPair r a b, Object r c,
ObjectPair t (f a) (f b), Object t (f c)) =>
r (a, b) c -> t (f a, f b) (f c)
fzipWith (forall (k :: * -> * -> *) a b c.
(Curry k, ObjectPair k a b, ObjectMorphism k b c) =>
k a (k b c) -> k (a, b) c
uncurry forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
($)) (f (a -> b)
fs, f a
xs)
haskTraverse :: (Hask.Traversable t, Monoidal f (->) (->))
=> (a -> f b) -> t a -> f (t b)
haskTraverse :: forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Monoidal f (->) (->)) =>
(a -> f b) -> t a -> f (t b)
haskTraverse a -> f b
f = forall (f :: * -> *) x. HaskWrapApplicative f x -> f x
getHWAppl forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Hask.traverse (forall (f :: * -> *) x. f x -> HaskWrapApplicative f x
HaskWrapApplicative forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. a -> f b
f)