Custom Controls in wxHaskell (part 5)

Window Painting

Most of the windows in the control will use their default paint functions, but since the two viewports for outputting diff information are based on a Window type, they will require special handling.

The behaviour required in a Window is slightly different depending on whether the original file or the changed file is being rendered. To indicate, we have a specific type, which
is curried into the selected on paint handler for each viewport.

 > data DVFileType = DVorig | DVchanged deriving Show

Now we can define a suitable custom paint handler. On entry, win is the viewport window, DC is a suitable device context which is provided by the framework and the rectangle represents the minimum area which needs to be updated.

When performing actions which might take a while (even for quite small values of ‘a while’), it is good practice to display a busy cursor

 > onPaint parent file_type win dc r@(Rect x y w h) =
 >     wxcBeginBusyCursor >>
 >     getDisplayableText parent >>= \render_info ->
 >     renderDiff file_type parent win dc render_info >>
 >     wxcEndBusyCursor

The getDisplayableText function was described in the previous installment, and is responsible for working out which text to render. In this installment, we are more interested in the specifics of rendering the text.

The renderDiff function is responsible for rendering text to the device context which was passed in via the onPaint function. To do this effectively, we need to determine the space taken up by the text characters. Since this depends on the selected font, point size, whether bold and/or italic text is required and even (although not relevant to this example) the device to which the text is being rendered – the sizing may be slightly different on a printed page compared to the display, for example – wxHaskell provides a function, getFullTextExtent, which will help you to obtain this information:

getFullTextExtent :: DC a -> String -> IO (Size, Int, Int)

What getFullTextExtent does is to determine the dimensions of a given string using the currently selected font (including bold/italic, point size etc.). The Size parameter gives the rectangle from the font baseline into which the string will render. The first integer is the descent (i.e. the space taken below the font baseline by the descenders on characters such as y and p. The second integer is any additional vertical space (external leading) – this is usually zero.

For optimum display of text, you should really call getFullTextExtent on each string to render. This is relatively slow, but accurate. In this case, however, we don’t really care about the absolute accuracy, and are optimizing for use with monospace fonts. I use a small function, getFontMetrics which can be useful where speed of rendering is more important than precision.

The basic idea is to call getFullTextExtent on some different characters (I use “W”, “y” and “l”) to determine the (probably) maximum space required to render a single character in a given font. This works well in parctice on most fonts, although I would expect it to be unsuitable for some of the more fancy font designs.

With this in mind, the operation of renderDiff is fairly straightforward. All text is rendered starting from (0, 0) in the client area (remember – we are managing scroll bars manually), clipping any initial characters which are not required (clipText) and starting each new line the maximum number of vertical pixels required by the font plus an optional, user-defined vertical space (to separate the lines a little more, for enhanced readability).

The text to display (a list of String) is zipped with the y axis positions for each line of text (y_posns).

 > renderDiff file_type parent win dc (RI diff_lines fst_col width) =
 >     dvGetState parent >>= \(DVS _ _ _ _ _ _ _ _ (DVF fs col bgcol spc) _ ) ->
 >     getFontMetrics win fs >>= \(FontMetrics x_max y_max desc el) ->
 >     get win clientSize >>= \(Size w h) ->
 >     set win [ color := col, bgcolor := bgcol ] >>
 >     set dc [ font := fs ] >>
 >     let disp_diff = map clipText diff_lines
 >         x_pos     = 0
 >         y_posns   = map (\n -> n * (y_max + desc + spc)) [0..]
 >         diff_pos  = zip disp_diff y_posns in
 >     mapM_ (\(diff, y_pos) -> renderLine file_type diff (Point x_pos y_pos) dc) diff_pos
 >         where
 >           clipText (DiffLine t s) = DiffLine t (take width (drop fst_col s))

The renderLine function renders a single line, selecting the appropriate renderer, and depending on whether this is the original or the updated file.

 > renderLine file_type (DiffLine t str) point dc =
 >     (getRenderer t) file_type str point dc

Determine which renderer function to use. There are four options: text we do not want to render at all is rendered using nullRenderer; text which has been added is rendered using addRenderer; text which has been deleted is rendered using delRenderer and text which is the same in both files is rendered using ctxtRenderer.

 > getRenderer OrigFileLine   = nullRenderer
 > getRenderer ChangeFileLine = nullRenderer
 > getRenderer RangeLine      = nullRenderer
 > getRenderer AddLine        = addRenderer
 > getRenderer DeleteLine     = delRenderer
 > getRenderer CommonLine     = ctxtRenderer
 > getRenderer _              = nullRenderer

Render Add line. This is presently configured to print added text (i.e. text which is present in the modified file but not the original) in green. Note that the current implementation uses the somewhat unsatisfactory approach of using silver ‘#’ characters to indicate text which is not present. This is an obvious area for improvement.

 > addRenderer DVorig _ point dc =
 >     let spaces = replicate 100 '#' in
 >     setTextColours dc colour_silver colour_silver >>
 >     drawText dc spaces point []
 > addRenderer DVchanged txt point dc =
 >     setTextColours dc colour_green colour_white >>
 >     drawText dc txt point []

Render Delete line. This is presently configured to show deleted text (present in original but not in modified file) in red.

 > delRenderer DVorig txt point dc =
 >     setTextColours dc colour_red colour_white >>
 >     drawText dc txt point []
 > delRenderer DVchanged _ point dc =
 >     let spaces = replicate 100 '#' in
 >     setTextColours dc colour_silver colour_silver >>
 >     drawText dc spaces point []

Render Unchanged line

 > ctxtRenderer _ txt point dc =
 >     setTextColours dc colour_black colour_white >>
 >     drawText dc txt point []

Null renderer can be used when there is nothing to render.

 > nullRenderer _ _ _ _ =  return ()

Helper function for setting text colours

 > setTextColours dc fg bg = dcSetTextForeground dc fg >>
 >                           dcSetTextBackground dc bg

The virtual canvas

The control implementation is almost complete. The only thing which remains is to complete the management of the scroll bars and the associated virtual canvas size. These simplify scrolling calculations, and are re-calculated when the diff text changes.

Given the font metrics for a device context on a file display windows we can work out the size of a virtual window which would be large enough to contain the entire diff text. Notice that this implementation only really works for monospace fonts.

We set both of the diff client windows to have the virtual size of this notional canvas and we work within a viewport onto this virtual canvas. We also configure the scroll bar
so that they range over the virtual canvas correctly. The key aspect here is that the scroll bars are resized depending on the proportion of the underlying virtual canvas which can be displayed in the client window

 > setVirtualCanvas w =
 >     dvGetState w >>= \(DVS _ _ _ vp1 vp2 vs hs _ (DVF fs _ _ spacer) m) ->
 >     get vp1 clientSize >>= \cs1 ->
 >     get vp2 clientSize >>= \cs2 ->
 >     getFontMetrics vp1 fs >>= \(FontMetrics x_max y_max desc el) ->
 >     let textSize    = calcTextSize m
 >         char_height = y_max + desc + spacer
 >         char_width  = x_max + el
 >         canvas_sz   = sz (char_width * (sizeW textSize)) (char_height * (sizeH textSize)) in
 >     set vp1 [ virtualSize := canvas_sz ] >>
 >     set vp2 [ virtualSize := canvas_sz ] >>
 >     adjustScrollbars w

Adjust the scroll bars to represent the correct view over the data in the viewport. For the purposes of calculation, assume that both viewports are the same size (they
will be clipped anyway, so worst case is that we do a little more work than strictly required).

Scroll bars are configured with a range (number of rows/columns of text) and a thumb size (number of rows/columns visible in the viewport). We take care to save the current thumb position before adjusting.

 > adjustScrollbars w =
 >     dvGetState w >>= \(DVS _ _ _ _ _ vs hs _ _ map) ->
 >     calcViewportTextSize w >>= \(Size x_cs_txt y_cs_txt) ->
 >     let (Size x_txt y_txt) = calcTextSize map in
 >     -- Save scroll position before updating
 >     scrollBarGetThumbPosition vs >>= \vs_pos ->
 >     scrollBarGetThumbPosition hs >>= \hs_pos ->
 >     scrollBarSetScrollbar vs vs_pos y_cs_txt y_txt y_cs_txt True >>
 >     scrollBarSetScrollbar hs hs_pos x_cs_txt x_txt x_cs_txt True


I chose to define helpers to allow me to use a small subset of the standard colour names/spaces defined in the W3C CSS specification.

 > colour_silver  = colorRGB 192 192 192
 > colour_black   = colorRGB   0   0   0
 > colour_green   = colorRGB   0 128   0
 > colour_white   = colorRGB 255 255 255
 > colour_red     = colorRGB 255   0   0

Custom Controls in wxHaskell (part 4)

Deciding what to render

Our DiffCtrl has two viewport Window instances on which we will eventually be rendering the diff text. In this section, we consider what actually needs to be rendered.

The background is that most GUI toolsets support the concept of a viewport which provides a window over all of the data in a window. There is too much information to be able to fit everything into the area available to display, so we see only a part of it. In wxWidgets (and therefore wxHaskell), the key ideas are the virtualSize which represents the size a window would need to be to fit all of the displayable information into it and the clientSize which is the size actually available for displaying information in the application.

One option available to us is to simply render all of the information into the virtual canvas. This is fine, and works OK for controls which have automatic management of scroll bars (incidentally, if you do not set the virtualSize and clientSize parameters for such controls, Layout often fails since any size control size up to the virtualSize is possible and the Layout algorithm has a tendency to decide that something like a 1 x 1 control size is a good choice – almost certainly not what you had in mind).

There is a problem with rendering everything to the virtual canvas, and that is that rendering can take a while. If you have a very large data set, and a small window on it, you are expending processing time just to throw away most of what you did (because wxWidgets only displays the part of the rendered information which can be seen on the client Window). For reasons of responsiveness, many applications therefore don’t bother to render what you cannot see, and only render what is visible.

In this application, we are managing what is displayed in Windows manually, as well as keeping manual control of the scroll bars. Therefore, we really have to take care about what is going to be rendered to the Window instances ourselves.

A digression: unified diff output

Below is a fragment of the output from a unified diff command:

--- /path/to/original ''timestamp''
+++ /path/to/new      ''timestamp''
@@ -1,3 +1,4 @@
+This is an important notice! It should therefore be located at the beginning of this document!
 This part of the document has stayed the same from version to
@@ -5,16 +11,10 @@
 be shown if it doesn't change.  Otherwise, that would not be helping to
-compress the size of the changes.Determine the viewable text, i.e. the text which should be displayed in the viewport
  • The — prefix indicates that the line contains the name and timestamp of the ‘original’ file in the diff.
  • The +++ prefix indicates that the line contains the name and timestamp of the ‘modified’ file in the diff.
  • The @@ prefix indicates which lines have changed.
  • The + prefix indicates a line which has been added to the original to create the modified file.
  • The – prefix indicates a line which has been deleted from the original to create the modified file.
  • Lines starting with a space character are unchanged between the original and modified files.

It is worthwhile to point out that we don’t want to render filename, timestamp or line number information in the Window. Therefore, the number of lines of information returned from the diff command is not the same as the number of lines we need to render.

We can express this with a suitable data type:

> data DiffLineType = CommonLine
>                   | AddLine
>                   | DeleteLine
>                   | RangeLine
>                   | OrigFileLine
>                   | ChangeFileLine
>                   | UnknownLine
>                     deriving (Eq, Show)

It is very straightforward to determine the type of information represented in a diff line. It is probably an error if we don’t have one of the prefixes given above. Since I’m not sure how I will deal with such an error for now, UnknownLine has been created.

> getDiffLineType :: String -> DiffLineType
> getDiffLineType ('-':'-':'-':_) = OrigFileLine
> getDiffLineType ('+':'+':'+':_) = ChangeFileLine
> getDiffLineType ('@':'@':_)     = RangeLine
> getDiffLineType ('+':_)         = AddLine
> getDiffLineType ('-':_)         = DeleteLine
> getDiffLineType (' ':_)         = CommonLine
> getDiffLineType _               = UnknownLine

Now we have everything we need to parse the raw output from the diff command into something a little easier to work with. The lines from a diff run are represented in a data type containing the line type and the remaining text.

> data DiffLine = DiffLine DiffLineType String
>                 deriving Show

Parse diff lines into DiffLine data structures.

> parseDiffLines = map parseDiffLine
>     where
>       parseDiffLine s =
>           case getDiffLineType s of
>             OrigFileLine   -> DiffLine OrigFileLine   (drop 3 s)
>             ChangeFileLine -> DiffLine ChangeFileLine (drop 3 s)
>             RangeLine      -> DiffLine RangeLine      (drop 2 s)
>             AddLine        -> DiffLine AddLine        (tail s)
>             DeleteLine     -> DiffLine DeleteLine     (tail s)
>             CommonLine     -> DiffLine CommonLine     (tail s)
>             UnknownLine    -> DiffLine UnknownLine    (tail s)

It is now straightforward to determine whether a line from the diff command should be displayed in the viewport or not. Displayable returns True if a line is displayable in a viewport.

 > displayable AddLine    = True
 > displayable DeleteLine = True
 > displayable CommonLine = True
 > displayable _          = False

We are now in a position to determine how many lines of displayable text the diff command generated for us.

> countDiffLines map = Map.fold countDiffLines' 0 map
>     where
>     countDiffLines' (DiffLine typ _) acc | displayable typ = acc + 1
>                                          | otherwise       = acc

What can I show you today?

This is basically a question of working out the row and column of the displayable lines of text at which we start display, and the row and column at which we finish display.

Working out which columns to display is the more straightforward calculation, so I chose to represent this in a RenderInfo type which contains a line of diff text, the first column to be displayed and the length of text to display. Note that when making these calculations, if the calculations as integers are inexact (they often are), just render slightly more information than your display area. The surplus will be clipped, but it will clip showing (for example) partial characters, which is what you want.

In passing, I should note that since the first column and maximum to render are the same for all lines of text, I could probably have done without this data type.

 > data RenderInfo = RI { ri_txt      :: ![DiffLine]  -- | Text to render
 >                      , ri_firstcol :: !Int         -- | First column to be used in text
 >                      , ri_length   :: !Int         -- | Length of text to render
 >                      } deriving Show

The getDisplayableText function uses calcViewportTextExtent to determine the size of a rectangle (in rows and columns of characters) on which text can be displayed, and the selectLines function to select the correct number of displayable lines.

 > getDisplayableText win =
 >     calcViewportTextExtent win >>= \r@(Rect x _ w _) ->
 >     dvGetState win >>= \(DVS _ _ _ _ _ _ _ _ _ map) ->
 >     let (_, diff_lines) = Map.fold (selectLines r) (0,[]) map
 >         disp_diff  = RI diff_lines x w in
 >     return disp_diff

The selectLines function selects those lines which will be displayed on the viewport, based on the following criteria:

  • displayable lines with line number < y are above the viewport and not displayed
  • displayable lines between line number y and line number y + h are displayed
  • other lines are not displayed

In addition, note that as not all lines are displayable, we need to keep a separate account of the displayable line number as we iterate over the map. This is why we use (Int, [DiffLine]) as our accumulator, rather than just [DiffLine].

 > selectLines :: Rect -> DiffLine -> (Int, [DiffLine]) -> (Int, [DiffLine]
 > selectLines (Rect _ y _ h) (DiffLine typ str) acc@(disp_line_no, strs)
 >                 | (disp_line_no < y)     && (displayable typ) = (disp_line_no + 1, strs)
 >                 | (disp_line_no < y + h) && (displayable typ) = (disp_line_no + 1, (DiffLine typ str) : strs)
 >                 | otherwise                                   = acc

As noted earlier, calcViewportTextExtent determines a rectangle over the complete displayable diff text which will be displayed. This is straightforward: the scroll bars give the starting row/column from their current position. We know the end row/column by calculating the viewport text size. Thus we obtain a starting row/column and an end row/column to display.

I should note that the viewport text size is the number of rows and columns of text which will fit in the viewport. This is dependent on the size of text and font used, which is why it has been calculated separately from working out which rows/columns of text to display.

 > calcViewportTextExtent w =
 >     dvGetState w >>= \(DVS _ _ _ _ _ vs hs _ _ map) ->
 >     scrollBarGetThumbPosition vs >>= \top_left_y ->
 >     scrollBarGetThumbPosition hs >>= \top_left_x ->
 >     calcViewportTextSize w >>= \(Size bot_right_raw_x bot_right_raw_y) ->
 >     let (Size max_x max_y) = calcTextSize map
 >         width  = min bot_right_raw_x (max_x - top_left_x)
 >         height = min bot_right_raw_y (max_y - top_left_y)
 >         textExtent  = Rect top_left_x top_left_y width height in
 >     putStrLn ("calcViewportTextExtent textExtent:" ++ (show textExtent)) >>
 >     return textExtent

Calculate the number of rows and columns required to completely fit the diff text (i.e. the number of lines and the length of the longest line).

 > calcTextSize :: Map.Map Int DiffLine -> Size
 > calcTextSize m = sz (longestString m) (countDiffLines m)
 >     where
 >       longestString m = Map.fold (\(DiffLine _ str) max_now -> max (length str) max_now) 0 m

Calculate how much text we can fit into the viewport. This is straightforward: on each axis, the ratio of virtual canvas extent to viewport canvas extent (i.e. in device context units) is the same as the ratio of the total number of rows/columns to the viewable rows/columns.

Notice that the virtualSize is given a minimum size of (1,1). This is to ensure that no divide by zero error is possible when calculating x_cs_txt and y_cs_txt.

 > calcViewportTextSize w =
 >     dvGetState w >>= \(DVS _ _ _ vp1 _ _ _ _ _ map) ->
 >     get vp1 clientSize  >>= \(Size x_cs y_cs) ->
 >     get vp1 virtualSize >>= \(Size x_vs y_vs) ->
 >     let (Size x_vs_txt y_vs_txt) = calcTextSize map
 >         x_vs'    = max 1 x_vs
 >         y_vs'    = max 1 y_vs
 >         x_cs_txt = min ((x_cs * x_vs_txt) `div` x_vs') x_vs_txt
 >         y_cs_txt = min ((y_cs * y_vs_txt) `div` y_vs') y_vs_txt
 >         cs_txt   = sz x_cs_txt y_cs_txt in
 >     return cs_txt

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 $ (==) (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 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 })

A digression into wxHaskell Layout

Eric Kow commented that it would be worthwhile to show the Layout version of the Diff control even though it doesn’t work correctly in this scenario (it works fine if the Layout is applied to an enclosing Frame instance).

Without further ado, here is the code for diffCtrl’ using Layout – you do not require the buildLayout function in this case at all. The Layout code is highlighted in red.

> diffViewer' p props =
>     do
>     let defaults   = [border := BorderStatic]
>     fn1 <- staticText p []
>     fn2 <- staticText p []
>     f1  <- window p []
>     f2  <- window p []
>     vsb <- scrollBarCreate p (-1) rectNull wxVERTICAL
>     hsb <- scrollBarCreate p (-1) rectNull wxHORIZONTAL
>     set f1 [ on paint := onPaint p DVorig f1 ]
>     set f2 [ on paint := onPaint p DVchanged f2 ]
>     let state  = DVS p fn1 fn2 f1 f2 vsb hsb Nothing dvf_default Map.empty
>         lay_fname w  = minsize (sz 400 (-1)) $ widget w
>         lay_diffp w  = minsize (sz 400 400)  $ fill $ widget w
>         lay_left     = column 5 [ lay_fname fn1, lay_diffp f1 ]
>         lay_right    = column 5 [ lay_fname fn1, lay_diffp f2 ]
>         layout'      = container p $ fill $ margin 5 $
>                            column 5 [ row 5 [ lay_left,
>                                               lay_right,
>                                               vfill $ widget vsb ],
>                                       hfill $ widget hsb ]
>     scrollBarSetEventHandler hsb (onScroll p hsb)
>     scrollBarSetEventHandler vsb (onScroll p vsb)
>     dvSetState p state
>     set p (defaults ++ props)
>     set p [layout := layout']
>     return p

To simplify explanation, I have split the layout into several components.

The first neat thing to notice is that constriction of layout is pure code – the transformation into sizers (which are bound the the IO monad) is done when the layout property is set on the owning DiffCtrl (Panel).Controls are specified by the widget (if they are ‘primitive’ widgets) and container (if they serve as containers for other widgets) combinators.

  • widget w tells the Layout system to insert a Window with identifier w in the appropriate location.
  • container p tells the Layout system that p is the container for the specified Layout. In the implementation, this means that Layout constructs a hierarchy of sizers which are owned by the container window.
  • minsize is a combinator which takes a Layout and gives it a minimum size. As an example, lay_fname w = minsize (sz 400 (-1)) $ widget w means insert the primitive control w and set a minimum width of 400 pixels (the -1 leaves the Layout to decide the best height).
  • row and column are combinators which lay out controls in rows and columns. In practice, this means that appropriate BoxSizer instances will be created into which the controls will be placed.
  • hfill, vfill and fill are combinators which request that the layout attempt to fill, either horizontally (hfill), vertically (vfill) or in both directions (fill) the available space. These are the combinators which prove problematic in our control in practice, and are the reason for defining the layout explicitly using Sizers.

The Layout will not become active until the layout Attribute has been set (set p [layout := layout’] in the code above). Setting the Layout in this way implicitly calls windowLayout and windowFit after the Sizers have been created.

Custom Controls in wxHaskell (part 2)

It may save you some typing to know that once this series is complete, I shall be publishing a Cabalized version of the Diff control on Hackage.

Subclassing the control

Witness types are used to represent the class hierarchy of the underlying wxWidgets library. The idea is that, for example, a Panel, which is a descendent of Window, can use all functions which accept a Window type.

Define diffViewer as a subclass of Window.

> type DiffViewer  a = Panel (CDiffViewer a)
> data CDiffViewer a = CDiffViewer

Creating the child windows

Create an instance of a diffViewer control.

In this case we create a panel as a child of the provided parent window, and set its style flags to indicate that the control will expand (horizontally and vertically) into the space allocated to it. We use the cast operator to convert the created panel and its properties into a DiffViewer related types. The cast operator is very dangerous, and should be used with great care (this is pretty much the only time you should need it in your wxHaskell life) – it operates essentially like the C cast operator!

> diffViewer :: Window a -> [Prop (DiffViewer ())] -> IO (DiffViewer ())
> diffViewer parent props =
>     do
>     p   <- panel parent [style := wxEXPAND]
>     let dv      = cast p
>         dvprops = castProps cast props
>     diffViewer' dv dvprops
>         where
>         cast :: Panel a -> DiffViewer ()
>         cast = objectCast

The diffViewer’ function does most of the work of creating and configuring the child windows in the control. These are all children of the panel, which is treated as the ‘owner’ of the control, and is the only window whose identity need be made visible outside of the control implementation.

A few things to note:

  • the diff output will be displayed on windows f1 and f2 – these use the Window type as we are going to take responsibility for painting this part of the control;
  • we create and manage scroll bars manually – this is because we wish to use the same scroll bars to scroll both of the windows containing diff information;
  • we are constructing a layout manually from sizers (call to buildLayout).
> diffViewer' p props =
>     do
>     fn1 <- staticText p [clientSize := sz 400 (-1)]
>     fn2 <- staticText p [clientSize := sz 400 (-1)]
>     f1  <- window p []
>     f2  <- window p []
>     vsb <- scrollBarCreate p (-1) rectNull wxVERTICAL
>     hsb <- scrollBarCreate p (-1) rectNull wxHORIZONTAL
>     set f1 [ on paint  := onPaint p DVorig f1 ]
>     set f2 [ on paint  := onPaint p DVchanged f2 ]
>     let state = DVS p fn1 fn2 f1 f2 vsb hsb Nothing dvf_default Map.empty
>         defaults = [border := BorderStatic]
>     scrollBarSetEventHandler hsb (onScroll p hsb)
>     scrollBarSetEventHandler vsb (onScroll p vsb)
>     dvSetState p state
>     set p (defaults ++ props)
>     buildLayout p fn1 fn2 f1 f2 vsb hsb
>     return p

Laying out the child windows

The wxHaskell layout implementation is buggy in some circumstances (it doesn’t seem to handle resizes as I would expect when window size exceeds minsize). Since we want the control to follow the size hints given by the owning application, we will use sizers to create a manual layout. In theory, wxHaskell layout should behave identically, but it doesn’t – that’s a bug to go and look for another day…

Since wxHaskell was originally designed to abstract the creation of sizers using layout, this code is rather low level, using functions from WXCore – you would be forgiven for thinking that it is just C++ implemented in Haskell, and that is essentially exactly what it is – most of the functions in WXCore are Haskell wrappers around the wxWidgets C++ API, which has the benefit that you can use the wxWidgets C++ API documentation to help to understand what most WXCore functions do.

The last two lines: the calls to windowLayout and windowFit are critical, and should be called before the application which uses the Diff control performs its own layout (they set the constraints for size which the application should respect when setting the size of its own windows).

> buildLayout p fn1 fn2 f1 f2 vsb hsb =
>     boxSizerCreate wxVERTICAL   >>= \p_sizer ->
>     boxSizerCreate wxHORIZONTAL >>= \h_sizer ->
>     boxSizerCreate wxVERTICAL   >>= \l_sizer ->
>     boxSizerCreate wxVERTICAL   >>= \r_sizer ->
>     sizerAddWindow l_sizer fn1     0 (wxALL .|. wxEXPAND) 5 nullPtr >>
>     sizerAddWindow l_sizer f1      1 wxEXPAND            10 nullPtr >>
>     sizerAddSizer  h_sizer l_sizer 1 wxEXPAND             5 nullPtr >>
>     sizerAddWindow r_sizer fn2     0 (wxALL .|. wxEXPAND) 5 nullPtr >>
>     sizerAddWindow r_sizer f2      1 wxEXPAND            10 nullPtr >>
>     sizerAddSizer  h_sizer r_sizer 1 wxEXPAND             5 nullPtr >>
>     sizerAddWindow h_sizer vsb     0 (wxALL .|. wxEXPAND) 5 nullPtr >>
>     sizerAddSizer  p_sizer h_sizer 1 wxEXPAND             5 nullPtr >>
>     sizerAddWindow p_sizer hsb     0 (wxALL .|. wxEXPAND) 5 nullPtr >>
>     windowSetSizer p p_sizer >>
>     windowLayout   p >>
>     windowFit      p

Scroll bars

In many cases, very little handling is required for scroll bars in wxHaskell since many of the common controls contain all the handling required for most purposes. However, as mentioned earlier, we are going to use a single set of control bars to control two client windows (one will contain the ‘original’ text and the other will contain the ‘updated’ text).

This code should serve as a simple example of custom scroll bar handling in wxHaskell.

Here we configure a custom event handler which provides the same handling for all scroll bar events. In more demanding applications (e.g. where the wxEVT_SCROLL_THUMBTRACK would cause too much processing to give smooth operation), you may want to do something a little different, perhaps by defining separate event handlers for different scroll bar events.

> scrollBarSetEventHandler window evtHandler =
>     windowOnEvent window events evtHandler (\evt -> evtHandler)
>         where
>           events = [ wxEVT_SCROLL_BOTTOM
>                    , wxEVT_SCROLL_LINEDOWN
>                    , wxEVT_SCROLL_LINEUP
>                    , wxEVT_SCROLL_PAGEDOWN
>                    , wxEVT_SCROLL_PAGEUP
>                    , wxEVT_SCROLL_THUMBRELEASE
>                    , wxEVT_SCROLL_THUMBTRACK
>                    , wxEVT_SCROLL_TOP ]

Define the ‘on scroll’ event handler for the scroll bars. In this case we can live with using the same event handler for both vertical and horizontal scroll bars as we will be updating the entire client area of the controlled windows on each scroll event (this is not too onerous, at least on my machine). This means that we just need to inform the parent window to refresh (i.e. repaint) the entire window next time the UI gets a chance to do so.

> onScroll dv _ =
>     windowRefresh dv True

Custom Controls in wxHaskell (part 1)

Edit: added a screenshot to show what we are working towards.

When I started working with wxHaskell, it quickly became obvious that a lot of time could be saved if I could produce reusable custom widgets in Haskell.

Looking into the samples which come with wxHaskell, there is one example of a custom control, but it is so simple as to be almost useless to someone hoping to develop something a little more ambitious.

Over the next few posts I will explain how I put custom controls together and try to point out a few of the pitfalls. I will do this by working through the development of a fairly simple custom control to display the output of running the diff command to compare two files.

DiffCtrl screenshot
DiffCtrl lScreenshot

This example is short enough to be manageable in a few posts, but contains enough functionality to explore some of the issues you may come up against.

Outline of a custom control

The control I am building is subclassed from Panel. This is probably a good choice for most controls as it can contain a top level sizer and many children.

  • You need to create a suitable subclass for the main window of your control, deriving from Panel. wxHaskell uses witness types to provide a good degree of type safety in what is basically a thin wrapper over a C++ library.
  • You need to create the widgets and their layout inside the main window.
  • You need to create and manage any Attributes your control may require. This may include making your control an instance of some of the standard wxHaskell attribute classes.
  • You need to handle any custom paint operations on the control.
  • You may require custom event handlers .