title: Structuring Haskell (gtk2hs) GUI's
body: <p>I'm trying to build medium sized GUI with Gtk2Hs and I'm not all that sure what would be the best way to structure the system. I'm looking for a way to develop subcomponents in isolation and in general to end up with a structure that doesn't leave me pulling out my hair later.</p>
  
  <p>The main difficulty is caused by components such as cameras for which the API is continuation based (ie. I need to wrap the block using the cameras with <code>withVideoMode :: Camera Undefined -&gt; (Camera a -&gt; IO ()) -&gt; IO ()</code>). I would like to separate these also, but I haven't found a reasonable way to do this.</p>
  
  <p>Most components that I need to add require <em>initialization</em>, such as setting camera parameters or building widgets, <em>catching events</em> that are triggered by other components and <em>cleanup</em>, such as disconnecting hardware,  at the end.</p>
  
  <p>Thus far, I've thought of using <code>ContT</code> for the cps parts and something like snaplets for the components and hiding them in some <code>State</code> somewhere. First seems awfully heavyweight and the second seems nasty since I can't elegantly use transformers in gtk2hs callbacks.</p>
  
  <p>(For some reason gists do not work for me today, so apologizes for posting the whole huge code here)</p>
  
  <pre><code>{-#LANGUAGE ScopedTypeVariables#-}
  {-#LANGUAGE DataKinds #-}
  
  import CV.CVSU
  import CV.CVSU.Rectangle
  import CV.Image as CV
  import CV.Transforms
  import CV.ImageOp 
  import CV.Drawing as CV
  import CVSU.PixelImage
  import CVSU.TemporalForest
  import Control.Applicative
  import Control.Applicative
  import Control.Concurrent
  import Control.Monad
  import Data.Array.MArray
  import Data.IORef
  import Data.Maybe
  import Data.Word
  import Utils.Rectangle
  import Foreign.Ptr
  import Graphics.UI.Gtk
  
  import System.Camera.Firewire.Simple
  
  convertToPixbuf :: CV.Image RGB D8 -&gt; IO Pixbuf
  convertToPixbuf cv = withRawImageData cv $ \stride d -&gt; do
      pixbufNewFromData (castPtr d) ColorspaceRgb False 8 w h stride
     where (w,h) = getSize cv
  
  
  initializeCamera dc e = do 
      putStrLn $ "Initializing camera "++show e
      cam &lt;- cameraFromID dc e
      setOperationMode cam B
      setISOSpeed  cam ISO_800
      setFrameRate cam Rate_30
      setupCamera cam 20 defaultFlags
      return cam
  
  handleFrame tforest image = do
    pimg    &lt;- toPixelImage (rgbToGray8 image)
    uforest &lt;- temporalForestUpdate tforest pimg
    uimg    &lt;- temporalForestVisualize uforest
    --uimage  &lt;- expectByteRGB =&lt;&lt; fromPixelImage uimg
    temporalForestGetSegments uforest
  
    --mapM (temporalForestGetSegmentBoundary uforest) ss
  
  createThumbnail img = do 
       pb     &lt;- convertToPixbuf $ unsafeImageTo8Bit $ scaleToSize Linear True (95,95) (unsafeImageTo32F img)
       imageNewFromPixbuf pb
  
  
  main :: IO ()
  main = withDC1394 $ \dc -&gt; do
      -- ** CAMERA Setup **
      cids &lt;- getCameras dc
      cams &lt;- mapM (initializeCamera dc) $ cids
  
      -- ** Initialize GUI ** 
      initGUI
      pp &lt;- pixbufNew ColorspaceRgb False 8 640 480
      window &lt;- windowNew
  
      -- * Create the image widgets 
      images &lt;- vBoxNew True 3
      image1  &lt;- imageNewFromPixbuf pp
      image2  &lt;- imageNewFromPixbuf pp
      boxPackStart images image1 PackGrow 0 
      boxPackEnd   images image2 PackGrow 0 
  
      -- * Create the Control &amp; main widgets
      screen     &lt;- hBoxNew True 3
      control    &lt;- vBoxNew True 3
      info       &lt;- labelNew (Just "This is info")
      but        &lt;- buttonNewWithLabel "Add thumbnail"
      thumbnails &lt;- hBoxNew True 2
      boxPackStart screen images PackGrow 0 
      boxPackStart screen control PackGrow 0 
      boxPackStart control info PackGrow 0 
      boxPackStart control but PackRepel 0 
      boxPackStart control thumbnails PackGrow 0 
      but `onClicked` (do
          info&lt;- labelNew (Just "This is info")
          widgetShowNow info
          boxPackStart thumbnails info PackGrow 0)
  
      set window [ containerBorderWidth := 10
                     , containerChild := screen ]
  
      -- ** Start video transmission **
      withVideoMode (cams !! 0) $ \(c :: Camera Mode_640x480_RGB8) -&gt; do
  --     withVideoMode (cams !! 1) $ \(c2 :: Camera Mode_640x480_RGB8) -&gt; do
          -- ** Start cameras ** --
          startVideoTransmission c
  --        startVideoTransmission c2
          -- ** Setup background subtraction ** --
          Just f &lt;- getFrame c 
          pimg &lt;- toPixelImage (rgbToGray8 f)
          tforest &lt;- temporalForestCreate 16 4 10 130 pimg
  
          -- * Callback for gtk
          let grabFrame = do
              frame &lt;- getFrame c 
  --            frame2 &lt;- getFrame c2 
              maybe (return ()) 
                    (\x -&gt; do
                            ss &lt;- handleFrame tforest x
                            let area = sum [ rArea r | r &lt;- (map segToRect ss)]
                            if area &gt; 10000 
                                  then return ()
                                   --putStrLn "Acquiring a thumbnail"
                                   --tn &lt;- createThumbnail x
                                   --boxPackStart thumbnails tn PackGrow 0 
                                   --widgetShowNow tn
                                   --containerResizeChildren thumbnails
                                  else return ()
                            labelSetText info ("Area: "++show area)
                            pb &lt;- convertToPixbuf
                                      --  =&lt;&lt; CV.drawLines x (1,0,0) 2 (concat segmentBoundary)
                                      (x &lt;## map (rectOp (1,0,0) 2) (map segToRect ss) )
                            pb2 &lt;- convertToPixbuf x
                            imageSetFromPixbuf image1 pb
                            imageSetFromPixbuf image2 pb2
                            )
                    frame
  --            maybe (return ()) 
  --                  (convertToPixbuf &gt;=&gt; imageSetFromPixbuf image2)
  --                  frame2
              flushBuffer c 
  --            flushBuffer c2 
              return True
  
          timeoutAddFull grabFrame priorityDefaultIdle 20
  
          -- ** Setup finalizers ** 
          window `onDestroy` do
                      stopVideoTransmission c
                      stopCapture c
                      mainQuit
  
          -- ** Start GUI **
          widgetShowAll window
          mainGUI
  </code></pre>