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.)