Last active
March 31, 2022 14:01
-
-
Save sacundim/8511f98d6173d8d46533 to your computer and use it in GitHub Desktop.
OOP Shape example in Haskell, using existentials, GADTs, Typeable and ConstraintKinds to support downcasts.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment