Composing bijections, surjections, and injections

0.md

It's occasionally useful to consider a slightly richer function definition than ->, one where you can reason about the preimage of the function's codomain.

One approach is to bundle each -> with another function describing the preimage:

data Bidirectional p q a b = Bidirectional
  { forwards :: p a b
  , backwards :: q b a
  }

-- | bijections
type (<->) = Bidirectional (->) (->)

-- | injections
type (?->) = Bidirectional (->) (Kleisli Maybe)

-- | surjections
type (+->) = Bidirectional (->) (Kleisli NonEmpty)

-- | general functions without any provable properties about their preimages
type (*->) = Bidirectional (->) (Kleisli [])

(strictly speaking, we should be using Kleisli arrows on non-empty sets for surjections, and the Kleisli arrows on sets for general functions, but we'll try to disregard order).

Defining bijections, surjections, and injections is fairly straightforward:

-- | a bijection from Int to Int
-- (exploiting minBound - 1 == maxBound, maxBound - 1 == minBound for Int)
incrementB :: Int <-> Int
incrementB = Bidirectional (+1) (subtract 1)

-- | an injection from Enum to Int
-- (a safer version of fromEnum/toEnum)
enumI :: Enum a => a ?-> Int
enumI = Bidirectional
    { forwards = fromEnum
    , backwards = Kleisli $ unsafePerformIO . toMaybeEnumIO
    }
  where
    toMaybeEnumIO :: Enum a => Int -> IO (Maybe a)
    toMaybeEnumIO !i = evaluate (Just $! toEnum i) `catch` orNothing

    orNothing :: SomeException -> IO (Maybe a)
    orNothing _ = return Nothing

-- | create a surjection from Int to Int
-- (evenS or oddS would also be good)
equalS :: Int -> (Int +-> Bool)
equalS a = Bidirectional
  { forwards = (==a)
  , backwards = Kleisli $ \case
      True  ->  a :| []
      False ->  let (x:xs) = [minBound + 1 .. a - 1] ++ [a + 1 .. maxBound]
                in x :| xs
  }

Through the magic of the Category typeclass, we can still compose bijections with bijections, injections with injections, and so on:

λ :l B0.hs
[1 of 1] Compiling B0               ( B0.hs, interpreted )
Ok, modules loaded: B0.
λ :t incrementB . incrementB
incrementB . incrementB :: Bidirectional (->) (->) Int Int
λ :t toInjection incrementB . enumI
toInjection incrementB . enumI
  :: Enum a => Bidirectional (->) (Kleisli Maybe) a Int

And even though we can manually cast a bijection to an injection or a surjection, this is slightly unsatisfying. After all, a bijection is an injection, it is a surjection.

Much nicer rather, if we could do this:

λ :t incrementB . enumI

<interactive>:1:14:
    Couldn't match type ‘Kleisli Maybe’ with ‘(->)’
    Expected type: Bidirectional (->) (->) a Int
      Actual type: a ?-> Int
    In the second argument of ‘(.)’, namely ‘enumI’
    In the expression: incrementB . enumI

And with a little redefinition

-- | bijections
type a <-> b = forall q. Arrow q => Bidirectional (->) q a b

incrementB :: Int <-> Int
incrementB = Bidirectional (+1) (arr $ subtract 1)

We can!

λ :l B1.hs
[1 of 1] Compiling B1               ( B1.hs, interpreted )
Ok, modules loaded: B1.
λ :t incrementB . enumI
incrementB . enumI
  :: Enum a => Bidirectional (->) (Kleisli Maybe) a Int
λ :t equalS 0 . incrementB
equalS 0 . incrementB
  :: Bidirectional (->) (Kleisli NonEmpty) Int Bool

However, what still can't do is compose surjections and injections:

λ :t equalS 0 . incrementB . enumI

<interactive>:1:25:
    Couldn't match type ‘Maybe’ with ‘NonEmpty’
    Expected type: Bidirectional (->) (Kleisli NonEmpty) a Int
      Actual type: a ?-> Int
    In the second argument of ‘(.)’, namely ‘enumI’
    In the second argument of ‘(.)’, namely ‘incrementB . enumI’

Leaving Category alone for a time, consider how a -> NonEmpty b and b -> Maybe a would compose. Both NonEmpty and Maybe are Functors, so we could use fmap to get a -> NonEmpty (Maybe b) or b -> Maybe (NonEmpty b). These are Kleisli (Compose NonEmpty Maybe) and Kleisli (Compose Maybe NonEmpty) arrows which are both isomorphic to Kleisli [] arrows, which we've chosen to represent functions without provable preimage properties.

In general, we can compose any Kleisli m and Kleisli n arrows to get a Kleisli (Compose m n) arrow as long as m is a Functor:

(#) :: Functor m
    => Bidirectional (->) (Kleisli m) b c
    -> Bidirectional (->) (Kleisli n) a b
    -> Bidirectional (->) (Kleisli (Compose m n)) a c
Bidirectional pbc qcb # Bidirectional pab qab = Bidirectional (pbc . pab) . Kleisli $
  Compose . fmap (runKleisli qab) . runKleisli qcb
infixr 9 #

This gives us a way to compose surjections and injections, even if it's not very pretty:

λ :l B2.hs
[1 of 1] Compiling B2               ( B2.hs, interpreted )
Ok, modules loaded: B2.
λ :t equalS 0 # incrementB # enumI
equalS 0 # incrementB # enumI
  :: (Enum a, Monad m) =>
     Bidirectional
       (->) (Kleisli (Compose NonEmpty (Compose m Maybe))) a Bool
λ :t incrementB # incrementB
incrementB # incrementB
  :: (Monad m, Monad n) =>
     Bidirectional (->) (Kleisli (Compose m n)) Int Int

We want to collapse these Compose layers somehow. When we were using (.) above, it was unnecessary because for any monad Compose m m a is isomorphic to m a.

What we really need to do is teach the type system that composition of these arrows obeys a lattice. For the types we care about, that lattice is just

              (->)
          ↙         ➘
  Kleisli Maybe   Kleisli NonEmpty
          ➘         ↙
           Kleisli []

We can use a type family to do this:

class (Category p, Category q) => Unifiable p q where
  type Union (p :: * -> * -> *) (q :: * -> * -> *) :: * -> * -> *
  (#) :: p b c -> q a b -> Union p q a c
infixr 9 #

instance Unifiable (->)                (->)                where { p # q = p . q                         ; type Union (->)                (->)                = (->)              }
instance Unifiable (->)                (Kleisli Maybe)     where { p # q = arr p . q                     ; type Union (->)                (Kleisli Maybe)     = Kleisli Maybe     }
instance Unifiable (->)                (Kleisli NonEmpty)  where { p # q = arr p . q                     ; type Union (->)                (Kleisli NonEmpty)  = Kleisli NonEmpty  }
instance Unifiable (->)                (Kleisli [])        where { p # q = arr p . q                     ; type Union (->)                (Kleisli [])        = Kleisli []        }
instance Unifiable (Kleisli Maybe)     (->)                where { p # q = p . arr q                     ; type Union (Kleisli Maybe)     (->)                = Kleisli Maybe     }
instance Unifiable (Kleisli NonEmpty)  (->)                where { p # q = p . arr q                     ; type Union (Kleisli NonEmpty)  (->)                = Kleisli NonEmpty  }
instance Unifiable (Kleisli [])        (->)                where { p # q = p . arr q                     ; type Union (Kleisli [])        (->)                = Kleisli []        }
instance Unifiable (Kleisli Maybe)     (Kleisli Maybe)     where { p # q = p . q                         ; type Union (Kleisli Maybe)     (Kleisli Maybe)     = Kleisli Maybe     }
instance Unifiable (Kleisli NonEmpty)  (Kleisli NonEmpty)  where { p # q = p . q                         ; type Union (Kleisli NonEmpty)  (Kleisli NonEmpty)  = Kleisli NonEmpty  }
instance Unifiable (Kleisli [])        (Kleisli [])        where { p # q = p . q                         ; type Union (Kleisli [])        (Kleisli [])        = Kleisli []        }
instance Unifiable (Kleisli Maybe)     (Kleisli NonEmpty)  where { p # q = toListArrow p . toListArrow q ; type Union (Kleisli Maybe)     (Kleisli NonEmpty)  = Kleisli []        }
instance Unifiable (Kleisli NonEmpty)  (Kleisli Maybe)     where { p # q = toListArrow p . toListArrow q ; type Union (Kleisli NonEmpty)  (Kleisli Maybe)     = Kleisli []        }
instance Unifiable (Kleisli Maybe)     (Kleisli [])        where { p # q = toListArrow p . q             ; type Union (Kleisli Maybe)     (Kleisli [])        = Kleisli []        }
instance Unifiable (Kleisli NonEmpty)  (Kleisli [])        where { p # q = toListArrow p . q             ; type Union (Kleisli NonEmpty)  (Kleisli [])        = Kleisli []        }
instance Unifiable (Kleisli [])        (Kleisli Maybe)     where { p # q = p . toListArrow q             ; type Union (Kleisli [])        (Kleisli Maybe)     = Kleisli []        }
instance Unifiable (Kleisli [])        (Kleisli NonEmpty)  where { p # q = p . toListArrow q             ; type Union (Kleisli [])        (Kleisli NonEmpty)  = Kleisli []        }

toListArrow :: Foldable m => Kleisli m a b -> Kleisli [] a b
toListArrow arr = Kleisli $ toList . runKleisli arr

We could use this to implement another operator for general composition of Bidirectional arrows, but we can also observe a join semi-lattice for those arrows:

Bidirectional (->) p        Bidirectional (->) q
                  ➘         ↙
           Bidirectional (->) (Union q p)

So it suffices to give an instance for Unifiable for this case:

instance Unifiable q p => Unifiable (Bidirectional (->) p) (Bidirectional (->) q) where
  Bidirectional bc pcb # Bidirectional ab qba = Bidirectional (bc . ab) (qba # pcb)
  type Union (Bidirectional (->) p) (Bidirectional (->) q) = Bidirectional (->) (Union q p)

Reverting to our original definition for bijections

-- | bijections
type a <-> b = Bidirectional (->) (->) a b

We've got composition of surjections and injections yielding general functions:

λ :l B3.hs
[1 of 1] Compiling B3               ( B3.hs, interpreted )
Ok, modules loaded: B3.
λ :t equalS 0 # incrementB # enumI
equalS 0 # incrementB # enumI
  :: Enum a => Bidirectional (->) (Kleisli []) a Bool

B0.hs

{-# LANGUAGE PackageImports #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeOperators #-}
module B0 where
import Prelude hiding ((.), id)
import "base" Control.Arrow (Kleisli(..))
import "base" Control.Category (Category (..))
import "base" Control.Exception (evaluate, catch, SomeException)
import "base" System.IO.Unsafe (unsafePerformIO)
import "semigroups" Data.List.NonEmpty (NonEmpty(..))

data Bidirectional p q a b = Bidirectional
  { forwards :: p a b
  , backwards :: q b a
  }

instance (Category p, Category q) => Category (Bidirectional p q) where
  Bidirectional pbc qcb . Bidirectional pab qba = Bidirectional (pbc . pab) (qba . qcb)
  id = Bidirectional id id

-- | bijections
--
-- Bidirectional fore back :: a <-> b =>
-- >  back . fore = id :: a -> a
-- >  fore . back = id :: b -> b
type (<->) = Bidirectional (->) (->)

-- | injections
--
-- Bidirectional fore back :: a ?-> b =>
-- >  ∀a. runKleisli back (fore a) = Just a
-- >
-- >  ∀b. fore <$> runKleisli back b =
-- >    Just b,   if b ∈ image(fore)
-- >    Nothing,  otherwise
type (?->) = Bidirectional (->) (Kleisli Maybe)

toInjection :: (a <-> b) -> (a ?-> b)
toInjection (Bidirectional fore back) = Bidirectional fore (Kleisli $ return . back)

-- | surjections
--
-- Bidirectional fore back :: a +-> b =>
-- >  ∀a. runKleisli back (fore a) ∋ a
-- >
-- >  ∀b ∃n. fore <$> runKleisli back b =
-- >    replicate n b, n >= 1
type (+->) = Bidirectional (->) (Kleisli NonEmpty)

toSurjection :: (a <-> b) -> (a +-> b)
toSurjection (Bidirectional fore back) = Bidirectional fore (Kleisli $ return . back)

-- | general functions
--
-- Bidirectional fore back :: a *-> b =>
-- >  ∀a. runKleisli back (fore a) ∋ a
-- >
-- >  ∀b ∃n. fmap fore $ runKleisli back b =
-- >    replicate n b, n >= 0
type (*->) = Bidirectional (->) (Kleisli [])

-- | a bijection from Int to Int
-- (exploiting minBound - 1 == maxBound, maxBound - 1 == minBound for Int)
incrementB :: Int <-> Int
incrementB = Bidirectional (+1) (subtract 1)

-- | an injection from Enum to Int
enumI :: Enum a => a ?-> Int
enumI = Bidirectional
    { forwards = fromEnum
    , backwards = Kleisli $ unsafePerformIO . toMaybeEnumIO
    }
  where
    toMaybeEnumIO :: Enum a => Int -> IO (Maybe a)
    toMaybeEnumIO !i = evaluate (Just $! toEnum i) `catch` orNothing

    orNothing :: SomeException -> IO (Maybe a)
    orNothing _ = return Nothing

-- | create a surjection from Int to Int
equalS :: Int -> (Int +-> Bool)
equalS a = Bidirectional
  { forwards = (==a)
  , backwards = Kleisli $ \case
      True  ->  a :| []
      False ->  let (x:xs) = [minBound + 1 .. a - 1] ++ [a + 1 .. maxBound]
                in x :| xs
  }

B1.hs

{-# LANGUAGE PackageImports #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
module B1 where
import Prelude hiding ((.), id)
import "base" Control.Arrow (Kleisli(..), Arrow(arr))
import "base" Control.Category (Category (..))
import "base" Control.Exception (evaluate, catch, SomeException)
import "base" System.IO.Unsafe (unsafePerformIO)
import "semigroups" Data.List.NonEmpty (NonEmpty(..))

data Bidirectional p q a b = Bidirectional
  { forwards :: p a b
  , backwards :: q b a
  }

instance (Category p, Category q) => Category (Bidirectional p q) where
  Bidirectional pbc qcb . Bidirectional pab qba = Bidirectional (pbc . pab) (qba . qcb)
  id = Bidirectional id id

-- | bijections
--
-- Bidirectional fore back :: a <-> b =>
-- >  back . fore = id :: a -> a
-- >  fore . back = id :: b -> b
type a <-> b = forall q. Arrow q => Bidirectional (->) q a b

-- | injections
--
-- Bidirectional fore back :: a ?-> b =>
-- >  ∀a. runKleisli back (fore a) = Just a
-- >
-- >  ∀b. fore <$> runKleisli back b =
-- >    Just b,   if b ∈ image(fore)
-- >    Nothing,  otherwise
type (?->) = Bidirectional (->) (Kleisli Maybe)

-- | surjections
--
-- Bidirectional fore back :: a +-> b =>
-- >  ∀a. runKleisli back (fore a) ∋ a
-- >
-- >  ∀b ∃n. fore <$> runKleisli back b =
-- >    replicate n b, n >= 1
type (+->) = Bidirectional (->) (Kleisli NonEmpty)

-- | general functions
--
-- Bidirectional fore back :: a *-> b =>
-- >  ∀a. runKleisli back (fore a) ∋ a
-- >
-- >  ∀b ∃n. fmap fore $ runKleisli back b =
-- >    replicate n b, n >= 0
type (*->) = Bidirectional (->) (Kleisli [])

-- | a bijection from Int to Int
-- (exploiting minBound - 1 == maxBound, maxBound - 1 == minBound for Int)
incrementB :: Int <-> Int
incrementB = Bidirectional (+1) (arr $ subtract 1)

-- | an injection from Enum to Int
enumI :: Enum a => a ?-> Int
enumI = Bidirectional
    { forwards = fromEnum
    , backwards = Kleisli $ unsafePerformIO . toMaybeEnumIO
    }
  where
    toMaybeEnumIO :: Enum a => Int -> IO (Maybe a)
    toMaybeEnumIO !i = evaluate (Just $! toEnum i) `catch` orNothing

    orNothing :: SomeException -> IO (Maybe a)
    orNothing _ = return Nothing

-- | create a surjection from Int to Int
equalS :: Int -> (Int +-> Bool)
equalS a = Bidirectional
  { forwards = (==a)
  , backwards = Kleisli $ \case
      True  ->  a :| []
      False ->  let (x:xs) = [minBound + 1 .. a - 1] ++ [a + 1 .. maxBound]
                in x :| xs
  }

B2.hs

{-# LANGUAGE PackageImports #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
module B2 where
import Prelude hiding ((.), id)
import "base" Control.Arrow (Kleisli(..), Arrow(arr))
import "base" Control.Category (Category (..))
import "base" Control.Exception (evaluate, catch, SomeException)
import "base" System.IO.Unsafe (unsafePerformIO)
import "semigroups" Data.List.NonEmpty (NonEmpty(..))
import "transformers" Data.Functor.Compose (Compose(..))

data Bidirectional p q a b = Bidirectional
  { forwards :: p a b
  , backwards :: q b a
  }

instance (Category p, Category q) => Category (Bidirectional p q) where
  Bidirectional pbc qcb . Bidirectional pab qba = Bidirectional (pbc . pab) (qba . qcb)
  id = Bidirectional id id

(#) :: Functor m
    => Bidirectional (->) (Kleisli m) b c
    -> Bidirectional (->) (Kleisli n) a b
    -> Bidirectional (->) (Kleisli (Compose m n)) a c
Bidirectional pbc qcb # Bidirectional pab qab = Bidirectional (pbc . pab) . Kleisli $
  Compose . fmap (runKleisli qab) . runKleisli qcb
infixr 9 #

-- | bijections
--
-- Bidirectional fore back :: a <-> b =>
-- >  back . fore = id :: a -> a
-- >  fore . back = id :: b -> b
type a <-> b = forall q. Arrow q => Bidirectional (->) q a b

-- | injections
--
-- Bidirectional fore back :: a ?-> b =>
-- >  ∀a. runKleisli back (fore a) = Just a
-- >
-- >  ∀b. fore <$> runKleisli back b =
-- >    Just b,   if b ∈ image(fore)
-- >    Nothing,  otherwise
type (?->) = Bidirectional (->) (Kleisli Maybe)

-- | surjections
--
-- Bidirectional fore back :: a +-> b =>
-- >  ∀a. runKleisli back (fore a) ∋ a
-- >
-- >  ∀b ∃n. fore <$> runKleisli back b =
-- >    replicate n b, n >= 1
type (+->) = Bidirectional (->) (Kleisli NonEmpty)

-- | general functions
--
-- Bidirectional fore back :: a *-> b =>
-- >  ∀a. runKleisli back (fore a) ∋ a
-- >
-- >  ∀b ∃n. fmap fore $ runKleisli back b =
-- >    replicate n b, n >= 0
type (*->) = Bidirectional (->) (Kleisli [])

-- | a bijection from Int to Int
-- (exploiting minBound - 1 == maxBound, maxBound - 1 == minBound for Int)
incrementB :: Int <-> Int
incrementB = Bidirectional (+1) (arr $ subtract 1)

-- | an injection from Enum to Int
enumI :: Enum a => a ?-> Int
enumI = Bidirectional
    { forwards = fromEnum
    , backwards = Kleisli $ unsafePerformIO . toMaybeEnumIO
    }
  where
    toMaybeEnumIO :: Enum a => Int -> IO (Maybe a)
    toMaybeEnumIO !i = evaluate (Just $! toEnum i) `catch` orNothing

    orNothing :: SomeException -> IO (Maybe a)
    orNothing _ = return Nothing

-- | create a surjection from Int to Int
equalS :: Int -> (Int +-> Bool)
equalS a = Bidirectional
  { forwards = (==a)
  , backwards = Kleisli $ \case
      True  ->  a :| []
      False ->  let (x:xs) = [minBound + 1 .. a - 1] ++ [a + 1 .. maxBound]
                in x :| xs
  }

B3.hs

{-# LANGUAGE PackageImports #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module B3 where
import Prelude hiding ((.), id)
import "base" Control.Arrow (Kleisli(..),arr)
import "base" Control.Category (Category (..))
import "base" Control.Exception (evaluate, catch, SomeException)
import "base" System.IO.Unsafe (unsafePerformIO)
import "base" Data.Foldable (Foldable, toList)
import "semigroups" Data.List.NonEmpty (NonEmpty(..))
import "transformers" Data.Functor.Compose (Compose(..))

data Bidirectional p q a b = Bidirectional
  { forwards :: p a b
  , backwards :: q b a
  }

instance (Category p, Category q) => Category (Bidirectional p q) where
  Bidirectional pbc qcb . Bidirectional pab qba = Bidirectional (pbc . pab) (qba . qcb)
  id = Bidirectional id id

instance Unifiable q p => Unifiable (Bidirectional (->) p) (Bidirectional (->) q) where
  Bidirectional bc pcb # Bidirectional ab qba = Bidirectional (bc . ab) (qba # pcb)
  type Union (Bidirectional (->) p) (Bidirectional (->) q) = Bidirectional (->) (Union q p)

class (Category p, Category q) => Unifiable p q where
  type Union (p :: * -> * -> *) (q :: * -> * -> *) :: * -> * -> *
  (#) :: p b c -> q a b -> Union p q a c
infixr 9 #

instance Unifiable (->)                (->)                where { p # q = p . q                         ; type Union (->)                (->)                = (->)              }
instance Unifiable (->)                (Kleisli Maybe)     where { p # q = arr p . q                     ; type Union (->)                (Kleisli Maybe)     = Kleisli Maybe     }
instance Unifiable (->)                (Kleisli NonEmpty)  where { p # q = arr p . q                     ; type Union (->)                (Kleisli NonEmpty)  = Kleisli NonEmpty  }
instance Unifiable (->)                (Kleisli [])        where { p # q = arr p . q                     ; type Union (->)                (Kleisli [])        = Kleisli []        }
instance Unifiable (Kleisli Maybe)     (->)                where { p # q = p . arr q                     ; type Union (Kleisli Maybe)     (->)                = Kleisli Maybe     }
instance Unifiable (Kleisli NonEmpty)  (->)                where { p # q = p . arr q                     ; type Union (Kleisli NonEmpty)  (->)                = Kleisli NonEmpty  }
instance Unifiable (Kleisli [])        (->)                where { p # q = p . arr q                     ; type Union (Kleisli [])        (->)                = Kleisli []        }
instance Unifiable (Kleisli Maybe)     (Kleisli Maybe)     where { p # q = p . q                         ; type Union (Kleisli Maybe)     (Kleisli Maybe)     = Kleisli Maybe     }
instance Unifiable (Kleisli NonEmpty)  (Kleisli NonEmpty)  where { p # q = p . q                         ; type Union (Kleisli NonEmpty)  (Kleisli NonEmpty)  = Kleisli NonEmpty  }
instance Unifiable (Kleisli [])        (Kleisli [])        where { p # q = p . q                         ; type Union (Kleisli [])        (Kleisli [])        = Kleisli []        }
instance Unifiable (Kleisli Maybe)     (Kleisli NonEmpty)  where { p # q = toListArrow p . toListArrow q ; type Union (Kleisli Maybe)     (Kleisli NonEmpty)  = Kleisli []        }
instance Unifiable (Kleisli NonEmpty)  (Kleisli Maybe)     where { p # q = toListArrow p . toListArrow q ; type Union (Kleisli NonEmpty)  (Kleisli Maybe)     = Kleisli []        }
instance Unifiable (Kleisli Maybe)     (Kleisli [])        where { p # q = toListArrow p . q             ; type Union (Kleisli Maybe)     (Kleisli [])        = Kleisli []        }
instance Unifiable (Kleisli NonEmpty)  (Kleisli [])        where { p # q = toListArrow p . q             ; type Union (Kleisli NonEmpty)  (Kleisli [])        = Kleisli []        }
instance Unifiable (Kleisli [])        (Kleisli Maybe)     where { p # q = p . toListArrow q             ; type Union (Kleisli [])        (Kleisli Maybe)     = Kleisli []        }
instance Unifiable (Kleisli [])        (Kleisli NonEmpty)  where { p # q = p . toListArrow q             ; type Union (Kleisli [])        (Kleisli NonEmpty)  = Kleisli []        }

toListArrow :: Foldable m => Kleisli m a b -> Kleisli [] a b
toListArrow p = Kleisli $ toList . runKleisli p

-- | bijections
--
-- Bidirectional fore back :: a <-> b =>
-- >  back . fore = id :: a -> a
-- >  fore . back = id :: b -> b
type (<->) = Bidirectional (->) (->)

-- | injections
--
-- Bidirectional fore back :: a ?-> b =>
-- >  ∀a. runKleisli back (fore a) = Just a
-- >
-- >  ∀b. fore <$> runKleisli back b =
-- >    Just b,   if b ∈ image(fore)
-- >    Nothing,  otherwise
type (?->) = Bidirectional (->) (Kleisli Maybe)

-- | surjections
--
-- Bidirectional fore back :: a +-> b =>
-- >  ∀a. runKleisli back (fore a) ∋ a
-- >
-- >  ∀b ∃n. fore <$> runKleisli back b =
-- >    replicate n b, n >= 1
type (+->) = Bidirectional (->) (Kleisli NonEmpty)

-- | general functions
--
-- Bidirectional fore back :: a *-> b =>
-- >  ∀a. runKleisli back (fore a) ∋ a
-- >
-- >  ∀b ∃n. fmap fore $ runKleisli back b =
-- >    replicate n b, n >= 0
type (*->) = Bidirectional (->) (Kleisli [])

-- | a bijection from Int to Int
-- (exploiting minBound - 1 == maxBound, maxBound - 1 == minBound for Int)
incrementB :: Int <-> Int
incrementB = Bidirectional (+1) (subtract 1)

-- | an injection from Enum to Int
enumI :: Enum a => a ?-> Int
enumI = Bidirectional
    { forwards = fromEnum
    , backwards = Kleisli $ unsafePerformIO . toMaybeEnumIO
    }
  where
    toMaybeEnumIO :: Enum a => Int -> IO (Maybe a)
    toMaybeEnumIO !i = evaluate (Just $! toEnum i) `catch` orNothing

    orNothing :: SomeException -> IO (Maybe a)
    orNothing _ = return Nothing

-- | create a surjection from Int to Int
equalS :: Int -> (Int +-> Bool)
equalS a = Bidirectional
  { forwards = (==a)
  , backwards = Kleisli $ \case
      True  ->  a :| []
      False ->  let (x:xs) = [minBound + 1 .. a - 1] ++ [a + 1 .. maxBound]
                in x :| xs
  }