The Visitor pattern in Haskell

VisitorExample.hs

{-# LANGUAGE ExistentialQuantification #-}
-- This file is a direct translation of the example for the Visitor pattern from
-- Wikipedia [1] to Haskell
--
-- The Visitor pattern essentially tackles two dispatching problems:
-- 
-- 1. double dispatching
-- 2. dispatching subtypes
-- 
-- While double dispatching of static types could be solved in Haskell by using
-- the "MultiParamTypeclass" extension, Haskell has no included implementation
-- of subtyping. Two standard ways to manually implement "subtyping" are:
--
-- 1. using a sum type, listing all alternatives, for instance:
--    data CarElement = Engine_ Engine | Wheel_ Wheel ...
-- 2. bundle the used functions together with the data, i.e. what existential
--    types [2] do (as well as OO languages).
--
-- In the first case pattern matching is appropriate to "dispatch" the
-- different "subtypes" (better subcases). In the second case the Visitor
-- pattern might be useful, to keep the number of bundled functions small,
-- while allowing to write new visitors (as it is in OO languages).
-- 
-- This file is a reaction to a blog post by E. Z. Yang [3], there he describes
-- how the problems of the GoF patterns are solvable in Haskell. In my opinion
-- he misses the problem that motivates the Visitor pattern.
--
-- [1] http://en.wikipedia.org/wiki/Visitor_pattern
-- [2] http://www.haskell.org/haskellwiki/Existential_type
-- [3] http://blog.ezyang.com/2010/05/design-patterns-in-haskel/

class CarElement e where
	accept :: (CarElementVisitor v) => e -> v -> IO ()

class CarElementVisitor v where
	-- Haskell supports no ad hoc overloading, so this uses different names
	-- for different type cases.
	visitCar :: v -> Car -> IO ()
	visitWheel :: v -> Wheel -> IO ()
	visitEngine :: v -> Engine -> IO ()

data Wheel = FrontLeft | FrontRight | BackLeft | BackRight deriving (Show, Enum)
wheelName :: Wheel -> String
wheelName FrontLeft = "left front"
wheelName FrontRight = "right front"
wheelName BackRight = "right back"
wheelName BackLeft = "left back"

data Engine = Engine deriving Show

newtype Car = Car {elements :: [CarElementBoxed]}

-- CarElementBoxed bundles the data of a specific CarElement together with the
-- corresponding dictionary of his CarElement instance. It represents roughly
-- an "object of the class CarElement".
data CarElementBoxed = forall e . CarElement e => CarElement e

-- We have to pass the accept function to the underlining element.
instance CarElement CarElementBoxed where
	CarElement e `accept` v = e `accept` v

instance CarElement Car where
	accept c v = do
		v `visitCar` c
		-- It might be more appropriate, to let the CarElementVisitor
		-- traverse the elements, to be more flexible.
		mapM_ (\e -> e `accept` v) (elements c)

instance CarElement Wheel where
	accept = flip visitWheel

instance CarElement Engine where
	accept = flip visitEngine

-- A CarElementVisitor that prints details of CarElements.
data Printer = Printer deriving Show

printVisit :: Show a => Printer -> a -> IO ()
Printer `printVisit` e = putStrLn $ '\t' : show e

instance CarElementVisitor Printer where
	Printer `visitCar` Car _ = putStrLn "Car with elements:"
	Printer `visitWheel` w =
		putStrLn $ "\tThe wheel at " ++ wheelName w ++ "."
	visitEngine = printVisit

-- A CarElementVisitor that "starts" CarElements.
data Starter = Starter deriving Show

instance CarElementVisitor Starter where
	Starter `visitCar` Car _ = putStrLn "Starting the car..."
	Starter `visitEngine` Engine = putStrLn "Starting the engine."
	Starter `visitWheel` w = putStrLn $ "Spinning the " ++ wheelName w ++ " wheel."

main = do
	let	wheel = FrontLeft
		car = Car $ CarElement Engine :
				map CarElement [FrontLeft .. BackRight]
	wheel `accept` Printer
	putChar '\n'
	car `accept` Printer
	car `accept` Starter