{-# 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
( module Control.Applicative.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 = k a (m b) -> k (t a) (m (t b))
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 = k (f a) (f a) -> k (t (f a)) (f (t a))
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 k (f a) (f a)
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 :: k a (f b) -> k [a] (f [b])
traverse k a (f b)
f = ([a] -> f [b]) -> k [a] (f [b])
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 [] = [b] -> k (UnitObject k) (f [b])
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 [] k (UnitObject k) (f [b]) -> k a (f b) -> k (UnitObject k) (f [b])
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ) (d :: κ).
Category k =>
k a b -> k c d -> k a b
`inCategoryOf` k a (f b)
f k (UnitObject k) (f [b]) -> UnitObject k -> f [b]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ UnitObject k
forall a. Monoid a => a
mempty
mM (a
x:[a]
xs) = k (b, [b]) [b] -> k (f b, f [b]) (f [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 (((b, [b]) -> [b]) -> k (b, [b]) [b]
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 (((b, [b]) -> [b]) -> k (b, [b]) [b])
-> ((b, [b]) -> [b]) -> k (b, [b]) [b]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (b -> [b] -> [b]) -> (b, [b]) -> [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(:)) k (f b, f [b]) (f [b]) -> k a (f b) -> k (f b, f [b]) (f [b])
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ) (d :: κ).
Category k =>
k a b -> k c d -> k a b
`inCategoryOf` k a (f b)
f
k (f b, f [b]) (f [b]) -> (f b, f [b]) -> f [b]
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (k a (f b)
f k a (f b) -> a -> f b
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 :: k a (f b) -> k (Maybe a) (f (Maybe b))
traverse k a (f b)
f = (Maybe a -> f (Maybe b)) -> k (Maybe a) (f (Maybe b))
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 = Maybe b -> k (UnitObject k) (f (Maybe b))
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 Maybe b
forall a. Maybe a
Nothing k (UnitObject k) (f (Maybe b))
-> k a (f b) -> k (UnitObject k) (f (Maybe b))
forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ) (d :: κ).
Category k =>
k a b -> k c d -> k a b
`inCategoryOf` k a (f b)
f k (UnitObject k) (f (Maybe b)) -> UnitObject k -> f (Maybe b)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ UnitObject k
forall a. Monoid a => a
mempty
mM (Just a
x) = k b (Maybe b) -> k (f b) (f (Maybe 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 ((b -> Maybe b) -> k b (Maybe b)
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 b -> Maybe b
forall a. a -> Maybe a
Just) k (f b) (f (Maybe b)) -> k a (f b) -> k a (f (Maybe b))
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 k a (f (Maybe b)) -> a -> f (Maybe b)
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 :: s a -> l a (m b) -> m (t b)
forM s a
v l a (m b)
f = l a (m b) -> l (s a) (m (t b))
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 l (s a) (m (t b)) -> s a -> m (t b)
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 { HaskWrapApplicative f x -> f x
getHWAppl :: f x }
instance (Functor f (->) (->)) => Hask.Functor (HaskWrapApplicative f) where
fmap :: (a -> b) -> HaskWrapApplicative f a -> HaskWrapApplicative f b
fmap a -> b
f (HaskWrapApplicative f a
c) = f b -> HaskWrapApplicative f b
forall (f :: * -> *) x. f x -> HaskWrapApplicative f x
HaskWrapApplicative (f b -> HaskWrapApplicative f b) -> f b -> HaskWrapApplicative f b
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (a -> b) -> f a -> f 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 :: a -> HaskWrapApplicative f a
pure a
x = f a -> HaskWrapApplicative f a
forall (f :: * -> *) x. f x -> HaskWrapApplicative f x
HaskWrapApplicative (f a -> HaskWrapApplicative f a) -> f a -> HaskWrapApplicative f a
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ((UnitObject (->) -> a) -> f (UnitObject (->)) -> f a
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 -> UnitObject (->) -> a
forall (a :: * -> * -> *) b x.
(WellPointed a, Object a b, ObjectPoint a x) =>
x -> a b x
const a
x) (f (UnitObject (->)) -> f a)
-> (() -> f (UnitObject (->))) -> () -> f a
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
. () -> f (UnitObject (->))
forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *).
Monoidal f r t =>
t (UnitObject t) (f (UnitObject r))
pureUnit) ()
HaskWrapApplicative f (a -> b)
fs <*> :: HaskWrapApplicative f (a -> b)
-> HaskWrapApplicative f a -> HaskWrapApplicative f b
<*> HaskWrapApplicative f a
xs
= f b -> HaskWrapApplicative f b
forall (f :: * -> *) x. f x -> HaskWrapApplicative f x
HaskWrapApplicative (f b -> HaskWrapApplicative f b) -> f b -> HaskWrapApplicative f b
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ((a -> b, a) -> b) -> (f (a -> b), f a) -> f 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 (((a -> b) -> a -> b) -> (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 (a -> b) -> a -> b
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 :: (a -> f b) -> t a -> f (t b)
haskTraverse a -> f b
f = HaskWrapApplicative f (t b) -> f (t b)
forall (f :: * -> *) x. HaskWrapApplicative f x -> f x
getHWAppl (HaskWrapApplicative f (t b) -> f (t b))
-> (t a -> HaskWrapApplicative f (t b)) -> t a -> f (t b)
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 -> HaskWrapApplicative f b)
-> t a -> HaskWrapApplicative f (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Hask.traverse (f b -> HaskWrapApplicative f b
forall (f :: * -> *) x. f x -> HaskWrapApplicative f x
HaskWrapApplicative (f b -> HaskWrapApplicative f b)
-> (a -> f b) -> a -> HaskWrapApplicative f b
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)