Ad-hoc Polymorphism vs. Data Constructors in Haskell - haskell

Question

Defining different data constructors for a type, and then defining functions using pattern matching over them resembles ad-hoc polymorphism in other languages a lot:
data Shape = Circle Float | Rectangle Float Float
area :: Shape -> Float
area (Circle r) = pi * r^2
area (Rectangle a b) = a*b
Using type classes you could do
class Shape s where
area :: s -> Float
data Circle = Circle Float
instance Shape Circle where
area (Circle r) = pi * r^2
data Rectangle = Rectangle Float Float
instance Shape Rectangle where
area (Rectangle a b) = a*b
One advantage of the second that I see is that it can be extended without touching existing declarations, in particular it may be your only option. Are there other reasons to prefer one over the other?

Answer 1

To make the 2nd approach work, you have to know the type s at compile time while with the 1st approach you can match runtime values
data Shape = Circle Float | Rectangle Float Float
area :: Shape -> Float
area (Circle r) = pi * r^2
area (Rectangle a b) = a*b
fromString :: String -> [Float] -> Shape
fromString "circle" (r:_) = Circle r
fromString "rectangle" (a:b:_) = Rectangle a b
areaFromString :: String -> [Float] -> Float
areaFromString s params = area $ fromString s params
Difference between Type Class and Algebraic data types
Scala: difference between a typeclass and an ADT?
Type classes vs algebraic data types?

Answer 2

To compare these approaches, it helps to see more than the data type declarations.
Suppose we want to write a Haskell program to parse a shape specification and display it as an ASCII diagram on the screen.
Solution #1
One method is to define our Shape as an ADT:
type Pos = (Float, Float)
type Scalar = Float
data Shape
= Circle Pos Scalar
| Rectangle Pos Scalar Scalar
deriving (Show)
To parse the specification, we'll use Megaparsec. This will require a Parser Shape:
shape :: Parser Shape
shape = Circle <$ char 'C' <*> pos <*> scalar
<|> Rectangle <$ char 'R' <*> pos <*> scalar <* char ',' <*> scalar
plus some additional pos and scalar parsers (see below).
To render the shape, we'll first calculate its bounding box:
data Box = Box Pos Pos deriving (Show)
bbox :: Shape -> Box
bbox (Circle (x,y) r) = Box (x-r,y-r) (x+r,y+r)
bbox (Rectangle (x,y) w h) = Box (x-w/2,y-h/2) (x+w/2,y+h/2)
and then write it to a raster over that bounding box:
type Raster = [[Char]]
render :: Box -> (Int, Int) -> Shape -> Raster
render (Box (x1,y1) (x2,y2)) (cx,cy) s
= [[ if inShape (x,y) s then 'X' else ' '
| x <- [x1',x1'+delta..x2']] | y <- [y1',y1'-delta*caspect..y2']]
where --- ugly computations of x1', etc. go here
This relies on a function that can determine if a raster point is inside the shape or not:
inShape :: Pos -> Shape -> Bool
inShape (x,y) (Circle (cx,cy) r) = sq (x-cx) + sq (y-cy) <= sq r
where sq a = a*a
inShape (x,y) (Rectangle (cx,cy) w h)
= cx-w/2 <= x && x <= cx+w/2
&& cy-h/2 <= y && y <= cy+h/2
After adding some driver/main functions and filling in the details, the full program is:
{-# OPTIONS_GHC -Wall #-}
import Data.Void
import Text.Megaparsec hiding (Pos)
import Text.Megaparsec.Char
type Pos = (Float, Float)
type Scalar = Float
data Shape
= Circle Pos Scalar
| Rectangle Pos Scalar Scalar
deriving (Show)
type Parser = Parsec Void String
shape :: Parser Shape
shape = Circle <$ char 'C' <*> pos <*> scalar
<|> Rectangle <$ char 'R' <*> pos <*> scalar <* char ',' <*> scalar
pos :: Parser Pos
pos = (,) <$ char '(' <*> scalar <* char ',' <*> scalar <* char ')'
scalar :: Parser Scalar
scalar = do
sgn <- option 1 (-1 <$ char '-')
dig1 <- digits
dig2 <- option "" ((:) <$> char '.' <*> digits)
return $ sgn * read (dig1 ++ dig2)
where digits = some digitChar
data Box = Box Pos Pos deriving (Show)
bbox :: Shape -> Box
bbox (Circle (x,y) r) = Box (x-r,y-r) (x+r,y+r)
bbox (Rectangle (x,y) w h) = Box (x-w/2,y-h/2) (x+w/2,y+h/2)
type Raster = [[Char]]
render :: Box -> (Int, Int) -> Shape -> Raster
render (Box (x1,y1) (x2,y2)) (cx,cy) s
= [[ if inShape (x,y) s then 'X' else ' '
| x <- [x1',x1'+delta..x2']] | y <- [y1',y1'-delta*caspect..y2']]
where caspect = 2 -- font character aspect ratio
expand = 1.2 -- expansion of raster beyond bounding box
delta = max ((x2-x1) / fromIntegral cx) ((y2-y1) / fromIntegral cy / caspect)
x1' = (x1+x2)/2 - expand*cx' * delta
x2' = (x1+x2)/2 + expand*cx' * delta
y1' = (y1+y2)/2 + expand*cy' * delta * caspect
y2' = (y1+y2)/2 - expand*cy' * delta * caspect
cx' = fromIntegral cx / 2
cy' = fromIntegral cy / 2
inShape :: Pos -> Shape -> Bool
inShape (x,y) (Circle (cx,cy) r) = sq (x-cx) + sq (y-cy) <= sq r
where sq a = a*a
inShape (x,y) (Rectangle (cx,cy) w h)
= cx-w/2 <= x && x <= cx+w/2
&& cy-h/2 <= y && y <= cy+h/2
driver :: String -> IO ()
driver spec = do
putStrLn "---BEGIN---"
let res = parse (shape <* eof) "(string)" spec
case res of
Left err -> error (errorBundlePretty err)
Right s -> putStrLn $ unlines $ render (bbox s) (40,20) s
putStrLn "---END---"
main :: IO ()
main = do
driver "C(3,8)8" -- circle radius 8 centered at (3,8)
driver "R(-1,6)8,3" -- rectangle centered at (-1,6) w/ dim 8 by 3
It works fine:
λ> main
---BEGIN---
XXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXX
X
---END---
---BEGIN---
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
---END---
Suppose we want to add a shape, like an Octagon. This requires adding an Octagon constructor:
data Shape
= ...
| Octagon Pos Scalar
...
Compiler warnings direct us to add the following cases to our functions:
bbox (Octagon (x,y) w) = Box (x-w/2,y-w/2) (x+w/2,y+w/2)
inShape (x,y) (Octagon (cx,cy) w)
= cx-w/2 <= x && x <= cx+w/2
&& cy-w/2 <= y && y <= cy+w/2
&& abs (x-cx) + abs (y-cy) <= w / sqrt 2
We have to figure out on our own that the parser needs to be modified:
shape = ...
<|> Octagon <$ char 'O' <*> pos <*> scalar
This change requires 7 lines of code added in 4 locations in the source.
Suppose we now want to add an ability to create shapes that consist of unions of other shapes. This change is similar in scope and requires the addition of 7 lines of code in 4 locations.
Finally, suppose we want to add the ability to "render" to a descriptive text format. This requires defining a 5-line function in one location:
description :: Shape -> String
description (Circle c r) = "a circle centered at " ++ show c ++ " with radius " ++ show r
description (Rectangle c w h) = "a rectangle centered at " ++ show c ++ " with width " ++ show w ++ " and height " ++ show h
description (Octagon c w) = "an octagon centered at " ++ show c ++ " with width " ++ show w
description (Union s t) = "the union of " ++ description s ++ " and " ++ description t
The full program follows. It's 94 lines and 3148 characters of source, and it makes no use of advanced Haskell features other than applicative syntax for the parser.
{-# OPTIONS_GHC -Wall #-}
import Data.Void
import Text.Megaparsec hiding (Pos)
import Text.Megaparsec.Char
type Pos = (Float, Float)
type Scalar = Float
data Shape
= Circle Pos Scalar
| Rectangle Pos Scalar Scalar
| Octagon Pos Scalar
| Union Shape Shape
deriving (Show)
type Parser = Parsec Void String
shape :: Parser Shape
shape = Circle <$ char 'C' <*> pos <*> scalar
<|> Rectangle <$ char 'R' <*> pos <*> scalar <* char ',' <*> scalar
<|> Octagon <$ char 'O' <*> pos <*> scalar
<|> Union <$ char 'U' <*> shape <*> shape
pos :: Parser Pos
pos = (,) <$ char '(' <*> scalar <* char ',' <*> scalar <* char ')'
scalar :: Parser Scalar
scalar = do
sgn <- option 1 (-1 <$ char '-')
dig1 <- digits
dig2 <- option "" ((:) <$> char '.' <*> digits)
return $ sgn * read (dig1 ++ dig2)
where digits = some digitChar
data Box = Box Pos Pos deriving (Show)
bbox :: Shape -> Box
bbox (Circle (x,y) r) = Box (x-r,y-r) (x+r,y+r)
bbox (Rectangle (x,y) w h) = Box (x-w/2,y-h/2) (x+w/2,y+h/2)
bbox (Octagon (x,y) w) = Box (x-w/2,y-w/2) (x+w/2,y+w/2)
bbox (Union s t)
= let Box (x1,y1) (x2,y2) = bbox s
Box (x3,y3) (x4,y4) = bbox t
in Box (min x1 x3, min y1 y3) (max x2 x4, max y2 y4)
type Raster = [[Char]]
render :: Box -> (Int, Int) -> Shape -> Raster
render (Box (x1,y1) (x2,y2)) (cx,cy) s
= [[ if inShape (x,y) s then 'X' else ' '
| x <- [x1',x1'+delta..x2']] | y <- [y1',y1'-delta*caspect..y2']]
where caspect = 2 -- font character aspect ratio
expand = 1.2 -- expansion of raster beyond bounding box
delta = max ((x2-x1) / fromIntegral cx) ((y2-y1) / fromIntegral cy / caspect)
x1' = (x1+x2)/2 - expand*cx' * delta
x2' = (x1+x2)/2 + expand*cx' * delta
y1' = (y1+y2)/2 + expand*cy' * delta * caspect
y2' = (y1+y2)/2 - expand*cy' * delta * caspect
cx' = fromIntegral cx / 2
cy' = fromIntegral cy / 2
inShape :: Pos -> Shape -> Bool
inShape (x,y) (Circle (cx,cy) r) = sq (x-cx) + sq (y-cy) <= sq r
where sq a = a*a
inShape (x,y) (Rectangle (cx,cy) w h)
= cx-w/2 <= x && x <= cx+w/2
&& cy-h/2 <= y && y <= cy+h/2
inShape (x,y) (Octagon (cx,cy) w)
= cx-w/2 <= x && x <= cx+w/2
&& cy-w/2 <= y && y <= cy+w/2
&& abs (x-cx) + abs (y-cy) <= w / sqrt 2
inShape p (Union s t) = inShape p s || inShape p t
description :: Shape -> String
description (Circle c r) = "a circle centered at " ++ show c ++ " with radius " ++ show r
description (Rectangle c w h) = "a rectangle centered at " ++ show c ++ " with width " ++ show w ++ " and height " ++ show h
description (Octagon c w) = "an octagon centered at " ++ show c ++ " with width " ++ show w
description (Union s t) = "the union of " ++ description s ++ " and " ++ description t
driver :: String -> IO ()
driver spec = do
putStrLn "---BEGIN---"
let res = parse (shape <* eof) "(string)" spec
case res of
Left err -> error (errorBundlePretty err)
Right s -> do
putStrLn $ unlines $ render (bbox s) (40,20) s
putStrLn $ description s
putStrLn "---END---"
main :: IO ()
main = do
driver "UR(0,0)2,2UC(1,1)0.5C(-1,1)0.5"
Solution #2
A second method of writing this program is to define a Shape class and a collection of instances of this class representing each possible shape. We might spec out the shapes we want to support as follows, without defining any functionality just yet:
class Shape s
data Circle = Circle Pos Scalar deriving (Show)
instance Shape Circle
data Rectangle = Rectangle Pos Scalar Scalar deriving (Show)
instance Shape Rectangle
Now, to parse the parse the shape specification, we'll use Megaparsec. We can't write a Parser Shape, because Shape is a type class. We can write a method for parsing the individual shapes however. This involves adding lines to the class and instances:
class Shape s where
parseShape :: Parser s
instance Shape Circle where
parseShape = Circle <$ char 'C' <*> pos <*> scalar
instance Shape Rectangle where
parseShape = Rectangle <$ char 'R' <*> pos <*> scalar <* char ',' <*> scalar
We can conveniently parse an arbitrary shape by definining an existential type:
data SomeShape = forall s. Shape s => SomeShape s
As tempting as it might seem, the following does not work at all:
someShape :: Parser SomeShape
someShape = SomeShape <$> parseShape
There is, unfortunately, no way to avoid enumerating the individual shapes like so:
someShape :: Parser SomeShape
someShape = SomeShape <$> (parseShape :: Parser Circle)
<|> SomeShape <$> (parseShape :: Parser Rectangle)
Now that we can parse shapes, we'll want to calculate a bounding box. This involves adding the Box type and three lines of the bbox definition to the class and two instances:
data Box = Box Pos Pos deriving (Show)
class Shape s where
...
bbox :: s -> Box
instance Shape Circle where
...
bbox (Circle (x,y) r) = Box (x-r,y-r) (x+r,y+r)
instance Shape Rectangle where
...
bbox (Rectangle (x,y) w h) = Box (x-w/2,y-h/2) (x+w/2,y+h/2)
The rendering function is much the same as before, except for its type signature:
render :: (Shape s) => Box -> (Int, Int) -> s -> Raster
The render function requires an inShape method, which involves adding the three lines of the inShape definition to the class and two instances.
The driver needs to be modified to handle the existential shape. In this case, the fix is easy -- just an additional pattern match on SomeShape:
driver :: String -> IO ()
driver spec = do
putStrLn "---BEGIN---"
let res = parse (someShape <* eof) "(string)" spec
case res of
Left err -> error (errorBundlePretty err)
Right (SomeShape s) -> putStrLn $ unlines $ render (bbox s) (40,20) s
putStrLn "---END---"
The full program follows:
{-# OPTIONS_GHC -Wall #-}
import Data.Void
import Text.Megaparsec hiding (Pos)
import Text.Megaparsec.Char
data Box = Box Pos Pos deriving (Show)
class Shape s where
parseShape :: Parser s
bbox :: s -> Box
inShape :: Pos -> s -> Bool
type Pos = (Float, Float)
type Scalar = Float
data Circle = Circle Pos Scalar deriving (Show)
instance Shape Circle where
parseShape = Circle <$ char 'C' <*> pos <*> scalar
bbox (Circle (x,y) r) = Box (x-r,y-r) (x+r,y+r)
inShape (x,y) (Circle (cx,cy) r) = sq (x-cx) + sq (y-cy) <= sq r
where sq a = a*a
data Rectangle = Rectangle Pos Scalar Scalar deriving (Show)
instance Shape Rectangle where
parseShape = Rectangle <$ char 'R' <*> pos <*> scalar <* char ',' <*> scalar
bbox (Rectangle (x,y) w h) = Box (x-w/2,y-h/2) (x+w/2,y+h/2)
inShape (x,y) (Rectangle (cx,cy) w h)
= cx-w/2 <= x && x <= cx+w/2
&& cy-h/2 <= y && y <= cy+h/2
type Parser = Parsec Void String
pos :: Parser Pos
pos = (,) <$ char '(' <*> scalar <* char ',' <*> scalar <* char ')'
scalar :: Parser Scalar
scalar = do
sgn <- option 1 (-1 <$ char '-')
dig1 <- digits
dig2 <- option "" ((:) <$> char '.' <*> digits)
return $ sgn * read (dig1 ++ dig2)
where digits = some digitChar
data SomeShape = forall s. Shape s => SomeShape s
someShape :: Parser SomeShape
someShape = SomeShape <$> (parseShape :: Parser Circle)
<|> SomeShape <$> (parseShape :: Parser Rectangle)
type Raster = [[Char]]
render :: (Shape s) => Box -> (Int, Int) -> s -> Raster
render (Box (x1,y1) (x2,y2)) (cx,cy) s
= [[ if inShape (x,y) s then 'X' else ' '
| x <- [x1',x1'+delta..x2']] | y <- [y1',y1'-delta*caspect..y2']]
where caspect = 2 -- font character aspect ratio
expand = 1.2 -- expansion of raster beyond bounding box
delta = max ((x2-x1) / fromIntegral cx) ((y2-y1) / fromIntegral cy / caspect)
x1' = (x1+x2)/2 - expand*cx' * delta
x2' = (x1+x2)/2 + expand*cx' * delta
y1' = (y1+y2)/2 + expand*cy' * delta * caspect
y2' = (y1+y2)/2 - expand*cy' * delta * caspect
cx' = fromIntegral cx / 2
cy' = fromIntegral cy / 2
driver :: String -> IO ()
driver spec = do
putStrLn "---BEGIN---"
let res = parse (someShape <* eof) "(string)" spec
case res of
Left err -> error (errorBundlePretty err)
Right (SomeShape s) -> putStrLn $ unlines $ render (bbox s) (40,20) s
putStrLn "---END---"
main :: IO ()
main = do
driver "C(3,8)8" -- circle radius 8 centered at (3,8)
driver "R(-1,6)8,3" -- rectangle centered at (-1,6) w/ dim 8 by 3
There's not a tremendous amount of difference between this type class based version and the first ADT version above. Using a natural, common syntax, it's about 15% longer, as measured by lines or characters, it requires the use of an existential data type, and it includes some complex distractions related to that type.
Now, suppose we want to add an Octagon. The type class implementation should provide much cleaner extensibility for new shapes. We need to add the type and its instance:
data Octagon = Octagon Pos Scalar deriving (Show)
instance Shape Octagon where
parseShape = Octagon <$ char 'O' <*> pos <*> scalar
bbox (Octagon (x,y) w) = Box (x-w/2,y-w/2) (x+w/2,y+w/2)
inShape (x,y) (Octagon (cx,cy) w)
= cx-w/2 <= x && x <= cx+w/2
&& cy-w/2 <= y && y <= cy+w/2
&& abs (x-cx) + abs (y-cy) <= w / sqrt 2
Unfortunately, we need to separately add the octagon to the enumeration in the shape parser:
someShape :: Parser SomeShape
someShape = SomeShape <$> (parseShape :: Parser Circle)
<|> SomeShape <$> (parseShape :: Parser Rectangle)
<|> SomeShape <$> (parseShape :: Parser Octagon)
This seems like defect. We ought to specify a master list of shapes in one place that can be sequenced at runtime to iterate over all parseShape methods (as well as other methods we might later add that require similar enumeration). A straightforward way of doing this is to define a function that converts a generic Shape operation into a sequence of specialized operations across concrete shapes. That is:
overShapes :: (forall s. Shape s => Proxy s -> a) -> [a]
overShapes op =
[ op (Proxy #Circle)
, op (Proxy #Rectangle)
, op (Proxy #Octagon)]
Now we can write shape succintly as:
someShape :: Parser SomeShape
someShape = asum (overShapes op)
where op :: forall s. (Shape s) => Proxy s -> Parser SomeShape
op _ = SomeShape <$> parseShape #s
This should really pay off now that we're ready to add unions. We will only need to define a Union type and instance containing all the supporting functionality in one place and then remember to add it to overShapes for a seamless extension.
Unfortunately, the obvious definition:
data Union = Union Shape Shape deriving (Show)
doesn't work, since Shape is a type class. We might start with something like:
data Union s t = Union s t deriving (Show)
instance (Shape s, Shape t) => Shape (Union s t) where
parseShape = ...
bbox (Union s t)
= let Box (x1,y1) (x2,y2) = bbox s
Box (x3,y3) (x4,y4) = bbox t
in Box (min x1 x3, min y1 y3) (max x2 x4, max y2 y4)
inShape p (Union s t) = inShape p s || inShape p t
Now, when we try to define parseShape, we run into a bit of a problem. We can certainly define:
instance (Shape s, Shape t) => Shape (Union s t) where
parseShape = Union <$ char 'U' <*> parseShape <*> parseShape
but it quickly becomes apparent that we can't make any use of it. The parseShape parser can only parse a known shape, like Union Circle Rectangle. If we want to parse an arbitrary union, we need to parse its components not using parseShape but instead by using someShape and then constructing an existential SomeShape for the Union, which can't expose its subshapes in the Union type. So, we'll probably need to write:
data Union = Union SomeShape SomeShape
instance Shape Union where
parseShape = Union <$ char 'U' <*> someShape <*> someShape
bbox (Union (SomeShape s) (SomeShape t))
= let Box (x1,y1) (x2,y2) = bbox s
Box (x3,y3) (x4,y4) = bbox t
in Box (min x1 x3, min y1 y3) (max x2 x4, max y2 y4)
inShape p (Union (SomeShape s) (SomeShape t)) = inShape p s || inShape p t
As mentioned, we'll need to add it to the overShapes function:
overShapes op =
[ op (Proxy #Circle)
, op (Proxy #Rectangle)
, op (Proxy #Octagon)
, op (Proxy #Union)]
Still, it's nice that we were able to add the support for Union in one place plus the overShapes enumeration.
Unfortunately, when it comes time to add our description method, the extensbility is the wrong way around. Instead of defining description in one place, as we did with the ADT implementation, we need to add a type signature and method calls to all the classes (basically 5 lines in 5 places), just as we did when adding bbox and inShape during development.
The final program is 113 lines and 3961 characters, about 20-25% longer than the ADT version. It also contains some real stinkers like:
overShapes :: (forall s. Shape s => Proxy s -> a) -> [a]
and
op :: forall s. (Shape s) => Proxy s -> Parser SomeShape
op _ = SomeShape <$> parseShape #s
but at least we can conveniently extend it by adding 7 lines in 2 places instead of 5 lines in 5 places, as long as we're only adding a new shape and not adding functionality that requires a new method -- for that, we need to add 5 lines in 5 places instead of 5 lines in 1 place.
The final program:
{-# OPTIONS_GHC -Wall #-}
import Data.Proxy
import Control.Applicative (asum)
import Data.Void
import Text.Megaparsec hiding (Pos)
import Text.Megaparsec.Char
data Box = Box Pos Pos deriving (Show)
class Shape s where
parseShape :: Parser s
bbox :: s -> Box
inShape :: Pos -> s -> Bool
description :: s -> String
overShapes :: (forall s. Shape s => Proxy s -> a) -> [a]
overShapes op =
[ op (Proxy #Circle)
, op (Proxy #Rectangle)
, op (Proxy #Octagon)
, op (Proxy #Union)]
type Pos = (Float, Float)
type Scalar = Float
data Circle = Circle Pos Scalar deriving (Show)
instance Shape Circle where
parseShape = Circle <$ char 'C' <*> pos <*> scalar
bbox (Circle (x,y) r) = Box (x-r,y-r) (x+r,y+r)
inShape (x,y) (Circle (cx,cy) r) = sq (x-cx) + sq (y-cy) <= sq r
where sq a = a*a
description (Circle c r) = "a circle centered at " ++ show c ++ " with radius " ++ show r
data Rectangle = Rectangle Pos Scalar Scalar deriving (Show)
instance Shape Rectangle where
parseShape = Rectangle <$ char 'R' <*> pos <*> scalar <* char ',' <*> scalar
bbox (Rectangle (x,y) w h) = Box (x-w/2,y-h/2) (x+w/2,y+h/2)
inShape (x,y) (Rectangle (cx,cy) w h)
= cx-w/2 <= x && x <= cx+w/2
&& cy-h/2 <= y && y <= cy+h/2
description (Rectangle c w h) = "a rectangle centered at " ++ show c ++ " with width " ++ show w ++ " and height " ++ show h
data Octagon = Octagon Pos Scalar deriving (Show)
instance Shape Octagon where
parseShape = Octagon <$ char 'O' <*> pos <*> scalar
bbox (Octagon (x,y) w) = Box (x-w/2,y-w/2) (x+w/2,y+w/2)
inShape (x,y) (Octagon (cx,cy) w)
= cx-w/2 <= x && x <= cx+w/2
&& cy-w/2 <= y && y <= cy+w/2
&& abs (x-cx) + abs (y-cy) <= w / sqrt 2
description (Octagon c w) = "an octagon centered at " ++ show c ++ " with width " ++ show w
data Union = Union SomeShape SomeShape
instance Shape Union where
parseShape = Union <$ char 'U' <*> someShape <*> someShape
bbox (Union (SomeShape s) (SomeShape t))
= let Box (x1,y1) (x2,y2) = bbox s
Box (x3,y3) (x4,y4) = bbox t
in Box (min x1 x3, min y1 y3) (max x2 x4, max y2 y4)
inShape p (Union (SomeShape s) (SomeShape t)) = inShape p s || inShape p t
description (Union (SomeShape s) (SomeShape t)) = "the union of " ++ description s ++ " and " ++ description t
type Parser = Parsec Void String
pos :: Parser Pos
pos = (,) <$ char '(' <*> scalar <* char ',' <*> scalar <* char ')'
scalar :: Parser Scalar
scalar = do
sgn <- option 1 (-1 <$ char '-')
dig1 <- digits
dig2 <- option "" ((:) <$> char '.' <*> digits)
return $ sgn * read (dig1 ++ dig2)
where digits = some digitChar
data SomeShape = forall s. Shape s => SomeShape s
someShape :: Parser SomeShape
someShape = asum (overShapes op)
where op :: forall s. (Shape s) => Proxy s -> Parser SomeShape
op _ = SomeShape <$> parseShape #s
type Raster = [[Char]]
render :: (Shape s) => Box -> (Int, Int) -> s -> Raster
render (Box (x1,y1) (x2,y2)) (cx,cy) s
= [[ if inShape (x,y) s then 'X' else ' '
| x <- [x1',x1'+delta..x2']] | y <- [y1',y1'-delta*caspect..y2']]
where caspect = 2 -- font character aspect ratio
expand = 1.2 -- expansion of raster beyond bounding box
delta = max ((x2-x1) / fromIntegral cx) ((y2-y1) / fromIntegral cy / caspect)
x1' = (x1+x2)/2 - expand*cx' * delta
x2' = (x1+x2)/2 + expand*cx' * delta
y1' = (y1+y2)/2 + expand*cy' * delta * caspect
y2' = (y1+y2)/2 - expand*cy' * delta * caspect
cx' = fromIntegral cx / 2
cy' = fromIntegral cy / 2
driver :: String -> IO ()
driver spec = do
putStrLn "---BEGIN---"
let res = parse (someShape <* eof) "(string)" spec
case res of
Left err -> error (errorBundlePretty err)
Right (SomeShape s) -> do
putStrLn $ unlines $ render (bbox s) (40,20) s
putStrLn $ description s
putStrLn "---END---"
main :: IO ()
main = do
driver "UR(0,0)2,2UC(1,1)0.5C(-1,1)0.5"
Conclusions
The bottom line is that the ADT solution is straightforward to develop, understand, and extend. The type class solution pays a notable price in unnecessary complexity during development, in terms of both unusual type system features and the tendency to break the natural flow of development by splitting functions (which are the natural unit of development for functional programs) across separate instances, all for the promise of improved "extensibility" of the final program that is rarely realized in the real world.
I didn't time myself, but I'd estimate that my development time was about the same for each version. Considering that I wrote the ADT version first and copied and pasted everything I could from that to the type class version, this is quite an indictment of the type class version. The time I spent thinking through the core logic of the program (the overall design, the technical aspects of rendering the shapes, parsing a scalar in the most awkward way possible, etc.) plus the ADT implementation itself took about as much effort as thinking through the stupidities of the SomeShape type and fighting the Haskell type system to get the Union to work.
My larger experience with Haskell programming is that this is how it usually goes with ADT-based versus type-class-based designs, except it gets worse for bigger programs.