-- |
-- Module      :  Data.Foldable.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 CPP                          #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses      #-}
#endif
{-# LANGUAGE KindSignatures               #-}
{-# LANGUAGE ScopedTypeVariables          #-}
{-# LANGUAGE TupleSections                #-}


module Data.Foldable.Constrained
           ( Foldable(..)
           , fold
           , traverse_, mapM_, forM_, sequence_
           , concatMap
           ) where


import Control.Category.Constrained
import Control.Functor.Constrained
import Control.Applicative.Constrained

import Prelude hiding (
     id, (.), ($)
   , Functor(..)
   , uncurry, curry
   , mapM_, sequence_, concatMap
   , Foldable(..)
   )

import Data.Semigroup
import Data.Monoid hiding ((<>))
import qualified Data.List as List

import qualified Control.Category.Hask as Hask
import qualified Data.Foldable as Hask
import qualified Control.Arrow as A

import Control.Arrow.Constrained




-- | Foldable class, generalised to use arrows in categories other than 'Hask.->'. This changes the interface
--   somewhat &#x2013; in particular, 'Hask.foldr' relies on currying and hence can't really be expressed in
--   a category without exponential objects; however the monoidal folds come out quite nicely. (Of course,
--   it's debatable how much sense the Hask-'Monoid' class even makes in other categories.)
--   
--   Unlike with the 'Functor' classes, there is no derived instance @'Hask.Foldable' f => 'Foldable' f (->) (->)@:
--   in this case, it would prevent some genarality.
--   See below for how to define such an instance manually.
class (Functor t k l) => Foldable t k l where
  -- |
  -- @
  -- 'ffoldl' &#x2261; 'uncurry' . 'Hask.foldl' . 'curry'
  -- @
  ffoldl :: ( ObjectPair k a b, ObjectPair l a (t b)
            ) => k (a,b) a -> l (a,t b) a
  -- |
  -- @
  -- 'foldMap' &#x2261; 'Hask.foldMap'
  -- @
  foldMap :: ( Object k a, Object l (t a), Semigroup m, Monoid m, Object k m, Object l m )
               => (a `k` m) -> t a `l` m

fold :: (Foldable t k k, Monoid m, Semigroup m, Object k m, Object k (t m)) => t m `k` m
fold :: forall (t :: * -> *) (k :: * -> * -> *) m.
(Foldable t k k, Monoid m, Semigroup m, Object k m,
 Object k (t m)) =>
k (t m) m
fold = forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *) a m.
(Foldable t k l, Object k a, Object l (t a), Semigroup m, Monoid m,
 Object k m, Object l m) =>
k a m -> l (t a) m
foldMap forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id

newtype Endo' k a = Endo' { forall (k :: * -> * -> *) a. Endo' k a -> k a a
runEndo' :: k a a }
instance (Category k, Object k a) => Semigroup (Endo' k a) where
  (Endo' k a a
f) <> :: Endo' k a -> Endo' k a -> Endo' k a
<> (Endo' k a a
g) = forall (k :: * -> * -> *) a. k a a -> Endo' k a
Endo' forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ k a a
f 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 a
g
instance (Category k, Object k a) => Monoid (Endo' k a) where
  mempty :: Endo' k a
mempty = forall (k :: * -> * -> *) a. k a a -> Endo' k a
Endo' forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id
  mappend :: Endo' k a -> Endo' k a -> Endo' k a
mappend = forall a. Semigroup a => a -> a -> a
(<>)

newtype Monoidal_ (r :: * -> * -> *) (s :: * -> * -> *) (f :: * -> *) (u :: *) 
      = Monoidal { forall (r :: * -> * -> *) (s :: * -> * -> *) (f :: * -> *) u.
Monoidal_ r s f u -> f u
runMonoidal :: f u }
instance ( Monoidal f k k, Function k
         , u ~ UnitObject k, Semigroup u, Monoid u 
         , ObjectPair k u u, ObjectPair k (f u) (f u), Object k (f u,f u)
         ) => Semigroup (Monoidal_ k k f u) where
  <> :: Monoidal_ k k f u -> Monoidal_ k k f u -> Monoidal_ k k f u
(<>) = forall (r :: * -> * -> *) (s :: * -> * -> *) (f :: * -> *) u v.
(Monoidal f r s, Function s, ObjectPair r u u,
 ObjectPair s (f u) (f u), Object s (f u, f u), Monoid v,
 u ~ UnitObject r, v ~ UnitObject s) =>
Monoidal_ r s f u -> Monoidal_ r s f u -> Monoidal_ r s f u
mappendMdl
instance ( Monoidal f k k, Function k
         , u ~ UnitObject k, Semigroup u, Monoid u 
         , ObjectPair k u u, ObjectPair k (f u) (f u), Object k (f u,f u)
         ) => Monoid (Monoidal_ k k f u) where
  mempty :: Monoidal_ k k f u
mempty = forall (r :: * -> * -> *) (s :: * -> * -> *) (f :: * -> *) u v.
(Monoidal f r s, Function s, ObjectPair s u u, Monoid v,
 u ~ UnitObject r, v ~ UnitObject s) =>
Monoidal_ r s f u
memptyMdl
  mappend :: Monoidal_ k k f u -> Monoidal_ k k f u -> Monoidal_ k k f u
mappend = forall a. Semigroup a => a -> a -> a
(<>)

memptyMdl :: forall r s f u v . ( Monoidal f r s, Function s
                                , ObjectPair s u u, Monoid v
                                , u~UnitObject r, v~UnitObject s )
               => Monoidal_ r s f u
memptyMdl :: forall (r :: * -> * -> *) (s :: * -> * -> *) (f :: * -> *) u v.
(Monoidal f r s, Function s, ObjectPair s u u, Monoid v,
 u ~ UnitObject r, v ~ UnitObject s) =>
Monoidal_ r s f u
memptyMdl = forall (r :: * -> * -> *) (s :: * -> * -> *) (f :: * -> *) u.
f u -> Monoidal_ r s f u
Monoidal ((forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *).
Monoidal f r t =>
t (UnitObject t) (f (UnitObject r))
pureUnit :: s v (f u)) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Monoid a => a
mempty)
mappendMdl :: forall r s f u v . ( Monoidal f r s, Function s
                                , ObjectPair r u u, ObjectPair s (f u) (f u)
                                , Object s (f u, f u), Monoid v
                                , u~UnitObject r, v~UnitObject s )
               => Monoidal_ r s f u -> Monoidal_ r s f u -> Monoidal_ r s f u
mappendMdl :: forall (r :: * -> * -> *) (s :: * -> * -> *) (f :: * -> *) u v.
(Monoidal f r s, Function s, ObjectPair r u u,
 ObjectPair s (f u) (f u), Object s (f u, f u), Monoid v,
 u ~ UnitObject r, v ~ UnitObject s) =>
Monoidal_ r s f u -> Monoidal_ r s f u -> Monoidal_ r s f u
mappendMdl (Monoidal f u
x) (Monoidal f u
y) 
      = forall (r :: * -> * -> *) (s :: * -> * -> *) (f :: * -> *) u.
f u -> Monoidal_ r s f u
Monoidal (s (f u, f u) (f u)
combine forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (f u
x, f u
y))
 where combine :: s (f u, f u) (f u)
       combine :: s (f u, f u) (f u)
combine = 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 :: * -> * -> *) unit a.
(Cartesian k, unit ~ UnitObject k, ObjectPair k a unit) =>
k (a, unit) a
detachUnit



instance Foldable [] (->) (->) where
  foldMap :: forall a m.
(Object (->) a, Object (->) [a], Semigroup m, Monoid m,
 Object (->) m, Object (->) m) =>
(a -> m) -> [a] -> m
foldMap a -> m
_ [] = forall a. Monoid a => a
mempty
  foldMap a -> m
f (a
x:[a]
xs) = a -> m
f a
x forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *) a m.
(Foldable t k l, Object k a, Object l (t a), Semigroup m, Monoid m,
 Object k m, Object l m) =>
k a m -> l (t a) m
foldMap a -> m
f [a]
xs
  ffoldl :: forall a b.
(ObjectPair (->) a b, ObjectPair (->) a [b]) =>
((a, b) -> a) -> (a, [b]) -> a
ffoldl (a, b) -> a
f = 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
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl (forall (k :: * -> * -> *) a b c.
(Curry k, ObjectPair k a b, ObjectMorphism k b c) =>
k (a, b) c -> k a (k b c)
curry (a, b) -> a
f)

instance Foldable Maybe (->) (->) where
  foldMap :: forall a m.
(Object (->) a, Object (->) (Maybe a), Semigroup m, Monoid m,
 Object (->) m, Object (->) m) =>
(a -> m) -> Maybe a -> m
foldMap a -> m
f Maybe a
Nothing = forall a. Monoid a => a
mempty
  foldMap a -> m
f (Just a
x) = a -> m
f a
x
  ffoldl :: forall a b.
(ObjectPair (->) a b, ObjectPair (->) a (Maybe b)) =>
((a, b) -> a) -> (a, Maybe b) -> a
ffoldl (a, b) -> a
_ (a
i,Maybe b
Nothing) = a
i
  ffoldl (a, b) -> a
f (a
i,Just b
a) = (a, b) -> a
f(a
i,b
a)


instance ( Foldable f s t, WellPointed s, WellPointed t, Functor f (o⊢s) (o⊢t) )
              => Foldable f (o⊢s) (o⊢t) where
  foldMap :: forall a m.
(Object (o ⊢ s) a, Object (o ⊢ t) (f a), Semigroup m, Monoid m,
 Object (o ⊢ s) m, Object (o ⊢ t) m) =>
(⊢) o s a m -> (⊢) o t (f a) m
foldMap (ConstrainedMorphism s a m
f) = forall (k :: * -> * -> *) (o :: * -> Constraint) a b.
k a b -> ConstrainedCategory k o a b
ConstrainedMorphism forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *) a m.
(Foldable t k l, Object k a, Object l (t a), Semigroup m, Monoid m,
 Object k m, Object l m) =>
k a m -> l (t a) m
foldMap s a m
f
  ffoldl :: forall a b.
(ObjectPair (o ⊢ s) a b, ObjectPair (o ⊢ t) a (f b)) =>
(⊢) o s (a, b) a -> (⊢) o t (a, f b) a
ffoldl (ConstrainedMorphism s (a, b) a
f) = forall (k :: * -> * -> *) (o :: * -> Constraint) a b.
k a b -> ConstrainedCategory k o a b
ConstrainedMorphism forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *) a b.
(Foldable t k l, ObjectPair k a b, ObjectPair l a (t b)) =>
k (a, b) a -> l (a, t b) a
ffoldl s (a, b) a
f

-- | Despite the ridiculous-looking signature, this is in fact equivalent
--   to 'Data.Foldable.traverse_' within Hask.
traverse_ :: forall t k l o f a b uk ul .
           ( Foldable t k l, PreArrow k, PreArrow l
           , Monoidal f l l, Monoidal f k k
           , ObjectPair l (f ul) (t a), ObjectPair k (f ul) a
           , ObjectPair l ul (t a), ObjectPair l (t a) ul
           , ObjectPair k b ul, Object k (f b)
           , ObjectPair k (f ul) (f ul), ObjectPair k ul ul
           , uk ~ UnitObject k, ul ~ UnitObject l, uk ~ ul
           ) => a `k` f b -> t a `l` f ul
traverse_ :: forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *) o
       (f :: * -> *) a b uk ul.
(Foldable t k l, PreArrow k, PreArrow l, Monoidal f l l,
 Monoidal f k k, ObjectPair l (f ul) (t a), ObjectPair k (f ul) a,
 ObjectPair l ul (t a), ObjectPair l (t a) ul, ObjectPair k b ul,
 Object k (f b), ObjectPair k (f ul) (f ul), ObjectPair k ul ul,
 uk ~ UnitObject k, ul ~ UnitObject l, uk ~ ul) =>
k a (f b) -> l (t a) (f ul)
traverse_ k a (f b)
f = forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *) a b.
(Foldable t k l, ObjectPair k a b, ObjectPair l a (t b)) =>
k (a, b) a -> l (a, t b) a
ffoldl k (f uk, a) (f uk)
q 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 (a :: * -> * -> *) b d c.
(Morphism a, ObjectPair a b d, ObjectPair a c d) =>
a b c -> a (b, d) (c, d)
first forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *).
Monoidal f r t =>
t (UnitObject t) (f (UnitObject r))
pureUnit 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 (k :: * -> * -> *) a b.
(Cartesian k, ObjectPair k a b, ObjectPair k b a) =>
k (a, b) (b, a)
swap 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 (k :: * -> * -> *) unit a.
(Cartesian k, unit ~ UnitObject k, ObjectPair k a unit) =>
k a (a, unit)
attachUnit
    where q :: k (f uk, a) (f uk)
          q :: k (f uk, a) (f uk)
q = 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 :: * -> * -> *) unit a.
(Cartesian k, unit ~ UnitObject k, ObjectPair k a unit) =>
k (a, unit) a
detachUnit 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 (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second (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.
(PreArrow a, Object a b) =>
a b (UnitObject a)
terminal 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)
  
-- | The distinction between 'mapM_' and 'traverse_' doesn't really make sense
--   on grounds of 'Monoidal' / 'Applicative' vs 'Monad', but it has in fact some
--   benefits to restrict this to endofunctors, to make the constraint list
--   at least somewhat shorter.
mapM_ :: forall t k o f a b u .
           ( Foldable t k k, WellPointed k, Monoidal f k k
           , u ~ UnitObject k
           , ObjectPair k (f u) (t a), ObjectPair k (f u) a
           , ObjectPair k u (t a), ObjectPair k (t a) u
           , ObjectPair k (f u) (f u), ObjectPair k u u
           , ObjectPair k b u, Object k (f b)
           ) => a `k` f b -> t a `k` f u
mapM_ :: forall (t :: * -> *) (k :: * -> * -> *) o (f :: * -> *) a b u.
(Foldable t k k, WellPointed k, Monoidal f k k, u ~ UnitObject k,
 ObjectPair k (f u) (t a), ObjectPair k (f u) a,
 ObjectPair k u (t a), ObjectPair k (t a) u,
 ObjectPair k (f u) (f u), ObjectPair k u u, ObjectPair k b u,
 Object k (f b)) =>
k a (f b) -> k (t a) (f u)
mapM_ = forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *) o
       (f :: * -> *) a b uk ul.
(Foldable t k l, PreArrow k, PreArrow l, Monoidal f l l,
 Monoidal f k k, ObjectPair l (f ul) (t a), ObjectPair k (f ul) a,
 ObjectPair l ul (t a), ObjectPair l (t a) ul, ObjectPair k b ul,
 Object k (f b), ObjectPair k (f ul) (f ul), ObjectPair k ul ul,
 uk ~ UnitObject k, ul ~ UnitObject l, uk ~ ul) =>
k a (f b) -> l (t a) (f ul)
traverse_
       


forM_ :: forall t k l f a b uk ul .
          ( Foldable t k l, Monoidal f l l, Monoidal f k k
          , Function l, Arrow k (->), Arrow l (->), ul ~ UnitObject l
          , uk ~ UnitObject k, uk ~ ul
          , ObjectPair l ul ul, ObjectPair l (f ul) (f ul)
          , ObjectPair l (f ul) (t a), ObjectPair l ul (t a)
          , ObjectPair l (t a) ul, ObjectPair l (f ul) a
          , ObjectPair k b (f b), ObjectPair k b ul
          , ObjectPair k uk uk, ObjectPair k (f uk) a, ObjectPair k (f uk) (f uk)
          ) => t a -> a `k` f b -> f uk
forM_ :: forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *)
       (f :: * -> *) a b uk ul.
(Foldable t k l, Monoidal f l l, Monoidal f k k, Function l,
 Arrow k (->), Arrow l (->), ul ~ UnitObject l, uk ~ UnitObject k,
 uk ~ ul, ObjectPair l ul ul, ObjectPair l (f ul) (f ul),
 ObjectPair l (f ul) (t a), ObjectPair l ul (t a),
 ObjectPair l (t a) ul, ObjectPair l (f ul) a, ObjectPair k b (f b),
 ObjectPair k b ul, ObjectPair k uk uk, ObjectPair k (f uk) a,
 ObjectPair k (f uk) (f uk)) =>
t a -> k a (f b) -> f uk
forM_ t a
v k a (f b)
f = forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *) o
       (f :: * -> *) a b uk ul.
(Foldable t k l, PreArrow k, PreArrow l, Monoidal f l l,
 Monoidal f k k, ObjectPair l (f ul) (t a), ObjectPair k (f ul) a,
 ObjectPair l ul (t a), ObjectPair l (t a) ul, ObjectPair k b ul,
 Object k (f b), ObjectPair k (f ul) (f ul), ObjectPair k ul ul,
 uk ~ UnitObject k, ul ~ UnitObject l, uk ~ ul) =>
k a (f b) -> l (t a) (f ul)
traverse_ k a (f b)
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ t a
v


sequence_ :: forall t k l m a b uk ul . 
             ( Foldable t k l, Arrow k (->), Arrow l (->)
             , uk ~ UnitObject k, ul ~ UnitObject l, uk ~ ul
             , Monoidal m k k, Monoidal m l l
             , ObjectPair k a uk, ObjectPair k (t (m a)) uk
             , ObjectPair k uk uk, ObjectPair k (m uk) (m uk), ObjectPair k (t (m a)) ul
             , ObjectPair l (m ul) (t (m a)), ObjectPair l ul (t (m a))
             , ObjectPair l (m uk) (t (m a)), ObjectPair l (t (m a)) ul
             , ObjectPair k (m uk) (m a)
             ) => t (m a) `l` m uk
sequence_ :: forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *)
       (m :: * -> *) a b uk ul.
(Foldable t k l, Arrow k (->), Arrow l (->), uk ~ UnitObject k,
 ul ~ UnitObject l, uk ~ ul, Monoidal m k k, Monoidal m l l,
 ObjectPair k a uk, ObjectPair k (t (m a)) uk, ObjectPair k uk uk,
 ObjectPair k (m uk) (m uk), ObjectPair k (t (m a)) ul,
 ObjectPair l (m ul) (t (m a)), ObjectPair l ul (t (m a)),
 ObjectPair l (m uk) (t (m a)), ObjectPair l (t (m a)) ul,
 ObjectPair k (m uk) (m a)) =>
l (t (m a)) (m uk)
sequence_ = forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *) o
       (f :: * -> *) a b uk ul.
(Foldable t k l, PreArrow k, PreArrow l, Monoidal f l l,
 Monoidal f k k, ObjectPair l (f ul) (t a), ObjectPair k (f ul) a,
 ObjectPair l ul (t a), ObjectPair l (t a) ul, ObjectPair k b ul,
 Object k (f b), ObjectPair k (f ul) (f ul), ObjectPair k ul ul,
 uk ~ UnitObject k, ul ~ UnitObject l, uk ~ ul) =>
k a (f b) -> l (t a) (f ul)
traverse_ forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id 



concatMap :: (Foldable f k l, Object k a, Object k [b], Object l (f a), Object l [b])
               => a `k` [b] -> f a `l` [b]
concatMap :: forall (f :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *) a b.
(Foldable f k l, Object k a, Object k [b], Object l (f a),
 Object l [b]) =>
k a [b] -> l (f a) [b]
concatMap = forall (t :: * -> *) (k :: * -> * -> *) (l :: * -> * -> *) a m.
(Foldable t k l, Object k a, Object l (t a), Semigroup m, Monoid m,
 Object k m, Object l m) =>
k a m -> l (t a) m
foldMap