{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE TypeOperators #-}

{-|
Module:      Control.Natural
Copyright:   (C) 2015 The University of Kansas
License:     BSD-style (see the file LICENSE)
Maintainer:  Andy Gill
Stability:   Experimental

A data type and class for natural transformations.
-}
module Control.Natural
  ( -- * Newtype for a Natural Transformation
    (:~>)(..)
    -- * Type Synonym for a Natural Transformation
  , type (~>)
    -- * Conversion functions between the newtype and the synonym
  , wrapNT
  , unwrapNT
    -- * Class for Natural Transformations
  , Transformation(..)
  ) where

import qualified Control.Category as C (Category(..))

#if !(MIN_VERSION_base(4,11,0))
import           Data.Semigroup (Semigroup(..))
#endif

---------------------------------------------------------------------------
-- Naming of ~>, :~> and $$ are taken (with permission) from Edward Kmett's @indexed@ package.
---------------------------------------------------------------------------

infixr 0 ~>
-- | A natural transformation from @f@ to @g@.
type f ~> g = forall x. f x -> g x

infixr 0 :~>, $$
-- | A natural transformation suitable for storing in a container.
newtype f :~> g = NT { forall {k} (f :: k -> *) (g :: k -> *). (f :~> g) -> f ~> g
($$) :: f ~> g }

instance C.Category (:~>) where
    id :: forall (a :: k -> *). a :~> a
id = (a ~> a) -> a :~> a
forall {k} (f :: k -> *) (g :: k -> *). (f ~> g) -> f :~> g
NT a x -> a x
a ~> a
forall a. a -> a
id
    NT b ~> c
f . :: forall (b :: k -> *) (c :: k -> *) (a :: k -> *).
(b :~> c) -> (a :~> b) -> a :~> c
. NT a ~> b
g = (a ~> c) -> a :~> c
forall {k} (f :: k -> *) (g :: k -> *). (f ~> g) -> f :~> g
NT (b x -> c x
b ~> c
f (b x -> c x) -> (a x -> b x) -> a x -> c x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a x -> b x
a ~> b
g)

instance f ~ g => Semigroup (f :~> g) where
    NT f ~> g
f <> :: (f :~> g) -> (f :~> g) -> f :~> g
<> NT f ~> g
g = (f ~> g) -> f :~> g
forall {k} (f :: k -> *) (g :: k -> *). (f ~> g) -> f :~> g
NT (f x -> g x
f ~> g
f (f x -> g x) -> (f x -> f x) -> f x -> g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> f x
f x -> g x
f ~> g
g)

instance f ~ g => Monoid (f :~> g) where
    mempty :: f :~> g
mempty = (f ~> g) -> f :~> g
forall {k} (f :: k -> *) (g :: k -> *). (f ~> g) -> f :~> g
NT f x -> f x
f x -> g x
f ~> g
forall a. a -> a
id
    mappend :: (f :~> g) -> (f :~> g) -> f :~> g
mappend = (f :~> g) -> (f :~> g) -> f :~> g
forall a. Semigroup a => a -> a -> a
(<>)

infix 0 #
-- | A (natural) transformation is inside @t@, and contains @f@ and @g@
-- (typically 'Functor's).
--
-- The order of arguments allows the use of @GeneralizedNewtypeDeriving@ to wrap
-- a ':~>', but maintain the 'Transformation' constraint. Thus, @#@ can be used
-- on abstract data types.
class Transformation f g t | t -> f g where
    -- | The invocation method for a natural transformation.
    (#) :: t -> forall a . f a -> g a

instance Transformation f g (f :~> g) where
    NT forall (a :: k). f a -> g a
f # :: (f :~> g) -> forall (a :: k). f a -> g a
# f a
g = f a -> g a
forall (a :: k). f a -> g a
f f a
g

-- | 'wrapNT' builds our natural transformation abstraction out of
-- a natural transformation function.
--
-- An alias to 'NT' provided for symmetry with 'unwrapNT'.
--
wrapNT :: (forall a . f a -> g a) -> f :~> g
wrapNT :: forall {k} (f :: k -> *) (g :: k -> *). (f ~> g) -> f :~> g
wrapNT = (f ~> g) -> f :~> g
forall {k} (f :: k -> *) (g :: k -> *). (f ~> g) -> f :~> g
NT

-- | 'unwrapNT' is the nonfix version of @#@. It is used to break natural
--   transformation wrappers, including ':~>'.
unwrapNT :: Transformation f g t => t -> (forall a . f a -> g a)
unwrapNT :: forall {k} (f :: k -> *) (g :: k -> *) t.
Transformation f g t =>
t -> forall (a :: k). f a -> g a
unwrapNT = t -> f a -> g a
t -> forall (a :: k). f a -> g a
forall {k} (f :: k -> *) (g :: k -> *) t.
Transformation f g t =>
t -> forall (a :: k). f a -> g a
(#)