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

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

-- | 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

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)