Connections.hs

module Barrie.Gadgets.Connections (connectChooser,
                                   connectCommand,
                                   connectDisplay,
                                   connectEditor,
                                   connectChild) where

import Control.Monad

import Data.Dynamic

import Barrie.Gadgets
import Barrie.Trace

connectCommand :: (IO () -> IO ())    -- ^ connection creator
               -> IO a                -- ^ state retriever
               -> Gadget a            -- ^ gadget representing the command
               -> (a -> IO ())        -- ^ state updater
               -> IO ()
connectCommand onCommand getState gadget setState = do
   onCommand (getState >>= setState . gadgetCommand gadget)

connectDisplay :: (Dynamic -> IO ())  -- ^ GUI element updater
               -> Gadget a            -- ^ gadget representing the display
               -> a                   -- ^ new state
               -> IO ()
connectDisplay update gadget = update . gadgetDisplay gadget

connectEditor :: (IO () -> IO ())     -- ^ connection creator
              -> IO a                 -- ^ gui state retriever
              -> (Dynamic -> IO Bool) -- ^ true if update should happen
              -> IO Dynamic           -- ^ current value of GUI element
              -> Gadget a             -- ^ gadget representing the editor
              -> (a -> IO ())         -- ^ state change applier
              -> IO ()

connectEditor onAction getState doUpdate getValue gadget apply = do
   let connect get set = onAction (do st <- getState
                                      go <- doUpdate (get st)
                                      when go (do curr <- getValue
                                                  apply $ set curr st))
   connect (gadgetDisplay gadget) (gadgetUpdate gadget)

-- |Connect a chooser to the GUI.  Elements of the chooser are stored
-- |in a tuple; as (renderable value, state value).

connectChooser :: ([(Dynamic, Dynamic)] -> IO ())   -- ^ Set list of options
               -> (Int -> IO ())         -- ^ choose value
               -> IO Dynamic             -- ^ get value
               -> Gadget a               -- ^ gadget representing the chooser
               -> a -> IO ()
connectChooser setChoices setValue getValue gadget = do
  let update getChoices get set st =
          (setChoices (getChoices st) >>
           setValue (snd $ fromDyn (get st) ([(get st, get st)],-12)))
  update (gadgetChooser gadget) (gadgetDisplay gadget) (gadgetUpdate gadget)

connectChild :: (IO () -> IO ())         --  ^ show child
             -> (Gadget a -> a -> IO a)  --  ^ child runner
             -> IO a                     --  ^ parent state retriever
             -> Gadget a                 --  ^ parent
             -> (a -> IO ())             --  ^ parent state updater
             -> IO ()
connectChild onLaunch inner getState gadget setState = do
  onLaunch (do st <- getState
               traceMessage $ "connecting: " ++ flatName gadget
               st' <- inner (gadgetChild gadget) st
               traceMessage $ "finished: " ++ flatName gadget
               setState st')