Universal Constructions in Haskell

universal_constructions.hs

{-# LANGUAGE ScopedTypeVariables #-}
import Prelude (IO, pure, print, String, Bool(True, False), Int, Show)

(.) :: (b -> c) -> (a -> b) -> (a -> c)
g . f = \x -> g (f x)

($) :: (x -> y) -> x -> y
f $ x = f x

id :: a -> a
id a = a

class BiFunctor f where
  bimap :: (a -> a') -> (b -> b') -> f a b -> f a' b'

data Pair a b = Pair a b deriving Show

fst :: Pair a b -> a
fst (Pair a _) = a

snd :: Pair a b -> b
snd (Pair _ b) = b

fanout :: (c -> a) -> (c -> b) -> (c -> Pair a b)
fanout f g c = Pair (f c) (g c)

fanin :: (c -> Pair a b) -> Pair (c -> a) (c -> b)
fanin h = Pair (fst . h) (snd . h)

instance BiFunctor Pair where
  -- bimap :: (a -> a') -> (b -> b') -> Pair a b -> Pair a' b'
  bimap f g = fanout (f . fst) (g . snd)
  
data Either a b = Left a | Right b deriving Show

either :: (a -> c) -> (b -> c) -> (Either a b -> c)
either f g x =
  case x of
    Left a -> f a
    Right b -> g b

uneither :: (Either a b -> c) -> Pair (a -> c) (b -> c)
uneither h = Pair (h . Left) (h . Right)

instance BiFunctor Either where
  -- bimap :: (a -> a') -> (b -> b') -> Either a b -> Either a' b'
  bimap f g = either (Left . f) (Right . g)

curry :: (Pair a b -> c) -> (a -> b -> c)
curry f a b = f (Pair a b)

uncurry :: (a -> b -> c) -> (Pair a b -> c)
uncurry f (Pair a b) = f a b

h' :: Either (Pair a c) (Pair b c) -> Pair (Either a b) c
h' = either helper1 helper2
  where
    helper1 :: Pair a c -> Pair (Either a b) c
    helper1 = bimap Left id
    
    helper2 :: Pair b c -> Pair (Either a b) c
    helper2 = bimap Right id
    
h :: Pair (Either a b) c -> Either (Pair a c) (Pair b c)
h = uncurry helper1
  where
    helper1 :: Either a b -> (c -> Either (Pair a c) (Pair b c))
    helper1 = either helper2 helper3
    
    helper2 :: a -> (c -> Either (Pair a c) (Pair b c))
    helper2 = curry Left
    
    helper3 :: b -> (c -> Either (Pair a c) (Pair b c))
    helper3 = curry Right

main :: IO ()
main = do
  let x :: Pair (Either String Bool) Int = Pair (Left "Me") 2022
      y :: Pair (Either String Bool) Int = Pair (Right True) 2021
      z :: Either (Pair String Int) (Pair Bool Int) = Left (Pair "Me" 2022)
      w :: Either (Pair String Int) (Pair Bool Int) = Right (Pair True 2021)
  print $ h x
  print $ h y
  print $ h' z
  print $ h' w