Custom Controls in wxHaskell (part 3)

State management

Note to readers: this is an aspect of the control implementation which I find rather unsatisfactory, and I will be exploring alternative approaches at some point in the future.

It is difficult to get away from the fact that the wxWidgets library which underlies wxHaskell is a piece of classic object-oriented C++ design, and many of the abstractions it presents to the world are about maintaining and manipulating stateful information encapsulated inside objects.

While wxHaskell has some neat abstractions, such as Attributes and Layout, which allow a more declarative style of programming in places, at the core of design of most wxHaskell programs will be manipulations of different controls and the like.

There are several options open to anyone building an application:

1. Pass the identities of all of the required controls around as parameters to the relevant functions. This is a properly functional approach, but quickly gets out of hand in a real application containing many widgets.
2. Wrap the state information in a state monad stacked on top of the IO monad (most of the wxHaskell API lives in the IO monad). This is among the more principled approaches I can think of, but it wraps everything monad transformers, and tends to make my head hurt. We will explore this approach in some depth later, however.
3. Use wxHaskell variables. A couple of the wxHaskell samples (notably BouncingBalls) do this.
4. Manage state manually, using something like a hash table to store the required information.

When implementing a re-usable control, one aspect of state management which needs extra consideration is that your design needs to account for the possibility of multiple instances of the control.

The approach taken here is stateful, maintaining a per-control state (so that multiple controls could be used in an application if required). A hash table, keyed on the DiffControl ID (actually the Window ID of the Panel which was sub-classed to create the control – which is unique within a given wxWidgets application) maintains state for all control instances.

The control id is taken to be the identity of the outermost panel (i.e. the dvs_panel field of the DiffViewerState type).

DiffViewerState attempts to encapsulate all of the state required to maintain the control. Notice that the diff function and the formatting for the diff lines line have been made ‘pluggable’, enabling the diff function and the formatting to be adapted to user requirements.

> data DiffViewerState = DVS { dvs_panel :: DiffViewer ()
>                            , dvs_fn1   :: StaticText ()
>                            , dvs_fn2   :: StaticText ()
>                            , dvs_f1    :: Window ()
>                            , dvs_f2    :: Window ()
>                            , dvs_vsb   :: ScrollBar ()
>                            , dvs_hsb   :: ScrollBar ()
>                            , dvs_diff  :: Maybe (FilePath -> FilePath -> IO [String])
>                            , dvs_fmt   :: DiffViewerFormatting
>                            , dvs_txt   :: Map.Map Int DiffLine
>                            }

Formatting information is defined in a separate structure, to keep things manageable, with a Show instance required only to simplify debugging.

> data DiffViewerFormatting = DVF { dvf_font     :: !FontStyle
>                                 , dvf_colour   :: !Color
>                                 , dvf_bgcolour :: !Color
>                                 , dvf_spacer   :: !Int
>                                 } deriving Show

The default formatting is black text on white background, fixed width font in 8 point text. You may prefer something larger, but I like to fit as much text as possible on my screen.

> dvf_default = DVF { dvf_font     = FontStyle 8 FontModern ShapeNormal WeightNormal False "" wxFONTENCODING_DEFAULT
>                   , dvf_colour   = colorRGB   0   0   0
>                   , dvf_bgcolour = colorRGB 255 255 255 
>                   , dvf_spacer   = 0
>                   }

Define the hash table which maintains control state. This should not be inlined, as we require a single instance to be used throughout any application using the control. Notice that the use of unsafePerformIO is ‘safe’ as this code will be executed once, when the application starts up.

> {-# noinline dv_states #-}
> dv_states :: Hash.HashTable Int DiffViewerState
> dv_states = unsafePerformIO $ Hash.new (==) (fromIntegral)

We provide functions to fetch and update the state of a given DiffViewer (remember, this is uniquely identified by the window ID of the DiffViewer control itself)

> dvGetState :: DiffViewer a -> IO DiffViewerState
> dvGetState dv =
>     windowGetId dv >>= \w ->
>     Hash.lookup dv_states w >>= \result ->
>     case result of
>       Just r  -> return r
>       Nothing -> error ("dvGetState: lookup failed for window ID: " ++ show w)

> dvSetState :: DiffViewer a -> DiffViewerState -> IO ()
> dvSetState dv st' =
>     windowGetId dv >>= \w ->
>     Hash.update dv_states w st' >>
>     return ()

A common idiom is to fetch the state in order to update the value of a single field. The dvModifyState function allows the updating to be expressed in terms of a function – normally one which will use record getters and setters to change the required field. This will allow us to use a somewhat declarative style in many state update cases. It works by applying a user-supplied function to a given field in DiffViewerState, with a supplied value. The order of parameters means that the function can often be curried so that only the new value and the required window need be supplied. We will make quite a bit of use of this when defining Attribute manipulations.

> dvModifyState fn w s =
>     dvGetState w >>= \dvs ->
>     let dvs' = fn dvs s in
>     dvSetState w dvs'

Attributes

Attributes offer a convenient declarative-style wrapper around manipulations of control state. Better still, wxHaskell has defined a set of Attribute typeclasses which are shared by controls with similar features (e.g. the Literate typeclass is used by controls which allow the style (font, colour etc) of displayed text to be manipulated.

In this section, we will define our own unique attributes for the DiffCtrl, as well as making DiffCtrl an instance of the Literate typeclass.

Custom Attributes

Configure an attribute, diffFn, which will be used by the owning application to set the function which will perform the diff operation. Notice that it is possible for no diff function to be set, and this is the default when the control is instantiated (i.e. we use a Maybe a type here).

Notice also that the diff function might be executed when the diffFn attribute is set – the condition for execution being that the diff function is known and the names of the files to test are also known.

All Attributes require a setter and a getter function – the setter changes the attribute value and the getter fetches it. Note that it is quite usual for Attribute setters, in particular, to have significant side effects. In this case, setting the diffFn attribute (dvSetDiffFn) may cause the diff function to be executed. Similarly, we have already seen that setting the layout attribute on a container window causes sizers to be created and windows fitted to the sizers.

The type signature of an Attribute definition tells you a great deal about the anatomy of the system.

1. The Attribute definition should allow for the required window type and all subclasses (i.e. anything derived from DiffCtrl will inherit the diffFn attribute). This also implies that DiffCtrl inherits all of the attributes of Panel and Window (since it derives from them). There is a big caveat, however, for anyone coming to Haskell from an OO language: you cannot override the attribute definition of a superclass in a derived class – Haskell is not C++. This has a slightly irritating consequence we will come back to later.
2. The Attribute definition can contain any value type you like. In our case it is a Maybe (FilePath -> FilePath -> IO [String]) type, which you will probably recognise as a straightforward wrapper around the diff function.

Notice that we use dvModifyState to define the state update in a somewhat declarative form .

> diffFn :: Attr (DiffViewer a) (Maybe (FilePath -> FilePath -> IO [String]))
> diffFn = newAttr "diffFn" dvGetDiffFn dvSetDiffFn
>     where
>     dvGetDiffFn = (liftM dvs_diff) . dvGetState
>     dvSetDiffFn win diff_fn = 
>         dvModifyState (\st s -> st { dvs_diff = s } ) win diff_fn >>
>         whenDiffLegal win runDiff

The diffFiles attribute controls selection of the files to which diff function will be applied. When files are set, we clear the diff map (because our existing diff text is invalidated) and possibly (if the file names are non empty) run a new diff function. A consequence of this design is that setting the files to “” will clear the diff control. This should probably have been represented with a Maybe String value, but it works, so I’ll leave this as an exercise for the reader. In other respects, this really looks similar to the diffFn attribute definition.

One minor design note: I chose to require the FilePath values to be set in a tuple – it dod not seem to make much sense to me to allow these to be set individually, as the two filenames required seemed like an atomic feature of performing a diff operation.

> diffFiles :: Attr (DiffViewer a) (FilePath, FilePath)
> diffFiles = newAttr "diffFiles" dvGetFiles dvSetFiles
>     where
>     dvGetFiles win =
>         dvGetState win >>= \(DVS _ fn1 fn2 _ _ _ _ _ _ _) ->
>         get fn1 text >>= \txt1 ->
>         get fn2 text >>= \txt2 ->
>         return (txt1, txt2)
>     dvSetFiles win (txt1, txt2) =
>         dvGetState win >>= \st@(DVS _ fn1 fn2 _ _ _ _ _ _ _) ->
>         let st' = st { dvs_txt = Map.empty } in
>         set fn1 [text := txt1] >>
>         set fn2 [text := txt2] >>
>         dvSetState win st' >>
>         whenDiffLegal win runDiff

Incidentally, the irritating consequence of the fact that you cannot override the Attribute implementation of a superclass is that I cannot, for example, override the implementation of the Colored typeclass to allow the background and foreground colours of the windows in the control to be set together (the default implementation only does this for the Panel itself).

Making a control a member of an existing Attribute class

Note: the wxHaskell documentation says that Panel is an instance of Literate. This is incorrect (or the following would not work…)

The control has configurable fonts and the like, so it has been made an instance of Literate. Note, however, that changing textColor only affects unmodified text (modified text has pre-defined colour attributes).

> instance Literate (DiffViewer a) where
>     font          = newAttr "font"          dvGetFont          dvSetFont
>     fontSize      = newAttr "fontSize"      dvGetFontSize      dvSetFontSize
>     fontWeight    = newAttr "fontWeight"    dvGetFontWeight    dvSetFontWeight
>     fontFamily    = newAttr "fontFamily"    dvGetFontFamily    dvSetFontFamily
>     fontShape     = newAttr "fontShape"     dvGetFontShape     dvSetFontShape
>     fontFace      = newAttr "fontFace"      dvGetFontFace      dvSetFontFace
>     fontUnderline = newAttr "fontUnderline" dvGetFontUnderline dvSetFontUnderline
>     textColor     = newAttr "textColor"     dvGetTextColor     dvSetTextColor
>     textBgcolor   = newAttr "textBgcolor"   dvGetTextBgColor   dvSetTextBgColor

Some helper functions around dvModifyState make the implementation of the Literate setters quite neat.

Modify the dvs_fmt field in a DiffViewerState, applying an updating function to change the existing value in the field.

> dvModifyFmt  fn = dvModifyState (\dvs s -> dvs { dvs_fmt = fn (dvs_fmt dvs) s })

Modify the dvf_font field of the dvs_fmt field in a DiffViewerState, applying an updating function to change the existing value in the field.

> dvModifyFont fn = dvModifyFmt   (\dvf s -> dvf { dvf_font = fn (dvf_font dvf) s })

All of the Literate attribute getters and setters can now be expressed in terms of dvGetState, dvModifyFont or dvModifyFmt

> dvGetFont          = (liftM (dvf_font . dvs_fmt)) . dvGetState
> dvSetFont          = dvModifyFmt  (\st s -> st { dvf_font = s })
> dvGetFontSize      = (liftM _fontSize) . dvGetFont
> dvSetFontSize      = dvModifyFont (\st s -> st { _fontSize = s })
> dvGetFontWeight    = (liftM _fontWeight) . dvGetFont
> dvSetFontWeight    = dvModifyFont (\st s -> st { _fontWeight = s })
> dvGetFontFamily    = (liftM _fontFamily) . dvGetFont
> dvSetFontFamily    = dvModifyFont (\st s -> st { _fontFamily = s })
> dvGetFontShape     = (liftM _fontShape) . dvGetFont
> dvSetFontShape     = dvModifyFont (\st s -> st { _fontShape = s })
> dvGetFontFace      = (liftM _fontFace) . dvGetFont
> dvSetFontFace      = dvModifyFont (\st s -> st { _fontFace = s })
> dvGetFontUnderline = (liftM _fontUnderline) . dvGetFont
> dvSetFontUnderline = dvModifyFont (\st s -> st { _fontUnderline = s })
> dvGetTextColor     = (liftM (dvf_colour . dvs_fmt)) . dvGetState
> dvSetTextColor     = dvModifyFmt  (\st s -> st { dvf_colour = s })
> dvGetTextBgColor   = (liftM (dvf_bgcolour . dvs_fmt)) . dvGetState
> dvSetTextBgColor   = dvModifyFmt  (\st s -> st { dvf_bgcolour = s })