OOP-style multiple inheritance in Haskell

Inheritance.hs

-- Reimagining Samuel Pocino's implementation of
-- prototype based inheritance in Haskell
-- (see https://x.com/sampocino/status/1977471406750507200)

{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedRecordDot #-}
module Inheritance where

import Data.Function (fix)
import Data.IORef
import Data.Kind (Type)

import Test.DocTest (doctest)
-- $setup
-- >>> :set -XOverloadedRecordDot


---------------------------
-- Class inheritance API --
---------------------------

type Interface = Type

newtype Class (i :: Interface)
  = Class {unClass :: i -> i}

new :: Class i -> i
new = fix . unClass

abstract :: a
abstract = error "unimplemented abstract method"

extend :: (child -> parent) -> Class parent -> (parent -> Class child) -> Class child
extend c2p superclass mkChildClass = Class $ \this ->
  let super = unClass superclass (c2p this)
   in unClass (mkChildClass super) this


-------------------------
-- Inheritance example --
-------------------------

data IParent = IParent
  { parentOuterMethod :: IO ()
  , parentInnerMethod :: IO ()
  , parentAbstractMethod :: IO ()
  }

-- |
-- >>> let parent = new parentClass
-- >>> parent.parentOuterMethod
-- parent outer
-- *** Exception: unimplemented abstract method
-- ...
parentClass :: Class IParent
parentClass = Class $ \this -> IParent
  { parentOuterMethod = do
      putStrLn "parent outer"
      this.parentAbstractMethod
  , parentInnerMethod = do
      putStrLn "parent inner"
  , parentAbstractMethod = abstract
  }

data IChild = IChild
  { parent :: IParent
  , childOuterMethod :: IO ()
  , childInnerMethod :: IO ()
  }

-- |
-- >>> let child = new childClass
-- >>> child.parent.parentOuterMethod
-- parent outer
-- child inner
-- >>> child.childOuterMethod
-- child outer
-- parent inner
childClass :: Class IChild
childClass
  = extend parent parentClass $ \super
 -> Class $ \this
 -> IChild
      { parent = super
          { parentAbstractMethod = this.childInnerMethod
          }
      , childOuterMethod = do
          putStrLn "child outer"
          this.parent.parentInnerMethod
      , childInnerMethod = do
          putStrLn "child inner"
      }


---------------------
-- Counter example --
---------------------

-- Here's how to have:
-- * private fields
-- * a constructor which takes arguments
-- * a constructor which performs side-effects

data ICounter = ICounter
  { increment :: IO ()
  , getCount :: IO Int
  }

-- |
-- >>> counter <- new <$> mkCounterClass 42
-- >>> counter.increment
-- >>> counter.getCount
-- 43
mkCounterClass :: Int -> IO (Class ICounter)
mkCounterClass initialValue = do
  field <- newIORef initialValue
  pure $ Class $ \_this -> ICounter
    { increment = do
        modifyIORef' field (+1)
    , getCount = do
        readIORef field
    }


----------------------------------
-- Multiple inheritance example --
----------------------------------

-- We construct the "dreaded" diamond inheritance pattern, ensuring that
-- the grandparent is only constructed once.
--
--     Counter
--     /     \
-- Parent1  Parent2
--     \     /
--     Diamond

data IParent1 = IParent1
  { counter1 :: ICounter
  , increment1 :: IO ()
  }

mkParent1Class :: Class ICounter -> Class IParent1
mkParent1Class counterClass
  = extend counter1 counterClass $ \super
 -> Class $ \_this
 -> IParent1
      { counter1 = super
      , increment1 = do
          putStrLn "Parent1 incrementing"
          super.increment
      }

data IParent2 = IParent2
  { counter2 :: ICounter
  , increment2 :: IO ()
  }

mkParent2Class :: Class ICounter -> Class IParent2
mkParent2Class counterClass
  = extend counter2 counterClass $ \super
 -> Class $ \_this
 -> IParent2
      { counter2 = super
      , increment2 = do
          putStrLn "Parent2 incrementing"
          super.increment
      }

data IDiamond = IDiamond
  { parent1 :: IParent1
  , parent2 :: IParent2
  , incrementBoth :: IO ()
  }

mkDiamondClass :: Class IParent1 -> Class IParent2 -> Class IDiamond
mkDiamondClass parent1Class parent2Class
  = extend parent1 parent1Class $ \super1
 -> extend parent2 parent2Class $ \super2
 -> Class $ \_this
 -> IDiamond
      { parent1 = super1
      , parent2 = super2
      , incrementBoth = do
          super1.increment1
          super2.increment2
      }

-- |
-- >>> diamond <- new <$> assembleDiamondClass
-- >>> diamond.incrementBoth
-- Parent1 incrementing
-- Parent2 incrementing
--
-- Both increments modified the same counter instance:
-- >>> diamond.parent1.counter1.getCount
-- 2
-- >>> diamond.parent2.counter2.getCount
-- 2
assembleDiamondClass :: IO (Class IDiamond)
assembleDiamondClass = do
  counterClass <- mkCounterClass 0
  let parent1Class = mkParent1Class counterClass
      parent2Class = mkParent2Class counterClass
  pure $ mkDiamondClass parent1Class parent2Class

-- Note how 'diamond' as both two copies of the 'ICounter' grandparent, namely
-- 'diamond.parent1.counter1' and 'diamond.parent2.counter2', and it also only
-- has a single copy, because both of those fields point to the same memory
-- location.

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

test :: IO ()
test = do
  doctest ["src/Lib.hs"]

main :: IO ()
main = do
  putStrLn "typechecks."