101 lines
4.2 KiB
Haskell
101 lines
4.2 KiB
Haskell
{-# LANGUAGE PartialTypeSignatures #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
|
|
module Functor.Bifunctor where
|
|
|
|
import Functor.Base
|
|
import Functor.Compose
|
|
import Relation
|
|
|
|
import Data.Kind (Constraint, Type)
|
|
import Data.Either (Either (Left, Right))
|
|
|
|
type Uncurry :: (a -> b -> c) -> (a, b) -> c
|
|
type family Uncurry
|
|
|
|
type Uncurry' :: (a -> b -> Type) -> (a, b) -> Type
|
|
newtype Uncurry' f ab = Uncurry { getUncurry :: f (Pi1 ab) (Pi2 ab) }
|
|
type instance Uncurry = Uncurry'
|
|
|
|
type UncurryN :: (a -> b -> c -> Type) -> (a, b) -> c -> Type
|
|
newtype UncurryN f ab x = UncurryN { getUncurryN :: f (Pi1 ab) (Pi2 ab) x }
|
|
type instance Uncurry = UncurryN
|
|
|
|
instance Functor (Uncurry' (,)) where
|
|
type Cod (Uncurry' (,)) = (->)
|
|
type Dom (Uncurry' (,)) = ProductRel (->) (->)
|
|
map (Product g f) = \(Uncurry (y, x)) -> Uncurry (g y, f x)
|
|
|
|
instance Functor (Uncurry' Either) where
|
|
type Cod (Uncurry' Either) = (->)
|
|
type Dom (Uncurry' Either) = ProductRel (->) (->)
|
|
map (Product g f) = \(Uncurry sum) -> Uncurry case sum of
|
|
Left y -> Left (g y)
|
|
Right x -> Right (f x)
|
|
|
|
instance Functor (Uncurry' (->)) where
|
|
type Cod (Uncurry' (->)) = (->)
|
|
type Dom (Uncurry' (->)) = ProductRel (Opposite (->)) (->)
|
|
map (Product (Opposite f) h) = \(Uncurry g) -> Uncurry (h . g . f)
|
|
|
|
instance (Functor (Pi1 fg), Functor (Pi2 fg), Dom (Pi2 fg) ~ (->)) => Functor (UncurryN (Compose :: (Type -> Type) -> (Type -> Type) -> Type -> Type) fg) where
|
|
type Cod (UncurryN Compose fg) = (->)
|
|
type Dom (UncurryN Compose fg) = (->)
|
|
map f (UncurryN (Compose x)) = UncurryN (Compose (map (map f) x))
|
|
|
|
instance Functor (UncurryN (Compose :: (Type -> Type) -> (Type -> Type) -> Type -> Type)) where
|
|
type Cod (UncurryN Compose) = Nat (->) (->)
|
|
type Dom (UncurryN Compose) = ProductRel (Nat (->) (->)) (Nat (->) (->))
|
|
map (Product (Nat g) (Nat f)) = Nat \o (UncurryN (Compose x)) -> UncurryN (Compose (g (map o) (map (f o) x)))
|
|
|
|
type family ProductPi1 x where
|
|
ProductPi1 (ProductRel f g) = f
|
|
type family ProductPi2 x where
|
|
ProductPi2 (ProductRel f g) = g
|
|
|
|
type Bifunctor :: (i -> j -> k) -> Constraint
|
|
class (Category (Dom1 f), Category (Dom2 f), Category (Cod1 f)) => Bifunctor (f :: i -> j -> k) where
|
|
type Dom1 f :: Relation i
|
|
type Dom2 f :: Relation j
|
|
type Cod1 f :: Relation k
|
|
bimap :: Dom1 f w y -> Dom2 f x z -> Cod1 f (f w x) (f y z)
|
|
-- The category must be wide, or else the `Object (Dom2 f) z` we have to pass around
|
|
-- actually makes this function an instance of bimap with x ~ z.
|
|
first :: Wide (Dom2 f) => Dom1 f x y -> Cod1 f (f x z) (f y z)
|
|
first g = bimap g id
|
|
second :: Wide (Dom1 f) => Dom2 f y z -> Cod1 f (f x y) (f x z)
|
|
second f = bimap id f
|
|
|
|
-- We can't make a generic instance for Bifunctor because we can't constrain a type family,
|
|
-- nor do we have existentially quantified type variables, so there's no way to state the
|
|
-- `Category r` constraint to make this function (or for that matter, the instance of Functor) work.
|
|
defaultBimap :: forall r s f w x y z. (Functor (Uncurry' f), Dom (Uncurry' f) ~ ProductRel r s, Cod (Uncurry' f) ~ (->), Category r, Category s) => r w y -> s x z -> Cod (Uncurry' f) (f w x) (f y z)
|
|
defaultBimap g f = getUncurry . (map (Product g f) :: Uncurry' f '(w, x) -> Uncurry' f '(y, z)) . Uncurry
|
|
|
|
instance Bifunctor (,) where
|
|
type Dom1 (,) = (->)
|
|
type Dom2 (,) = (->)
|
|
type Cod1 (,) = (->)
|
|
bimap = defaultBimap
|
|
|
|
instance Bifunctor Either where
|
|
type Dom1 Either = (->)
|
|
type Dom2 Either = (->)
|
|
type Cod1 Either = (->)
|
|
bimap = defaultBimap
|
|
|
|
instance Bifunctor (->) where
|
|
type Dom1 (->) = Opposite (->)
|
|
type Dom2 (->) = (->)
|
|
type Cod1 (->) = (->)
|
|
bimap g f = getUncurry . (map (Product g f) :: Uncurry' (->) '(_, _) -> Uncurry' (->) '(_, _)) . Uncurry
|
|
|
|
instance Bifunctor (Compose :: (Type -> Type) -> (Type -> Type) -> Type -> Type) where
|
|
type Dom1 Compose = Nat (->) (->)
|
|
type Dom2 Compose = Nat (->) (->)
|
|
type Cod1 Compose = Nat (->) (->)
|
|
bimap (Nat g) (Nat f) = Nat \_ (Compose x) -> Compose (map (f id) (g id x))
|
|
|
|
dimap :: (Bifunctor f, Dom1 f ~ Opposite r) => r x w -> Dom2 f z y -> Cod1 f (f w z) (f x y)
|
|
dimap f = bimap (Opposite f)
|