-- |
-- Module      :  Control.Applicative.Constrained
-- Copyright   :  (c) 2013 Justus Sagemüller
-- License     :  GPL v3 (see COPYING)
-- Maintainer  :  (@) jsag $ hvl.no
-- 
{-# LANGUAGE ConstraintKinds              #-}
{-# LANGUAGE TypeFamilies                 #-}
{-# LANGUAGE TypeOperators                #-}
{-# LANGUAGE FunctionalDependencies       #-}
{-# LANGUAGE FlexibleContexts             #-}
{-# LANGUAGE FlexibleInstances            #-}
{-# LANGUAGE ScopedTypeVariables          #-}
{-# LANGUAGE CPP                          #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE UndecidableSuperClasses      #-}
#endif


module Control.Applicative.Constrained ( 
            module Control.Functor.Constrained
            -- * Monoidal / applicative functors
          , Monoidal(..)
          , Applicative(..)
            -- * Helper for constrained categories
          , constrainedFZipWith
            -- * Utility functions
          , constPure, fzip, (<**>), liftA, liftA2, liftA3
          ) where


import Control.Category.Constrained
import Control.Functor.Constrained
import Control.Arrow.Constrained

import Prelude hiding (id, const, (.), ($), Functor(..), Applicative(..), curry, uncurry)
import qualified Control.Category.Hask as Hask


class (Functor f r t, Cartesian r, Cartesian t, Object t (f (UnitObject r)))
               => Monoidal f r t where
  pureUnit :: UnitObject t `t` f (UnitObject r)
  fzipWith :: (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)

constPure :: (WellPointed r, Monoidal f r t, ObjectPoint r a, Object t (f a) )
       => a -> t (UnitObject t) (f a)
constPure :: 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 a
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 (forall (a :: * -> * -> *) b x.
(WellPointed a, Object a b, ObjectPoint a x) =>
x -> a b x
const a
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
. forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *).
Monoidal f r t =>
t (UnitObject t) (f (UnitObject r))
pureUnit

fzip :: (Monoidal f r t, ObjectPair r a b, ObjectPair t (f a) (f b), Object t (f (a,b)))
        => t (f a, f b) (f (a,b))
fzip :: forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Monoidal f r t, ObjectPair r a b, ObjectPair t (f a) (f b),
 Object t (f (a, b))) =>
t (f a, f b) (f (a, b))
fzip = 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 :: κ).
(Category k, Object k a) =>
k a a
id

class (Monoidal f r t, Curry r, Curry t) => Applicative f r t where
  -- ^ Note that this tends to make little sense for non-endofunctors. 
  --   Consider using 'constPure' instead.
  pure :: (Object r a, Object t (f a)) => a `t` f a 
  
  (<*>) :: ( ObjectMorphism r a b
           , ObjectMorphism t (f a) (f b), Object t (t (f a) (f b))
           , ObjectPair r (r a b) a, ObjectPair t (f (r a b)) (f a)
           , Object r a, Object r b )
       => f (r a b) `t` t (f a) (f b)
  (<*>) = 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 (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 (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 :: κ).
(Category k, Object k a) =>
k a a
id)

infixl 4 <*>, <**>
  
(<**>) :: ( Applicative f r (->), ObjectMorphism r a b, ObjectPair r (r a b) a )
             => f a -> f (r a b) -> f b
<**> :: forall (f :: * -> *) (r :: * -> * -> *) a b.
(Applicative f r (->), ObjectMorphism r a b,
 ObjectPair r (r a b) a) =>
f a -> f (r a b) -> f b
(<**>) = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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, b) c -> k a (k b c)
curry (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 (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 :: κ).
(Category k, Object k a) =>
k a a
id)

liftA :: (Applicative f r t, Object r a, Object r b, Object t (f a), Object t (f b)) 
             => a `r` b -> f a `t` f b
liftA :: forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Applicative f r t, Object r a, Object r b, Object t (f a),
 Object t (f b)) =>
r a b -> t (f a) (f b)
liftA = 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

liftA2 :: ( Applicative f r t, Object r c, ObjectMorphism r b c
          , Object t (f c), ObjectMorphism t (f b) (f c) 
          , ObjectPair r a b, ObjectPair t (f a) (f b) ) 
             => a `r` (b `r` c) -> f a `t` (f b `t` f c)
liftA2 :: forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) c b a.
(Applicative f r t, Object r c, ObjectMorphism r b c,
 Object t (f c), ObjectMorphism t (f b) (f c), ObjectPair r a b,
 ObjectPair t (f a) (f b)) =>
r a (r b c) -> t (f a) (t (f b) (f c))
liftA2 = 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 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 :: * -> * -> *) 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 :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. 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

liftA3 :: ( Applicative f r t
          , Object r c, Object r d
          , ObjectMorphism r c d, ObjectMorphism r b (c`r`d), Object r (r c d)
          , ObjectPair r a b, ObjectPair r (r c d) c 
          , Object t (f c), Object t (f d), Object t(f a,f b)
          , ObjectMorphism t (f c)(f d),ObjectMorphism t (f b)(t(f c)(f d)),Object t(t(f c)(f d))
          , ObjectPair t (f a) (f b), ObjectPair t (t (f c) (f d)) (f c)
          , ObjectPair t (f (r c d)) (f c)
          ) => a `r` (b `r` (c `r` d)) -> f a `t` (f b `t` (f c `t` f d))
liftA3 :: forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) c d b a.
(Applicative f r t, Object r c, Object r d, ObjectMorphism r c d,
 ObjectMorphism r b (r c d), Object r (r c d), ObjectPair r a b,
 ObjectPair r (r c d) c, Object t (f c), Object t (f d),
 Object t (f a, f b), ObjectMorphism t (f c) (f d),
 ObjectMorphism t (f b) (t (f c) (f d)), Object t (t (f c) (f d)),
 ObjectPair t (f a) (f b), ObjectPair t (t (f c) (f d)) (f c),
 ObjectPair t (f (r c d)) (f c)) =>
r a (r b (r c d)) -> t (f a) (t (f b) (t (f c) (f d)))
liftA3 r a (r b (r c d))
f = 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 forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Applicative f r t, ObjectMorphism r a b,
 ObjectMorphism t (f a) (f b), Object t (t (f a) (f b)),
 ObjectPair r (r a b) a, ObjectPair t (f (r a b)) (f a), Object r a,
 Object r b) =>
t (f (r a b)) (t (f a) (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
. (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 (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 r a (r b (r c d))
f)


constrainedFZipWith :: ( Category r, Category t, o a, o b, o (a,b), o c
                                               , o (f a, f b), o (f c) )
        =>  (   r  (a, b) c ->    t  (f a, f b) (f c) )
          -> (o⊢r) (a, b) c -> (o⊢t) (f a, f b) (f c)
constrainedFZipWith :: forall (r :: * -> * -> *) (t :: * -> * -> *) (o :: * -> Constraint)
       a b c (f :: * -> *).
(Category r, Category t, o a, o b, o (a, b), o c, o (f a, f b),
 o (f c)) =>
(r (a, b) c -> t (f a, f b) (f c))
-> (⊢) o r (a, b) c -> (⊢) o t (f a, f b) (f c)
constrainedFZipWith r (a, b) c -> t (f a, f b) (f c)
zf = forall (o :: * -> Constraint) (k :: * -> * -> *) a b.
(Category k, o a, o b) =>
k a b -> (⊢) o k a b
constrained 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
. r (a, b) c -> t (f a, f b) (f c)
zf 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 (o :: * -> Constraint) (k :: * -> * -> *) a b.
Category k =>
(⊢) o k a b -> k a b
unconstrained
         

instance (Hask.Applicative f) => Monoidal f (->) (->) where
  pureUnit :: UnitObject (->) -> f (UnitObject (->))
pureUnit = forall (f :: * -> *) a. Applicative f => a -> f a
Hask.pure
  fzipWith :: forall a b c.
(ObjectPair (->) a b, Object (->) c, ObjectPair (->) (f a) (f b),
 Object (->) (f c)) =>
((a, b) -> c) -> (f a, f b) -> f c
fzipWith (a, b) -> c
f (f a
p, f b
q) = 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) -> c
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Hask.<$> f a
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
Hask.<*> f b
q

instance (Hask.Applicative f) => Applicative f (->) (->) where
  pure :: forall a. (Object (->) a, Object (->) (f a)) => a -> f a
pure = forall (f :: * -> *) a. Applicative f => a -> f a
Hask.pure
  <*> :: forall a b.
(ObjectMorphism (->) a b, ObjectMorphism (->) (f a) (f b),
 Object (->) (f a -> f b), ObjectPair (->) (a -> b) a,
 ObjectPair (->) (f (a -> b)) (f a), Object (->) a,
 Object (->) b) =>
f (a -> b) -> (f a -> f b)
(<*>) = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(Hask.<*>)