71 lines
2.2 KiB
Haskell
71 lines
2.2 KiB
Haskell
{-# LANGUAGE UndecidableInstances #-}
|
|
module Functor.Identity where
|
|
|
|
import Functor.Base
|
|
import Functor.Bifunctor
|
|
import Functor.Compose
|
|
import Relation
|
|
|
|
import Data.Either (Either (Left, Right))
|
|
import Data.Functor.Identity (Identity (Identity, runIdentity))
|
|
import Data.Kind (Constraint)
|
|
import Data.Void (Void)
|
|
|
|
type LeftIdentity :: (k -> k -> k) -> Constraint
|
|
class Bifunctor f => LeftIdentity (f :: k -> k -> k) where
|
|
type UnitL f :: k
|
|
unitLI :: Object (Cod1 f) x -> Cod1 f x (f (UnitL f) x)
|
|
unitLE :: Object (Cod1 f) x -> Cod1 f (f (UnitL f) x) x
|
|
|
|
unitLI' :: (LeftIdentity f, Wide (Cod1 f)) => Cod1 f x (f (UnitL f) x)
|
|
unitLI' = unitLI id
|
|
|
|
unitLE' :: (LeftIdentity f, Wide (Cod1 f)) => Cod1 f (f (UnitL f) x) x
|
|
unitLE' = unitLE id
|
|
|
|
type RightIdentity :: (k -> k -> k) -> Constraint
|
|
class Bifunctor f => RightIdentity (f :: k -> k -> k) where
|
|
type UnitR f :: k
|
|
unitRI :: Object (Cod1 f) x -> Cod1 f x (f x (UnitR f))
|
|
unitRE :: Object (Cod1 f) x -> Cod1 f (f x (UnitR f)) x
|
|
|
|
-- TODO: unitRI', unitRE'
|
|
|
|
type LeftRightIdentity :: (k -> k -> k) -> Constraint
|
|
class (LeftIdentity f, RightIdentity f, UnitL f ~ UnitR f) => LeftRightIdentity (f :: k -> k -> k) where
|
|
type Unit f :: k
|
|
instance (LeftIdentity f, RightIdentity f, UnitL f ~ UnitR f) => LeftRightIdentity f where
|
|
type Unit f = UnitL f
|
|
|
|
instance LeftIdentity (,) where
|
|
type UnitL (,) = ()
|
|
unitLI _ x = ((), x)
|
|
unitLE _ (_, x) = x
|
|
|
|
instance LeftIdentity Either where
|
|
type UnitL Either = Void
|
|
unitLI _ x = Right x
|
|
unitLE _ (Right x) = x
|
|
unitLE _ (Left x) = case x of {}
|
|
|
|
instance LeftIdentity Compose where
|
|
type UnitL Compose = Identity
|
|
unitLI (Nat _) = Nat \_ -> Compose . Identity
|
|
unitLE (Nat _) = Nat \_ -> runIdentity . getCompose
|
|
|
|
instance RightIdentity (,) where
|
|
type UnitR (,) = ()
|
|
unitRI _ x = (x, ())
|
|
unitRE _ (x, _) = x
|
|
|
|
instance RightIdentity Either where
|
|
type UnitR Either = Void
|
|
unitRI _ x = Left x
|
|
unitRE _ (Right x) = case x of {}
|
|
unitRE _ (Left x) = x
|
|
|
|
instance RightIdentity Compose where
|
|
type UnitR Compose = Identity
|
|
unitRI (Nat _) = Nat \_ -> Compose . map Identity
|
|
unitRE (Nat _) = Nat \_ -> map runIdentity . getCompose
|