packages feed

gtk-helpers (empty) → 0.0.7

raw patch · 25 files changed

+1452/−0 lines, 25 filesdep +arraydep +basedep +giosetup-changed

Dependencies added: array, base, gio, glib, gtk, mtl, process, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Ivan Perez (Keera Studios) 2010-2012++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Ivan Perez nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ gtk-helpers.cabal view
@@ -0,0 +1,48 @@+Name:                gtk-helpers+Version:             0.0.7+Synopsis:            A collection of auxiliary operations and widgets related to Gtk+-- Description:         +Homepage:            http://keera.es/blog/community+License:             BSD3+License-file:        LICENSE+Author:              Ivan Perez+Maintainer:          ivan.perez@keera.es+-- Copyright:           +Stability:           Experimental+Category:            Graphics+Build-type:          Simple+-- Extra-source-files:  +Cabal-version:       >=1.2++Library+  Build-depends:       base >= 4 && < 5,+                       template-haskell, process, gtk, gio, glib, mtl, array++  hs-source-dirs:      src/++  -- Build-tools:         +  ghc-options: -Wall++  -- Exposed-modules:     +  exposed-modules: Data.Board.GameBoardIO+                 , Game.Board.BasicTurnGame+                 , Graphics.UI.Gtk.Board.TiledBoard+                 , Graphics.UI.Gtk.Board.BoardLink+                 , Graphics.UI.Gtk.Entry.FormatEntry+                 , Graphics.UI.Gtk.Entry.HighlightedEntry+                 , Graphics.UI.Gtk.Extra.Builder+                 , Graphics.UI.Gtk.Extra.BuilderTH+                 , Graphics.UI.Gtk.Helpers.Combo+                 , Graphics.UI.Gtk.Helpers.FileDialog+                 , Graphics.UI.Gtk.Helpers.MenuItem+                 , Graphics.UI.Gtk.Helpers.MessageDialog+                 , Graphics.UI.Gtk.Helpers.ModelViewNotebookSync+                 , Graphics.UI.Gtk.Helpers.ModelViewPath+                 , Graphics.UI.Gtk.Helpers.Multiline.TextBuffer+                 , Graphics.UI.Gtk.Helpers.Pixbuf+                 , Graphics.UI.Gtk.Helpers.TreeView+                 , Graphics.UI.Gtk.Layout.BackgroundContainer+                 , Graphics.UI.Gtk.Layout.DummyBin+                 , Graphics.UI.Gtk.Layout.EitherWidget+                 , Graphics.UI.Gtk.Layout.MaybeWidget+                 , System.Application
+ src/Data/Board/GameBoardIO.hs view
@@ -0,0 +1,89 @@+module Data.Board.GameBoardIO where++import Control.Monad+import Data.Array.IO+import Data.Maybe++data GameBoard index e = GameBoard (IOArray (index,index) (Maybe e))++gameBoardNew :: (Ix index) => [(index, index, e)] -> IO (GameBoard index e)+gameBoardNew es = do+    gameBoardNewWithBoundaries boundaries es+  where indexList  = map (\(i,j,_) -> (i,j)) es+        boundaries = listBoundaries indexList++gameBoardNewWithBoundaries :: (Ix index) => ((index, index), (index, index)) -> [(index, index, e)] -> IO (GameBoard index e)+gameBoardNewWithBoundaries boundaries es = do+    array <- newArray boundaries Nothing+    mapM_ (\(i,j,e) -> writeArray array (i,j) (Just e)) es+    return $ GameBoard array++gameBoardNewEmptySquare :: (Num index, Ix index) => index -> index -> IO (GameBoard index e)+gameBoardNewEmptySquare iX jX = do+    array <- newArray ((0,0),(iX,jX)) Nothing+    return $ GameBoard array++gameBoardNewEmpty :: Ix index => [(index, index)] -> IO (GameBoard index e)+gameBoardNewEmpty es = do+    array <- newArray (listBoundaries es) Nothing+    return $ GameBoard array++listBoundaries :: Ix index => [(index,index)] -> ((index,index),(index,index))+listBoundaries ((ix,jx):es) = foldr updateBoundaries ((ix,jx),(ix,jx)) es+  where updateBoundaries (x,y) ((minX,minY),(maxX,maxY)) = ((minX',minY'),(maxX',maxY'))+         where minX' = if x < minX then x else minX+               minY' = if y < minY then y else minY+               maxX' = if x > maxX then x else maxX+               maxY' = if y > maxY then y else maxY++gameBoardSetPiece :: Ix index => (index, index) -> e -> GameBoard index e -> IO () -- GameBoard index e)+gameBoardSetPiece pos e (GameBoard board) =+  writeArray board pos (Just e)++gameBoardGetPiece :: Ix index => (index, index) -> GameBoard index e -> IO (Maybe e)+gameBoardGetPiece pos (GameBoard board) =+  readArray board pos++gameBoardRemovePiece :: Ix index => (index, index) -> GameBoard index e -> IO () -- GameBoard index e)+gameBoardRemovePiece pos (GameBoard board) =+  writeArray board pos Nothing++gameBoardMovePiece :: Ix index => (index, index) -> (index, index) -> GameBoard index e -> IO () -- GameBoard index e)+gameBoardMovePiece posO posD gb = do+  piece <- gameBoardGetPiece posO gb+  maybe (return ()) (\piece' -> do+    gameBoardRemovePiece posO gb+    gameBoardSetPiece posD piece' gb) piece++gameBoardFoldM :: (Ix index) => GameBoard index a -> (b -> ((index,index), a) -> IO b) -> b -> IO b+gameBoardFoldM (GameBoard array) f def = do+  assocs <- getAssocs array+  let assocs' = map (\(x,y) -> (x,fromJust y)) $ filter (isJust . snd) assocs+  foldM f def assocs'++gameBoardMapM_ :: (Ix index) => GameBoard index a -> ((index,index) -> a -> IO ()) -> IO ()+gameBoardMapM_ (GameBoard array) f =+  arrayMapM_ array f'+ where f' x e = maybe (return ()) (f x) e++arrayMapM_ :: (Ix index) => IOArray index a -> (index -> a -> IO ()) -> IO ()+arrayMapM_ array f = do+  assocs <- getAssocs array+  mapM_ (uncurry f) assocs++gameBoardClear :: (Ix index) => GameBoard index a -> IO()+gameBoardClear board@(GameBoard array) = do+  ((xm, ym), (xM, yM)) <- getBounds array+  forM_ (range (xm, xM)) $ \x -> +    forM_ (range (ym, yM)) $ \y ->+      gameBoardRemovePiece (x,y) board++gameBoardGetBoundaries :: (Ix index) => GameBoard index a -> IO ((index,index),(index,index))+gameBoardGetBoundaries (GameBoard array) = getBounds array++gameBoardClone :: (Ix index) => GameBoard index a -> IO (GameBoard index a)+gameBoardClone (GameBoard array) = do+  bounds <- getBounds array+  assocs <- getAssocs array+  let assocs' = [(ix,iy,e) | ((ix,iy), Just e) <- assocs]+  gameBoardNewWithBoundaries bounds assocs'
+ src/Game/Board/BasicTurnGame.hs view
@@ -0,0 +1,61 @@+{-# Language MultiParamTypeClasses, FunctionalDependencies #-}++module Game.Board.BasicTurnGame where++import Data.Ix+import Data.Maybe++data GameChange index player piece +  = AddPiece (index, index) player piece+  | RemovePiece (index, index)+  | MovePiece (index, index) (index, index)++-- FIXME: Wrong data structure => use unmutable matrices+hasPiece :: Ix index => GameState index tile player piece -> (index, index) -> Bool+hasPiece game ix = isJust (getPieceAt game ix)++getPieceAt :: Ix index => GameState index tile player piece -> (index, index) -> Maybe (player, piece)+getPieceAt game (posX, posY) = +  listToMaybe [(player, piece) | (x, y, player, piece) <- boardPieces' game+                               , x == posX+                               , y == posY]+  ++data GameState index tile player piece = GameState+  { curPlayer'   :: player+  , boardPos     :: [(index, index, tile)]+  , boardPieces' :: [(index, index, player, piece)]+  }++class PlayableGame a index tile player piece | a -> index, a -> tile, a -> player, a -> piece where++  curPlayer :: a -> player+  allPieces :: a -> [(index, index, player, piece)]+  allPos    :: a -> [(index, index, tile)]++  moveEnabled     :: a -> Bool+  moveEnabled _ = False++  canMove         :: a -> player -> (index, index) -> Bool+  canMove _ _ _ = False++  canMoveTo       :: a -> player -> (index, index) -> (index, index) -> Bool+  canMoveTo _ _ _ _ = False++  move            :: a -> player -> (index, index) -> (index, index) -> [GameChange index player piece]+  move _ _ _ _ = []++  activateEnabled :: a -> Bool+  activateEnabled _ = False++  canActivate     :: a -> player -> (index, index) -> Bool+  canActivate _ _ _ = False++  activate        :: a -> player -> (index, index) -> [GameChange index player piece]+  activate _ _ _ = []++  applyChange     :: a -> GameChange index player piece -> a+  applyChange g _ = g++  applyChanges    :: a -> [GameChange index player piece] -> a+  applyChanges a ls = foldl applyChange a ls
+ src/Graphics/UI/Gtk/Board/BoardLink.hs view
@@ -0,0 +1,67 @@+{-# Language MultiParamTypeClasses, FunctionalDependencies #-}++module Graphics.UI.Gtk.Board.BoardLink where++import Control.Monad+import Data.IORef+import Data.Ix+import Data.Maybe+import Game.Board.BasicTurnGame+import Graphics.UI.Gtk+import Graphics.UI.Gtk.Board.TiledBoard+++attachGameRules :: (PlayableGame pg index tile player piece, Ix index)+                => Game pg index tile player piece -> IO (Board index tile (player, piece))+attachGameRules game = do+  board <- boardNew (allPos $ gameS game) (tileF $ visual game) (pieceF $ visual game)++  let (r,g,b) = bgColor (visual game)+      (r', g', b') = (fromIntegral r, fromIntegral g, fromIntegral b)+  mapM_ (\s -> widgetModifyBg board s (Color r' g' b')) [StateNormal, StateActive, StatePrelight, StateSelected]+  when (isJust (bg $ visual game)) $ boardSetBackground board (bg $ visual game)++  vgRef <- newIORef game++  -- Set the initial board state+  mapM_ (\(x,y) -> boardSetPiece x y board) $ [((x,y),(pl,pc)) | (x,y,pl,pc) <- allPieces (gameS game)]++  board `boardOnPieceDragStart` \pos -> do+    visualGame <- readIORef vgRef+    let game' = gameS visualGame+    return (moveEnabled game' && canMove game' (curPlayer game') pos)++  board `boardOnPieceDragOver` \posF posT -> do+    visualGame <- readIORef vgRef+    let game' = gameS visualGame+    return (moveEnabled game' && canMoveTo game' (curPlayer game') posF posT)++  board `boardOnPieceDragDrop` \posF posT -> do+    visualGame <- readIORef vgRef+    let game'  = gameS visualGame+        moves  = move game' (curPlayer game') posF posT+        game'' = foldl applyChange game' moves+    writeIORef vgRef (visualGame { gameS = game'' })+    forM_ moves (applyBoardChange board)+    +  when (moveEnabled (gameS game)) $ boardEnableDrag board++  return board++applyBoardChange :: Ix index => Board index tile (player, piece) -> GameChange index player piece -> IO ()+applyBoardChange board (AddPiece pos player piece) = boardSetPiece pos (player, piece) board+applyBoardChange board (RemovePiece pos)           = boardRemovePiece pos board+applyBoardChange board (MovePiece posO posD)       = boardMovePiece posO posD board++data VisualGameAspects index tile player piece = VisualGameAspects+  { tileF   :: PixmapsFor tile+  , pieceF  :: PixmapsFor (player, piece)+  , bgColor :: (Int, Int, Int)+  , bg      :: Maybe (Pixbuf, SizeAdjustment)+  } +++data Game pg index tile player piece = Game+  { visual :: VisualGameAspects index tile player piece+  , gameS  :: pg+  }
+ src/Graphics/UI/Gtk/Board/TiledBoard.hs view
@@ -0,0 +1,403 @@+module Graphics.UI.Gtk.Board.TiledBoard where++import Control.Monad (when, void)+import Control.Monad.Trans (liftIO)+import Data.Array.IO+import Data.IORef+import Data.Maybe (isJust, fromJust)+import Graphics.UI.Gtk+import Graphics.UI.Gtk.Gdk.GC (gcNew)+import System.Glib.Types++-- Local imports+import Data.Board.GameBoardIO++data Board index tile piece = Board+  { boardDrawingArea  :: DrawingArea+  , boardTiles        :: GameBoard index tile+  , boardPieces       :: GameBoard index piece+  , tilePixmaps       :: PixmapsFor tile+  , piecePixmaps      :: PixmapsFor piece+  , tileSize          :: (Int, Int)+  , background        :: IORef (Maybe (Pixbuf, SizeAdjustment))+  , overlay           :: IORef (Maybe (Pixbuf, SizeAdjustment))+  , dragEnabled       :: IORef Bool+  , draggingFrom      :: IORef (Maybe (index, index))+  , draggingTo        :: IORef (Maybe (index, index))+  , draggingMouseOrig :: IORef (Maybe (Int, Int))+  , draggingMousePos  :: IORef (Maybe (Int, Int))+  , movingStatus      :: IORef (Maybe (MovingStatus index))+  }++data MovingStatus index = MovingStatus+  { movingFrom   :: (index, index)+  , movingTo     :: (index, index)+  , stepsPerUnit :: Double+  , timePerUnit  :: Double+  , movingStep   :: Double+  }++instance WidgetClass (Board index tile piece)+instance ObjectClass (Board index tile piece)+instance GObjectClass (Board index tile piece) where+  toGObject           = toGObject . boardDrawingArea+  unsafeCastGObject x = Board (unsafeCastGObject x) undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined++type PixmapsFor a = a -> Pixbuf++data SizeAdjustment = SizeAdjustment++boardNew :: Ix index+         => [(index,index,tile)] -> PixmapsFor tile -> PixmapsFor piece+         -> IO (Board index tile piece)+boardNew tileList tilePixs piecePixs = do+  da <- drawingAreaNew++  tb <- gameBoardNew tileList+  pb <- gameBoardNewEmpty (map (\(x,y,_) -> (x,y)) tileList)++  ts <- getTileSize tileList tilePixs++  bg <- newIORef Nothing+  ov <- newIORef Nothing++  dragging  <- newIORef False+  draggingF <- newIORef Nothing+  draggingT <- newIORef Nothing+  draggingO <- newIORef Nothing+  draggingP <- newIORef Nothing++  movingSt <- newIORef Nothing++  let board = Board da tb pb tilePixs piecePixs ts bg ov+                    dragging draggingF draggingT draggingO draggingP+                    movingSt++  (pixW, pixH) <- boardGetPixelSize board++  da `on` realize $ widgetSetSizeRequest da pixW pixH+  da `on` exposeEvent $ liftIO (boardRefresh board) >> return False++  return board++getTileSize :: [(index, index, tile)] -> PixmapsFor tile -> IO (Int, Int)+getTileSize []          _    = return (0,0)+getTileSize ((_,_,t):_) pixs = do+  let pb = pixs t+  w  <- pixbufGetWidth pb+  h  <- pixbufGetHeight pb+  return (w,h)++boardGetPiece :: Ix index => (index, index) -> Board index tile piece -> IO (Maybe piece)+boardGetPiece pos board = gameBoardGetPiece pos (boardPieces board)++boardSetPiece :: Ix index => (index, index) -> piece -> Board index tile piece -> IO ()+boardSetPiece pos piece board = do+  boardSetPieceNoRefresh pos piece board+  boardInvalidate board+--   boardRefresh board++boardSetPieceNoRefresh :: Ix index => (index, index) -> piece -> Board index tile piece -> IO ()+boardSetPieceNoRefresh pos piece board = do+  -- check that there's a tile there+  posOk <- fmap isJust $ gameBoardGetPiece pos $ boardTiles board+  when posOk $ do+    -- if there is, place the piece on the pieces board+    gameBoardSetPiece pos piece (boardPieces board) ++boardRemovePiece :: Ix index => (index, index) -> Board index tile piece -> IO ()+boardRemovePiece pos board = do+  -- check that there's a tile there+  posOk <- fmap isJust $ gameBoardGetPiece pos $ boardTiles board+  when posOk $ do+    -- if there is, remove the piece from the pieces board+    gameBoardRemovePiece pos (boardPieces board) +    -- refresh the image+    boardInvalidate board+    -- boardRefresh board++boardMovePiece :: Ix index => (index, index) -> (index, index) -> Board index tile piece -> IO ()+boardMovePiece posO posD board = do+  -- check that there's a tile there+  posOrigOk <- fmap isJust $ gameBoardGetPiece posO $ boardTiles board+  posDestOk <- fmap isJust $ gameBoardGetPiece posD $ boardTiles board+  when (posOrigOk && posDestOk) $ do+    -- Move the piece+    gameBoardMovePiece posO posD $ boardPieces board+    -- Refresh the UI+    boardInvalidate board+    -- boardRefresh board++boardInvalidate :: Ix index => Board index tile piece -> IO ()+boardInvalidate = widgetQueueDraw ++boardRefresh :: Ix index => Board index tile piece -> IO ()+boardRefresh board = do +  realized <- widgetGetRealized board+  when realized $ do+    dw <- widgetGetDrawWindow (boardDrawingArea board)+  +    (w,h) <- widgetGetSize (boardDrawingArea board)++    bg <- readIORef (background board)+    ov <- readIORef (overlay board)+  +    drawWindowBeginPaintRect dw (Rectangle 0 0 w h)+  +    -- Clear Drawing area+    drawWindowClear dw+    gc <- gcNew dw+    when (isJust bg) $ do+      ((posBgX, posBgY), bg') <- uncurry (adjustPixbuf (w,h)) (fromJust bg)+      drawPixbuf dw gc bg' 0 0 posBgX posBgY (-1) (-1) RgbDitherNone (-1) (-1)++    -- Dragging status (used to determine what to draw)+    posM   <- readIORef (draggingFrom board)+    mpOrig <- readIORef (draggingMouseOrig board)+    mpPos  <- readIORef (draggingMousePos board)++    -- Draw tiles+    drawPixmaps dw (tileSize board) (boardTiles board) (tilePixmaps board)+  +    -- Draw Pieces+    piecesBoard <- if isJust posM && isJust mpOrig && isJust mpPos+                    then do pieces' <- gameBoardClone $ boardPieces board+                            gameBoardRemovePiece (fromJust posM) pieces'+                            return pieces'+                    else return $ boardPieces board+             +    -- drawPixmaps dw (tileSize board) (boardPieces board) (piecePixmaps board)+    drawPixmaps dw (tileSize board) piecesBoard (piecePixmaps board)++    -- Draw moving piece+    when (isJust posM && isJust mpOrig && isJust mpPos) $ do+      pieceM <- boardGetPiece (fromJust posM) board+      when (isJust pieceM) $ do+        let pb = piecePixmaps board (fromJust pieceM)+        let (mpPosX, mpPosY)   = fromJust mpPos+            (mpOrigX, mpOrigY) = fromJust mpOrig+            (x,y) = (mpPosX - mpOrigX, mpPosY - mpOrigY)+        drawPixbuf dw gc pb 0 0 x y (-1) (-1) RgbDitherNone (-1) (-1)++    when (isJust ov) $ do+      ((posOvX, posOvY), ov') <- uncurry (adjustPixbuf (w,h)) (fromJust ov)+      drawPixbuf dw gc ov' 0 0 posOvX posOvY (-1) (-1) RgbDitherNone (-1) (-1)+  +    drawWindowEndPaint dw++-- FIXME: To be completed+adjustPixbuf :: (Int, Int) -> Pixbuf -> SizeAdjustment -> IO ((Int, Int), Pixbuf)+adjustPixbuf _ pb _ = return ((0,0), pb)++mouseMotionHandler :: Ix index => Board index tile piece -> ((index, index) -> EventM EMotion Bool) -> EventM EMotion Bool+mouseMotionHandler board p = do+  coords <- eventCoordinates+  pos <- liftIO $ getMouseCoordinates board coords+  maybe (return False) p pos++mouseButtonHandler :: Ix index => Board index tile piece -> ((index, index) -> EventM EButton Bool) -> EventM EButton Bool+mouseButtonHandler board p = do+  coords <- eventCoordinates+  pos <- liftIO $ getMouseCoordinates board coords+  maybe (return False) p pos++getMouseCoordinates :: Ix index => Board index tile piece -> (Double, Double) -> IO (Maybe (index, index))+getMouseCoordinates board (x,y) = do+  let (tileW, tileH) = tileSize board+      tileCol = round x `div` tileW+      tileRow = round y `div` tileH+  let (GameBoard array) = boardTiles board+  ((xm, ym), (xM, yM)) <- getBounds $ array+  let xs = range (xm, xM)+      ys = range (ym, yM)+  if (inRange (0, length xs - 1) tileCol && inRange (0, length ys - 1) tileRow)+      then return $ Just ((head (drop tileCol xs)), (head (drop tileRow ys)))+      else return Nothing++clickHandler :: Ix index => Board index tile piece -> ((index, index) -> IO ()) -> EventM EButton Bool+clickHandler board p = do+  (x,y) <- eventCoordinates+  liftIO $ do+    let (tileW, tileH) = tileSize board+        tileCol = round x `div` tileW+        tileRow = round y `div` tileH+    let (GameBoard array) = boardTiles board+    ((xm, ym), (xM, yM)) <- getBounds $ array+    let xs = range (xm, xM)+        ys = range (ym, yM)+    when (inRange (0, length xs - 1) tileCol && inRange (0, length ys - 1) tileRow) $+      p ((head (drop tileCol xs)), (head (drop tileRow ys)))+    return False+    +boardGetPixelSize :: Ix index => Board index tile piece -> IO (Int, Int)+boardGetPixelSize board = do+  let (GameBoard array) = boardTiles board++  ((xm, ym), (xM, yM)) <- getBounds $ array+  let htiles = rangeSize (xm, xM)+      vtiles = rangeSize (ym, yM)+      (tileW, tileH) = tileSize board++  return (htiles * tileW, vtiles * tileH)++drawPixmaps :: (Ix index, DrawableClass d) => d -> (Int, Int) -> GameBoard index e -> PixmapsFor e -> IO()+drawPixmaps d tileSize@(tw, th) gameBoard@(GameBoard array) pixmaps = do+  gc <- gcNew d+  ((xm, ym), (xM, yM)) <- gameBoardGetBoundaries gameBoard++  let paintPixmap (x,y) elem = do+          let pixmap = pixmaps elem+              ix     = index (xm, xM) x+              iy     = index (ym, yM) y+              posX   = ix * tw+              posY   = iy * th+          drawPixbuf d gc pixmap 0 0 posX posY (-1) (-1) RgbDitherNone (-1) (-1)+      +  gameBoardMapM_ gameBoard paintPixmap++boardFoldM :: (Ix index) => Board index tile piece -> (b -> ((index,index), piece) -> IO b) -> b -> IO b+boardFoldM board f def = gameBoardFoldM (boardPieces board) f def++boardClear :: Ix index => Board index tile piece -> IO ()+boardClear board = do+  gameBoardClear (boardPieces board)+  boardInvalidate board++boardLoad :: Ix index => Board index tile piece -> [((index, index), piece)] -> IO()+boardLoad board pieces = do+  gameBoardClear (boardPieces board)+  mapM_ (\(pos, piece) -> boardSetPieceNoRefresh pos piece board) pieces+  boardRefresh board++boardOnClick :: Ix index => Board index tile piece -> ((index, index) -> IO ()) -> IO()+boardOnClick board p = boardOnPress board (\c -> liftIO (p c) >> return False)++boardOnPress :: Ix index => Board index tile piece -> ((index, index) -> EventM EButton Bool) -> IO()+boardOnPress board f = void $ do+  widgetAddEvents (boardDrawingArea board) [ButtonPressMask]+  (boardDrawingArea board) `on` buttonPressEvent $ mouseButtonHandler board f++boardOnRelease :: Ix index => Board index tile piece -> ((index, index) -> EventM EButton Bool) -> IO()+boardOnRelease board f = void $ do+  widgetAddEvents (boardDrawingArea board) [ButtonPressMask, ButtonReleaseMask]+  (boardDrawingArea board) `on` buttonReleaseEvent $ mouseButtonHandler board f++boardOnMotion :: Ix index => Board index tile piece -> ((index, index) -> EventM EMotion Bool) -> IO()+boardOnMotion board f =  void $ do+  widgetAddEvents board [PointerMotionMask]+  (boardDrawingArea board) `on` motionNotifyEvent $ mouseMotionHandler board f++boardSetBackground :: Ix index => Board index tile piece -> Maybe (Pixbuf, SizeAdjustment) -> IO()+boardSetBackground board bg = do+  writeIORef (background board) bg+  boardInvalidate board++boardSetOverlay :: Ix index => Board index tile piece -> Maybe (Pixbuf, SizeAdjustment) -> IO()+boardSetOverlay board bg = do+  writeIORef (overlay board) bg+  boardInvalidate board++boardEnableDrag :: Ix index => Board index tile piece -> IO()+boardEnableDrag board = writeIORef (dragEnabled board) True++boardDisableDrag :: Ix index => Board index tile piece -> IO()+boardDisableDrag board = do+  writeIORef (dragEnabled board) False+  boardInvalidate board++boardStartDrag :: Ix index => Board index tile piece -> (index, index) -> IO()+boardStartDrag board ix@(i,j) = do+  writeIORef (draggingFrom board) (Just ix)+  ((xm, ym), (xM, yM)) <- gameBoardGetBoundaries $ boardPieces board+  let (w,h) = tileSize board+      x     = round ((0.5 + fromIntegral (rangeSize (xm, i))) * fromIntegral w)+      y     = round ((0.5 + fromIntegral (rangeSize (ym, j))) * fromIntegral h)+  writeIORef (draggingMouseOrig board) (Just (x, y))++boardStopDrag :: Ix index => Board index tile piece -> IO()+boardStopDrag board = do+  writeIORef (draggingFrom board) Nothing+  writeIORef (draggingTo board) Nothing+  boardInvalidate board++boardOnPieceDragStart :: Ix index => Board index tile piece -> ((index, index) -> IO Bool) -> IO()+boardOnPieceDragStart board f = boardOnPress board $ \ix -> do+  (x,y) <- eventCoordinates+  returning False $ liftIO $ do+    drag <- readIORef (dragEnabled board)+    when drag $ do+      canDragThis <- f ix+      let from = if canDragThis then Just ix else Nothing+          orig = if canDragThis then Just (relativePos board ix (round x, round y)) else Nothing+      writeIORef (draggingFrom board) from+      writeIORef (draggingMouseOrig board) orig+      boardInvalidate board++boardOnPieceDragOver :: Ix index => Board index tile piece -> ((index, index) -> (index, index) -> IO Bool) -> IO()+boardOnPieceDragOver board f = boardOnMotion board $ \ix -> do+  (x,y) <- eventCoordinates+  returning False $ liftIO $ do+    drag  <- readIORef (dragEnabled board)+    origM <- readIORef (draggingFrom board)+    when (drag && isJust origM) $ do+      canDropHere <- f (fromJust origM) ix+      let newDest = if canDropHere then Just ix else Nothing+      writeIORef (draggingTo board) newDest+      writeIORef (draggingMousePos board) (Just (round x, round y))+    boardInvalidate board++boardOnPieceDragDrop :: Ix index => Board index tile piece -> ((index, index) -> (index, index) -> IO ()) -> IO()+boardOnPieceDragDrop board f = void $ do+  widgetAddEvents (boardDrawingArea board) [ButtonPressMask, ButtonReleaseMask]+  (boardDrawingArea board) `on` buttonReleaseEvent $ returning False $ liftIO $ do+    drag  <- readIORef (dragEnabled board)+    origM <- readIORef (draggingFrom board)+    destM <- readIORef (draggingTo board)+    let notSame = origM /= destM+    when (drag && isJust origM) $ do++      -- No longer dragging+      writeIORef (draggingFrom board)      Nothing+      writeIORef (draggingTo board)        Nothing+      writeIORef (draggingMouseOrig board) Nothing+      writeIORef (draggingMousePos board)  Nothing++      -- When possible, call the handler+      when (isJust destM && notSame) $ f (fromJust origM) (fromJust destM)++      -- In any case, the board must be repainted+      boardInvalidate board++boardIsDragging :: Ix index => Board index tile piece -> IO Bool+boardIsDragging = fmap isJust . readIORef . draggingFrom++relativePos :: Ix index => Board index tile piece -> (index, index) -> (Int, Int) -> (Int, Int)+relativePos board (ix,iy) (x,y) = (x', y')+ where (w,h) = tileSize board+       x'    = x `mod` w+       y'    = y `mod` h++returning :: Monad m => a -> m b -> m a+returning v f = f >> return v++-- boardLiveMove :: Ix index => (index, index) -> (index, index) -> Board index tile piece -> IO ()+-- boardLiveMove posO posD board = do+--   evs <- widgetGetEvents board+--   +--   let evs' = undefined+--   +--   movingParams <- undefined+-- +--   let timeDelay = undefined+-- +--   writeIORef (movingStatus board) (Just movingParams)+-- +--   -- Set delay and time handler+--   timeoutAdd (do undefined -- advance moving one step+--                  boardInvalidate board+--                  -- return True if not the end, otherwise return False+--              )+--              timeDelay+--              +--      -- Time Handler includes resetting the event handers+--   return ()
+ src/Graphics/UI/Gtk/Entry/FormatEntry.hs view
@@ -0,0 +1,76 @@+module Graphics.UI.Gtk.Entry.FormatEntry+   ( FormatEntry+   , formatEntryNew+   , formatEntryNewWithFunction+   , formatEntrySetColor+   , formatEntryGetColor+   , formatEntrySetCheckFunction+   , formatEntryGetCheckFunction+   , formatEntryHasCorrectFormat+   , formatEntryColor+   , formatEntryCheckFunction+   )+  where++import Control.Monad.Trans (liftIO)+import Graphics.UI.Gtk+import Graphics.UI.Gtk.Entry.HighlightedEntry+import System.Glib.Types+import Data.IORef++-- Higlighted Entries+data FormatEntry = FormatEntry HighlightedEntry (IORef FormatEntryParams)+type FormatEntryParams = String -> Bool++formatEntryNew :: IO FormatEntry+formatEntryNew = formatEntryNewWithFunction (const True)++formatEntryNewWithFunction :: (String -> Bool) -> IO FormatEntry+formatEntryNewWithFunction checkF = do+  entry <- highlightedEntryNew+  defaultParamsRef <- newIORef checkF+  let formatEntry = FormatEntry entry defaultParamsRef+  formatEntry `on` editableChanged $ refreshEntry formatEntry+  return formatEntry++instance GObjectClass FormatEntry where+  toGObject (FormatEntry entry _) = toGObject entry+  unsafeCastGObject o = FormatEntry (unsafeCastGObject o) undefined+instance ObjectClass FormatEntry+instance WidgetClass FormatEntry+instance EntryClass FormatEntry+instance EditableClass FormatEntry++formatEntrySetColor :: FormatEntry -> Color -> IO ()+formatEntrySetColor (FormatEntry e _) color = highlightedEntrySetColor e color++formatEntryGetColor :: FormatEntry -> IO Color+formatEntryGetColor (FormatEntry e _) = highlightedEntryGetColor e++formatEntrySetCheckFunction :: FormatEntry -> (String -> Bool) -> IO ()+formatEntrySetCheckFunction fe@(FormatEntry _ params) checkF = do+  writeIORef params checkF+  refreshEntry fe++formatEntryGetCheckFunction :: FormatEntry -> IO (String -> Bool)+formatEntryGetCheckFunction (FormatEntry _ params) =+  readIORef params++-- Repaints the entry using the current color, or resets the+-- default style if no warning has to be given+refreshEntry :: FormatEntry -> IO()+refreshEntry f@(FormatEntry entry params) = do+  correct <- formatEntryHasCorrectFormat f+  highlightedEntrySetStatus entry (not correct)++formatEntryColor :: Attr FormatEntry Color+formatEntryColor = newAttr formatEntryGetColor formatEntrySetColor++formatEntryCheckFunction :: Attr FormatEntry (String -> Bool)+formatEntryCheckFunction = newAttr formatEntryGetCheckFunction formatEntrySetCheckFunction++formatEntryHasCorrectFormat :: FormatEntry -> IO Bool+formatEntryHasCorrectFormat f = do+  text <- entryGetText f+  func <- formatEntryGetCheckFunction f+  return $ func text
+ src/Graphics/UI/Gtk/Entry/HighlightedEntry.hs view
@@ -0,0 +1,71 @@+module Graphics.UI.Gtk.Entry.HighlightedEntry+   ( HighlightedEntry+   , highlightedEntryNew+   , highlightedEntrySetColor+   , highlightedEntryGetColor+   , highlightedEntrySetStatus+   , highlightedEntryGetStatus+   , highlightedEntryColor+   , highlightedEntryStatus+   )+  where++import Control.Monad.Trans (liftIO)+import Graphics.UI.Gtk+import System.Glib.Types+import Data.IORef++-- Higlighted Entries+data HighlightedEntry = HighlightedEntry Entry (IORef HighlightedEntryParams)+type HighlightedEntryParams = (Color, Bool)++highlightedEntryNew :: IO HighlightedEntry+highlightedEntryNew = do+  entry <- entryNew+  defaultParamsRef <- newIORef (Color 65000 32000 32000, False)+  return $ HighlightedEntry entry defaultParamsRef++instance GObjectClass HighlightedEntry where+  toGObject (HighlightedEntry entry _) = toGObject entry+  unsafeCastGObject o = HighlightedEntry (unsafeCastGObject o) undefined+instance ObjectClass HighlightedEntry+instance WidgetClass HighlightedEntry+instance EntryClass HighlightedEntry++highlightedEntrySetStatus :: HighlightedEntry -> Bool -> IO ()+highlightedEntrySetStatus he@(HighlightedEntry _ params) status = do+  modifyIORef params (\(c,_) -> (c,status))+  refreshBaseColor he++highlightedEntryGetStatus :: HighlightedEntry -> IO Bool+highlightedEntryGetStatus (HighlightedEntry _ params) = do+  (_,status) <- readIORef params+  return status++highlightedEntrySetColor :: HighlightedEntry -> Color -> IO ()+highlightedEntrySetColor he@(HighlightedEntry _ params) color = do+  modifyIORef params (\(_, s) -> (color, s))+  refreshBaseColor he++highlightedEntryGetColor :: HighlightedEntry -> IO Color+highlightedEntryGetColor (HighlightedEntry _ params) = do+  (color, _) <- readIORef params+  return color++-- Repaints the entry using the current color, or resets the+-- default style if no warning has to be given+refreshBaseColor :: HighlightedEntry -> IO()+refreshBaseColor (HighlightedEntry entry params) = do+  (color, status) <- readIORef params+  if status+   then mapM_ (\s -> widgetModifyBase entry s color) sensitiveStates+   else mapM_ (widgetRestoreBase entry) sensitiveStates+ where sensitiveStates = [ StateNormal, StateActive+                         , StateSelected, StatePrelight+                         ]++highlightedEntryStatus :: Attr HighlightedEntry Bool+highlightedEntryStatus = newAttr highlightedEntryGetStatus highlightedEntrySetStatus++highlightedEntryColor :: Attr HighlightedEntry Color+highlightedEntryColor = newAttr highlightedEntryGetColor highlightedEntrySetColor
+ src/Graphics/UI/Gtk/Extra/Builder.hs view
@@ -0,0 +1,39 @@+-- | A collection of small functions to help retrieve+-- information from Glade files.++module Graphics.UI.Gtk.Extra.Builder+   ( fromBuilder+   , loadInterface+   )+  where++import Graphics.UI.Gtk++-- | Graphics.UI.Gtk.builderGetObject with the arguments flipped+-- (Builder goes last).+fromBuilder :: (GObjectClass cls) =>+               (GObject -> cls) -> String -> Builder -> IO cls+fromBuilder f s b = builderGetObject b f s++-- | Returns a builder from which the objects in this part of the interface+-- can be accessed.+loadInterface :: String -> IO Builder+loadInterface fn = builderNew `incidentallyM` (`builderAddFromFile` fn)+-- It can be written in point-free style, but I'm not sure it's+-- clearer+-- loadInterface = incidentallyM builderNew . flip builderAddFromFile++-- -- | Returns a builder from which the objects in this part of the interface+-- --+-- -- can be accessed.+-- loadInterface :: String -> IO Builder+-- loadInterface builderPath = do+--   builder <- builderNew+--   builderAddFromFile builder builderPath+--   return builder++-- | Sequences two monadic computations and returns the+-- result of the first.+incidentallyM :: Monad m => m a -> (a -> m b) -> m a +incidentallyM op f = op >>= (\x -> (f x >> return x))+
+ src/Graphics/UI/Gtk/Extra/BuilderTH.hs view
@@ -0,0 +1,64 @@+-- | This module allows you to access Glade objects from+-- a Gtk Builder by providing the builder, the type of the+-- object and the name (the cast operation is deduced+-- automatically from the type name).+--+-- It uses Graphics.UI.Gtk.Builder.onBuilder to access a+-- glade object using TH.++module Graphics.UI.Gtk.Extra.BuilderTH+  ( gtkBuilderAccessor+  , gtkViewAccessor+  , fromBuilder+  )+ where++import Graphics.UI.Gtk.Extra.Builder (fromBuilder)+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lib++-- | Accessor for Glade objects from Gtk Builders by name and+-- type.+gtkBuilderAccessor :: String -> String -> Q [Dec]+gtkBuilderAccessor name kind = sequenceQ+  -- Declaration+  [ sigD funcName+         -- Builder -> IO Kind+         (appT (appT arrowT (conT (mkName "Builder")))           +               (appT (conT (mkName "IO")) (conT (mkName kind))))+  -- Implementation+  , funD funcName                                                 +         -- castedOnBuilder objectName+         [clause [] (normalB (appE castedAccess                   +                                   (litE (stringL name)))) []]+  ]++  where castedAccess = appE (varE (mkName "fromBuilder")) casting+        casting      = varE (mkName ("castTo" ++ kind))+        funcName     = mkName name++-- | Accessor for Glade objects from Gtk Builders encapsulated in+-- Views, by name and -- type.+gtkViewAccessor :: String -> String -> String -> String -> Q [Dec]+gtkViewAccessor builderModule uiAccessor name kind = sequenceQ+  -- Declaration+  [ sigD funcName+         -- Builder -> IO Kind+         (appT (appT arrowT (conT (mkName "View")))           +               (appT (conT (mkName "IO")) (conT (mkName kind))))+  -- Implementation+  , funD funcName                                                 +         -- castedOnBuilder objectName+         [clause [varP builderName]+                 (normalB (appE (varE funcNameInBuilder)+                                (appE (varE (mkName uiAccessor))+                                      (varE builderName)+                                )+                          )) []]+  ]++  where castedAccess      = appE (varE (mkName "fromBuilder")) casting+        casting           = varE (mkName ("castTo" ++ kind))+        funcName          = mkName name+        funcNameInBuilder = mkName $ builderModule ++ ('.' : name) +        builderName       = mkName "b"
+ src/Graphics/UI/Gtk/Helpers/Combo.hs view
@@ -0,0 +1,44 @@+module Graphics.UI.Gtk.Helpers.Combo where++import Data.List+import Data.Maybe+import Graphics.UI.Gtk++addTextColumn :: (TreeModelClass (model row), TypedTreeModelClass model)+                => ComboBox -> model row -> (row -> Maybe String) -> IO()+addTextColumn cb st f = do++  comboBoxSetModel cb (Just st)+  renderer <- cellRendererTextNew+  cellLayoutPackStart cb renderer True+  cellLayoutSetAttributes cb renderer st $ map (cellText :=).maybeToList.f+  return ()++type TypedComboBox a = (ComboBox, ListStore a)++typedComboBoxCombo :: TypedComboBox a -> ComboBox+typedComboBoxCombo = fst++typedComboBoxStore :: TypedComboBox a -> ListStore a+typedComboBoxStore = snd++typedComboBoxGetSelected :: TypedComboBox a -> IO (Maybe a)+typedComboBoxGetSelected (cb, ls) = do+  sel  <- get cb comboBoxActive+  list <- listStoreToList ls+  if sel < 0 || length list <= sel+   then return Nothing+   else return $ Just $ list!!sel++typedComboBoxGetSelectedUnsafe :: TypedComboBox a -> IO a+typedComboBoxGetSelectedUnsafe (cb, ls) = do+  sel  <- get cb comboBoxActive+  list <- listStoreToList ls+  return $ list!!sel++typedComboBoxSetSelected :: (Eq a) => TypedComboBox a -> a -> IO ()+typedComboBoxSetSelected (cb, ls) x = do+  list <- listStoreToList ls+  case elemIndex x list of+   Nothing -> return ()+   Just ix -> set cb [ comboBoxActive := ix ]
+ src/Graphics/UI/Gtk/Helpers/FileDialog.hs view
@@ -0,0 +1,42 @@+module Graphics.UI.Gtk.Helpers.FileDialog+  ( openOpenFileDialog+  )+  where++import Graphics.UI.Gtk++type Ext = ([String], String)++-- Auxiliary functions: open file dialogs+openOpenFileDialog :: String -> [Ext] -> IO (Maybe String)+openOpenFileDialog title exts = do++  dialog <- fileChooserDialogNew+              (Just title)           --dialog title+              Nothing+              FileChooserActionOpen  --the kind of dialog we want+              [("gtk-cancel"         --The buttons to display+               ,ResponseCancel)+              ,("gtk-ok"+               , ResponseAccept)]++  ffs <- extsToFilters exts+  mapM_ (fileChooserAddFilter dialog) ffs++  widgetShow dialog+  result <- dialogRun dialog+  res <- case result of+           ResponseAccept -> fileChooserGetFilename dialog+           _              -> return Nothing+  widgetDestroy dialog+  return res++extsToFilters :: [Ext] -> IO [FileFilter]+extsToFilters = mapM extToFilter++extToFilter :: Ext -> IO FileFilter+extToFilter (pats, name) = do+  ff <- fileFilterNew+  fileFilterSetName ff name+  mapM_ (fileFilterAddPattern ff) pats+  return ff
+ src/Graphics/UI/Gtk/Helpers/MenuItem.hs view
@@ -0,0 +1,6 @@+module Graphics.UI.Gtk.Helpers.MenuItem where++import Graphics.UI.Gtk++menuItemGetLabel :: MenuItemClass self => self -> IO (Maybe Label)+menuItemGetLabel = fmap (fmap castToLabel) . binGetChild
+ src/Graphics/UI/Gtk/Helpers/MessageDialog.hs view
@@ -0,0 +1,10 @@+module Graphics.UI.Gtk.Helpers.MessageDialog where++import Graphics.UI.Gtk+import Control.Monad++popupError :: String -> String -> IO ()+popupError t s = do+  md <- messageDialogNew Nothing [DialogModal] MessageError ButtonsOk s+  set md [ windowTitle := t ]+  void $ dialogRun md >> widgetDestroy md
+ src/Graphics/UI/Gtk/Helpers/ModelViewNotebookSync.hs view
@@ -0,0 +1,60 @@+-- | This module provides functions to alter the view in a notebook and a+-- maybewidget with a notebook inside based on what is selected in a model view+-- (icon view, list view, tree view)+--+-- This pattern appears very often in my programs. I like to use model views to+-- let the user choose what to see (instead of using the tab pages).+module Graphics.UI.Gtk.Helpers.ModelViewNotebookSync where++import Graphics.UI.Gtk+import Graphics.UI.Gtk.Helpers.ModelViewPath+import Graphics.UI.Gtk.Layout.MaybeWidget++-- | Keeps the page of a notebook in sync with the selection in a model view.+-- It uses an auxiliary function to determine which page to select.+modelViewNotebookSync :: (ViewWithPathSelection a c, NotebookClass b)+                            => a -> b -> (TreePath -> Int) -> IO()+modelViewNotebookSync modelView notebook syncF = do+  (path, _) <- modelViewGetCursor modelView+  let page = syncF path+  notebookSetCurrentPage notebook page++-- | Keeps the page of a notebook in sync with the selection in a model view.+-- It selects the page with the same number as the element selected in the+-- model view. If there's more than one selection, or if the model view is not+-- flat and the selected element is not at the first level, then it selects nothing.+modelViewNotebookSyncId :: (ViewWithPathSelection a c, NotebookClass b) => a -> b -> IO()+modelViewNotebookSyncId modelView notebook = do+  (path, _) <- modelViewGetCursor modelView+  case path of+   [page] -> notebookSetCurrentPage notebook page+   _      -> return ()++-- | Keeps the page of a notebook inside a maybe widget in sync with the+-- selection in a model view.+--+-- It uses an auxiliary function to determine which page to select. If the function+-- returns Nothing, then the maybe widget is deactivated.+modelViewMaybeNotebookSync :: (ViewWithPathSelection a c, NotebookClass b)+                            => a -> MaybeWidget b -> (TreePath -> Maybe Int) -> IO()+modelViewMaybeNotebookSync modelView maybeNotebook syncF = do+  (path, _) <- modelViewGetCursor modelView+  case syncF path of+    Nothing -> set maybeNotebook [ maybeWidgetActivated := False]+    Just p  -> do set maybeNotebook [ maybeWidgetActivated := True ]+                  notebookSetCurrentPage (maybeWidgetGetWidget maybeNotebook) p++-- | Keeps the page of a notebook inside a maybe widget in sync with the+-- selection in a model view.+--+-- It selects the page with the same number as the element selected in the+-- model view. If there's more than one selection, or if the model view is not+-- flat and the selected element is not at the first level, then it selects nothing.+modelViewMaybeNotebookSyncId :: (ViewWithPathSelection a c, NotebookClass b)+                             => a -> MaybeWidget b -> IO()+modelViewMaybeNotebookSyncId modelView maybeNotebook = do+  (path, _) <- modelViewGetCursor modelView+  case path of+   [page] -> do set maybeNotebook [ maybeWidgetActivated := True ]+                notebookSetCurrentPage (maybeWidgetGetWidget maybeNotebook) page+   _      -> set maybeNotebook [ maybeWidgetActivated := False ]
+ src/Graphics/UI/Gtk/Helpers/ModelViewPath.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-}+module Graphics.UI.Gtk.Helpers.ModelViewPath where++import Graphics.UI.Gtk++class ViewWithPathSelection a b | a -> b where+  modelViewGetCursor :: a -> IO (TreePath, Maybe b)++instance ViewWithPathSelection IconView CellRenderer where+  modelViewGetCursor = iconViewGetCursor++instance ViewWithPathSelection TreeView TreeViewColumn where+  modelViewGetCursor = treeViewGetCursor+
+ src/Graphics/UI/Gtk/Helpers/Multiline/TextBuffer.hs view
@@ -0,0 +1,19 @@+-- | Auxiliary functions userful to manipulate TextBuffers+module Graphics.UI.Gtk.Helpers.Multiline.TextBuffer where++-- External imports+import Control.Monad+import Graphics.UI.Gtk++-- | Updates a text buffer only if it's necessary (to avoid extra events)+textBufferUpdateText :: TextBuffer -> String -> IO ()+textBufferUpdateText bf s = do+ tx <- textBufferGetAllText bf True+ when (tx /= s) $ textBufferSetText bf s++-- | Gets all the text from a text buffer+textBufferGetAllText :: TextBuffer -> Bool -> IO String+textBufferGetAllText bf hidden = do+ si <- textBufferGetStartIter bf+ ei <- textBufferGetEndIter bf+ textBufferGetText bf si ei hidden
+ src/Graphics/UI/Gtk/Helpers/Pixbuf.hs view
@@ -0,0 +1,61 @@+module Graphics.UI.Gtk.Helpers.Pixbuf where++import Graphics.UI.Gtk+import Data.Word++safePixbufComposite :: Pixbuf -> Pixbuf+                    -> Int -> Int -- position+                    -> Int -> Int -- something else?+                    -> InterpType+                    -> Word8+                    -> IO ()+safePixbufComposite pbO pbD x y x' y' interp alpha = do+  w <- pixbufGetWidth pbO+  h <- pixbufGetHeight pbO+  w' <- pixbufGetWidth pbD+  h' <- pixbufGetHeight pbD+  safePixbufComposite' pbO pbD x y x' y' w h w' h' interp alpha++safePixbufComposite' :: Pixbuf -> Pixbuf+                    -> Int -> Int -- position+                    -> Int -> Int -- something else?+                    -> Int -> Int -- original image size+                    -> Int -> Int -- destination image size+                    -> InterpType+                    -> Word8+                    -> IO ()+safePixbufComposite' pbO pbD x y x' y' w h w' h' interp alpha+  | x + w < 0 || y + h < 0 || w < 0 || h < 0+  = return ()+  | x < 0 || y < 0+  = do let diffX = if x > 0 then 0 else abs x+           diffY = if y > 0 then 0 else abs y+           newX  = if x < 0 then 0 else x+           newY  = if y < 0 then 0 else y+           newX' = if x < 0 then 0 else x'+           newY' = if y < 0 then 0 else y'+       pbO' <- pixbufNew ColorspaceRgb True 8 (w - diffX) (h - diffY)+       pixbufCopyArea pbO diffX diffY (w - diffX) (h - diffY) pbO' 0 0+       safePixbufComposite' pbO' pbD+                            newX newY+                            newX' newY'+                            (w - diffX) (h - diffY)+                            w' h'+                            interp alpha+  | otherwise+  = do let realw = if (x + w) > w' then w' - x else w+           realh = if (y + h) > h' then h' - y else h+       pixbufComposite pbO pbD x y realw realh (fI x') (fI y') 1 1 interp alpha+ where fI = fromIntegral++pixbufNewEmpty :: Int -> Int -> IO Pixbuf+pixbufNewEmpty w h = do+  pb <- pixbufNew ColorspaceRgb True 8 w h+  pixbufFill pb 0 0 0 1+  return pb++pixbufNewWithBGColor :: Bool -> Int -> Int -> (Word8, Word8, Word8) -> IO Pixbuf+pixbufNewWithBGColor alpha w h (r,g,b) = do+  pb <- pixbufNew ColorspaceRgb alpha 8 w h+  pixbufFill pb r g b 255+  return pb
+ src/Graphics/UI/Gtk/Helpers/TreeView.hs view
@@ -0,0 +1,58 @@+module Graphics.UI.Gtk.Helpers.TreeView where++-- External imports+import Control.Monad+import Data.Maybe+import Graphics.UI.Gtk++type TypedTreeView a = (TreeView, ListStore a)++addTextColumn :: (TreeModelClass (model row), TypedTreeModelClass model)+                => TreeView -> model row -> (row -> Maybe String) -> IO()+addTextColumn tv st f = void $ do+  col <- treeViewColumnNew+  renderer <- cellRendererTextNew+  cellLayoutPackStart col renderer True+  cellLayoutSetAttributes col renderer st $ map (cellText :=).maybeToList.f+  treeViewAppendColumn tv col++addPixbufColumn :: (TreeModelClass (model row), TypedTreeModelClass model)+                => TreeView -> model row -> (row -> Maybe Pixbuf) -> IO()+addPixbufColumn tv st f = void $ do+  icon <- treeViewColumnNew+  renderIcon <- cellRendererPixbufNew+  cellLayoutPackStart icon renderIcon True+  cellLayoutSetAttributes icon renderIcon st $ map (cellPixbuf :=).maybeToList.f+  treeViewAppendColumn tv icon++addPixbufTextDoubleColumn :: (TreeModelClass (model row), TypedTreeModelClass model)+                          => TreeView -> model row -> (row -> (Maybe Pixbuf, Maybe String)) -> IO()+addPixbufTextDoubleColumn tv st f = void $ do+  col <- treeViewColumnNew++  renderIcon <- cellRendererPixbufNew+  cellLayoutPackStart col renderIcon False+  cellLayoutSetAttributes col renderIcon st $ map (cellPixbuf :=).maybeToList.fst.f++  renderer <- cellRendererTextNew+  cellLayoutPackEnd col renderer True+  cellLayoutSetAttributes col renderer st $ map (cellText :=).maybeToList.snd.f++  treeViewAppendColumn tv col++synchroniseTreeViewAndNotebook :: TreeView -> Notebook -> ([TreePath] -> Maybe Int) -> IO()+synchroniseTreeViewAndNotebook tv nb f = do+  tr <- treeViewGetSelectedPath tv+  maybe (return ()) (\v -> set nb [ notebookPage := v ]) (f tr)++treeViewGetSelectedPath :: TreeViewClass tv => tv -> IO [[Int]]+treeViewGetSelectedPath =+  treeSelectionGetSelectedRows <=< treeViewGetSelection++treeViewGetSelected :: TreeViewClass tv => tv -> ListStore a -> IO (Maybe a)+treeViewGetSelected tv ls = do+  tr <- treeViewGetSelectedPath tv+  case tr of+   [[x]] -> fmap Just $ listStoreGetValue ls x+   _     -> return Nothing+
+ src/Graphics/UI/Gtk/Layout/BackgroundContainer.hs view
@@ -0,0 +1,65 @@+module Graphics.UI.Gtk.Layout.BackgroundContainer where++import Control.Monad.Trans (liftIO)+import Data.IORef+import Graphics.UI.Gtk+import Graphics.UI.Gtk.Gdk.GC+import System.Glib.Types++data BackgroundContainer = BackgroundContainer EventBox (IORef (Maybe Pixbuf))++instance WidgetClass BackgroundContainer+instance ObjectClass BackgroundContainer+instance GObjectClass BackgroundContainer where+  toGObject (BackgroundContainer ev _) = toGObject ev+  unsafeCastGObject ev = (BackgroundContainer (unsafeCastGObject ev) undefined)++instance EventBoxClass BackgroundContainer+instance ContainerClass BackgroundContainer+instance BinClass BackgroundContainer++backgroundContainerNew :: IO BackgroundContainer+backgroundContainerNew = do+  ev  <- eventBoxNew+  ref <- newIORef Nothing+  return $ BackgroundContainer ev ref++backgroundContainerNewWithPicture :: FilePath -> IO BackgroundContainer+backgroundContainerNewWithPicture fp = do+  ev  <- eventBoxNew+  pb  <- pixbufNewFromFile fp+  ref <- newIORef (Just pb)+  let wdgt = BackgroundContainer ev ref+  wdgt `on` exposeEvent $ liftIO (backgroundExpose wdgt) >> return False+  return wdgt++backgroundContainerNewWithPixbuf :: Pixbuf -> IO BackgroundContainer+backgroundContainerNewWithPixbuf pb = do+  ev  <- eventBoxNew+  ref <- newIORef (Just pb)+  let wdgt = BackgroundContainer ev ref+  wdgt `on` exposeEvent $ liftIO (backgroundExpose wdgt) >> return False+  return wdgt++backgroundExpose :: BackgroundContainer -> IO ()+backgroundExpose (BackgroundContainer ev ref) = do+  dw <- widgetGetDrawWindow ev+  drawWindowClear dw+  pixbufM <- readIORef ref+  case pixbufM of+   Nothing -> return ()+   Just pb -> do sz@(w,h) <- widgetGetSize ev+                 pb' <- pixbufScaleSimple pb w h InterpBilinear+                 drawWindowBeginPaintRect dw (Rectangle 0 0 w h)+                 gc <- gcNew dw+                 drawPixbuf dw gc pb' 0 0 0 0 (-1) (-1) RgbDitherNone (-1) (-1)+                 drawWindowEndPaint dw++backgroundSetPicture :: BackgroundContainer -> Maybe FilePath -> IO()+backgroundSetPicture (BackgroundContainer ev ref) fpM = do+  pbM <- maybe (return Nothing) (fmap Just . pixbufNewFromFile) fpM+  writeIORef ref pbM++backgroundSetPixbuf :: BackgroundContainer -> Maybe Pixbuf -> IO()+backgroundSetPixbuf (BackgroundContainer ev ref) pbM =+  writeIORef ref pbM
+ src/Graphics/UI/Gtk/Layout/DummyBin.hs view
@@ -0,0 +1,19 @@+module Graphics.UI.Gtk.Layout.DummyBin where++import Graphics.UI.Gtk+import System.Glib.Types++data DummyBin = DummyBin EventBox++instance WidgetClass DummyBin+instance ObjectClass DummyBin+instance GObjectClass DummyBin where+ toGObject (DummyBin x) = toGObject x+ unsafeCastGObject = DummyBin . unsafeCastGObject++dummyBinNew :: IO DummyBin+dummyBinNew = do+ evbox <- eventBoxNew+ return $ DummyBin evbox++instance ContainerClass DummyBin where
+ src/Graphics/UI/Gtk/Layout/EitherWidget.hs view
@@ -0,0 +1,41 @@+module Graphics.UI.Gtk.Layout.EitherWidget where++import Control.Monad+import Data.IORef+import Graphics.UI.Gtk+import System.Glib.Types++data EitherWidget a b   = EitherWidget Notebook (IORef EitherWidgetParams)+type EitherWidgetParams = Bool++instance WidgetClass (EitherWidget a b)+instance ObjectClass (EitherWidget a b)+instance GObjectClass (EitherWidget a b) where+  toGObject (EitherWidget nb _) = toGObject nb+  unsafeCastGObject o = EitherWidget (unsafeCastGObject o) undefined+ +eitherWidgetNew :: (WidgetClass a, WidgetClass b) => a -> b -> IO (EitherWidget a b)+eitherWidgetNew wL wR = do+  nb <- notebookNew+  _  <- notebookAppendPage nb wL ""+  _  <- notebookAppendPage nb wR ""+  notebookSetShowTabs nb False+  params <- newIORef True+  return $ EitherWidget nb params++eitherWidgetLeftActivated :: Attr (EitherWidget a b) Bool+eitherWidgetLeftActivated = newAttr getter setter+  where getter (EitherWidget _ paramsR)    = readIORef paramsR+        setter (EitherWidget nb paramsR) v = do+                  params <- readIORef paramsR+                  when (v /= params) $ do let upd = if v then 0 else 1+                                          notebookSetCurrentPage nb upd+                                          writeIORef paramsR v++eitherWidgetRightActivated :: Attr (EitherWidget a b) Bool+eitherWidgetRightActivated = newAttr getter setter+  where getter w   = fmap not $ get w eitherWidgetLeftActivated+        setter w v = set w [ eitherWidgetLeftActivated := not v ]++eitherWidgetToggle :: EitherWidget a b -> IO()+eitherWidgetToggle w = set w [ eitherWidgetLeftActivated :~ not ]
+ src/Graphics/UI/Gtk/Layout/MaybeWidget.hs view
@@ -0,0 +1,45 @@+module Graphics.UI.Gtk.Layout.MaybeWidget where++import Control.Monad+import Data.IORef+import Graphics.UI.Gtk+import System.Glib.Types++data MaybeWidget a     = MaybeWidget Notebook a Label (IORef MaybeWidgetParams)+type MaybeWidgetParams = Bool++instance WidgetClass (MaybeWidget a)+instance ObjectClass (MaybeWidget a)+instance GObjectClass (MaybeWidget a) where+  toGObject (MaybeWidget nb _ _ _) = toGObject nb+  unsafeCastGObject o = MaybeWidget (unsafeCastGObject o) undefined undefined undefined+ +maybeWidgetNewWithLabel :: (WidgetClass a) => a -> Maybe String -> IO (MaybeWidget a)+maybeWidgetNewWithLabel w label = do+  lblW <- labelNew label+  nb <- notebookNew+  _  <- notebookAppendPage nb lblW ""+  _  <- notebookAppendPage nb w ""+  notebookSetShowTabs nb False+  params <- newIORef False+  return $ MaybeWidget nb w lblW params++maybeWidgetGetWidget :: MaybeWidget a -> a+maybeWidgetGetWidget (MaybeWidget _ a _ _) = a+ +maybeWidgetLabelText :: Attr (MaybeWidget a) String+maybeWidgetLabelText = newAttr getter setter+  where getter (MaybeWidget _ _ lblW _)   = get lblW labelLabel+        setter (MaybeWidget _ _ lblW _) s = set lblW [ labelLabel := s ]++maybeWidgetActivated :: Attr (MaybeWidget a) Bool+maybeWidgetActivated = newAttr getter setter+  where getter (MaybeWidget _ _ _ paramsR)    = readIORef paramsR+        setter (MaybeWidget nb _ _ paramsR) v = do+                  params <- readIORef paramsR+                  when (v /= params) $ do let upd = if v then 1 else 0+                                          notebookSetCurrentPage nb upd+                                          writeIORef paramsR v++maybeWidgetToggle :: MaybeWidget a -> IO()+maybeWidgetToggle w = set w [ maybeWidgetActivated :~ not ]
+ src/System/Application.hs view
@@ -0,0 +1,17 @@+module System.Application where++-- External imports+import Control.Monad+-- import Control.Monad.Extra+import System.GIO.File.AppInfo+import System.Process++-- FIXME: This uses runProcess instead of appInfoLaunchUris because+-- the latter segfaults in my machine+openUrlBySystemTool :: String -> IO Bool+openUrlBySystemTool url = do+  infos <- appInfoGetAllForType "text/html"+  unless (null infos) $ void $ do+    let exe = appInfoGetExecutable $ head infos+    runProcess exe [url] Nothing Nothing Nothing Nothing Nothing+  return (not (null infos))