Subtyping, OO-Style

Subtyping.hs

{-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, FlexibleContexts, OverlappingInstances, ScopedTypeVariables #-}
-- The goal of the code below is to emulate OO method dispatch.
--
-- The use-case is binding to a C++ GUI framework that is heavily OO and
-- providing the user with a familiar experience.
--
-- This scheme sketched out below emulates not only OO style method dispatch
-- but also allows users to "sub-class", "override" and even arbitrarily
-- change the type signature of overridden methods, all without touching the
-- original library code.
--
-- It is also conservative with respect to language extensions and so portable
-- to older versions of GHC. The newest extension used is GADTs.

-- All test code below uses this example "object" hierarchy:
-- Base -> Shape -> Rectangle -> Square
--               |
--               -> Circle
-- Shape has `Area` and `ToString` functions
-- Square and Circle override the `Area` function` but inherit `ToString`
--
-- Skip to the `dispatch` function to see how all of this works.
data Base
data CShape f a
type Shape          = CShape (Area (ToString ())) Base
data CRectangle f a
type Rectangle      = CRectangle () Shape
data CSquare f a
type Square         = CSquare (Area ()) Rectangle
data CCircle f a
type Circle         = CCircle (Area ()) Shape
-- A type that will carry the hierarchy with it.
-- In the actual binding the RHS would carry a
-- reference to a void pointer like this:
-- data Ref a  = Ref !(ForeignPtr (Ptr ()))
data Ref a          = Ref
-- The methods
data Area a
data Blah a
data ToString a
data NonExistent a

-- Type level function where `b` is SameType
-- if `x` and `y` are equal and `DifferentType`
-- if not.
data SameType
data DifferentType
class TypeEqual x y b | x y -> b
instance TypeEqual a a SameType
instance DifferentType ~ b => TypeEqual x y b

-- Move down a nested type hierarchy
-- eg. Tail (w (x (y (z ())))) (x (y (z ())))
class Tail aas as | aas -> as
instance Tail (a as) as
instance (r ~ ()) => Tail () r

-- Test whether a given nested type contains
-- a type
-- eg. Contains (w (x (y (z ())))) (y ()) SameType
--     Contains (w (x (y (z ())))) (a ()) DifferentType
class Contains' a b match r | a b match -> r
instance (Tail aas as, Contains as b r) => Contains' aas b DifferentType r
instance (r ~ SameType) => Contains' a b SameType r

class Contains as a r | as a -> r
instance (TypeEqual (a ()) b match, Contains' (a as) b match r) => Contains (a as) b r
instance Contains () b DifferentType

-- Move down the "object" hierarchy
-- eg. Downcast Rectangle Shape
class Downcast aas as | aas -> as
instance Downcast (a fs as) as
instance Downcast Base Base

-- Find an the first "object" with given
-- associated method in the hierarchy.
-- eg. FindOp Rectangle (ToString ()) (Match Shape)
--     FindOp Shape     (Area ())     (NoFunction (Area ()))
data Match a
data NoFunction a
class FindOp' a b c r | a b c -> r
instance (Downcast aas as, FindOp as f r) => FindOp' aas f DifferentType r
instance (r ~ (Match a)) => FindOp' a b SameType r

class FindOp a b c | a b -> c
instance (Contains fs f match, FindOp' (a fs as) f match r) => FindOp (a fs as) f r
instance FindOp Base f (NoFunction f)

-- Implementations of methods on various types
-- of objects
class Op op s impl | op s -> impl where
    runOp :: op -> (Ref s) -> impl
-- The `Area` method on a `Shape`
instance Op (Area ()) Shape (Int -> Int -> IO ()) where
    runOp _ _ x y = print (x * y)
-- The `Area` method on a `Rectangle`
-- NOTE: It can have different type signature than it's parent type
instance Op (Area ()) Square (Int -> IO ()) where
    runOp _ _ x = print (x * x)
-- The `ToString` method on all `Shape`s
instance Op (ToString ()) Shape (IO ()) where
    runOp _ _ = print "I am a shape."
-- The `Area` method on a `Circle`
instance Op (Area ()) Circle (Int -> IO ()) where
    runOp _ _ r = let r' = fromIntegral r
                  in print $ 3.14 * r' * r'

-- Arbitrarily cast from one thing to another
-- Probably should add some safety here ...
class CastTo a b r where castTo :: (Ref a) -> (Ref r)
instance CastTo a b r where castTo Ref = Ref

-- Given some "object" and a "function" dispatch to the
-- right implementation.
dispatch :: forall a r op impl. (FindOp a op (Match r), Op op r impl) => op -> Ref a -> impl
dispatch _ refA = runOp (undefined :: op) ((castTo refA) :: Ref r)
-- Running an example
-- > dispatch (undefined :: Area ()) (Ref :: Ref Rectangle) 5 6
-- 30
-- > dispatch (undefined :: Area ()) (Ref :: Ref Square) 5
-- 25
-- > dispatch (undefined :: ToString ()) (Ref :: Ref Square)
-- "I am a shape"
-- > dispatch (undefined :: Area ()) (Ref :: Ref Circle) 1
-- 3.14

-- Convenience functions that delegate to `dispatch`
-- Example usage:
-- > area (Ref :: Ref Rectangle) 5 6
-- 30
-- > area (Ref :: Ref Square) 5
-- 25
-- > toString (Ref :: Ref Rectangle)
-- "I am a shape."
area :: (FindOp a (Area ()) (Match r), Op (Area ()) r impl) => Ref a -> impl
area = dispatch (undefined :: Area ())

toString :: (FindOp a (ToString ()) (Match r), Op (ToString ()) r impl) => Ref a -> impl
toString = dispatch (undefined :: ToString ())


-- Unused type class
class Below' a b match | a b -> match
instance (Downcast aas as, Below as b r) => Below' aas b DifferentType
instance (r ~ SameType) => Below' aas b r

class Below a b r | a b -> r
instance (TypeEqual (a ()) b match, Below' (a as) b match) => Below (a as) b r
instance Below Base b DifferentType

-- Tests, don't worry about these
hDowncastTest :: (Downcast Shape r) => r
hDowncastTest = undefined
hCastTo :: (CastTo a b r) => a -> b -> r
hCastTo = undefined
hFindOpTest :: (FindOp a (Area ()) r) => a -> r
hFindOpTest = undefined
hMemberTest :: (Contains (Blah (Area (Blah ()))) (Area ()) r) => r
hMemberTest = undefined
hMemberTest2 :: (Contains (Area ()) (Area ()) r) => r
hMemberTest2 = undefined
hEqTest :: (TypeEqual (Area ()) (Area ()) r) => r
hEqTest = undefined
hEqTest2 :: (TypeEqual (Area (Blah ())) (Area ()) r) => r
hEqTest2 = undefined
hEqTest3 :: (TypeEqual () (Area ()) r) => r
hEqTest3 = undefined
hEqTest4 :: (TypeEqual () () r) => r
hEqTest4 = undefined
asTypeOf :: a -> a -> a
asTypeOf a b = a