-- |
-- 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.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) => 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 :: a -> t (UnitObject t) (f a)
constPure a
a = r (UnitObject r) a -> t (f (UnitObject r)) (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 -> r (UnitObject r) a
forall (a :: * -> * -> *) b x.
(WellPointed a, Object a b, ObjectPoint a x) =>
x -> a b x
const a
a) t (f (UnitObject r)) (f a)
-> t (UnitObject t) (f (UnitObject r)) -> t (UnitObject t) (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
. t (UnitObject t) (f (UnitObject r))
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 :: t (f a, f b) (f (a, b))
fzip = r (a, b) (a, b) -> t (f a, f b) (f (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 r (a, b) (a, b)
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)
  (<*>) = t (f (r a b), f a) (f b) -> t (f (r a b)) (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 (r (r a b, a) b -> t (f (r 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 (r (r a b, a) b -> t (f (r a b), f a) (f b))
-> r (r a b, a) b -> t (f (r a b), f a) (f b)
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ r (r a b) (r a b) -> r (r 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 (r a b) (r a b)
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
<**> :: f a -> f (r a b) -> f b
(<**>) = (f (r a b) -> f a -> f b) -> f a -> f (r a b) -> f b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((f (r a b) -> f a -> f b) -> f a -> f (r a b) -> f b)
-> (f (r a b) -> f a -> f b) -> f a -> f (r a b) -> f b
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ ((f (r a b), f a) -> f b) -> f (r a b) -> 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 (r (r a b, a) b -> (f (r 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 (r (r a b, a) b -> (f (r a b), f a) -> f b)
-> r (r a b, a) b -> (f (r a b), f a) -> f b
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ r (r a b) (r a b) -> r (r 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 (r a b) (r a b)
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 :: r a b -> t (f a) (f b)
liftA = r a b -> t (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

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 :: r a (r b c) -> t (f a) (t (f b) (f c))
liftA2 = t (f a, f b) (f c) -> t (f a) (t (f b) (f c))
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 (t (f a, f b) (f c) -> t (f a) (t (f b) (f c)))
-> (r a (r b c) -> t (f a, f b) (f c))
-> r a (r b c)
-> t (f a) (t (f b) (f c))
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)
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 (r (a, b) c -> t (f a, f b) (f c))
-> (r a (r b c) -> r (a, b) c) -> r a (r b c) -> t (f a, f b) (f c)
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 (r b c) -> r (a, b) 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 :: 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 = t (f a, f b) (t (f c) (f d)) -> t (f a) (t (f b) (t (f c) (f d)))
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 (t (f a, f b) (t (f c) (f d)) -> t (f a) (t (f b) (t (f c) (f d))))
-> t (f a, f b) (t (f c) (f d))
-> t (f a) (t (f b) (t (f c) (f d)))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ t (f (r c d)) (t (f c) (f d))
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))
(<*>) t (f (r c d)) (t (f c) (f d))
-> t (f a, f b) (f (r c d)) -> t (f a, f b) (t (f c) (f d))
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) (r c d) -> t (f a, f b) (f (r c d))
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 (r (a, b) (r c d) -> t (f a, f b) (f (r c d)))
-> r (a, b) (r c d) -> t (f a, f b) (f (r c d))
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ r a (r b (r c d)) -> r (a, b) (r c d)
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 :: (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 = t (f a, f b) (f c) -> (⊢) o t (f a, f b) (f c)
forall (o :: * -> Constraint) (k :: * -> * -> *) a b.
(Category k, o a, o b) =>
k a b -> (⊢) o k a b
constrained (t (f a, f b) (f c) -> (⊢) o t (f a, f b) (f c))
-> ((⊢) o r (a, b) c -> t (f a, f b) (f c))
-> (⊢) o r (a, b) c
-> (⊢) o t (f a, f b) (f c)
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 (r (a, b) c -> t (f a, f b) (f c))
-> ((⊢) o r (a, b) c -> r (a, b) c)
-> (⊢) o r (a, b) c
-> t (f a, f b) (f c)
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
. (⊢) o r (a, b) c -> r (a, b) 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 = UnitObject (->) -> f (UnitObject (->))
forall (f :: * -> *) a. Applicative f => a -> f a
Hask.pure
  fzipWith :: ((a, b) -> c) -> (f a, f b) -> f c
fzipWith (a, b) -> c
f (f a
p, f b
q) = ((a, b) -> c) -> a -> b -> c
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 (a -> b -> c) -> f a -> f (b -> c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Hask.<$> f a
p f (b -> c) -> f b -> f c
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 :: a -> f a
pure = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
Hask.pure
  <*> :: f (a -> b) -> f a -> f b
(<*>) = f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(Hask.<*>)