CovariantFunctor.hs

{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wall -Werror #-}

-- | A reified covariant functor: a covariant mapping from one category to another,
-- wrapping @forall a b. cat a b -> cat' (f a) (f b)@.
--
-- 'CovariantFunctor' @cat cat' f@ reifies the action of a covariant functor on
-- a type constructor @f@, generalised over a source category @cat@ and a
-- target category @cat'@. When both are @(->)@, this specialises to
-- 'CovariantFunctor'' @f@ wrapping @forall a b. (a -> b) -> f a -> f b@, which is
-- exactly 'fmap'.
--
-- Unlike 'Functor' which is a type class (one instance per type), this is a
-- value — and it is generalised over the source and target categories.
--
-- @
-- newtype 'CovariantFunctor' cat cat' f = 'CovariantFunctor' (forall a b. cat a b -> cat' (f a) (f b))
-- type 'CovariantFunctor'' f = 'CovariantFunctor' (->) (->) f
-- @
module Data.Valuation.CovariantFunctor
  ( CovariantFunctor (..),
    CovariantFunctor',

    -- * combinators
    runCovariantFunctor,
    composeFunctor,
    fmapCovariantFunctor,

    -- * covariant functor values
    identityCovariantFunctor,
    maybeCovariantFunctor,
    listCovariantFunctor,
    proxyCovariantFunctor,
    constCovariantFunctor,

    -- * laws
    lawCovariantFunctorIdentity,
    lawCovariantFunctorComposition,
  )
where

import Data.Functor.Compose (Compose (..))
import Data.Functor.Const (Const (..))
import Data.Functor.Identity (Identity (..))
import Data.Profunctor (Profunctor (dimap))
import Data.Proxy (Proxy)

-- $setup
-- >>> :set -Wno-name-shadowing -Wno-type-defaults
-- >>> import Data.Functor.Const (Const(..))
-- >>> import Data.Functor.Identity (Identity(..))
-- >>> import Data.Proxy (Proxy(..))

-- |
-- >>> runCovariantFunctor listCovariantFunctor (+1) [1,2,3]
-- [2,3,4]
--
-- >>> runCovariantFunctor maybeCovariantFunctor (*2) (Just 5)
-- Just 10
newtype CovariantFunctor cat cat' f = CovariantFunctor (forall a b. cat a b -> cat' (f a) (f b))

-- | A 'CovariantFunctor' specialised to @(->)@ for both categories.
-- Wraps @forall a b. (a -> b) -> f a -> f b@, equivalent to 'fmap'.
type CovariantFunctor' f = CovariantFunctor (->) (->) f

-- | Unwrap a 'CovariantFunctor' to its underlying natural transformation.
--
-- >>> runCovariantFunctor identityCovariantFunctor (+1) (Identity 3)
-- Identity 4
--
-- >>> runCovariantFunctor maybeCovariantFunctor show (Just 42)
-- Just "42"
-- >>> runCovariantFunctor maybeCovariantFunctor show Nothing
-- Nothing
--
-- >>> runCovariantFunctor listCovariantFunctor (*2) [1,2,3]
-- [2,4,6]
-- >>> runCovariantFunctor listCovariantFunctor (*2) []
-- []
runCovariantFunctor :: CovariantFunctor cat cat' f -> cat a b -> cat' (f a) (f b)
runCovariantFunctor (CovariantFunctor f) = f

-- | Compose two covariant functors.
-- The result is covariant (covariant ∘ covariant = covariant).
--
-- Given @f@ covariant from @cat@ to @cat'@ and @g@ covariant from @cat'@ to @cat''@,
-- @g ∘ f@ is covariant from @cat@ to @cat''@ acting on @'Compose' g f@.
--
-- >>> import Data.Functor.Compose (Compose(..))
-- >>> let p = composeFunctor maybeCovariantFunctor listCovariantFunctor
-- >>> runCovariantFunctor p (+1) (Compose [Just 1, Nothing, Just 3])
-- Compose [Just 2,Nothing,Just 4]
--
-- >>> import Data.Functor.Compose (Compose(..))
-- >>> let p = composeFunctor listCovariantFunctor maybeCovariantFunctor
-- >>> runCovariantFunctor p (+1) (Compose (Just [1,2,3]))
-- Compose (Just [2,3,4])
-- >>> runCovariantFunctor p (+1) (Compose Nothing :: Compose Maybe [] Int)
-- Compose Nothing
composeFunctor ::
  (Profunctor cat'') =>
  CovariantFunctor cat cat' f ->
  CovariantFunctor cat' cat'' g ->
  CovariantFunctor cat cat'' (Compose g f)
composeFunctor (CovariantFunctor f) (CovariantFunctor g) =
  CovariantFunctor (dimap getCompose Compose . g . f)

-- | The canonical 'CovariantFunctor'' for any 'Functor',
-- using 'fmap'.
--
-- >>> runCovariantFunctor fmapCovariantFunctor (+1) [1,2,3]
-- [2,3,4]
-- >>> runCovariantFunctor fmapCovariantFunctor not (Just True)
-- Just False
fmapCovariantFunctor :: (Functor f) => CovariantFunctor' f
fmapCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on 'Identity': maps the wrapped value.
--
-- >>> runCovariantFunctor identityCovariantFunctor (+1) (Identity 3)
-- Identity 4
-- >>> runCovariantFunctor identityCovariantFunctor show (Identity 42)
-- Identity "42"
identityCovariantFunctor :: CovariantFunctor' Identity
identityCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on 'Maybe': maps over the contained value if present.
--
-- >>> runCovariantFunctor maybeCovariantFunctor (+1) (Just 3)
-- Just 4
-- >>> runCovariantFunctor maybeCovariantFunctor (+1) Nothing
-- Nothing
--
-- >>> runCovariantFunctor maybeCovariantFunctor show (Just 42)
-- Just "42"
maybeCovariantFunctor :: CovariantFunctor' Maybe
maybeCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on @[]@: maps over each element.
--
-- >>> runCovariantFunctor listCovariantFunctor (+1) [1,2,3]
-- [2,3,4]
-- >>> runCovariantFunctor listCovariantFunctor (*2) []
-- []
--
-- >>> runCovariantFunctor listCovariantFunctor show [1,2,3]
-- ["1","2","3"]
listCovariantFunctor :: CovariantFunctor' []
listCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on 'Proxy': trivially maps the phantom type parameter.
--
-- >>> runCovariantFunctor proxyCovariantFunctor not (Proxy :: Proxy Bool)
-- Proxy
--
-- >>> runCovariantFunctor proxyCovariantFunctor show (Proxy :: Proxy Int)
-- Proxy
proxyCovariantFunctor :: CovariantFunctor' Proxy
proxyCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on @'Const' r@: trivially maps the phantom second parameter.
-- The constant value is preserved.
--
-- >>> runCovariantFunctor constCovariantFunctor not (Const 42 :: Const Int Bool)
-- Const 42
--
-- >>> runCovariantFunctor constCovariantFunctor show (Const "hello" :: Const String Int)
-- Const "hello"
constCovariantFunctor :: CovariantFunctor' (Const r)
constCovariantFunctor = CovariantFunctor fmap

-- | The identity law for a 'CovariantFunctor'': mapping the identity morphism
-- must be the identity on @f a@.
--
-- @
-- 'runCovariantFunctor' p 'id' x == x
-- @
--
-- >>> lawCovariantFunctorIdentity identityCovariantFunctor (Identity 42)
-- True
-- >>> lawCovariantFunctorIdentity maybeCovariantFunctor (Just 42 :: Maybe Int)
-- True
-- >>> lawCovariantFunctorIdentity listCovariantFunctor [1,2,3 :: Int]
-- True
-- >>> lawCovariantFunctorIdentity proxyCovariantFunctor (Proxy :: Proxy Int)
-- True
-- >>> lawCovariantFunctorIdentity constCovariantFunctor (Const 42 :: Const Int Bool)
-- True
lawCovariantFunctorIdentity :: (Eq (f a)) => CovariantFunctor' f -> f a -> Bool
lawCovariantFunctorIdentity p x =
  runCovariantFunctor p id x == x

-- | The composition law for a 'CovariantFunctor'': mapping a composition must
-- equal composing the individual mappings.
--
-- @
-- 'runCovariantFunctor' p (g '.' f) x == 'runCovariantFunctor' p g ('runCovariantFunctor' p f x)
-- @
--
-- >>> lawCovariantFunctorComposition identityCovariantFunctor (+1) (*2) (Identity 3)
-- True
-- >>> lawCovariantFunctorComposition maybeCovariantFunctor (+1) (*2) (Just 3 :: Maybe Int)
-- True
-- >>> lawCovariantFunctorComposition listCovariantFunctor (+1) (*2) [1,2,3 :: Int]
-- True
-- >>> lawCovariantFunctorComposition proxyCovariantFunctor not (&&True) (Proxy :: Proxy Bool)
-- True
-- >>> lawCovariantFunctorComposition constCovariantFunctor (+1) (*2) (Const "hello" :: Const String Int)
-- True
lawCovariantFunctorComposition :: (Eq (f c)) => CovariantFunctor' f -> (b -> c) -> (a -> b) -> f a -> Bool
lawCovariantFunctorComposition p g f x =
  runCovariantFunctor p (g . f) x == runCovariantFunctor p g (runCovariantFunctor p f x)