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,
    eitherCovariantFunctor,
    listCovariantFunctor,
    nonEmptyCovariantFunctor,
    pairCovariantFunctor,
    readerCovariantFunctor,
    downCovariantFunctor,
    dualCovariantFunctor,
    sumCovariantFunctor,
    productCovariantFunctor,
    firstCovariantFunctor,
    lastCovariantFunctor,
    minCovariantFunctor,
    maxCovariantFunctor,
    proxyCovariantFunctor,
    constCovariantFunctor,
    mapCovariantFunctor,
    intMapCovariantFunctor,
    seqCovariantFunctor,
    treeCovariantFunctor,

    -- * laws
    lawCovariantFunctorIdentity,
    lawCovariantFunctorComposition,
  )
where

import Data.Functor.Compose (Compose (..))
import Data.Functor.Const (Const (..))
import Data.Functor.Identity (Identity (..))
import Data.IntMap (IntMap)
import Data.List.NonEmpty (NonEmpty)
import Data.Map (Map)
import Data.Monoid (Dual, First, Last, Product, Sum)
import Data.Ord (Down)
import Data.Profunctor (Profunctor (dimap))
import Data.Proxy (Proxy)
import Data.Semigroup (Max, Min)
import Data.Sequence (Seq)
import Data.Tree (Tree)

-- $setup
-- >>> :set -Wno-name-shadowing -Wno-type-defaults
-- >>> import Data.Functor.Const (Const(..))
-- >>> import Data.Functor.Identity (Identity(..))
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> import Data.Monoid (Dual(..), Sum(..), Product(..), First(..), Last(..))
-- >>> import Data.Ord (Down(..))
-- >>> import Data.Proxy (Proxy(..))
-- >>> import Data.Semigroup (Min(..), Max(..))

-- |
-- >>> 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 @'Either' e@: maps over the 'Right' value,
-- leaving 'Left' unchanged.
--
-- >>> runCovariantFunctor eitherCovariantFunctor (+1) (Right 3 :: Either String Int)
-- Right 4
-- >>> runCovariantFunctor eitherCovariantFunctor (+1) (Left "error" :: Either String Int)
-- Left "error"
eitherCovariantFunctor :: CovariantFunctor' (Either e)
eitherCovariantFunctor = 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 'NonEmpty': maps over each element.
--
-- >>> runCovariantFunctor nonEmptyCovariantFunctor (+1) (1 :| [2,3])
-- 2 :| [3,4]
-- >>> runCovariantFunctor nonEmptyCovariantFunctor show (42 :| [])
-- "42" :| []
nonEmptyCovariantFunctor :: CovariantFunctor' NonEmpty
nonEmptyCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on @(,) a@: maps over the second component of a pair.
--
-- >>> runCovariantFunctor pairCovariantFunctor (+1) ("hello", 3)
-- ("hello",4)
-- >>> runCovariantFunctor pairCovariantFunctor show (True, 42)
-- (True,"42")
pairCovariantFunctor :: CovariantFunctor' ((,) a)
pairCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on @(->) r@: post-composes a function.
--
-- >>> runCovariantFunctor readerCovariantFunctor (*2) (+1) 3
-- 8
-- >>> runCovariantFunctor readerCovariantFunctor show ((+1) :: Int -> Int) 3
-- "4"
readerCovariantFunctor :: CovariantFunctor' ((->) r)
readerCovariantFunctor = CovariantFunctor fmap

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

-- | 'CovariantFunctor'' on 'Dual': maps over the wrapped value.
--
-- >>> runCovariantFunctor dualCovariantFunctor (+1) (Dual 3)
-- Dual {getDual = 4}
-- >>> runCovariantFunctor dualCovariantFunctor show (Dual 42)
-- Dual {getDual = "42"}
dualCovariantFunctor :: CovariantFunctor' Dual
dualCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on @'Data.Monoid.Sum'@: maps over the wrapped value.
--
-- >>> runCovariantFunctor sumCovariantFunctor (+1) (Sum 3)
-- Sum {getSum = 4}
-- >>> runCovariantFunctor sumCovariantFunctor show (Sum 42)
-- Sum {getSum = "42"}
sumCovariantFunctor :: CovariantFunctor' Sum
sumCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on @'Data.Monoid.Product'@: maps over the wrapped value.
--
-- >>> runCovariantFunctor productCovariantFunctor (+1) (Product 3)
-- Product {getProduct = 4}
-- >>> runCovariantFunctor productCovariantFunctor show (Product 42)
-- Product {getProduct = "42"}
productCovariantFunctor :: CovariantFunctor' Product
productCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on @'Data.Monoid.First'@: maps over the wrapped 'Maybe' value.
--
-- >>> runCovariantFunctor firstCovariantFunctor (+1) (First (Just 3))
-- First {getFirst = Just 4}
-- >>> runCovariantFunctor firstCovariantFunctor (+1) (First Nothing)
-- First {getFirst = Nothing}
firstCovariantFunctor :: CovariantFunctor' First
firstCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on @'Data.Monoid.Last'@: maps over the wrapped 'Maybe' value.
--
-- >>> runCovariantFunctor lastCovariantFunctor (+1) (Last (Just 3))
-- Last {getLast = Just 4}
-- >>> runCovariantFunctor lastCovariantFunctor (+1) (Last Nothing)
-- Last {getLast = Nothing}
lastCovariantFunctor :: CovariantFunctor' Last
lastCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on 'Min': maps over the wrapped value.
--
-- >>> runCovariantFunctor minCovariantFunctor (+1) (Min 3)
-- Min {getMin = 4}
-- >>> runCovariantFunctor minCovariantFunctor show (Min 42)
-- Min {getMin = "42"}
minCovariantFunctor :: CovariantFunctor' Min
minCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on 'Max': maps over the wrapped value.
--
-- >>> runCovariantFunctor maxCovariantFunctor (+1) (Max 3)
-- Max {getMax = 4}
-- >>> runCovariantFunctor maxCovariantFunctor show (Max 42)
-- Max {getMax = "42"}
maxCovariantFunctor :: CovariantFunctor' Max
maxCovariantFunctor = 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

-- | 'CovariantFunctor'' on @'Map' k@: maps over the values, preserving keys.
--
-- >>> import qualified Data.Map as Map
-- >>> runCovariantFunctor mapCovariantFunctor (+1) (Map.fromList [("a", 1), ("b", 2)])
-- fromList [("a",2),("b",3)]
-- >>> runCovariantFunctor mapCovariantFunctor show (Map.fromList [(1, True)])
-- fromList [(1,"True")]
mapCovariantFunctor :: CovariantFunctor' (Map k)
mapCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on 'IntMap': maps over the values, preserving keys.
--
-- >>> import qualified Data.IntMap as IntMap
-- >>> runCovariantFunctor intMapCovariantFunctor (+1) (IntMap.fromList [(1, 10), (2, 20)])
-- fromList [(1,11),(2,21)]
-- >>> runCovariantFunctor intMapCovariantFunctor show (IntMap.fromList [(1, True)])
-- fromList [(1,"True")]
intMapCovariantFunctor :: CovariantFunctor' IntMap
intMapCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on 'Seq': maps over each element.
--
-- >>> import qualified Data.Sequence as Seq
-- >>> runCovariantFunctor seqCovariantFunctor (+1) (Seq.fromList [1,2,3])
-- fromList [2,3,4]
-- >>> runCovariantFunctor seqCovariantFunctor show (Seq.fromList [1,2])
-- fromList ["1","2"]
seqCovariantFunctor :: CovariantFunctor' Seq
seqCovariantFunctor = CovariantFunctor fmap

-- | 'CovariantFunctor'' on 'Tree': maps over every node label.
--
-- >>> import Data.Tree (Tree(..))
-- >>> runCovariantFunctor treeCovariantFunctor (+1) (Node 1 [Node 2 [], Node 3 []])
-- Node {rootLabel = 2, subForest = [Node {rootLabel = 3, subForest = []},Node {rootLabel = 4, subForest = []}]}
treeCovariantFunctor :: CovariantFunctor' Tree
treeCovariantFunctor = 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)