Структурирование графических интерфейсов Haskell (gtk2hs)

Question

Я пытаюсь создать графический интерфейс среднего размера с помощью Gtk2H, и я не совсем уверен, что будет лучшим способом структурировать систему. Я ищу способ разрабатывать субкомпоненты изолированно и, в общем, получить структуру, которая не оставляет меня за волосы.

Основная трудность вызвана такими компонентами, как камеры, для которых API основан на продолжении (т.е. мне нужно обернуть блок, используя камеры с withVideoMode :: Camera Undefined -> (Camera a -> IO ()) -> IO ()). Я хотел бы также отделить их, но я не нашел разумного способа сделать это.

Большинство компонентов, которые мне нужно добавить, требуют инициализации, например установки параметров камеры или создания виджетов, перехвата событий, запускаемых другими компонентами, и очистки, например, отключения оборудования, в конце.

До сих пор я думал об использовании ContT для частей CPS и что-то вроде защелки для компонентов и скрывая их в некоторых State где-то. Первый выглядит ужасно тяжеловесным, а второй - противным, поскольку я не могу элегантно использовать преобразователи в обратных вызовах gtk2hs.

(По какой-то причине у меня сегодня не работает суть, поэтому извиняюсь за размещение здесь всего огромного кода)

{-#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

Итак, ваши требования:

• API в стиле CPS
• Инициализация ресурса и завершение
• вероятно монадный трансформатор, для ввода-вывода
• модульность и сочетаемость

Похоже, что одна из библиотек итераторов идеально подходит для вас. Особенно 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 (библиотека, с которой я наиболее знаком)