gtk2hs-rpn-0.1: src/RPN.hs

{-# OPTIONS_HADDOCK hide #-}

module RPN (
    pushWidget, touchWidget, pullWidget, RPN (RPN), io2rpn,
    widgetsFromRpn
 ) where
import Graphics.UI.Gtk (Widget,ContainerClass)
import Data.Monoid
import Control.Monad.State
import Data.Maybe
import Data.List
import CanBeCasted

-- | All operators in our reverse polish notation implementation
-- are going to operate on a stack, represented by a
-- @['Graphics.UI.Gtk.Widget']@. 'ActionType' is the type
-- of such operations.  A few functions are also defined to
-- manipulate that stack.

type ActionType a = StateT [Widget] IO a

-- | 'pushWidget' inserts a widget in the stack, casting it
-- to Widget.

pushWidget :: ( CanBeCasted w ) => w -> ActionType ()
pushWidget w = case (glibCast w) of
    Just w' -> modify (w':)
    _ -> return ()

-- | 'touchWidget' applies a @(a -> IO ())@ to the last
-- inserted widget in the stack that can be casted to @a@,
-- if there is one.  The widget remains in the stack.

touchWidget :: (CanBeCasted a) => (a -> IO ()) -> ActionType ()
touchWidget f = liftM (listToMaybe . mapMaybe glibCast) get >>=
    maybe (return ()) (liftIO . f)

-- | 'pullWidget' will apply a packing function (like, say,
-- 'Graphics.UI.Gtk.containerAdd') to the last container
-- inserted in the widget list that can be casted to type @a@
-- and the last inserted widget that is not such container.
-- The container remains in the list.

pullWidget :: (CanBeCasted a, ContainerClass a) =>
 (a -> Widget -> IO ()) -> ActionType ()
pullWidget f = do
    casted <- liftM (map glibCast) get
    let iC = take 1 $ findIndices isJust casted
    let iW = [0..length casted - 1] \\ iC
    case (listToMaybe iC,listToMaybe iW) of
        (Just ic, Just iw) -> do
            let Just c = casted !! ic
            w <- liftM (!! iw) get
            liftIO $ f c w
            modify $ (\(a,b) -> a ++ drop 1 b) . splitAt iw
        _ -> return ()

-- | 'RPN' is the type of all operators, and encapsulates the
-- underline machinery.  It instantiates 'Data.Monoid.Monoid',
-- therefore we can sequence operators in a list, and also
-- create new operators by 'Data.Monoid.mconcat'ing others.

newtype RPN = RPN ( ActionType () )

instance Monoid RPN where
    mempty = RPN $ return ()
    mappend (RPN a) (RPN b) = RPN (a >> b)

-- | Using 'io2rpn' we can make an @IO widget@ into an operator
-- that inserts a widget in the stack.

io2rpn :: (CanBeCasted w) => IO w -> RPN
io2rpn = RPN . (>>= pushWidget) . liftIO

-- | After we describe our widgets using a list of 'RPN's,
-- we use 'widgetsFromRpn' to get them.

widgetsFromRpn :: [RPN] -> IO [Widget]
widgetsFromRpn list = liftM reverse $ execStateT unified []
 where RPN unified = mconcat list