ConstraintKinds

{-# 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