Existential antipattern, how to avoid

Question

The below seems to work... but it seems clumsy.

data Point = Point Int Int
data Box = Box Int Int
data Path = Path [Point]
data Text = Text

data Color = Color Int Int Int
    data WinPaintContext = WinPaintContext Graphics.Win32.HDC

class CanvasClass vc paint where
    drawLine :: vc -> paint -> Point -> Point -> IO ()
    drawRect :: vc -> paint -> Box -> IO ()
    drawPath :: vc -> paint -> Path -> IO ()

class (CanvasClass vc paint) => TextBasicClass vc paint where
    basicDrawText :: vc -> paint -> Point -> String -> IO ()

instance CanvasClass WinPaintContext WinPaint where
    drawLine = undefined
    drawRect = undefined
    drawPath = undefined

instance TextBasicClass WinPaintContext WinPaint where
    basicDrawText (WinPaintContext a) = winBasicDrawText a

op :: CanvasClass vc paint => vc -> Box -> IO ()
op canvas _ = do
    basicDrawText canvas WinPaint (Point 30 30) "Hi"

open :: IO ()
open = do
    makeWindow (Box 300 300) op

winBasicDrawText :: Graphics.Win32.HDC -> WinPaint -> Point -> String -> IO ()
winBasicDrawText hdc _ (Point x y) str = do
    Graphics.Win32.setBkMode hdc Graphics.Win32.tRANSPARENT
    Graphics.Win32.setTextColor hdc (Graphics.Win32.rgb 255 255 0)
    Graphics.Win32.textOut hdc 20 20 str
    return ()

windowsOnPaint :: (WinPaintContext -> Box -> IO ()) ->
                  Graphics.Win32.RECT ->
                  Graphics.Win32.HDC ->
                  IO ()
windowsOnPaint f rect hdc = f (WinPaintContext hdc) (Box 30 30)

makeWindow :: Box -> (WinPaintContext -> Box -> IO ()) -> IO ()
makeWindow (Box w h) onPaint =
  Graphics.Win32.allocaPAINTSTRUCT $ \ lpps -> do
  hwnd <- createWindow w h (wndProc lpps (windowsOnPaint onPaint))
  messagePump hwnd

Now, what seems to be the preferred way is to just simply have

data Canvas = Canvas {
    drawLine :: Point -> Point -> IO (),
    drawRect :: Box -> IO (),
    drawPath :: Path -> IO ()
}

hdc2Canvas :: Graphics.Win32.HDC -> Paint -> IO ( Canvas )
hdc2Canvas hdc paint = Canvas { drawLine = winDrawLine hdc paint ... }

HOWEVER...

We like to keep paints around and mutate them throughout the drawing process, as they're expensive to create and destroy. A paint could just be a list like [bgColor red, fgColor blue, font "Tahoma"] or something, or it could be a pointer to an internal structure the paint system uses (this is an abstraction over windows GDI, but will ultimately abstract over direct2d and coregraphics), which have "paint" objects which I don't wanna recreate over and over and then bind over.

The beauty of existentials in my mind is that they can opaquely wrap something to abstract over it, and we can save it somewhere, pull it back, whatever. When you partially apply, I think there is the problem that the thing you've partially applied is now "stuck inside" the container. Here's an example. Say I have a paint object like

data Paint = Paint {
    setFg :: Color -> IO () ,
    setBg :: Color -> IO ()
}

Where can I place the pointer? When I give the Paint to some function in Canvas, how does he get the pointer? What's the right way to design this API?

Answer 1

The Interface

First, you need to ask "What are my requirements?". Let's state in plain English what we want a canvas to do (these are my guesses based on your question):

• Some canvases can have shapes put on them
• Some canvases can have text put on them
• Some canvases change what they do based on a paint
• We don't know what paints are yet, but they will be different for different canvases

Now we translate these ideas into Haskell. Haskell is a "types-first" language, so when we are talking about requirements and design, we are probably talking about types.

• In Haskell, when we see the word "some" while talking about types, we think of type classes. For example, the show class says "some types can be represented as strings".
• When we talk about something we don't know about yet, while talking about requirements, that's a type where we don't know what it is yet. That's a type variable.
• "put on them" seems to mean that we'd take have a canvas, put something on it, and have a canvas again.

Now we could write classes for each of these requirements:

class ShapeCanvas c where -- c is the type of the Canvas
    draw :: Shape -> c -> c

class TextCanvas c where
    write :: Text -> c -> c

class PaintCanvas p c where -- p is the type of Paint
    load :: p -> c -> c

The type variable c is only used once, appearing as c -> c. This suggests we could make these more general by replacing c -> c with c.

class ShapeCanvas c where -- c is the type of the canvas
    draw :: Shape -> c

class TextCanvas c where
    write :: Text -> c

class PaintCanvas p c where -- p is the type of paint
    load :: p -> c

Now PaintCanvas looks like a class that is problematic in Haskell. It's hard for the type system to figure out what's going on in classes like

class Implicitly a b where
    convert :: b -> a

I'd alleviate this by changing PaintCanvas to take advantage of the TypeFamilies extension.

class PaintCanvas c where 
    type Paint c :: * -- (Paint c) is the type of Paint for canvases of type c
    load :: (Paint c) -> c

Now, let's put together everything for our interface, including your data types for shapes and text (modified to make sense to me):

{-# LANGUAGE TypeFamilies #-}

module Data.Canvas (
    Point(..),
    Shape(..),
    Text(..),
    ShapeCanvas(..),
    TextCanvas(..),
    PaintCanvas(..)
) where

data Point = Point Int Int

data Shape = Dot Point
           | Box Point Point 
           | Path [Point]

data Text = Text Point String

class ShapeCanvas c where -- c is the type of the Canvas
    draw :: Shape -> c

class TextCanvas c where
    write :: Text -> c

class PaintCanvas c where 
    type Paint c :: * -- (Paint c) is the type of Paint for canvases of type c
    load :: (Paint c) -> c

Some Examples

This section will introduce an additional requirement for useful canvases besides those we have already worked out. It is the analog of what we lost when we replaced c -> c with c in the canvas classes.

Let's start with your first example code, op. With our new interface it's simply:

op :: (TextCanvas c) => c
op = write $ Text (Point 30 30) "Hi"

Let's make a slightly more complicated example. How about something that draws an "X"? We can make the first stroke of the "X"

ex :: (ShapeCanvas c) => c
ex = draw $ Path [Point 10 10, Point 20 20]

But we have no way to add another Path for the cross stroke. We need some way to put two drawing steps together. Something with type c -> c -> c would be perfect. The simplest Haskell class I can think of that provides this is Monoid a's mappend :: a -> a -> a. A Monoid requires an identity and associativity. Is it resonable to assume that there's a drawing operation on canvases that leaves them untouched? That sounds quite reasonable. Is it reasonable to assume that three drawing operations, done in the same order, do the same thing even if the first two are performed together, and then the third, or if the first is performed, and then the second and third are performed together? Again, that seems quite reasonable to me. This suggest we can write ex as:

ex :: (Monoid c, ShapeCanvas c) => c
ex = (draw $ Path [Point 10 10, Point 20 20]) `mappend` (draw $ Path [Point 10 20, Point 20 10])

Finally, let's consider something interactive, that decides what to draw based on something external:

randomDrawing :: (MonadIO m, ShapeCanvas (m ()), TextCanvas (m ())) => m ()
randomDrawing = do
    index <- liftIO . getStdRandom $ randomR (0,2)
    choices !! index        
    where choices = [op, ex, return ()]

This doesn't quite work, because we don't have an instance for (Monad m) => Monoid (m ()) so that ex will work. We could use Data.Semigroup.Monad from the reducers package, or add one ourselves, but that puts us in incoherent instances land. It'd be easier to change ex to:

ex :: (Monad m, ShapeCanvas (m ())) => m ()
ex = do
    draw $ Path [Point 10 10, Point 20 20]
    draw $ Path [Point 10 20, Point 20 10]

But the type system can't quite figure out that the unit from the first draw is the same as the unit from the second. Our difficulty here suggests additional requirements, that we couldn't quite put our finger on at first:

• Canvases extend existing sequences of operations, providing operations for drawing, writing text, etc.

Stealing directly from http://www.haskellforall.com/2013/06/from-zero-to-cooperative-threads-in-33.html:

• When you hear "sequence of instructions" you should think: "monad".
• When you qualify that with "extend" you should think: "monad transformer".

Now we realize our canvas implementation is most likely going to be a monad transformer. We can go back to our interface, and change it so that each of the classes is a class for a monad, similar to transformers' MonadIO class and mtl's monad classes.

The Interface, revisited

{-# LANGUAGE TypeFamilies #-}

module Data.Canvas (
    Point(..),
    Shape(..),
    Text(..),
    ShapeCanvas(..),
    TextCanvas(..),
    PaintCanvas(..)
) where

data Point = Point Int Int

data Shape = Dot Point
           | Box Point Point 
           | Path [Point]

data Text = Text Point String

class Monad m => ShapeCanvas m where -- c is the type of the Canvas
    draw :: Shape -> m ()

class Monad m => TextCanvas m where
    write :: Text -> m ()

class Monad m => PaintCanvas m where 
    type Paint m :: * -- (Paint c) is the type of Paint for canvases of type c
    load :: (Paint m) -> m ()

Examples, revisited

Now all of our example drawing operations are actions in some unknown Monad m:

op :: (TextCanvas m) => m ()
op = write $ Text (Point 30 30) "Hi"

ex :: (ShapeCanvas m) => m ()
ex = do
    draw $ Path [Point 10 10, Point 20 20]
    draw $ Path [Point 10 20, Point 20 10]


randomDrawing :: (MonadIO m, ShapeCanvas m, TextCanvas m) => m ()
randomDrawing = do
    index <- liftIO . getStdRandom $ randomR (0,2)
    choices !! index        
    where choices = [op, ex, return ()]

We can also make an example using paint. Since we don't know what paints will exist, they all have to be provided externally (as arguments to the example):

checkerBoard :: (ShapeCanvas m, PaintCanvas m) => Paint m -> Paint m -> m ()
checkerBoard red black = 
    do
        load red
        draw $ Box (Point 10 10) (Point 20 20)
        draw $ Box (Point 20 20) (Point 30 30)
        load black
        draw $ Box (Point 10 20) (Point 20 30)
        draw $ Box (Point 20 10) (Point 30 20)

An Implementation

If you can make your code work to draw points, boxes, lines and text using various paints without introducing abstraction, we can change it to implement the interface from the first section.