gtk2hs-rpn-0.0.2: src/Graphics/UI/Gtk/Layout/Rpn.hs

module Graphics.UI.Gtk.Layout.Rpn where { import Graphics.UI.Gtk hiding
( get ) ; import qualified Data.Word ; import Data.Monoid ; import
Control.Monad.State ;
import Graphics.UI.Gtk.Types ;
import Graphics.Rendering.Cairo ;
import Graphics.UI.Gtk.Gdk.EventM ;
import Data.IORef ;
import Data.Maybe ;
import Data.List ;
import Graphics.UI.Gtk.Layout.Rpn.CanBeCasted ;

 doNothing :: (Monad m) => m () ;
 doNothing = return () ;

 maybeDoNothing :: (Monad m) => Maybe a -> ( a -> m b ) -> m () ;
 maybeDoNothing a f = maybe doNothing f' a
     where { f' a = f a >> doNothing } ;

 type ActionType a = StateT [ Widget ] IO a ;

 pushWidget :: ( WidgetClass w ) => w -> ActionType () ;
 pushWidget w = modify ( toWidget w : ) ;

 touchWidget :: ( CanBeCasted a ) => ( a -> IO b ) -> ActionType () ;
 touchWidget f = do {
     w <- ( liftM $ take 1 ) get ;
     case mapMaybe glibCast w of {
         [ w' ] -> liftIO $ f w' >> doNothing ;
         _ -> doNothing
     }
 } ;

 reachWidget :: ( CanBeCasted a ) => Int -> ActionType ( Maybe a ) ;
 reachWidget n = do {
     s <- get ;
     return $ if length s > n
         then glibCast ( s !! n )
         else Nothing
 } ;

 pullWidget :: ( CanBeCasted a , CanBeCasted b ) =>
 ( a -> b -> IO c ) -> ActionType () ;
 pullWidget f = do {
     w0 <- reachWidget 0 ;
     w1 <- reachWidget 1 ;
     case ( w0 , w1 ) of {
         ( Just w0' , Just w1' ) -> do {
             liftIO $ f w0' w1' ;
             ( s : ss ) <- get ;
             put $ s : drop 1 ss
         } ;
         _ -> doNothing
     }
 } ;

 pullWidget3 :: ( CanBeCasted a , CanBeCasted b , CanBeCasted c ,
 CanBeCasted d ) => ( a -> b -> c -> d -> IO e ) -> ActionType () ;
 pullWidget3 f = do {
     w0 <- reachWidget 0 ;
     w1 <- reachWidget 1 ;
     w2 <- reachWidget 2 ;
     w3 <- reachWidget 3 ;
     case ( w0 , w1 , w2 , w3 ) of {
         ( Just w0 , Just w1 , Just w2 , Just w3 ) -> do {
             liftIO $ f w0 w1 w2 w3 ;
             ( s : ss ) <- get ;
             put $ s : drop 3 ss
         } ;
         _ -> doNothing
     }
 } ;

 newtype RPN = RPN ( ActionType () ) ;

 instance Monoid RPN where { mempty = RPN doNothing ; mappend ( RPN
 rpn1 ) ( RPN rpn2 ) = RPN $ rpn1 >> rpn2 } ;

 widgetsFromRpn :: RPN -> IO [ Widget ] ;
 widgetsFromRpn ( RPN rpn ) = ( liftM $ reverse )  ( execStateT rpn [] ) ;

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

 cWID = RPN . pushWidget ;
 cACL = io2rpn . accelLabelNew ;
 cALN = ((( io2rpn .).).). alignmentNew ;
 cARW = ( io2rpn .). arrowNew ;
 cAFR = (( io2rpn .).). aspectFrameNew ;
 cBTN = io2rpn buttonNew ;
 cBTNSTK = io2rpn . buttonNewFromStock ;
 cBTNL = io2rpn . buttonNewWithLabel ;
 cBTNMNM = io2rpn . buttonNewWithMnemonic ;
 cCLD = io2rpn calendarNew ;
 cCVW = io2rpn cellViewNew ;
 cCVWPIX = io2rpn . cellViewNewWithPixbuf ;
 cCVWMRK = io2rpn . cellViewNewWithMarkup ;
 cCVWTXT = io2rpn . cellViewNewWithText ;
 cBTNCHK = io2rpn checkButtonNew ;
 cBTNCHKL = io2rpn . checkButtonNewWithLabel ;
 cBTNCHKMNM = io2rpn . checkButtonNewWithMnemonic ;
 cMENCHKIT = io2rpn checkMenuItemNew ;
 cMENCHKITL = io2rpn . checkMenuItemNewWithLabel ;
 cMENCHKITMNM = io2rpn . checkMenuItemNewWithMnemonic ;
 cBTNCLR = io2rpn colorButtonNew ;
 cBTNCLRCL = io2rpn . colorButtonNewWithColor ;
 cCLRSEL = io2rpn colorSelectionNew ;
 cCMBENY = io2rpn comboBoxEntryNew ;
 cCMBENYTXT = io2rpn comboBoxEntryNewText ;
 cCMBENYMDL = io2rpn . comboBoxEntryNewWithModel ;
 cCMB = io2rpn comboBoxNew ;
 cCMBTXT = io2rpn comboBoxNewText ;
 cCMBMDL = io2rpn . comboBoxNewWithModel ;
 cDRW = io2rpn drawingAreaNew ;
 cENY = io2rpn entryNew ;
 cEVN = io2rpn eventBoxNew ;
 cEXN = io2rpn . expanderNew ;
 cEXNMNM = io2rpn . expanderNewWithMnemonic ;
 cBTNFLE = ( io2rpn .). fileChooserButtonNew ;
 cFLESEL = io2rpn . fileChooserWidgetNew ;
 cFXD = io2rpn fixedNew ;
 cBTNFON = io2rpn fontButtonNew ;
 cBTNFONFN = io2rpn . fontButtonNewWithFont ;
 cFONSEL = io2rpn fontSelectionNew ;
 cFRM = io2rpn frameNew ;
 cHBX = ( io2rpn .). hBoxNew ;
 cHBXBTN = io2rpn hButtonBoxNew ;
 cHPD = io2rpn hPanedNew ;
 cHSC = io2rpn . hScaleNew ;
 cHSCRNG = (( io2rpn .).). hScaleNewWithRange ;
 cHSB = io2rpn . hScrollbarNew ;
 cHSBDF = io2rpn hScrollbarNewDefaults ;
 cHSP = io2rpn hSeparatorNew ;
 cHNB = io2rpn handleBoxNew ;
 cIVW = io2rpn iconViewNew ;
 cIVWMDL = io2rpn . iconViewNewWithModel ;
 cMENIMGIT = io2rpn imageMenuItemNew ;
 cMENIMGITSTK = io2rpn . imageMenuItemNewFromStock ;
 cMENIMGITL = io2rpn . imageMenuItemNewWithLabel ;
 cMENIMGITMNM = io2rpn . imageMenuItemNewWithMnemonic ;
 cIMG = io2rpn imageNew ;
 cIMGFLE = io2rpn . imageNewFromFile ;
 cIMGICN = ( io2rpn .). imageNewFromIconName ;
 cIMGPIX = io2rpn . imageNewFromPixbuf ;
 cIMGSTK = ( io2rpn .). imageNewFromStock ;
 cLBL = io2rpn . labelNew ;
 cLBLMNM = io2rpn . labelNewWithMnemonic ;
 cLAY = ( io2rpn .). layoutNew ;
 cMENBAR = io2rpn menuBarNew ;
 cMENIT = io2rpn menuItemNew ;
 cMENITL = io2rpn . menuItemNewWithLabel ;
 cMENITMNM = io2rpn . menuItemNewWithMnemonic ;
 cMEN = io2rpn menuNew ;
 cMENTBN = ( io2rpn .). menuToolButtonNew ;
 cMENTBNSTK = io2rpn . menuToolButtonNewFromStock ;
 cNBK = io2rpn notebookNew ;
 cPRB = io2rpn progressBarNew ;
 cBTNRDI = io2rpn radioButtonNew ;
 cBTNRDIWID = io2rpn . radioButtonNewFromWidget ;
 cBTNRDIL = io2rpn . radioButtonNewWithLabel ;
 cBTNRDILWID = ( io2rpn .). radioButtonNewWithLabelFromWidget ;
 cBTNRDIMNM = io2rpn . radioButtonNewWithMnemonic ;
 cBTNRDIMNMWID = ( io2rpn .). radioButtonNewWithMnemonicFromWidget ;
 cMENRDIIT = io2rpn radioMenuItemNew ;
 cMENRDIITWID = io2rpn . radioMenuItemNewFromWidget ;
 cMENRDIITL = io2rpn . radioMenuItemNewWithLabel ;
 cMENRDIITLWID = ( io2rpn .). radioMenuItemNewWithLabelFromWidget ;
 cMENRDIMNM = io2rpn . radioMenuItemNewWithMnemonic ;
 cMENRDIMNMWID = ( io2rpn .). radioMenuItemNewWithMnemonicFromWidget ;
 cTBNRDI = io2rpn radioToolButtonNew ;
 cTBNRDISTK = io2rpn . radioToolButtonNewFromStock ;
 cTBNRDIWID = io2rpn . radioToolButtonNewFromWidget ;
 cTBNRDISTKWID = ( io2rpn .). radioToolButtonNewWithStockFromWidget ;
 cSRL = ( io2rpn .). scrolledWindowNew ;
 cMENITSP = io2rpn separatorMenuItemNew ;
 cTLBITSP = io2rpn separatorToolItemNew ;
 cSKT = io2rpn socketNew ;
 cBTNSPI = (( io2rpn .).). spinButtonNew ;
 cBTNSPIRNG = (( io2rpn .).). spinButtonNewWithRange ;
 cSTU = io2rpn statusbarNew ;
 cTBL = (( io2rpn .).). tableNew ;
 cMENITTF = io2rpn tearoffMenuItemNew ;
 cXVW = io2rpn textViewNew ;
 cTVWBF = io2rpn . textViewNewWithBuffer ;
 cBTNTGL = io2rpn toggleButtonNew ;
 cBTNTGLL = io2rpn . toggleButtonNewWithLabel ;
 cBTNTGLMNM = io2rpn . toggleButtonNewWithMnemonic ;
 cTLBITTLG = io2rpn toggleToolButtonNew ;
 cTLBITTLGSTK = io2rpn . toggleToolButtonNewFromStock ;
 cTLBITBTN = ( io2rpn .). toolButtonNew ;
 cTLBITBTNSTK = io2rpn . toolButtonNewFromStock ;
 cTLBIT = io2rpn toolItemNew ;
 cTLB = io2rpn toolbarNew ;
 cRVW = io2rpn treeViewNew ;
 cRVWMDL = io2rpn . treeViewNewWithModel ;
 cVBX = ( io2rpn .). vBoxNew ;
 cVBXBTN = io2rpn vButtonBoxNew ;
 cVPD = io2rpn vPanedNew ;
 cVSC = io2rpn . vScaleNew ;
 cVSCRNG = (( io2rpn .).). vScaleNewWithRange ;
 cVSB = io2rpn . vScrollbarNew ;
 cVSBDF = io2rpn vScrollbarNewDefaults ;
 cVSP = io2rpn vSeparatorNew ;
 cVWP = ( io2rpn .). viewportNew ;
 cWND = io2rpn windowNew ;
 cWNDPU = io2rpn windowNewPopup ;

 tSET :: ( CanBeCasted w ) => [ AttrOp w ] -> RPN ;
 tSET a = RPN $ touchWidget $ ( $ a ) . set ;

 tON :: ( CanBeCasted w ) => Signal w c -> c -> RPN ;
 tON s c = RPN $ touchWidget $ ($ c) . ($ s) . on ;

 tAF :: ( CanBeCasted w ) => Signal w c -> c -> RPN ;
 tAF s c = RPN $ touchWidget $ ($ c) . ($ s) . after ;

 tSKT :: NativeWindowId -> RPN ;
 tSKT n = RPN $ touchWidget $ ($ n) . sai
     where { sai :: Socket -> NativeWindowId -> IO () ;
     sai = socketAddId } ;

 pCA = RPN $
     let { ca :: Container -> Widget -> IO () ; ca = containerAdd }
         in pullWidget ca ;

 pBSI = RPN $
     let { bsi :: Button -> Widget -> IO () ; bsi = buttonSetImage }
         in pullWidget bsi ;

 pBPS p i = RPN $
     let { bps :: Box -> Widget -> IO () ; bps b w = boxPackStart b w p i }
         in pullWidget bps ;

 pBPE p i = RPN $
     let { bpe :: Box -> Widget -> IO () ; bpe b w = boxPackEnd b w p i }
         in pullWidget bpe ;

 pBPSD = RPN $
     let { bpsd :: Box -> Widget -> IO () ; bpsd = boxPackStartDefaults }
         in pullWidget bpsd ;

 pBPED = RPN $
     let { bped :: Box -> Widget -> IO () ; bped = boxPackEndDefaults }
         in pullWidget bped ;

 pFP p = RPN $
     let { fp :: Fixed -> Widget -> IO () ; fp f w = fixedPut f w p }
         in pullWidget fp ;

 pPA1 = RPN $
     let { pa1 :: Paned -> Widget -> IO () ; pa1 = panedAdd1 }
         in pullWidget pa1 ;

 pPA2 = RPN $
     let { pa2 :: Paned -> Widget -> IO () ; pa2 = panedAdd2 }
         in pullWidget pa2 ;

 pPP1 r s = RPN $
     let { pp1 :: Paned -> Widget -> IO () ; pp1 p w = panedPack1 p w r s }
         in pullWidget pp1 ;

 pPP2 r s = RPN $
     let { pp2 :: Paned -> Widget -> IO () ; pp2 p w = panedPack2 p w r s }
         in pullWidget pp2 ;

 pLP x y = RPN $
     let { lp :: Layout -> Widget -> IO () ; lp l w = layoutPut l w x y }
         in pullWidget lp ;

 pNAP s = RPN $
     let { nap :: Notebook -> Widget -> IO Int ;
     nap l w = notebookAppendPage l w s }
         in pullWidget nap ;

 pNAPM = RPN $
     let { napm :: Notebook -> Widget -> Widget -> Widget -> IO Int ;
     napm = notebookAppendPageMenu }
         in pullWidget3 napm ;

 pNPP s = RPN $
     let { npp :: Notebook -> Widget -> IO Int ;
     npp l w = notebookPrependPage l w s }
         in pullWidget npp ;

 pNPPM = RPN $
     let { nppm :: Notebook -> Widget -> Widget -> Widget -> IO Int ;
     nppm = notebookPrependPageMenu }
         in pullWidget3 nppm ;

 pTA l r t b xo yo xp yp = RPN $
     let { ta :: Table -> Widget -> IO () ; ta tab wid =
     tableAttach tab wid l r t b xo yo xp yp }
         in pullWidget ta ;

 pTAD l r t b = RPN $
     let { tad :: Table -> Widget -> IO () ;
     tad ta wi = tableAttachDefaults ta wi l r t b }
         in pullWidget tad ;

 pTVACAA a = RPN $
     let { tvacaa :: TextView -> Widget -> IO () ; tvacaa t w =
     textViewAddChildAtAnchor t w a }
         in pullWidget tvacaa ;

 pTVACIW t x y = RPN $
     let { tvaciw :: TextView -> Widget -> IO () ; tvaciw te wi =
     textViewAddChildInWindow te wi t x y }
         in pullWidget tvaciw ;

 pTI i = RPN $
     let { ti :: Toolbar -> ToolItem -> IO () ; ti tc tic =
     toolbarInsert tc tic i }
         in pullWidget ti ;

 rCBK :: ( Widget -> IO () ) -> RPN ;
 rCBK f = RPN $ touchWidget cb
  where {
      cb w = after w realize $ f w
  } ;

 rTME :: ( Widget -> IO () ) -> Int -> RPN ;
 rTME f dt = rCBK i
  where {
      i w = do {
           id <- timeoutAdd ( f w >> return True ) dt ;
           on w unrealize $ timeoutRemove id
      } >> return ()
  } ;

 rSHPE :: ( ( Double , Double ) -> Render () ) -> RPN ;
 rSHPE c = mconcat [ cDRW , tON e s ]
  where {
      e :: Signal Widget ( EventM EExpose Bool ) ;
      e = exposeEvent ;
      s = do {
           w <- eventWindow ;
           liftIO $ do {
               ( ww , wh ) <- liftIO $ drawableGetSize w ;
               let { ch = c ( fromIntegral ww , fromIntegral wh ) } ;
               liftIO $ renderWithDrawable w ch ;
           } ;
           return True
      }
  } ;

 rANIM :: Int -> IO a -> ( a -> ( Double , Double ) -> Render () ) -> RPN ;
 rANIM dt readData toRender = mconcat [ cDRW , tON e ef , tON m mf ]
  where {
      e :: Signal Widget ( EventM EExpose Bool ) ;
      e = exposeEvent ;
      ef = do {
          dw <- eventWindow ;
          liftIO $ do {
              (sx,sy) <- drawableGetSize dw ;
              let { (sx',sy') = (fromIntegral sx , fromIntegral sy) } ;
              d <- readData ;
              let { render = toRender d (sx',sy') } ;
              renderWithDrawable dw render ;
          } ;
          return True
      } ;
      m :: Signal Widget ( EventM EAny Bool ) ;
      m = mapEvent ;
      mf = do {
          dw <- eventWindow ;
          liftIO $ do {
              (sx,sy) <- drawableGetSize dw ;
              let { area = Rectangle 0 0 sx sy } ;
              let { f = drawWindowInvalidateRect dw area False } ;
              timeoutAdd ( f >> return True ) dt
          } ;
          return True
      }
  } ;
}