{-# LANGUAGE GADTs, ConstraintKinds, KindSignatures, DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleInstances, FlexibleContexts #-}
-- http://stackoverflow.com/questions/31317159/constraintkinds-explained-on-a-super-simple-example
-- 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
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
exampleData :: [Object Shape]
exampleData = [Obj (Circle 1.5), Obj (Rectangle 2 3)]
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)
main = print example
