-- |
-- Module      :  Data.Traversable.Constrained
-- Copyright   :  (c) 2014 Justus Sagemüller
-- License     :  GPL v3 (see COPYING)
-- Maintainer  :  (@) jsag $ hvl.no
-- 
{-# 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)
  
  -- | 'traverse', restricted to endofunctors. May be more efficient to implement.
  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

-- | Flipped version of 'traverse' / 'mapM'.
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


-- | A traversable that can be used with 'mapM'.
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)

-- | Use this if you want to “derive” a constrained traversable instance from a
--   given 'Hask.Traversable' one. (You will not be able to simply set
--   @'traverse' = 'Hask.traverse'@, because the latter requires the Prelude version
--   of 'Hask.Applicative', which can not be inferred from the constrained `Monoidal`.
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)