The extensible visitor pattern in tagless final style

Proper Treatment 正當作法/ blog/ posts/ 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

(It would be nice to overload the names processShape and processUnionShape. We can do that by reifying the type classes ShapeProcessor and UnionShapeProcessor as two types that belong to the same multiparameter type class.)