HKT.hs

{-|
Module      : Data.Void.HKT
Description : A poly-kinded uninhabited type.
Copyright   : ©2020 James Alexander Feldman-Crough
License     : MPL-2.0
Maintainer  : alex@fldcr.com
-}
{-# OPTIONS_GHC -Wno-unused-binds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
module Data.Void.HKT (Void, Uninhabited(..)) where

import           Data.Profunctor                ( Profunctor(..)
                                                , Strong(..)
                                                , Choice(..)
                                                )
import           Data.Bifunctor                 ( Bifunctor(..) )

-- | A poly-kinded, uninhabited type family.
data family Void :: k

-- | The uninhabited type taking no arguments.
data instance Void

-- | The uninhabited type taking one argument.
newtype instance Void (a :: ka) = Void1 Void

-- | The uninhabited type taking two arguments.
newtype instance Void (a :: ka) (b :: kb) = Void2 Void

-- | The uninhabited type taking three arguments.
newtype instance Void (a :: ka) (b :: kb) (c :: kc) = Void3 Void

-- | Defines uninhabited types.
class Uninhabited a where
    -- | If @a@ is an uninhabited type, we will never receive a value of type
    -- @a@ and thus we can return a value of any type.
    absurd :: a -> b

instance Uninhabited Void where
    absurd = \case {}

instance Uninhabited (Void a) where
    absurd = \case {}

instance Uninhabited (Void a b) where
    absurd = \case {}

instance Uninhabited (Void a b c) where
    absurd = \case {}

instance Functor Void where
    fmap = const absurd

instance Functor (Void a) where
    fmap = const absurd

instance Functor (Void a b) where
    fmap = const absurd

instance Bifunctor Void where
    bimap = const (const absurd)

instance Bifunctor (Void a) where
    bimap = const (const absurd)

instance Profunctor Void where
    dimap = const (const absurd)

instance Profunctor (Void a) where
    dimap = const (const absurd)

instance Strong Void where
    first'  = absurd
    second' = absurd

instance Strong (Void a) where
    first'  = absurd
    second' = absurd

instance Choice Void where
    left'  = absurd
    right' = absurd

instance Choice (Void a) where
    left'  = absurd
    right' = absurd