{-# 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 = forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> (b -> a) -> f a -> f b
invmapFunctor

invIso :: Invariant f => Iso (->) a a' -> Iso (->) (f a) (f a')
invIso :: forall (f :: * -> *) a a'.
Invariant f =>
Iso (->) a a' -> Iso (->) (f a) (f a')
invIso (Iso a -> a'
f a' -> a
g)  = forall (cat :: * -> * -> *) a b. cat a b -> cat b a -> Iso cat a b
Iso (forall (f :: * -> *) a a'.
Invariant f =>
(a -> a') -> (a' -> a) -> f a -> f a'
invmap a -> a'
f a' -> a
g) (forall (f :: * -> *) a a'.
Invariant f =>
(a -> a') -> (a' -> a) -> f a -> f a'
invmap a' -> a
g a -> a'
f)

newtype FromFunctor f a = FromFunctor { forall (f :: * -> *) a. FromFunctor f a -> f a
runBi :: f a }

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

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

newtype FromContra f a = FromContra { forall (f :: * -> *) a. FromContra f a -> f a
runContra :: f a }

instance Contravariant f => Invariant (FromContra f) where
  invmap :: (a -> a') -> (a' -> a) -> FromContra f a -> FromContra f a'
  invmap :: forall a a'.
(a -> a') -> (a' -> a) -> FromContra f a -> FromContra f a'
invmap a -> a'
_ a' -> a
g = forall (f :: * -> *) a. f a -> FromContra f a
FromContra forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. FromContra f a -> f a
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)