Invariant.hs

{-# LANGUAGE DefaultSignatures #-}

module Data.Functor.Invariant
  ( -- * Invariant
    Invariant (..),
    invIso,
  )
where

--------------------------------------------------------------------------------

import Control.Applicative (ZipList)
import Control.Category.Tensor (Iso (Iso))
import Data.Functor.Compose (Compose (..))
import Data.Functor.Contravariant (Contravariant (..))
import Data.Functor.Identity (Identity (Identity))
import Data.Functor.Product (Product)
import Data.Functor.Sum (Sum)
import Data.List.NonEmpty (NonEmpty)
import Prelude

--------------------------------------------------------------------------------

-- $setup
-- >>> :set -dppr-cols=1000
-- >>> import Prelude
-- >>> import Data.Functor.Identity (Identity (..))
-- >>> import Control.Category.Tensor (Iso (..), fwd)

--------------------------------------------------------------------------------

-- | A functor is 'Invariant' if it is parametric in its type
-- parameter @a@.
--
-- === Laws
--
-- @
-- 'invmap' 'id' 'id' ≡ 'id'
-- 'invmap' @f2@ @f2'@ 'Control.Category..' 'invmap' @f1@ @f1'@ ≡ 'invmap' (@f2@ 'Control.Category..' @f1@) (@f1'@ 'Control.Category..' @f2'@)
-- @
class Invariant f where
  -- | Given two isomorphic functions @f@ and @g@, map over the
  -- invariant parameter @a@.
  --
  -- ==== __Examples__
  --
  -- >>> :t invmap @Identity (read @Bool) show
  -- invmap @Identity (read @Bool) show :: Identity String -> Identity Bool
  --
  -- >>> invmap @Identity (read @Bool) show (Identity "True")
  -- Identity True
  invmap :: (a -> a') -> (a' -> a) -> f a -> f a'
  default invmap :: (Functor f) => (a -> a') -> (a' -> a) -> f a -> f a'
  invmap = invmapFunctor

-- | Lift an 'Iso' through an 'Invariant' functor.
--
-- ==== __Examples__
--
-- >>> fwd (invIso @Identity (Iso (read @Bool) show)) (Identity "True")
-- Identity True
invIso :: (Invariant f) => Iso (->) a a' -> Iso (->) (f a) (f a')
invIso (Iso f g) = Iso (invmap f g) (invmap g f)

newtype FromFunctor f a = FromFunctor {runBi :: f a}

-- | Every 'Functor' is also an 'Invariant' functor.
invmapFunctor :: (Functor f) => (a -> b) -> (b -> a) -> f a -> f b
invmapFunctor = flip $ const fmap

instance (Functor f) => Invariant (FromFunctor f) where
  invmap :: (a -> a') -> (a' -> a) -> FromFunctor f a -> FromFunctor f a'
  invmap f _ = FromFunctor . fmap f . runBi

newtype FromContra f a = FromContra {runContra :: f a}

instance (Contravariant f) => Invariant (FromContra f) where
  invmap :: (a -> a') -> (a' -> a) -> FromContra f a -> FromContra f a'
  invmap _ g = FromContra . contramap g . runContra

deriving via FromFunctor Identity instance Invariant Identity

deriving via FromFunctor (Compose f g) instance (Functor f, Functor g) => Invariant (Compose f g)

deriving via FromFunctor [] instance Invariant []

deriving via FromFunctor ZipList instance Invariant ZipList

deriving via FromFunctor NonEmpty instance Invariant NonEmpty

deriving via FromFunctor Maybe instance Invariant Maybe

deriving via FromFunctor (Either e) instance Invariant (Either e)

deriving via FromFunctor IO instance Invariant IO

deriving via FromFunctor (Sum f g) instance (Functor f, Functor g) => Invariant (Sum f g)

deriving via FromFunctor (Product f g) instance (Functor f, Functor g) => Invariant (Product f g)

deriving via (FromFunctor ((,) x1)) instance Invariant ((,) x1)

deriving via (FromFunctor ((,,) x1 x2)) instance Invariant ((,,) x1 x2)

deriving via (FromFunctor ((,,,) x1 x2 x3)) instance Invariant ((,,,) x1 x2 x3)