构建Haskell（gtk2hs）GUI

Question

我正在尝试用Gtk2Hs构建中等大小的GUI，但我并不确定构建系统的最佳方法是什么。我正在寻找一种单独开发子组件的方法，一般来说最终会得到一种不会让我后来脱掉头发的结构。

主要困难是由于API是基于连续性的相机等组件引起的（即我需要使用带withVideoMode :: Camera Undefined -> (Camera a -> IO ()) -> IO ()的相机来包裹块）。我想将这些分开，但我没有找到合理的方法来做到这一点。

我需要添加的大多数组件都需要初始化，例如设置摄像机参数或构建小部件，捕获事件，这些事件由其他组件触发，并且清理< / em>，例如最后断开硬件。

到目前为止，我已经考虑过将ContT用于cps部分以及类似snaplet的内容，并将它们隐藏在某些State的某个地方。首先看起来非常重量级，第二个看起来很讨厌，因为我无法在gtk2hs回调中优雅地使用变换器。

（出于某种原因，gists今天不适合我，所以为在这里张贴整个巨大的代码而道歉）

{-#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 -> IO Pixbuf
convertToPixbuf cv = withRawImageData cv $ \stride d -> 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 <- 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    <- toPixelImage (rgbToGray8 image)
  uforest <- temporalForestUpdate tforest pimg
  uimg    <- temporalForestVisualize uforest
  --uimage  <- expectByteRGB =<< fromPixelImage uimg
  temporalForestGetSegments uforest

  --mapM (temporalForestGetSegmentBoundary uforest) ss

createThumbnail img = do 
     pb     <- convertToPixbuf $ unsafeImageTo8Bit $ scaleToSize Linear True (95,95) (unsafeImageTo32F img)
     imageNewFromPixbuf pb


main :: IO ()
main = withDC1394 $ \dc -> do
    -- ** CAMERA Setup **
    cids <- getCameras dc
    cams <- mapM (initializeCamera dc) $ cids

    -- ** Initialize GUI ** 
    initGUI
    pp <- pixbufNew ColorspaceRgb False 8 640 480
    window <- windowNew

    -- * Create the image widgets 
    images <- vBoxNew True 3
    image1  <- imageNewFromPixbuf pp
    image2  <- imageNewFromPixbuf pp
    boxPackStart images image1 PackGrow 0 
    boxPackEnd   images image2 PackGrow 0 

    -- * Create the Control & main widgets
    screen     <- hBoxNew True 3
    control    <- vBoxNew True 3
    info       <- labelNew (Just "This is info")
    but        <- buttonNewWithLabel "Add thumbnail"
    thumbnails <- 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<- 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) -> do
--     withVideoMode (cams !! 1) $ \(c2 :: Camera Mode_640x480_RGB8) -> do
        -- ** Start cameras ** --
        startVideoTransmission c
--        startVideoTransmission c2
        -- ** Setup background subtraction ** --
        Just f <- getFrame c 
        pimg <- toPixelImage (rgbToGray8 f)
        tforest <- temporalForestCreate 16 4 10 130 pimg

        -- * Callback for gtk
        let grabFrame = do
            frame <- getFrame c 
--            frame2 <- getFrame c2 
            maybe (return ()) 
                  (\x -> do
                          ss <- handleFrame tforest x
                          let area = sum [ rArea r | r <- (map segToRect ss)]
                          if area > 10000 
                                then return ()
                                 --putStrLn "Acquiring a thumbnail"
                                 --tn <- createThumbnail x
                                 --boxPackStart thumbnails tn PackGrow 0 
                                 --widgetShowNow tn
                                 --containerResizeChildren thumbnails
                                else return ()
                          labelSetText info ("Area: "++show area)
                          pb <- convertToPixbuf
                                    --  =<< CV.drawLines x (1,0,0) 2 (concat segmentBoundary)
                                    (x <## map (rectOp (1,0,0) 2) (map segToRect ss) )
                          pb2 <- convertToPixbuf x
                          imageSetFromPixbuf image1 pb
                          imageSetFromPixbuf image2 pb2
                          )
                  frame
--            maybe (return ()) 
--                  (convertToPixbuf >=> 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

Answer 1

所以你的要求是：

• CPS样式API
• 资源初始化和最终确定
• 可能是monad变压器，用于IO
• 模块化和可组合性

似乎其中一个迭代器库对你来说是完美的。特别是conduit有最成熟的资源最终确定，但pipes的理论优雅和可组合性也可能让您感兴趣。如果您的代码仅基于IO，则新发布的io-streams也是一个不错的选择。

pipes：http://hackage.haskell.org/packages/archive/pipes/3.1.0/doc/html/Control-Proxy-Tutorial.html

conduit：https://www.fpcomplete.com/school/pick-of-the-week/conduit-overview

io-streams：http://hackage.haskell.org/packages/archive/io-streams/1.0.1.0/doc/html/System-IO-Streams-Tutorial.html

如果你提供一个小片段或你想要完成的内容的描述，我可以尝试使用pipes（我最熟悉的库）来编写它