The extensible visitor pattern in tagless final style

This literate Haskell program translates Shriram Krishnamurthi, Matthias Felleisen, and Daniel P. Friedman’s “extensible visitor pattern”. Their paper “Synthesizing object-oriented and functional design to promote re-use” (ECOOP 1998, 91–113) proposes this pattern as a solution to the expression problem. Unlike them, we don’t use any type casts!

{-# LANGUAGE Rank2Types #-} module ExtensibleVisitor where data Point = Point { x, y :: Double } deriving (Eq, Show) class ShapeProcessor a where square :: Double {-s-} -> a circle :: Double {-r-} -> a translated :: Point {-d-} -> a {-s-} -> a newtype Render = Render (Int {-prec-} -> String -> String) instance Show Render where showsPrec p (Render s) = s p instance ShapeProcessor Render where square s = Render (\prec -> showParen (prec > 10) (showString "square " . showsPrec 11 s)) circle r = Render (\prec -> showParen (prec > 10) (showString "circle " . showsPrec 11 r)) translated d (Render s) = Render (\prec -> showParen (prec > 10) (showString "translated " . showsPrec 11 d . showChar ' ' . s 11))

> translated (Point 1 2) (circle 3) :: Render

translated (Point {x = 1.0, y = 2.0}) (circle 3.0)

newtype ContainsPt = ContainsPt { containsPt :: Point {-p-} -> Bool } instance ShapeProcessor ContainsPt where square s = ContainsPt (\(Point x y) -> 0 <= x && x <= s && 0 <= y && y <= s) circle r = ContainsPt (\(Point x y) -> x * x + y * y <= r * r) translated (Point dx dy) s = ContainsPt (\(Point x y) -> containsPt s (Point (x - dx) (y - dy)))

> containsPt (translated (Point 1 2) (circle 3)) (Point 2 3)

True

newtype Shrink a = Shrink { shrink :: Double {-pct-} -> a } instance (ShapeProcessor a) => ShapeProcessor (Shrink a) where square s = Shrink (\pct -> square (s / pct)) circle r = Shrink (\pct -> circle (r / pct)) translated d s = Shrink (\pct -> translated d (shrink s pct))

> shrink (translated (Point 1 2) (circle 3)) 10 :: Render

translated (Point {x = 1.0, y = 2.0}) (circle 0.3)

class ShapeProcessor a => UnionShapeProcessor a where union :: a {-s1-} -> a {-s2-} -> a instance UnionShapeProcessor Render where union (Render s1) (Render s2) = Render (\prec -> showParen (prec > 10) (showString "union " . s1 11 . showChar ' ' . s2 11))

> translated (Point 1 2) (union (square 4) (circle 3)) :: Render

translated (Point {x = 1.0, y = 2.0}) (union (square 4.0) (circle 3.0))

instance UnionShapeProcessor ContainsPt where union s1 s2 = ContainsPt (\p -> containsPt s1 p || containsPt s2 p)

> containsPt (translated (Point 1 2) (union (square 4) (circle 3))) (Point 2 3)

True

instance (UnionShapeProcessor a) => UnionShapeProcessor (Shrink a) where union s1 s2 = Shrink (\pct -> union (shrink s1 pct) (shrink s2 pct))

> shrink (translated (Point 1 2) (union (square 4) (circle 3))) 10 :: Render

translated (Point {x = 1.0, y = 2.0}) (union (square 0.4) (circle 0.3))

> containsPt (shrink (translated (Point 1 2) (union (square 4) (circle 3))) 10) (Point 2 3)

False

Below is the part that uses rank-2 types. We only need them if we want to process the output of a processor multiple times.

newtype Shape = Shape { processShape :: forall a. ShapeProcessor a => a } instance ShapeProcessor Shape where square s = Shape (square s) circle r = Shape (circle r) translated d s = Shape (translated d (processShape s)) newtype UnionShape = UnionShape { processUnionShape :: forall a. UnionShapeProcessor a => a } instance ShapeProcessor UnionShape where square s = UnionShape (square s) circle r = UnionShape (circle r) translated d s = UnionShape (translated d (processUnionShape s)) instance UnionShapeProcessor UnionShape where union s1 s2 = UnionShape (union (processUnionShape s1) (processUnionShape s2)) test :: UnionShape test = shrink (translated (Point 1 2) (union (square 4) (circle 3))) 10

> processUnionShape test :: Render

translated (Point {x = 1.0, y = 2.0}) (union (square 0.4) (circle 0.3))

> containsPt (processUnionShape test) (Point 2 3)

False