packages feed

gtk2hs-rpn 0.0.2 → 0.1

raw patch · 9 files changed

+608/−881 lines, 9 filesdep +glib

Dependencies added: glib

Files

.hg_archival.txt view
@@ -1,2 +1,2 @@ repo: 73f9f23123106e581edbcf74b725d9a23e2eb1f4-node: d6720590f1abaf37f58578d9aa71302681440f8c+node: bd4d9234cf7e7a1fa4b8c5a47f711348d0192a7c
.hgtags view
@@ -1,1 +1,3 @@ 9e2bed8ab08ad6f310093bec0c339ae8f6ddb142 0.0.2+6ad8883193562cd2d520d765028713a689fe43b1 0.1+8a3c94fd99a61ca2a002f71edaa0594fa8d54e27 0.1
examples/example1.hs view
@@ -13,48 +13,44 @@ main = do     initGUI -    -- Create a new operator ('line') that takes a label-    -- ('cLBL') and a button ('cBTNL') and pack then ('pBPED')-    -- in a horizontal box ('cHBX').+    -- Create a new operator  that takes a label+    -- and a button  and pack then +    -- in a horizontal box .      let line s = mconcat [-         cLBL (Just $ s ++ ":"),-         cBTNL s,-         cHBX True 0,-         pBPED,-         pBPED]+         rLABEL s,+         rRIGHT,+         rBUTTON s $ return (),+         rCENTER,+         rHBOX [PackGrow,PackGrow]+         ] -    -- Create a new operator ('column') that packs many 'line'-    -- in a vertical box ('cVBX').+    -- Create a new operator  that packs many 'line'+    -- in a vertical box .      let column = mconcat $ [          line "One Button",          line "Another Button",          line "Yet Another Button",          line "Last Button",-         cVBX True 0] ++ replicate 4 pBPED+         rVBOX $ replicate 4 PackGrow+         ] -    -- Take two copies of 'column' and add ('pNAP') then-    -- to a notebook ('cNBK'). Then create a stock button-    -- ('cBTNSTK') and attach a action to an event ('tON'). Then+    -- Take two copies of 'column' and add  then+    -- to a notebook . Then create a stock button+    --  and attach a action to an event . Then     -- join the notebook and that button in a vertical box.-    -- Insert everything in a main window ('cWND, pCA'), and-    -- finally make everything into widgets ('widgetsFromRpn').+    -- Insert everything in a main window , and+    -- finally make everything into widgets . -    [mainWindow] <- widgetsFromRpn $ mconcat $ [+    [mainWindow] <- widgetsFromRpn [          column,          column,-         cNBK,-         pNAP "First Page",-         pNAP "Second Page",-         cBTNSTK stockQuit,-         tON pressed (liftIO mainQuit >> return True),-         cVBX False 0,-         pBPE PackNatural 0,-         pBPED,-         cWND,-         pCA,-         tSET (title "Layout.RPN Example")]+         rNOTEBOOK ["First Page","Second Page"],+         rBUTTON stockQuit mainQuit,+         rVBOX [PackGrow,PackNatural],+         rMAIN "Layout.Rpn Example"+         ]      widgetShowAll mainWindow     mainGUI
gtk2hs-rpn.cabal view
@@ -1,27 +1,28 @@ cabal-Version: >= 1.2 name: gtk2hs-rpn-version: 0.0.2+version: 0.1 synopsis:-  Adds a module to gtk2hs allowing layouts to-  be defined using reverse polish notation.+  Adds a module to gtk2hs allowing layouts to be defined using+  reverse polish notation. description:-  Adds a module 'Graphics.UI.Gtk.Layout.Rpn' to gtk2hs. This-  module defines a type 'RPN' for operators, and is an instance-  of Monoid class.  You can combine those operators using reverse-  polish notation, as made popular by, say, HP calculators. There-  are operators for layout elements, like expanders, panes,-  boxes and notebooks, and for a few other widgets, like buttons-  and labels. You can include any gtk2hs widget in the stack.+  Adds a module "Graphics.UI.Gtk.Layout.Rpn" to @gtk2hs@. This+  module defines a type @RPN@ for operators, which is an+  instance of 'Data.Monoid.Monoid' class.  You can combine those+  operators using reverse polish notation, as made popular by,+  say, HP calculators. There are operators for layout elements,+  like expanders, panes, boxes and notebooks, and for a few+  other widgets, like buttons and labels. You can also insert+  any existing @gtk2hs@ widget in the stack. build-type: Simple license: LGPL license-file: LICENSE maintainer: Maurício CA <mauricio.antunes@gmail.com> category: GUI Library-  build-depends: base, gtk >= 0.10, cairo, mtl+  build-depends: base, gtk >= 0.10, cairo, mtl, glib   hs-source-dirs: src   extensions:     NoMonomorphismRestriction   exposed-modules:     Graphics.UI.Gtk.Layout.Rpn-    Graphics.UI.Gtk.Layout.Rpn.CanBeCasted+  other-modules: RPN, Basic, CanBeCasted
+ src/Basic.hs view
@@ -0,0 +1,100 @@+{-# OPTIONS_HADDOCK hide #-}++-- | Here we provide several low level operators that we are+-- going to use to build others, user friendly, operators.+-- Operators in this module are all simple capsules over existing+-- @gtk2hs@ functions.++module Basic where+import Control.Monad.State+import Graphics.UI.Gtk+import CanBeCasted+import RPN++-- * Operators with prefix @c@++-- | These are maps of @gtk2hs@ widget creation functions.+-- See 'io2rpn'.++cWID = RPN . pushWidget+cALN = io2rpn . \x -> alignmentNew x 0.5 0 0+cARW = io2rpn . \t -> arrowNew t ShadowNone+cAFR = io2rpn (aspectFrameNew 0.5 0.5 Nothing)+cBTNSTK = io2rpn . buttonNewFromStock+cBTNCLRCL = io2rpn . colorButtonNewWithColor+cEXN = io2rpn . expanderNew+cBTNFLE = io2rpn . fileChooserButtonNew ""+cBTNFONFN = io2rpn . fontButtonNewWithFont+cFRM = io2rpn frameNew+cHBX = io2rpn (hBoxNew False 0)+cVBX = io2rpn (vBoxNew False 0)+cHBXBTN = io2rpn hButtonBoxNew+cVBXBTN = io2rpn vButtonBoxNew+cHPD = io2rpn hPanedNew+cVPD = io2rpn vPanedNew+cHSCRNG = (io2rpn .). \mi ma -> hScaleNewWithRange mi ma ((mi+ma)/2)+cVSCRNG = (io2rpn .). \mi ma -> vScaleNewWithRange mi ma ((mi+ma)/2)+cHSP = io2rpn hSeparatorNew+cVSP = io2rpn vSeparatorNew+cIMGFLE = io2rpn . imageNewFromFile+cLBL = io2rpn . labelNew . Just+cNBK = io2rpn notebookNew+cSRL = io2rpn $ scrolledWindowNew Nothing Nothing+cLAY = io2rpn $ layoutNew Nothing Nothing+cSKT = io2rpn socketNew+cBTNSPIRNG = (io2rpn .). \mi ma -> spinButtonNewWithRange mi ma ((mi+ma)/2)+cTVWBF = io2rpn . textViewNewWithBuffer+cWND = io2rpn windowNew++-- * Operators with prefix @t@++-- | These operators act on a widget. 'tON' and its derivatives+-- connect callbacks to events. 'tSET' and derivatives set+-- attributes. 'tCBK' and derivatives allows callbacks to+-- be called at realize time with the corresponding widget+-- as parameters, we use them to connect to events for those+-- widgets @gtk2hs@ doesn't yet define event names for.++tON s c = RPN $ touchWidget $ \w -> on w s c >> return ()+tONBUTTON = tON :: Signal Button c -> c -> RPN++tSET a = RPN $ touchWidget $ ( $ a ) . set+tSETFRAME = tSET :: [AttrOp Frame] -> RPN+tSETLABEL = tSET :: [AttrOp Label] -> RPN+tSETWINDOW = tSET :: [AttrOp Window] -> RPN++tCBK f = RPN $ touchWidget cb+ where cb w = (after w realize $ f w) >> return ()+tCBKCOLOR = tCBK :: (ColorButton -> IO ()) -> RPN+tCBKFONT = tCBK :: (FontButton -> IO ()) -> RPN+tCBKRANGE = tCBK :: (Range -> IO ()) -> RPN+tCBKSOCKET = tCBK :: (Socket -> IO ()) -> RPN+tCBKSPIN = tCBK :: (SpinButton -> IO ()) -> RPN++-- * Operators with prefix @p@++-- | These are packing operators. They pack a widget into a+-- container, and the widget is removed from the stack.++pCA = RPN $+    let { ca :: Container -> Widget -> IO () ; ca = containerAdd }+        in pullWidget ca+pBPE p = RPN $+    let { bpe :: Box -> Widget -> IO () ; bpe b w = boxPackEnd b w p 0 }+        in pullWidget bpe+pPP1 r = RPN $+    let { pp1 :: Paned -> Widget -> IO () ; pp1 p w = panedPack1 p w r False }+        in pullWidget pp1+pPP2 r = RPN $+    let { pp2 :: Paned -> Widget -> IO () ; pp2 p w = panedPack2 p w r False }+        in pullWidget pp2+pNPP s = RPN $+    let+        npp :: Notebook -> Widget -> IO ()+        npp l w = notebookPrependPage l w s >> return ()+        in pullWidget npp+pLAY = RPN $+    let+        lay :: Layout -> Widget -> IO ()+        lay la w = layoutPut la w 0 0+        in pullWidget lay
+ src/CanBeCasted.hs view
@@ -0,0 +1,212 @@+{-# OPTIONS_HADDOCK hide #-}++module CanBeCasted (+    CanBeCasted (glibCast)+ ) where+import Graphics.UI.Gtk+import Graphics.UI.Gtk.Types++-- | 'CanBeCasted' class allows casting between some+-- 'System.Glib.GObject.GObjectClass' instances.++class (GObjectClass g) => CanBeCasted g where++    -- | 'glibCast' casts between types,if possible.++    glibCast :: (GObjectClass o) => o -> Maybe g+    glibCast a = if isA a t then Just (c a) else Nothing+        where { (t,c) = castData }++    -- | 'castData' provides data for casting,using @gtk2hs@+    -- map of similar @gtk+@ data.  This is the only class+    -- member that instances shall redefine.++    castData :: (GObjectClass g1) => (GType,g1 -> g)++instance CanBeCasted Adjustment where+    castData = (gTypeAdjustment,castToAdjustment)+instance CanBeCasted Alignment where+    castData = (gTypeAlignment,castToAlignment)+instance CanBeCasted Arrow where+    castData = (gTypeArrow,castToArrow)+instance CanBeCasted AspectFrame where+    castData = (gTypeAspectFrame,castToAspectFrame)+instance CanBeCasted Bin where+    castData = (gTypeBin,castToBin)+instance CanBeCasted Box where+    castData = (gTypeBox,castToBox)+instance CanBeCasted Button where+    castData = (gTypeButton,castToButton)+instance CanBeCasted ButtonBox where+    castData = (gTypeButtonBox,castToButtonBox)+instance CanBeCasted Calendar where+    castData = (gTypeCalendar,castToCalendar)+instance CanBeCasted CheckButton where+    castData = (gTypeCheckButton,castToCheckButton)+instance CanBeCasted CheckMenuItem where+    castData = (gTypeCheckMenuItem,castToCheckMenuItem)+instance CanBeCasted Clipboard where+    castData = (gTypeClipboard,castToClipboard)+instance CanBeCasted ColorButton where+    castData = (gTypeColorButton,castToColorButton)+instance CanBeCasted ColorSelection where+    castData = (gTypeColorSelection,castToColorSelection)+instance CanBeCasted ColorSelectionDialog where+    castData = (gTypeColorSelectionDialog,castToColorSelectionDialog)+instance CanBeCasted Container where+    castData = (gTypeContainer,castToContainer)+instance CanBeCasted Dialog where+    castData = (gTypeDialog,castToDialog)+instance CanBeCasted DragContext where+    castData = (gTypeDragContext,castToDragContext)+instance CanBeCasted DrawWindow where+    castData = (gTypeDrawWindow,castToDrawWindow)+instance CanBeCasted Drawable where+    castData = (gTypeDrawable,castToDrawable)+instance CanBeCasted DrawingArea where+    castData = (gTypeDrawingArea,castToDrawingArea)+instance CanBeCasted Editable where+    castData = (gTypeEditable,castToEditable)+instance CanBeCasted Entry where+    castData = (gTypeEntry,castToEntry)+instance CanBeCasted EntryCompletion where+    castData = (gTypeEntryCompletion,castToEntryCompletion)+instance CanBeCasted EventBox where+    castData = (gTypeEventBox,castToEventBox)+instance CanBeCasted Expander where+    castData = (gTypeExpander,castToExpander)+instance CanBeCasted FileChooser where+    castData = (gTypeFileChooser,castToFileChooser)+instance CanBeCasted FileChooserButton where+    castData = (gTypeFileChooserButton,castToFileChooserButton)+instance CanBeCasted FileChooserDialog where+    castData = (gTypeFileChooserDialog,castToFileChooserDialog)+instance CanBeCasted FileChooserWidget where+    castData = (gTypeFileChooserWidget,castToFileChooserWidget)+instance CanBeCasted FileFilter where+    castData = (gTypeFileFilter,castToFileFilter)+instance CanBeCasted FileSelection where+    castData = (gTypeFileSelection,castToFileSelection)+instance CanBeCasted Fixed where+    castData = (gTypeFixed,castToFixed)+instance CanBeCasted FontButton where+    castData = (gTypeFontButton,castToFontButton)+instance CanBeCasted FontSelection where+    castData = (gTypeFontSelection,castToFontSelection)+instance CanBeCasted FontSelectionDialog where+    castData = (gTypeFontSelectionDialog,castToFontSelectionDialog)+instance CanBeCasted Frame where+    castData = (gTypeFrame,castToFrame)+instance CanBeCasted HBox where+    castData = (gTypeHBox,castToHBox)+instance CanBeCasted HButtonBox where+    castData = (gTypeHButtonBox,castToHButtonBox)+instance CanBeCasted HPaned where+    castData = (gTypeHPaned,castToHPaned)+instance CanBeCasted HScale where+    castData = (gTypeHScale,castToHScale)+instance CanBeCasted HScrollbar where+    castData = (gTypeHScrollbar,castToHScrollbar)+instance CanBeCasted HSeparator where+    castData = (gTypeHSeparator,castToHSeparator)+instance CanBeCasted HandleBox where+    castData = (gTypeHandleBox,castToHandleBox)+instance CanBeCasted IconView where+    castData = (gTypeIconView,castToIconView)+instance CanBeCasted Image where+    castData = (gTypeImage,castToImage)+instance CanBeCasted ImageMenuItem where+    castData = (gTypeImageMenuItem,castToImageMenuItem)+instance CanBeCasted Label where+    castData = (gTypeLabel,castToLabel)+instance CanBeCasted Layout where+    castData = (gTypeLayout,castToLayout)+instance CanBeCasted Misc where+    castData = (gTypeMisc,castToMisc)+instance CanBeCasted Notebook where+    castData = (gTypeNotebook,castToNotebook)+instance CanBeCasted Object where+    castData = (gTypeObject,castToObject)+instance CanBeCasted OptionMenu where+    castData = (gTypeOptionMenu,castToOptionMenu)+instance CanBeCasted Paned where+    castData = (gTypePaned,castToPaned)+instance CanBeCasted Pixbuf where+    castData = (gTypePixbuf,castToPixbuf)+instance CanBeCasted Range where+    castData = (gTypeRange,castToRange)+instance CanBeCasted Scale where+    castData = (gTypeScale,castToScale)+instance CanBeCasted Screen where+    castData = (gTypeScreen,castToScreen)+instance CanBeCasted Scrollbar where+    castData = (gTypeScrollbar,castToScrollbar)+instance CanBeCasted ScrolledWindow where+    castData = (gTypeScrolledWindow,castToScrolledWindow)+instance CanBeCasted Separator where+    castData = (gTypeSeparator,castToSeparator)+instance CanBeCasted Socket where+    castData = (gTypeSocket,castToSocket)+instance CanBeCasted SpinButton where+    castData = (gTypeSpinButton,castToSpinButton)+instance CanBeCasted Table where+    castData = (gTypeTable,castToTable)+instance CanBeCasted TearoffMenuItem where+    castData = (gTypeTearoffMenuItem,castToTearoffMenuItem)+instance CanBeCasted TextBuffer where+    castData = (gTypeTextBuffer,castToTextBuffer)+instance CanBeCasted TextMark where+    castData = (gTypeTextMark,castToTextMark)+instance CanBeCasted TextTag where+    castData = (gTypeTextTag,castToTextTag)+instance CanBeCasted TextTagTable where+    castData = (gTypeTextTagTable,castToTextTagTable)+instance CanBeCasted TextView where+    castData = (gTypeTextView,castToTextView)+instance CanBeCasted ToggleButton where+    castData = (gTypeToggleButton,castToToggleButton)+instance CanBeCasted ToggleToolButton where+    castData = (gTypeToggleToolButton,castToToggleToolButton)+instance CanBeCasted ToolButton where+    castData = (gTypeToolButton,castToToolButton)+instance CanBeCasted ToolItem where+    castData = (gTypeToolItem,castToToolItem)+instance CanBeCasted Toolbar where+    castData = (gTypeToolbar,castToToolbar)+instance CanBeCasted Tooltips where+    castData = (gTypeTooltips,castToTooltips)+instance CanBeCasted TreeModel where+    castData = (gTypeTreeModel,castToTreeModel)+instance CanBeCasted TreeModelSort where+    castData = (gTypeTreeModelSort,castToTreeModelSort)+instance CanBeCasted TreeSelection where+    castData = (gTypeTreeSelection,castToTreeSelection)+instance CanBeCasted TreeSortable where+    castData = (gTypeTreeSortable,castToTreeSortable)+instance CanBeCasted TreeView where+    castData = (gTypeTreeView,castToTreeView)+instance CanBeCasted TreeViewColumn where+    castData = (gTypeTreeViewColumn,castToTreeViewColumn)+instance CanBeCasted UIManager where+    castData = (gTypeUIManager,castToUIManager)+instance CanBeCasted VBox where+    castData = (gTypeVBox,castToVBox)+instance CanBeCasted VButtonBox where+    castData = (gTypeVButtonBox,castToVButtonBox)+instance CanBeCasted VPaned where+    castData = (gTypeVPaned,castToVPaned)+instance CanBeCasted VScale where+    castData = (gTypeVScale,castToVScale)+instance CanBeCasted VScrollbar where+    castData = (gTypeVScrollbar,castToVScrollbar)+instance CanBeCasted VSeparator where+    castData = (gTypeVSeparator,castToVSeparator)+instance CanBeCasted Viewport where+    castData = (gTypeViewport,castToViewport)+instance CanBeCasted Widget where+    castData = (gTypeWidget,castToWidget)+instance CanBeCasted Window where+    castData = (gTypeWindow,castToWindow)+instance CanBeCasted WindowGroup where+    castData = (gTypeWindowGroup,castToWindowGroup)+
src/Graphics/UI/Gtk/Layout/Rpn.hs view
@@ -1,374 +1,218 @@-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 ;+module Graphics.UI.Gtk.Layout.Rpn ( - doNothing :: (Monad m) => m () ;- doNothing = return () ;+    RPN(), widgetsFromRpn, rWID, rCENTER, rLEFT, rRIGHT, rARROW,+    rASPECT, rBUTTON, rEXPANDER, rCOLOR, rFILE, rFONT, rFRAME,+    rHBOX,rVBOX, rHBBOX,rVBBOX, rHPANE,rVPANE, rHSCALE,rVSCALE,+    rHSEPARATOR,rVSEPARATOR, rIMAGE, rLABEL, rNOTEBOOK, rSCROLL,+    rSOCKET, rSPIN, rTEXT, rMAIN - maybeDoNothing :: (Monad m) => Maybe a -> ( a -> m b ) -> m () ;- maybeDoNothing a f = maybe doNothing f' a-     where { f' a = f a >> doNothing } ;+ ) where+import Graphics.UI.Gtk+import System.Glib.Attributes as A (get)+import Control.Monad.State+import Data.Monoid+import Data.List+import RPN+import Basic - type ActionType a = StateT [ Widget ] IO a ;+-- | Inserts your widget in the stack.  Your widget needs to+-- pass through Gtk.toWidget before applying 'rWID'. - pushWidget :: ( WidgetClass w ) => w -> ActionType () ;- pushWidget w = modify ( toWidget w : ) ;+rWID :: Widget -> RPN+rWID = cWID - 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-     }- } ;+-- | Insert the last widget inside a container.  When that+-- container grows, the widget keeps its natural size, aligned+-- in the center of the container. - reachWidget :: ( CanBeCasted a ) => Int -> ActionType ( Maybe a ) ;- reachWidget n = do {-     s <- get ;-     return $ if length s > n-         then glibCast ( s !! n )-         else Nothing- } ;+rCENTER :: RPN+rCENTER = mconcat [cALN 0.5, pCA] - 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-     }- } ;+-- | Same as 'rCENTER', but aligns to the left. - 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-     }- } ;+rLEFT :: RPN+rLEFT = mconcat [cALN 0, pCA] - newtype RPN = RPN ( ActionType () ) ;+-- | Same as 'rCENTER', but aligns to the right. - instance Monoid RPN where { mempty = RPN doNothing ; mappend ( RPN- rpn1 ) ( RPN rpn2 ) = RPN $ rpn1 >> rpn2 } ;+rRIGHT :: RPN+rRIGHT = mconcat [cALN 1, pCA] - widgetsFromRpn :: RPN -> IO [ Widget ] ;- widgetsFromRpn ( RPN rpn ) = ( liftM $ reverse )  ( execStateT rpn [] ) ;+-- | Inserts an 'Graphics.UI.Gtk.Misc.Arrow.Arrow' in the stack. - io2rpn :: ( WidgetClass w ) => IO w -> RPN ;- io2rpn = RPN . ( >>= pushWidget ) . liftIO ;+rARROW :: ArrowType -> RPN+rARROW t = cARW t - 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 ;+-- | Sets the last widget to always keep the aspect ratio of+-- its original size requisition. - tSET :: ( CanBeCasted w ) => [ AttrOp w ] -> RPN ;- tSET a = RPN $ touchWidget $ ( $ a ) . set ;+rASPECT :: RPN+rASPECT = mconcat [cAFR, pCA] - tON :: ( CanBeCasted w ) => Signal w c -> c -> RPN ;- tON s c = RPN $ touchWidget $ ($ c) . ($ s) . on ;+-- | Inserts a button into the stack, after a+-- 'Graphics.UI.Gtk.General.StockItems.StockId' and an @IO ()@+-- to be called when it is clicked. - tAF :: ( CanBeCasted w ) => Signal w c -> c -> RPN ;- tAF s c = RPN $ touchWidget $ ($ c) . ($ s) . after ;+rBUTTON :: StockId -> IO () -> RPN+rBUTTON id io = mconcat [cBTNSTK id, tONBUTTON buttonPressEvent io']+ where io' = liftIO io >> return True - tSKT :: NativeWindowId -> RPN ;- tSKT n = RPN $ touchWidget $ ($ n) . sai-     where { sai :: Socket -> NativeWindowId -> IO () ;-     sai = socketAddId } ;+-- | Packs the last widget in an+-- 'Graphics.UI.Gtk.Layout.Expander.Expander', allowing the+-- user to hide or show that widget under a label. - pCA = RPN $-     let { ca :: Container -> Widget -> IO () ; ca = containerAdd }-         in pullWidget ca ;+rEXPANDER :: String -> RPN+rEXPANDER s = mconcat [cEXN s, pCA] - pBSI = RPN $-     let { bsi :: Button -> Widget -> IO () ; bsi = buttonSetImage }-         in pullWidget bsi ;+-- | Inserts a color chooser button, after an initial+-- 'Graphics.UI.Gtk.Gdk.GC.Color' and a @Color -> IO ()@ to be+-- called when a new color is choosen. - pBPS p i = RPN $-     let { bps :: Box -> Widget -> IO () ; bps b w = boxPackStart b w p i }-         in pullWidget bps ;+rCOLOR :: Color -> (Color -> IO ()) -> RPN+rCOLOR c cb = mconcat [cBTNCLRCL c, tCBKCOLOR callback]+ where callback w = onColorSet w (colorButtonGetColor w >>= cb)+        >> return () - pBPE p i = RPN $-     let { bpe :: Box -> Widget -> IO () ; bpe b w = boxPackEnd b w p i }-         in pullWidget bpe ;+-- | Inserts a+-- 'Graphics.UI.Gtk.Selectors.FileChooserButton.FileChooserButton'+-- after a @'System.IO.FilePath' -> IO ()@ to be called when+-- a file is choosen by the user. (This is not working since+-- @gtk2hs@ do not yet support the @"file-set"@ signal for+-- this widget.) - pBPSD = RPN $-     let { bpsd :: Box -> Widget -> IO () ; bpsd = boxPackStartDefaults }-         in pullWidget bpsd ;+rFILE :: FileChooserAction -> RPN+rFILE = cBTNFLE - pBPED = RPN $-     let { bped :: Box -> Widget -> IO () ; bped = boxPackEndDefaults }-         in pullWidget bped ;+-- | Inserts a font chooser button after a @String -> IO ()@+-- to be called when a new font is choosen. - pFP p = RPN $-     let { fp :: Fixed -> Widget -> IO () ; fp f w = fixedPut f w p }-         in pullWidget fp ;+rFONT :: String -> (String -> IO ()) -> RPN+rFONT c cb = mconcat [cBTNFONFN c, tCBKFONT callback]+ where callback w = onFontSet w (fontButtonGetFontName w >>= cb)+        >> return () - pPA1 = RPN $-     let { pa1 :: Paned -> Widget -> IO () ; pa1 = panedAdd1 }-         in pullWidget pa1 ;+-- | Frames the last widget, adding a label. - pPA2 = RPN $-     let { pa2 :: Paned -> Widget -> IO () ; pa2 = panedAdd2 }-         in pullWidget pa2 ;+rFRAME :: String -> RPN+rFRAME s = mconcat [cFRM, tSETFRAME [frameLabel := s], pCA] - pPP1 r s = RPN $-     let { pp1 :: Paned -> Widget -> IO () ; pp1 p w = panedPack1 p w r s }-         in pullWidget pp1 ;+-- | After a list of 'Graphics.UI.Gtk.Abstract.Box.Packing'+-- styles, 'rHBOX' and 'rVBOX' pack the last widgets respectively+-- in an horizontal or vertical box, as many as there are styles+-- in that list. Do not use them to pack buttons, instead use+-- 'rHBBOX' and 'rVBBOX'. - pPP2 r s = RPN $-     let { pp2 :: Paned -> Widget -> IO () ; pp2 p w = panedPack2 p w r s }-         in pullWidget pp2 ;+rHBOX,rVBOX :: [Packing] -> RPN+rHBOX p = mconcat $ cHBX : map pBPE (reverse p)+rVBOX p = mconcat $ cVBX : map pBPE (reverse p) - pLP x y = RPN $-     let { lp :: Layout -> Widget -> IO () ; lp l w = layoutPut l w x y }-         in pullWidget lp ;+-- | After a number @n@, 'rHBBOX' and 'rVBBOX' pack the last @n@+-- widgets respectively in an horizontal or vertical box. Widgets+-- are supposed to be buttons. - pNAP s = RPN $-     let { nap :: Notebook -> Widget -> IO Int ;-     nap l w = notebookAppendPage l w s }-         in pullWidget nap ;+rHBBOX,rVBBOX :: (Integral n) => n -> RPN+rHBBOX n = mconcat $ cHBXBTN : genericReplicate n (pBPE PackNatural)+rVBBOX n = mconcat $ cVBXBTN : genericReplicate n (pBPE PackNatural) - pNAPM = RPN $-     let { napm :: Notebook -> Widget -> Widget -> Widget -> IO Int ;-     napm = notebookAppendPageMenu }-         in pullWidget3 napm ;+-- | 'rHPANE' and 'rVPANE' create, respectively, horizontal+-- and vertical 'Graphics.UI.Gtk.Abstract.Paned.Paned's.+-- @Bool@ parameters says whether left and right panes are+-- allowed to expand when the containing @Paned@ widget+-- grows. - pNPP s = RPN $-     let { npp :: Notebook -> Widget -> IO Int ;-     npp l w = notebookPrependPage l w s }-         in pullWidget npp ;+rHPANE,rVPANE :: (Bool,Bool) -> RPN+rHPANE (r1,r2) = mconcat [cHPD, pPP2 r2, pPP1 r1]+rVPANE (r1,r2) = mconcat [cVPD, pPP2 r2, pPP1 r1] - pNPPM = RPN $-     let { nppm :: Notebook -> Widget -> Widget -> Widget -> IO Int ;-     nppm = notebookPrependPageMenu }-         in pullWidget3 nppm ;+-- | 'rHSCALE' and 'rVSCALE' create, respectively, horizontal+-- and vertical 'Graphics.UI.Gtk.Abstract.Scale.Scale's, after+-- a @(Double,Double)@ interval and a @Double -> IO ()@ to be+-- called when the value in the @Scale@ changes. - 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 ;+rHSCALE,rVSCALE :: (Double,Double) -> (Double -> IO ()) -> RPN+rHSCALE (v1,v2) io = mconcat [cHSCRNG v1 v2,+ tCBKRANGE $ configScale io]+rVSCALE (v1,v2) io = mconcat [cVSCRNG v1 v2,+ tCBKRANGE $ configScale io] - pTAD l r t b = RPN $-     let { tad :: Table -> Widget -> IO () ;-     tad ta wi = tableAttachDefaults ta wi l r t b }-         in pullWidget tad ;+configScale io w = do+  set w [rangeUpdatePolicy := UpdateDelayed]+  adj <- A.get w rangeAdjustment+  v1 <- A.get adj adjustmentLower+  v2 <- A.get adj adjustmentUpper+  set w [rangeValue := (v2+v1)/2]+  onRangeValueChanged w $ A.get w rangeValue >>= io+  return () - pTVACAA a = RPN $-     let { tvacaa :: TextView -> Widget -> IO () ; tvacaa t w =-     textViewAddChildAtAnchor t w a }-         in pullWidget tvacaa ;+-- | 'rHSEPARATOR' and 'rVSEPARATOR' insert, respectively,+-- horizontal and vertical 'Graphics.UI.Gtk.Abstract.Separator's+-- in the stack. - pTVACIW t x y = RPN $-     let { tvaciw :: TextView -> Widget -> IO () ; tvaciw te wi =-     textViewAddChildInWindow te wi t x y }-         in pullWidget tvaciw ;+rHSEPARATOR,rVSEPARATOR :: RPN+rHSEPARATOR = cHSP+rVSEPARATOR = cVSP - pTI i = RPN $-     let { ti :: Toolbar -> ToolItem -> IO () ; ti tc tic =-     toolbarInsert tc tic i }-         in pullWidget ti ;+-- | 'rIMAGE' takes a 'System.IO.FilePath' to+-- an image and inserts a widget showing that+-- image in the stack. - rCBK :: ( Widget -> IO () ) -> RPN ;- rCBK f = RPN $ touchWidget cb-  where {-      cb w = after w realize $ f w-  } ;+rIMAGE :: FilePath -> RPN+rIMAGE = cIMGFLE - 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 ()-  } ;+-- | 'rLABEL' inserts a 'Graphics.UI.Gtk.Display.Label.Label'+-- in the stack, after a @String@. This @String@+-- is supposed to be @Pango@ "Graphics.UI.Gtk.Pango.Markup". - 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-      }-  } ;+rLABEL :: String -> RPN+rLABEL s = mconcat [cLBL s, tSETLABEL [labelUseMarkup := 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-      }-  } ;-}+-- | 'rNOTEBOOK' takes a list of @String@+-- labels and add widgets from the stack to a+-- 'Graphics.UI.Gtk.Layout.Notebook.Notebook', as many as the+-- labels provided.++rNOTEBOOK :: [String] -> RPN+rNOTEBOOK lb = mconcat $ cNBK : map pNPP (reverse lb)++-- | 'rSCROLL' packs the last widget in a container+-- with horizontal and vertical scroll bars.++rSCROLL :: RPN+rSCROLL = mconcat [cLAY, pLAY, cSRL, pCA]++-- | 'rSOCKET' allows inserting a foreign (from+-- other program) widget inside the stack, given its+-- 'Graphics.UI.Gtk.Embedding.Socket.NativeWindowId'.++rSOCKET :: NativeWindowId -> RPN+rSOCKET id = mconcat [cSKT, tCBKSOCKET (flip socketAddId id)]++-- | 'rSPIN' creates a+-- 'Graphics.UI.Gtk.Entry.SpinButton.SpinButton' after a+-- @(Double,Double)@ interval and a @Double -> IO ()@ to be+-- called when the value in the @SpinButton@ changes.++rSPIN :: (Double,Double) -> (Double -> IO ()) -> RPN+rSPIN (v1,v2) io = mconcat [cBTNSPIRNG v1 v2,+ tCBKSPIN $ configSpin io]++configSpin io w = do+  adj <- A.get w spinButtonAdjustment+  v1 <- A.get adj adjustmentLower+  v2 <- A.get adj adjustmentUpper+  set w [spinButtonValue := (v2+v1)/2]+  onValueSpinned w $ A.get w spinButtonValue >>= io+  return ()++-- | 'rTEXT' creates a text view after a+-- given buffer, which shall be an instance of+-- 'Graphics.UI.Gtk.Multiline.TextBuffer.TextBufferClass'.++rTEXT :: (TextBufferClass b) => b -> RPN+rTEXT = cTVWBF++-- | 'rMAIN' packs the last widget in a main window, given+-- its title.++rMAIN :: String -> RPN+rMAIN t = mconcat [cWND, tSETWINDOW [windowTitle := t], pCA]
− src/Graphics/UI/Gtk/Layout/Rpn/CanBeCasted.hs 
@@ -1,508 +0,0 @@-module Graphics.UI.Gtk.Layout.Rpn.CanBeCasted where {-import Graphics.UI.Gtk ;-import Graphics.UI.Gtk.Types ;-- class ( GObjectClass g ) => CanBeCasted g where {-     glibCast :: ( GObjectClass o ) => o -> Maybe g ;-     glibCast a = if isA a t then Just ( c a ) else Nothing-         where { ( t , c ) = castData } ;-     castData :: ( GObjectClass g1 ) => ( GType , g1 -> g )- } ;-- instance CanBeCasted AboutDialog where {-     castData = ( gTypeAboutDialog , castToAboutDialog )- } ;- instance CanBeCasted AccelLabel where {-     castData = ( gTypeAccelLabel , castToAccelLabel )- } ;- instance CanBeCasted Action where {-     castData = ( gTypeAction , castToAction )- } ;- instance CanBeCasted ActionGroup where {-     castData = ( gTypeActionGroup , castToActionGroup )- } ;--- instance CanBeCasted Adapter where {---     castData = ( gTypeAdapter , castToAdapter )--- } ;- instance CanBeCasted Adjustment where {-     castData = ( gTypeAdjustment , castToAdjustment )- } ;- instance CanBeCasted Alignment where {-     castData = ( gTypeAlignment , castToAlignment )- } ;- instance CanBeCasted Arrow where {-     castData = ( gTypeArrow , castToArrow )- } ;- instance CanBeCasted AspectFrame where {-     castData = ( gTypeAspectFrame , castToAspectFrame )- } ;--- instance CanBeCasted BaseSink where {---     castData = ( gTypeBaseSink , castToBaseSink )--- } ;--- instance CanBeCasted BaseSrc where {---     castData = ( gTypeBaseSrc , castToBaseSrc )--- } ;--- instance CanBeCasted BaseTransform where {---     castData = ( gTypeBaseTransform , castToBaseTransform )--- } ;- instance CanBeCasted Bin where {-     castData = ( gTypeBin , castToBin )- } ;- instance CanBeCasted Box where {-     castData = ( gTypeBox , castToBox )- } ;--- instance CanBeCasted Buffer where {---     castData = ( gTypeBuffer , castToBuffer )--- } ;--- instance CanBeCasted Bus where {---     castData = ( gTypeBus , castToBus )--- } ;- instance CanBeCasted Button where {-     castData = ( gTypeButton , castToButton )- } ;- instance CanBeCasted ButtonBox where {-     castData = ( gTypeButtonBox , castToButtonBox )- } ;- instance CanBeCasted Calendar where {-     castData = ( gTypeCalendar , castToCalendar )- } ;- instance CanBeCasted CellRenderer where {-     castData = ( gTypeCellRenderer , castToCellRenderer )- } ;- instance CanBeCasted CellRendererCombo where {-     castData = ( gTypeCellRendererCombo , castToCellRendererCombo )- } ;- instance CanBeCasted CellRendererPixbuf where {-     castData = ( gTypeCellRendererPixbuf , castToCellRendererPixbuf )- } ;- instance CanBeCasted CellRendererProgress where {-     castData = ( gTypeCellRendererProgress , castToCellRendererProgress )- } ;- instance CanBeCasted CellRendererText where {-     castData = ( gTypeCellRendererText , castToCellRendererText )- } ;- instance CanBeCasted CellRendererToggle where {-     castData = ( gTypeCellRendererToggle , castToCellRendererToggle )- } ;- instance CanBeCasted CellView where {-     castData = ( gTypeCellView , castToCellView )- } ;- instance CanBeCasted CheckButton where {-     castData = ( gTypeCheckButton , castToCheckButton )- } ;- instance CanBeCasted CheckMenuItem where {-     castData = ( gTypeCheckMenuItem , castToCheckMenuItem )- } ;- instance CanBeCasted Clipboard where {-     castData = ( gTypeClipboard , castToClipboard )- } ;--- instance CanBeCasted Clock where {---     castData = ( gTypeClock , castToClock )--- } ;- instance CanBeCasted ColorButton where {-     castData = ( gTypeColorButton , castToColorButton )- } ;- instance CanBeCasted ColorSelection where {-     castData = ( gTypeColorSelection , castToColorSelection )- } ;- instance CanBeCasted ColorSelectionDialog where {-     castData = ( gTypeColorSelectionDialog , castToColorSelectionDialog )- } ;- instance CanBeCasted Combo where {-     castData = ( gTypeCombo , castToCombo )- } ;- instance CanBeCasted ComboBox where {-     castData = ( gTypeComboBox , castToComboBox )- } ;- instance CanBeCasted ComboBoxEntry where {-     castData = ( gTypeComboBoxEntry , castToComboBoxEntry )- } ;- instance CanBeCasted Container where {-     castData = ( gTypeContainer , castToContainer )- } ;- instance CanBeCasted Dialog where {-     castData = ( gTypeDialog , castToDialog )- } ;- instance CanBeCasted DragContext where {-     castData = ( gTypeDragContext , castToDragContext )- } ;- instance CanBeCasted DrawWindow where {-     castData = ( gTypeDrawWindow , castToDrawWindow )- } ;- instance CanBeCasted Drawable where {-     castData = ( gTypeDrawable , castToDrawable )- } ;- instance CanBeCasted DrawingArea where {-     castData = ( gTypeDrawingArea , castToDrawingArea )- } ;--- instance CanBeCasted Drive where {---     castData = ( gTypeDrive , castToDrive )--- } ;- instance CanBeCasted Editable where {-     castData = ( gTypeEditable , castToEditable )- } ;--- instance CanBeCasted Element where {---     castData = ( gTypeElement , castToElement )--- } ;--- instance CanBeCasted ElementFactory where {---     castData = ( gTypeElementFactory , castToElementFactory )--- } ;- instance CanBeCasted Entry where {-     castData = ( gTypeEntry , castToEntry )- } ;- instance CanBeCasted EntryCompletion where {-     castData = ( gTypeEntryCompletion , castToEntryCompletion )- } ;- instance CanBeCasted EventBox where {-     castData = ( gTypeEventBox , castToEventBox )- } ;- instance CanBeCasted Expander where {-     castData = ( gTypeExpander , castToExpander )- } ;- instance CanBeCasted FileChooser where {-     castData = ( gTypeFileChooser , castToFileChooser )- } ;- instance CanBeCasted FileChooserButton where {-     castData = ( gTypeFileChooserButton , castToFileChooserButton )- } ;- instance CanBeCasted FileChooserDialog where {-     castData = ( gTypeFileChooserDialog , castToFileChooserDialog )- } ;- instance CanBeCasted FileChooserWidget where {-     castData = ( gTypeFileChooserWidget , castToFileChooserWidget )- } ;- instance CanBeCasted FileFilter where {-     castData = ( gTypeFileFilter , castToFileFilter )- } ;- instance CanBeCasted FileSelection where {-     castData = ( gTypeFileSelection , castToFileSelection )- } ;- instance CanBeCasted Fixed where {-     castData = ( gTypeFixed , castToFixed )- } ;- instance CanBeCasted FontButton where {-     castData = ( gTypeFontButton , castToFontButton )- } ;- instance CanBeCasted FontSelection where {-     castData = ( gTypeFontSelection , castToFontSelection )- } ;- instance CanBeCasted FontSelectionDialog where {-     castData = ( gTypeFontSelectionDialog , castToFontSelectionDialog )- } ;- instance CanBeCasted Frame where {-     castData = ( gTypeFrame , castToFrame )- } ;- instance CanBeCasted GC where {-     castData = ( gTypeGC , castToGC )- } ;--- instance CanBeCasted GLConfig where {---     castData = ( gTypeGLConfig , castToGLConfig )--- } ;--- instance CanBeCasted GLContext where {---     castData = ( gTypeGLContext , castToGLContext )--- } ;--- instance CanBeCasted GLDrawable where {---     castData = ( gTypeGLDrawable , castToGLDrawable )--- } ;--- instance CanBeCasted GLPixmap where {---     castData = ( gTypeGLPixmap , castToGLPixmap )--- } ;--- instance CanBeCasted GLWindow where {---     castData = ( gTypeGLWindow , castToGLWindow )--- } ;--- instance CanBeCasted GhostPad where {---     castData = ( gTypeGhostPad , castToGhostPad )--- } ;- instance CanBeCasted HBox where {-     castData = ( gTypeHBox , castToHBox )- } ;- instance CanBeCasted HButtonBox where {-     castData = ( gTypeHButtonBox , castToHButtonBox )- } ;- instance CanBeCasted HPaned where {-     castData = ( gTypeHPaned , castToHPaned )- } ;- instance CanBeCasted HScale where {-     castData = ( gTypeHScale , castToHScale )- } ;- instance CanBeCasted HScrollbar where {-     castData = ( gTypeHScrollbar , castToHScrollbar )- } ;- instance CanBeCasted HSeparator where {-     castData = ( gTypeHSeparator , castToHSeparator )- } ;- instance CanBeCasted HandleBox where {-     castData = ( gTypeHandleBox , castToHandleBox )- } ;- instance CanBeCasted IconFactory where {-     castData = ( gTypeIconFactory , castToIconFactory )- } ;- instance CanBeCasted IconView where {-     castData = ( gTypeIconView , castToIconView )- } ;- instance CanBeCasted Image where {-     castData = ( gTypeImage , castToImage )- } ;- instance CanBeCasted ImageMenuItem where {-     castData = ( gTypeImageMenuItem , castToImageMenuItem )- } ;--- instance CanBeCasted ImplementsInterface where {---     castData = ( gTypeImplementsInterface , castToImplementsInterface )--- } ;--- instance CanBeCasted Index where {---     castData = ( gTypeIndex , castToIndex )--- } ;--- instance CanBeCasted IndexFactory where {---     castData = ( gTypeIndexFactory , castToIndexFactory )--- } ;- instance CanBeCasted Label where {-     castData = ( gTypeLabel , castToLabel )- } ;- instance CanBeCasted Layout where {-     castData = ( gTypeLayout , castToLayout )- } ;- instance CanBeCasted Menu where {-     castData = ( gTypeMenu , castToMenu )- } ;- instance CanBeCasted MenuBar where {-     castData = ( gTypeMenuBar , castToMenuBar )- } ;- instance CanBeCasted MenuItem where {-     castData = ( gTypeMenuItem , castToMenuItem )- } ;- instance CanBeCasted MenuShell where {-     castData = ( gTypeMenuShell , castToMenuShell )- } ;- instance CanBeCasted MenuToolButton where {-     castData = ( gTypeMenuToolButton , castToMenuToolButton )- } ;--- instance CanBeCasted Message where {---     castData = ( gTypeMessage , castToMessage )--- } ;- instance CanBeCasted MessageDialog where {-     castData = ( gTypeMessageDialog , castToMessageDialog )- } ;--- instance CanBeCasted MiniObject where {---     castData = ( gTypeMiniObject , castToMiniObject )--- } ;- instance CanBeCasted Misc where {-     castData = ( gTypeMisc , castToMisc )- } ;- instance CanBeCasted Notebook where {-     castData = ( gTypeNotebook , castToNotebook )- } ;- instance CanBeCasted Object where {-     castData = ( gTypeObject , castToObject )- } ;- instance CanBeCasted OptionMenu where {-     castData = ( gTypeOptionMenu , castToOptionMenu )- } ;--- instance CanBeCasted Pad where {---     castData = ( gTypePad , castToPad )--- } ;--- instance CanBeCasted PadTemplate where {---     castData = ( gTypePadTemplate , castToPadTemplate )--- } ;- instance CanBeCasted Paned where {-     castData = ( gTypePaned , castToPaned )- } ;--- instance CanBeCasted Pipeline where {---     castData = ( gTypePipeline , castToPipeline )--- } ;- instance CanBeCasted Pixbuf where {-     castData = ( gTypePixbuf , castToPixbuf )- } ;- instance CanBeCasted Plug where {-     castData = ( gTypePlug , castToPlug )- } ;--- instance CanBeCasted Plugin where {---     castData = ( gTypePlugin , castToPlugin )--- } ;--- instance CanBeCasted PluginFeature where {---     castData = ( gTypePluginFeature , castToPluginFeature )--- } ;- instance CanBeCasted ProgressBar where {-     castData = ( gTypeProgressBar , castToProgressBar )- } ;--- instance CanBeCasted PushSrc where {---     castData = ( gTypePushSrc , castToPushSrc )--- } ;--- instance CanBeCasted Query where {---     castData = ( gTypeQuery , castToQuery )--- } ;- instance CanBeCasted RadioAction where {-     castData = ( gTypeRadioAction , castToRadioAction )- } ;- instance CanBeCasted RadioButton where {-     castData = ( gTypeRadioButton , castToRadioButton )- } ;- instance CanBeCasted RadioMenuItem where {-     castData = ( gTypeRadioMenuItem , castToRadioMenuItem )- } ;- instance CanBeCasted RadioToolButton where {-     castData = ( gTypeRadioToolButton , castToRadioToolButton )- } ;- instance CanBeCasted Range where {-     castData = ( gTypeRange , castToRange )- } ;--- instance CanBeCasted Registry where {---     castData = ( gTypeRegistry , castToRegistry )--- } ;- instance CanBeCasted Scale where {-     castData = ( gTypeScale , castToScale )- } ;- instance CanBeCasted Screen where {-     castData = ( gTypeScreen , castToScreen )- } ;- instance CanBeCasted Scrollbar where {-     castData = ( gTypeScrollbar , castToScrollbar )- } ;- instance CanBeCasted ScrolledWindow where {-     castData = ( gTypeScrolledWindow , castToScrolledWindow )- } ;- instance CanBeCasted Separator where {-     castData = ( gTypeSeparator , castToSeparator )- } ;- instance CanBeCasted SeparatorMenuItem where {-     castData = ( gTypeSeparatorMenuItem , castToSeparatorMenuItem )- } ;- instance CanBeCasted SeparatorToolItem where {-     castData = ( gTypeSeparatorToolItem , castToSeparatorToolItem )- } ;- instance CanBeCasted SizeGroup where {-     castData = ( gTypeSizeGroup , castToSizeGroup )- } ;- instance CanBeCasted Socket where {-     castData = ( gTypeSocket , castToSocket )- } ;--- instance CanBeCasted SourceBuffer where {---     castData = ( gTypeSourceBuffer , castToSourceBuffer )--- } ;--- instance CanBeCasted SourceLanguage where {---     castData = ( gTypeSourceLanguage , castToSourceLanguage )--- } ;--- instance CanBeCasted SourceLanguageManager where {---     castData = ( gTypeSourceLanguageManager , castToSourceLanguageManager )--- } ;--- instance CanBeCasted SourceMark where {---     castData = ( gTypeSourceMark , castToSourceMark )--- } ;--- instance CanBeCasted SourceStyleScheme where {---     castData = ( gTypeSourceStyleScheme , castToSourceStyleScheme )--- } ;--- instance CanBeCasted SourceView where {---     castData = ( gTypeSourceView , castToSourceView )--- } ;- instance CanBeCasted SpinButton where {-     castData = ( gTypeSpinButton , castToSpinButton )- } ;- instance CanBeCasted StatusIcon where {-     castData = ( gTypeStatusIcon , castToStatusIcon )- } ;- instance CanBeCasted Statusbar where {-     castData = ( gTypeStatusbar , castToStatusbar )- } ;- instance CanBeCasted Style where {-     castData = ( gTypeStyle , castToStyle )- } ;--- instance CanBeCasted SystemClock where {---     castData = ( gTypeSystemClock , castToSystemClock )--- } ;- instance CanBeCasted Table where {-     castData = ( gTypeTable , castToTable )- } ;- instance CanBeCasted TearoffMenuItem where {-     castData = ( gTypeTearoffMenuItem , castToTearoffMenuItem )- } ;- instance CanBeCasted TextBuffer where {-     castData = ( gTypeTextBuffer , castToTextBuffer )- } ;- instance CanBeCasted TextMark where {-     castData = ( gTypeTextMark , castToTextMark )- } ;- instance CanBeCasted TextTag where {-     castData = ( gTypeTextTag , castToTextTag )- } ;- instance CanBeCasted TextTagTable where {-     castData = ( gTypeTextTagTable , castToTextTagTable )- } ;- instance CanBeCasted TextView where {-     castData = ( gTypeTextView , castToTextView )- } ;- instance CanBeCasted ToggleAction where {-     castData = ( gTypeToggleAction , castToToggleAction )- } ;- instance CanBeCasted ToggleButton where {-     castData = ( gTypeToggleButton , castToToggleButton )- } ;- instance CanBeCasted ToggleToolButton where {-     castData = ( gTypeToggleToolButton , castToToggleToolButton )- } ;- instance CanBeCasted ToolButton where {-     castData = ( gTypeToolButton , castToToolButton )- } ;- instance CanBeCasted ToolItem where {-     castData = ( gTypeToolItem , castToToolItem )- } ;- instance CanBeCasted Toolbar where {-     castData = ( gTypeToolbar , castToToolbar )- } ;- instance CanBeCasted Tooltips where {-     castData = ( gTypeTooltips , castToTooltips )- } ;- instance CanBeCasted TreeModel where {-     castData = ( gTypeTreeModel , castToTreeModel )- } ;- instance CanBeCasted TreeModelSort where {-     castData = ( gTypeTreeModelSort , castToTreeModelSort )- } ;- instance CanBeCasted TreeSelection where {-     castData = ( gTypeTreeSelection , castToTreeSelection )- } ;- instance CanBeCasted TreeSortable where {-     castData = ( gTypeTreeSortable , castToTreeSortable )- } ;- instance CanBeCasted TreeView where {-     castData = ( gTypeTreeView , castToTreeView )- } ;- instance CanBeCasted TreeViewColumn where {-     castData = ( gTypeTreeViewColumn , castToTreeViewColumn )- } ;- instance CanBeCasted UIManager where {-     castData = ( gTypeUIManager , castToUIManager )- } ;- instance CanBeCasted VBox where {-     castData = ( gTypeVBox , castToVBox )- } ;- instance CanBeCasted VButtonBox where {-     castData = ( gTypeVButtonBox , castToVButtonBox )- } ;- instance CanBeCasted VPaned where {-     castData = ( gTypeVPaned , castToVPaned )- } ;- instance CanBeCasted VScale where {-     castData = ( gTypeVScale , castToVScale )- } ;- instance CanBeCasted VScrollbar where {-     castData = ( gTypeVScrollbar , castToVScrollbar )- } ;- instance CanBeCasted VSeparator where {-     castData = ( gTypeVSeparator , castToVSeparator )- } ;- instance CanBeCasted Viewport where {-     castData = ( gTypeViewport , castToViewport )- } ;--- instance CanBeCasted Volume where {---     castData = ( gTypeVolume , castToVolume )--- } ;- instance CanBeCasted Widget where {-     castData = ( gTypeWidget , castToWidget )- } ;- instance CanBeCasted Window where {-     castData = ( gTypeWindow , castToWindow )- } ;- instance CanBeCasted WindowGroup where {-     castData = ( gTypeWindowGroup , castToWindowGroup )- }--}
+ src/RPN.hs view
@@ -0,0 +1,80 @@+{-# 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