GenericWidget.hs

{-# LANGUAGE ExistentialQuantification, FlexibleContexts
  , FlexibleInstances, FunctionalDependencies
  , GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses
  , RankNTypes, ScopedTypeVariables #-}
{-# OPTIONS -Wall #-}

{- |Contains GenWid, which is the type used for the inner widget in WxGeneric. Plus
functions to create GenWid.

GenWid contains a valued version of 'Composite'.
-}
module Graphics.UI.WxGeneric.GenericWidget
    ( fromWidget, valuedCompose
    , mkGenWid, mkSingleObservable, GenWid, GenWidIO
    , MapValue(..)
    )
where

import Graphics.UI.WX as Wx
import Graphics.UI.XTC
import Graphics.UI.WxGeneric.Composite

type GenWidIO a = forall w. Window w -> IO (GenWid a)

-- |Makes a GenWid from a an ordinary WxHaskell 'Window w' (widget)
-- that implements Observable and ValuedWidget.
fromWidget :: forall w a. (Observable (Window w), ValuedWidget a (Window w)) =>
              (forall w'. Window w' -> IO (Window w))
           -> GenWidIO a
fromWidget wid = fromWidget' widgetValue change wid

-- |Similar to fromWidget, except you explicitly gives the widgetValue
-- (ValuedWidget) attribute and change (Observable) event.
fromWidget' :: forall w a.
               Attr (Window w) a
            -> Event (Window w) (IO ())
            -> (forall w'. Window w' -> IO (Window w))
            -> GenWidIO a
fromWidget' valueAttr observable toWindowW w
    = do windowW <- toWindowW w
         return $ mkGenWid windowW (get windowW valueAttr) (\x -> set windowW [ valueAttr := x ])
                         (get windowW (on observable)) (\x -> set windowW [ on observable := x ])

-- |Composing multiple widgets into a composite GenWid. It is similar
-- to 'Composite.compose'.
valuedCompose :: (Panel () -> IO (Layout, IO a, a -> IO(), IO (IO ()), IO() -> IO()))
               -> GenWidIO a
valuedCompose f w =
    do p <- panel w []
       (lay, getter, setter, getChange, setChange) <- f p
       set p [ layout := fill lay ]
       return $ mkGenWid p getter setter getChange setChange

data ValuedCmds a = ValuedCmds
    { pickGetValue  :: IO a
    , pickSetValue  :: a -> IO ()
    , pickGetChange :: IO (IO ())
    , pickSetChange :: IO() -> IO()
    }
instance Observable (ValuedCmds a) where
    change = newEvent "change" pickGetChange pickSetChange

instance ValuedWidget a (ValuedCmds a) where
    widgetValue = newAttr "valued" pickGetValue pickSetValue

newtype GenWid a = GenWid (Composite (ValuedCmds a) ())
    deriving ( Widget, Able, Bordered, Child, Dimensions, Identity, Literate, Visible, Reactive
             , Observable, ValuedWidget a
             )

-- |Creates a GenWid using monadic actions.
mkGenWid :: forall w a.
            Window w -> IO a -> (a -> IO ()) -> IO (IO ()) -> (IO() -> IO())
         -> GenWid a
mkGenWid w getVal setVal getChg setChg = 
    GenWid $ singleComposite w (ValuedCmds getVal setVal getChg setChg) ()

-- |Creates a GenWid using an Observable widget, a get-value action
-- and a set-value action.
mkSingleObservable :: forall w a. (Observable (Window w)) =>
                      Window w -> IO a -> (a -> IO ())
                   -> GenWid a
mkSingleObservable wid getter setter =
    mkGenWid wid getter setter (get wid (on change)) (\x -> set wid [on change := x])

-- *** MapValue class

class MapValue (valued :: * -> *) where
    mapValue :: (a -> b) -> (a -> b -> a) -> valued a -> valued b

instance MapValue GenWid where
    mapValue oldToNew newToOld (GenWid composite) =
        let updateCmds valuedCmds =
                valuedCmds { pickGetValue = pickGetValue valuedCmds >>= return . oldToNew
                           , pickSetValue = \x -> do old <- pickGetValue valuedCmds
                                                     pickSetValue valuedCmds (newToOld old x)
                           }
        in GenWid $ updateSuper updateCmds composite