Skip to content

anonymous /VisitorExample.hs

Embed URL


Subversion checkout URL

You can clone with
Download ZIP
The Visitor pattern in Haskell
{-# 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]
-- [2]
-- [3]
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.