OOP Shape example in Haskell, using existentials, GADTs, Typeable and ConstraintKinds to support downcasts.

Shape.hs

{-# LANGUAGE GADTs, ConstraintKinds, KindSignatures, DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleInstances #-}

module Shape where

import Control.Applicative ((<$>), (<|>))
import Data.Maybe (mapMaybe)
import Data.Typeable
import GHC.Exts (Constraint)
 
-- | Generic, reflective, heterogeneous container for instances
-- of a type class.
data Object (constraint :: * -> Constraint) where
    Obj :: (Typeable a, constraint a) => a -> Object constraint
           deriving Typeable
 
-- | Downcast an 'Object' to any type that satisfies the relevant
-- constraints.
downcast :: forall a constraint. (Typeable a, constraint a) =>
            Object constraint -> Maybe a
downcast (Obj (value :: b)) = 
  case eqT :: Maybe (a :~: b) of
    Just Refl -> Just value
    Nothing -> Nothing
 
 
-----------------------------------------------------------------------
-----------------------------------------------------------------------
--
-- The good old "Shape example"
--
 
class Shape shape where
  getArea :: shape -> Double
 
-- Note how the 'Object' type is parametrized by 'Shape', a class 
-- constraint.  That's the sort of thing ConstraintKinds enables.
instance Shape (Object Shape) where
    getArea (Obj o) = getArea o
 
 
data Circle = Circle { radius :: Double }
            deriving Typeable
 
instance Shape Circle where
  getArea (Circle radius) = pi * radius^2
 

data Rectangle = Rectangle { height :: Double, width :: Double }
               deriving Typeable
 
instance Shape Rectangle where
  getArea (Rectangle height width) = height * width
 

-- | Data used for the examples below.  Note again the type: "list of
-- 'Object's that satisfy the 'Shape' constraint."
exampleData :: [Object Shape]
exampleData = [Obj (Circle 1.5), Obj (Rectangle 2 3)]

-- | For each 'Shape' in the list, try to cast it to a Circle.  If we
-- succeed, then pass the result to a monomorphic function that 
-- demands a 'Circle'.  Evaluates to:
--
-- >>> example
-- ["A Circle of radius 1.5","A Shape with area 6.0"]
example :: [String]
example = mapMaybe step exampleData
  where step shape = describeCircle <$> (downcast shape)
                 <|> Just (describeShape shape)
 
describeCircle :: Circle -> String
describeCircle (Circle radius) = "A Circle of radius " ++ show radius

describeShape :: Shape a => a -> String
describeShape shape = "A Shape with area " ++ show (getArea shape)