public
anonymous / VisitorExample.hs
Last active

The Visitor pattern in Haskell

  • Download Gist
VisitorExample.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102
{-# 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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.