Gang of Four patterns in Haskell

visitor-direct-translation.lhs

This example comes from the Wikipedia article:

    https://en.wikipedia.org/wiki/Visitor_pattern

Our first indication of complexity is the fact that the MyInterface[] array requires rank 2 types:

> {-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies #-}

The multiparam type class and functional dependency is not part of the Wikipedia article proper,
and instead come because I saw myself writing an expression like:

    mapM f x >> y

below, and realized that this could become traverse f x *> y instead, lowering the constraint from
Monad to simply Applicative. So I got playful.

The pattern involves defining an up-front visitor typeclass:

>   class CarElementVisitor v f | v -> f where
>       visitCar    :: v -> Car    -> f ()
>       visitWheel  :: v -> Wheel  -> f ()
>       visitBody   :: v -> Body   -> f ()
>       visitEngine :: v -> Engine -> f ()

And then CarElements need to accept them:

>   class CarElement ce where
>       accept :: (Applicative f, CarElementVisitor v f) => ce -> v -> f ()

We then have to define our actual data structures which participate in this class:

>   data Wheel = Wheel {getName :: String}
>   instance CarElement Wheel where
>       accept = flip visitWheel
>
>   data Engine = Engine
>   instance CarElement Engine where
>       accept = flip visitEngine
>
>   data Body = Body
>   instance CarElement Body where
>       accept = flip visitBody
>
>   data Car = Car {elements :: [CEWrap]}
>   instance CarElement Car where
>       accept car v = traverse (\ce -> accept ce v) (elements car) *> visitCar v car

That above expression is the part where I realized I could downgrade mapM f x >> y to
work only on an Applicative functor.

Here is the part where we use the rank-2 type: a Car has a bunch of CEWrap elements above, which is
a sort of Interface[] array. So we need a way to remove every distinction about a type other than
the fact that it's a CarElement:

>   newtype CEWrap = CEWrap {
>           unWrapCE :: forall v f. (Applicative f, CarElementVisitor v f)
>               => v -> f ()
>       }
>
>   instance CarElement CEWrap where
>       accept = unWrapCE
>
>   wrapCE :: CarElement ce => ce -> CEWrap
>   wrapCE ce = CEWrap (accept ce)

Now we define our actual car:

>   mycar = Car [
>       wrapCE (Wheel "front left"), wrapCE (Wheel "front right"),
>       wrapCE (Wheel "back left"), wrapCE (Wheel "back right"),
>       wrapCE Body, wrapCE Engine]

And our two visitors for that car are singletons of their type, existing only to hold the static
methods that display the parts of the car differently:

>   data CarElementPrintVisitor = CarElementPrintVisitor
>   instance CarElementVisitor CarElementPrintVisitor IO where
>       visitCar _ _ = putStrLn "Visiting car"
>       visitWheel _ wheel = putStrLn ("Visiting " ++ getName wheel ++ " wheel")
>       visitBody _ _ = putStrLn "Visiting body"
>       visitEngine _ _ = putStrLn "Visiting engine"
>
>   data CarElementDoVisitor = CarElementDoVisitor
>   instance CarElementVisitor CarElementDoVisitor IO where
>       visitCar _ _ = putStrLn "Starting my car"
>       visitWheel _ wheel = putStrLn ("Kicking my " ++ getName wheel ++ " wheel")
>       visitBody _ _ = putStrLn "Moving my body"
>       visitEngine _ _ = putStrLn "Starting my engine"

Finally we can test this with:

>   main = do
>       accept mycar CarElementPrintVisitor
>       accept mycar CarElementDoVisitor

visitor-simplified.lhs

So now that we have seen what the official implementation looks like, how would an actual
Haskell programmer do the same thing natively?

First we have seen that a great deal of complexity comes simply from that Rank-2 type, which only
exists because Java does not have nice sum types. A Haskeller would probably start from the data,
writing:

> data CarElement = Car [CarElement] | Wheel String | Engine | Body deriving (Show)
>
> mycar :: CarElement
> mycar = Car [Wheel "front left", Wheel "front right", Wheel "back left",
>         Wheel "back right", Body, Engine]

Now if we want each of them to accept a visitor, we can do this by simply defining an appropriate
function:

> accept :: Applicative f => (CarElement -> f b) -> CarElement -> f b
> accept visitor element = case element of
>     Car subelements -> traverse visitor subelements *> visitor element
>     _               -> visitor element

(I am not sure whether I should leave that above type variable as b or force it to be (). The
advantage of the latter is that people don't get the wrong impression when they start providing
some other value and the *> operator blows it away on the subtrees.)

Notice that this actually really gets to the core of the visitor pattern, something which it takes
a whole Wikipedia article to even half-get-to: the core of the visitor pattern is that the code to
recurse on the subelements of the car is all written up-front once in this "accept" function so
that it does not have to be duplicated for each visitor. That is all that this pattern is. The rest
of the pattern involves simply handing different functions to the accept function to do different
things:

> printVisitor :: CarElement -> IO ()
> printVisitor element = putStrLn $ case element of
>     Wheel name -> "Visiting " ++ name ++ " wheel"
>     Engine -> "Visiting engine"
>     Body -> "Visiting body"
>     Car _ -> "Visiting car"
>
> doVisitor :: CarElement -> IO ()
> doVisitor element = putStrLn $ case element of
>     Wheel name -> "Kicking my " ++ name ++ " wheel"
>     Engine -> "Starting my engine"
>     Body -> "Moving my body"
>     Car _ -> "Starting my car"

Again we have the test program:

> main = do
>     accept printVisitor mycar
>     accept doVisitor mycar

Moreover, this format lets you notice something really hinky about the Wikipedia example, which is:
why is a Car a sort of CarElement?!

A much better example may have been a sort of JSON type where some values can legitimately contain
other values of the same type:

    data Value = VNull | VBool !Bool | VStr !Text | VNum !Double | VArr !(Seq Value)
               | VObj !(Map Text Value)

    accept :: Applicative f => (Value -> f ()) -> Value -> f ()
    accept visitor element = case element of
        VArr arr -> traverse visitor arr *> visitor element
        VObj obj -> traverse visitor obj *> visitor obj
        _        -> visitor element

This in turn reveals that the accept method itself is more or less just a version of traverse which
works on types of kind * rather than kind * -> *.