Build (single) inheritance up from scratch in Haskell

subtype-examples.hs

{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts,
             TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses
  #-}

import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (maybeToList)
import Data.Ratio (numerator, denominator)
import Data.IORef (IORef)
import SubType

-------------------------------------------------------------------------------
-- "Tall" subtype tree

{-   Double
 -     |
 -  Rational
 -     |
 -  Integer
 -}

instance Subtype Integer where
  type SuperType Integer = Rational
  embedImmediate = fromIntegral

instance Subtype Rational where
  type SuperType Rational = Double
  embedImmediate r = fromIntegral (numerator r) / fromIntegral (denominator r)

integer2double :: Integer -> Double
integer2double = embed

-------------------------------------------------------------------------------
-- "Wide" subtype tree

{-            [a]
 -           /    \
 -          /      \
 -  NonEmpty a    Maybe a
 -}

instance Subtype (NonEmpty a) where
  type SuperType (NonEmpty a) = [a]
  embedImmediate (x :| xs) = x : xs

instance Subtype (Maybe a) where
  type SuperType (Maybe a) = [a]
  embedImmediate = maybeToList

maybe2list :: Maybe a -> [a]
maybe2list = embed

nonempty2list :: NonEmpty a -> [a]
nonempty2list = embed

-------------------------------------------------------------------------------
-- Covariance, contravariance, invariance
  
instance {-# OVERLAPPING #-} (a <: b) => [a] <: [b] where
  embed = map embed

instance {-# OVERLAPPING #-} (a <: b, c <: d) => (b -> c) <: (a -> d) where
  embed f = embed . f . embed
  
instance {-# OVERLAPPING #-} (IORef a) <: (IORef a) where
  embed = id

listInteger2listDouble :: [Integer] -> [Double]
listInteger2listDouble = embed

fromDouble2fromInteger :: (Double -> ()) -> (Integer -> ())
fromDouble2fromInteger = embed

-------------------------------------------------------------------------------

subtype.hs

{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, TypeOperators,
             FlexibleInstances, FlexibleContexts, UndecidableInstances
  #-}

-- Model subtyping when a given subtype has at most one immediate supertype (so you
-- have a tree of subtypes instead of a lattice.
module SubType where

-- | 'a' is an immediate subtype of 'b'. Formally,
--
--   * 'a <: b'
--   * 'a /= b'
--   * there does not exist a 'c' different from 'a' and 'b' such that 'a <: c <: b'
--
class Subtype a where
  type SuperType a :: *
  embedImmediate :: a -> SuperType a

-- | 'a' is a subtype of 'b'
class a <: b where
  -- | Embed a value of a subtype into a supertype
  embed :: a -> b

-- | Any type is a subtype of itself
instance a <: a where
  embed = id

-- | For 'a <: b', we get the immediate supertype 'c' of 'a' ('a <: c') and check that 'c <: b'
instance {-# OVERLAPPABLE #-} (Subtype a, (SuperType a) <: b) => a <: b where
  embed = embed . embedImmediate