Menu
▾
▴
gtk2hs-commit — Mailing list for Darcs commit messages.
You can subscribe to this list here.
| 2003 |
Jan
|
Feb
|
Mar
|
Apr
|
May
(4) |
Jun
|
Jul
(68) |
Aug
(4) |
Sep
|
Oct
(23) |
Nov
(95) |
Dec
(9) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2004 |
Jan
(3) |
Feb
|
Mar
|
Apr
(51) |
May
(81) |
Jun
(2) |
Jul
(86) |
Aug
(143) |
Sep
(3) |
Oct
(31) |
Nov
(63) |
Dec
(90) |
| 2005 |
Jan
(277) |
Feb
(157) |
Mar
(99) |
Apr
(195) |
May
(151) |
Jun
(148) |
Jul
(98) |
Aug
(123) |
Sep
(20) |
Oct
(174) |
Nov
(155) |
Dec
(26) |
| 2006 |
Jan
(51) |
Feb
(19) |
Mar
(16) |
Apr
(12) |
May
(5) |
Jun
|
Jul
(11) |
Aug
(7) |
Sep
(10) |
Oct
(31) |
Nov
(174) |
Dec
(56) |
| 2007 |
Jan
(45) |
Feb
(52) |
Mar
(10) |
Apr
(5) |
May
(47) |
Jun
(16) |
Jul
(80) |
Aug
(29) |
Sep
(14) |
Oct
(59) |
Nov
(46) |
Dec
(16) |
| 2008 |
Jan
(10) |
Feb
(1) |
Mar
|
Apr
|
May
(49) |
Jun
(26) |
Jul
(8) |
Aug
(4) |
Sep
(25) |
Oct
(53) |
Nov
(9) |
Dec
(1) |
| 2009 |
Jan
(66) |
Feb
(11) |
Mar
(1) |
Apr
(14) |
May
(8) |
Jun
(1) |
Jul
(2) |
Aug
(2) |
Sep
(9) |
Oct
(23) |
Nov
(35) |
Dec
|
| 2010 |
Jan
(7) |
Feb
(2) |
Mar
(39) |
Apr
(19) |
May
(161) |
Jun
(19) |
Jul
(32) |
Aug
(65) |
Sep
(113) |
Oct
(120) |
Nov
(2) |
Dec
|
| 2012 |
Jan
|
Feb
(5) |
Mar
(4) |
Apr
(7) |
May
(9) |
Jun
(14) |
Jul
(1) |
Aug
|
Sep
(1) |
Oct
(1) |
Nov
(12) |
Dec
(2) |
| 2013 |
Jan
(1) |
Feb
(17) |
Mar
(4) |
Apr
(4) |
May
(9) |
Jun
|
Jul
(8) |
Aug
|
Sep
(2) |
Oct
|
Nov
|
Dec
|
|
From: Axel S. <si...@co...> - 2010-05-05 07:58:37
|
Wed May 5 03:56:46 EDT 2010 Axe...@in...
* Make the bootstrap file ignore a package if it can't be built.
Ignore-this: d92362cd5d0ee8820c127a0367e4d498
hunk ./bootstrap.sh 5
-for pkg in glib cairo pango gtk gconf gio glade gnomevfs gtkglext gtksourceview2 soegtk svgcairo vte webkit; do cd $pkg; cabal clean; cabal configure --user; cabal build; cabal haddock; cabal install; cd ..; done;
+for pkg in glib cairo pango gtk gconf gio glade gnomevfs gtkglext gtksourceview2 soegtk svgcairo vte webkit; do [_$_]
+ cd $pkg;
+ if cabal configure $1; then
+ cabal build;
+ cabal haddock;
+ cabal install;
+ fi;
+ cd ..;
+done;
|
|
From: Axel S. <si...@co...> - 2010-05-05 07:58:36
|
Wed May 5 03:57:27 EDT 2010 Axe...@in...
* Include the setup files in the distribution.
Ignore-this: d56ac4eb24866e5d917386b2df6ec28e
hunk ./cairo/cairo.cabal 20
+ Gtk2HsSetup.hs
hunk ./gconf/gconf.cabal 21
+Extra-Source-Files: Gtk2HsSetup.hs
hunk ./gio/gio.cabal 25
+Extra-Source-Files: Gtk2HsSetup.hs
hunk ./glade/glade.cabal 20
+
hunk ./glade/glade.cabal 25
+Extra-Source-Files: Gtk2HsSetup.hs
hunk ./glib/glib.cabal 21
+ Gtk2HsSetup.hs
hunk ./glib/glib.cabal 43
-[_^I_][_^I_] [_$_]
+
hunk ./gnomevfs/gnomevfs.cabal 28
+ Gtk2HsSetup.hs
hunk ./gtk/gtk.cabal 28
+ Gtk2HsSetup.hs
hunk ./gtkglext/gtkglext.cabal 23
+Extra-Source-Files: Gtk2HsSetup.hs
hunk ./gtksourceview2/gtksourceview2.cabal 25
+ Gtk2HsSetup.hs
hunk ./pango/pango.cabal 22
+ Gtk2HsSetup.hs
hunk ./svgcairo/svgcairo.cabal 22
+ Gtk2HsSetup.hs
hunk ./vte/vte.cabal 26
+ Gtk2HsSetup.hs
hunk ./webkit/webkit.cabal 28
+ Gtk2HsSetup.hs
|
|
From: Axel S. <si...@co...> - 2010-05-04 13:59:24
|
Tue May 4 09:58:48 EDT 2010 Axe...@in...
* Fix documenation to Editable.
Ignore-this: d9494bc1fb323d50164f219423a5e17
hunk ./gtk/Graphics/UI/Gtk/Entry/Editable.chs 280
--- | Emitted when the settings of the 'Editable' widget changes.
+-- | The 'onEditableChanged' signal is emitted at the end of a single
+-- user-visible operation on the contents of the 'Editable'.
+--
+-- * For inctance, a paste operation that replaces the contents of the
+-- selection will cause only one signal emission (even though it is
+-- implemented by first deleting the selection, then inserting the new
+-- content, and may cause multiple 'onEditableInserText' signals to be
+-- emitted).
|
|
From: Andy S. <And...@co...> - 2010-05-03 14:09:36
|
Mon May 3 10:07:19 EDT 2010 Andy Stewart <laz...@gm...>
* Fix textView signals (rename `setScrollAdjustments` to `setTextViewScrollAdjustments`) and fix signal docs.
Ignore-this: 3fcfbfe8659c1f01d806990a6a59e0dc
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 179
- setScrollAdjustments,
+ setTextViewScrollAdjustments,
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1160
-backspace :: TextBufferClass self => Signal self (IO ())
-backspace = Signal (connect_NONE__NONE "on_backspace")
+-- | The 'backspace' signal is a keybinding signal which gets emitted when the user asks for it.
+--
+-- The default bindings for this signal are Backspace and Shift-Backspace.
+--
+backspace :: TextViewClass self => Signal self (IO ())
+backspace = Signal (connect_NONE__NONE "on-backspace")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1167
-copyClipboard :: TextBufferClass self => Signal self (IO ())
-copyClipboard = Signal (connect_NONE__NONE "copy_clipboard")
+-- | Copying to the clipboard.
+--
+-- * This signal is emitted when a selection is copied to the clipboard. [_$_]
+--
+-- * The action itself happens when the 'TextView' processes this
+-- signal.
+--
+copyClipboard :: TextViewClass self => Signal self (IO ())
+copyClipboard = Signal (connect_NONE__NONE "copy-clipboard")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1177
-cutClipboard :: TextBufferClass self => Signal self (IO ())
-cutClipboard = Signal (connect_NONE__NONE "cut_clipboard")
+-- | Cutting to the clipboard.
+--
+-- * This signal is emitted when a selection is cut out and copied to the
+-- clipboard. The action itself happens when the textview processed this
+-- request.
+--
+cutClipboard :: TextViewClass self => Signal self (IO ())
+cutClipboard = Signal (connect_NONE__NONE "cut-clipboard")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1186
-deleteFromCursor :: TextBufferClass self => Signal self (DeleteType -> Int -> IO ())
-deleteFromCursor = Signal (connect_ENUM_INT__NONE "delete_from_cursor")
+-- | Deleting text.
+--
+-- * The widget will remove the specified number of units in the text where
+-- the meaning of units depends on the kind of deletion.
+--
+-- * The action itself happens when the 'TextView' processes this
+-- signal.
+--
+deleteFromCursor :: TextViewClass self => Signal self (DeleteType -> Int -> IO ())
+deleteFromCursor = Signal (connect_ENUM_INT__NONE "delete-from-cursor")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1197
-insertAtCursor :: TextBufferClass self => Signal self (String -> IO ())
-insertAtCursor = Signal (connect_STRING__NONE "insert_at_cursor")
+-- | Inserting text.
+--
+-- * The widget will insert the string into the text where the meaning
+-- of units depends on the kind of deletion.
+--
+-- * The action itself happens when the 'TextView' processes this
+-- signal.
+--
+insertAtCursor :: TextViewClass self => Signal self (String -> IO ())
+insertAtCursor = Signal (connect_STRING__NONE "insert-at-cursor")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1208
-moveCursor :: TextBufferClass self => Signal self (MovementStep -> Int -> Bool -> IO ())
-moveCursor = Signal (connect_ENUM_INT_BOOL__NONE "move_cursor")
+-- | Moving the cursor.
+--
+-- * The signal specifies what kind and how many steps the cursor will do.
+-- The flag is set to @True@ if this movement extends a selection.
+--
+-- * The action itself happens when the 'TextView' processes this
+-- signal.
+--
+moveCursor :: TextViewClass self => Signal self (MovementStep -> Int -> Bool -> IO ())
+moveCursor = Signal (connect_ENUM_INT_BOOL__NONE "move-cursor")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1219
-moveViewport :: TextBufferClass self => Signal self (ScrollStep -> Int -> IO ())
-moveViewport = Signal (connect_ENUM_INT__NONE "move_viewport")
+-- | The 'moveViewport' signal is a keybinding signal which can be bound to key combinations [_$_]
+-- to allow the user to move the viewport, i.e. [_$_]
+-- change what part of the text view is visible in a containing scrolled window.
+-- There are no default bindings for this signal.
+-- [_$_]
+moveViewport :: TextViewClass self => Signal self (ScrollStep -> Int -> IO ())
+moveViewport = Signal (connect_ENUM_INT__NONE "move-viewport")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1227
-moveFocus :: TextBufferClass self => Signal self (DirectionType -> IO ())
-moveFocus = Signal (connect_ENUM__NONE "move_focus")
+-- | Moving the focus.
+--
+-- * The action itself happens when the 'TextView' processes this
+-- signal.
+--
+moveFocus :: TextViewClass self => Signal self (DirectionType -> IO ())
+moveFocus = Signal (connect_ENUM__NONE "move-focus")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1235
-pageHorizontally :: TextBufferClass self => Signal self (Int -> Bool -> IO ())
-pageHorizontally = Signal (connect_INT_BOOL__NONE "page_horizontally")
+-- | Page change signals.
+--
+-- * The signal specifies how many pages the view should move up or down.
+-- The flag is set to @True@ if this movement extends a selection.
+--
+-- * The action itself happens when the 'TextView' processes this
+-- signal.
+--
+-- * Figure out why this signal is called horizontally, not vertically.
+--
+pageHorizontally :: TextViewClass self => Signal self (Int -> Bool -> IO ())
+pageHorizontally = Signal (connect_INT_BOOL__NONE "page-horizontally")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1248
-pasteClipboard :: TextBufferClass self => Signal self (IO ())
-pasteClipboard = Signal (connect_NONE__NONE "paste_clipboard")
+-- | Pasting from the clipboard.
+--
+-- * This signal is emitted when something is pasted from the clipboard. [_$_]
+--
+-- * The action itself happens when the 'TextView' processes this
+-- signal.
+--
+pasteClipboard :: TextViewClass self => Signal self (IO ())
+pasteClipboard = Signal (connect_NONE__NONE "paste-clipboard")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1258
-populatePopup :: TextBufferClass self => Signal self (Menu -> IO ())
-populatePopup = Signal (connect_OBJECT__NONE "populate_popup")
+-- | Add menu entries to context menus.
+--
+-- * This signal is emitted if a context menu within the 'TextView'
+-- is opened. This signal can be used to add application specific menu
+-- items to this popup.
+--
+populatePopup :: TextViewClass self => Signal self (Menu -> IO ())
+populatePopup = Signal (connect_OBJECT__NONE "populate-popup")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1267
-selectAll :: TextBufferClass self => Signal self (Bool -> IO ())
+-- | Inserting an anchor.
+--
+-- * This signal is emitted when anchor is inserted into the text. [_$_]
+--
+-- * The action itself happens when the 'TextView' processes this
+-- signal.
+--
+selectAll :: TextViewClass self => Signal self (Bool -> IO ())
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1277
-setAnchor :: TextBufferClass self => Signal self (IO ())
-setAnchor = Signal (connect_NONE__NONE "set_anchor")
+-- | The scroll-bars changed.
+--
+setAnchor :: TextViewClass self => Signal self (IO ())
+setAnchor = Signal (connect_NONE__NONE "set-anchor")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1282
-setScrollAdjustments :: TextBufferClass self => Signal self (Adjustment -> Adjustment -> IO ())
-setScrollAdjustments = Signal (connect_OBJECT_OBJECT__NONE "set_scroll_adjustments")
+-- | The 'setTextViewScrollAdjustments' signal is a keybinding signal which [_$_]
+-- gets emitted to toggle the visibility of the cursor.
+-- The default binding for this signal is F7.
+--
+setTextViewScrollAdjustments :: TextViewClass self => Signal self (Adjustment -> Adjustment -> IO ())
+setTextViewScrollAdjustments = Signal (connect_OBJECT_OBJECT__NONE "set-scroll-adjustments")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1289
-toggleCursorVisible :: TextBufferClass self => Signal self (IO ())
-toggleCursorVisible = Signal (connect_NONE__NONE "toggle_cursor_visible")
+-- | The 'toggleCursorVisible' signal is a keybinding signal [_$_]
+-- which gets emitted to toggle the visibility of the cursor.
+-- The default binding for this signal is F7.
+--
+toggleCursorVisible :: TextViewClass self => Signal self (IO ())
+toggleCursorVisible = Signal (connect_NONE__NONE "toggle-cursor-visible")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1296
-toggleOverwrite :: TextBufferClass self => Signal self (IO ())
-toggleOverwrite = Signal (connect_NONE__NONE "toggle_overwrite")
+-- | Insert Overwrite mode has changed.
+--
+-- * This signal is emitted when the 'TextView' changes from
+-- inserting mode to overwriting mode and vice versa. [_$_]
+--
+-- * The action itself happens when the 'TextView' processes this
+-- signal.
+--
+toggleOverwrite :: TextViewClass self => Signal self (IO ())
+toggleOverwrite = Signal (connect_NONE__NONE "toggle-overwrite")
|
|
From: Andy S. <And...@co...> - 2010-05-02 11:04:17
|
Sun May 2 07:02:06 EDT 2010 Andy Stewart <laz...@gm...>
* Fix TextView signals.
Ignore-this: 3cc1d9c7e1452e577264f2a287852a22
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 166
+ backspace,
+ copyClipboard,
+ cutClipboard,
+ deleteFromCursor,
+ insertAtCursor,
+ moveCursor,
+ moveViewport,
+ moveFocus,
+ pageHorizontally,
+ pasteClipboard,
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 177
+ selectAll,
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 179
- setTextViewScrollAdjustments,
+ setScrollAdjustments,
+ toggleCursorVisible,
+ toggleOverwrite,
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1160
+backspace :: TextBufferClass self => Signal self (IO ())
+backspace = Signal (connect_NONE__NONE "on_backspace")
+
+copyClipboard :: TextBufferClass self => Signal self (IO ())
+copyClipboard = Signal (connect_NONE__NONE "copy_clipboard")
+
+cutClipboard :: TextBufferClass self => Signal self (IO ())
+cutClipboard = Signal (connect_NONE__NONE "cut_clipboard")
+
+deleteFromCursor :: TextBufferClass self => Signal self (DeleteType -> Int -> IO ())
+deleteFromCursor = Signal (connect_ENUM_INT__NONE "delete_from_cursor")
+
+insertAtCursor :: TextBufferClass self => Signal self (String -> IO ())
+insertAtCursor = Signal (connect_STRING__NONE "insert_at_cursor")
+
+moveCursor :: TextBufferClass self => Signal self (MovementStep -> Int -> Bool -> IO ())
+moveCursor = Signal (connect_ENUM_INT_BOOL__NONE "move_cursor")
+
+moveViewport :: TextBufferClass self => Signal self (ScrollStep -> Int -> IO ())
+moveViewport = Signal (connect_ENUM_INT__NONE "move_viewport")
+
+moveFocus :: TextBufferClass self => Signal self (DirectionType -> IO ())
+moveFocus = Signal (connect_ENUM__NONE "move_focus")
+
+pageHorizontally :: TextBufferClass self => Signal self (Int -> Bool -> IO ())
+pageHorizontally = Signal (connect_INT_BOOL__NONE "page_horizontally")
+
+pasteClipboard :: TextBufferClass self => Signal self (IO ())
+pasteClipboard = Signal (connect_NONE__NONE "paste_clipboard")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1190
--- | Add menu entries to context menus.
---
--- * This signal is emitted if a context menu within the 'TextView' is opened.
--- This signal can be used to add application specific menu items to this
--- popup.
---
--- * If you need to add items to the context menu, connect to this signal and
--- append your menuitems to the 'Menu'.
---
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1191
-populatePopup = Signal (connect_OBJECT__NONE "populate-popup")
+populatePopup = Signal (connect_OBJECT__NONE "populate_popup")
+
+selectAll :: TextBufferClass self => Signal self (Bool -> IO ())
+selectAll = Signal (connect_BOOL__NONE "select-all")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1196
--- | Inserting an anchor.
---
--- * This signal is emitted when anchor is inserted into the text. [_$_]
---
--- * The action itself happens when the 'TextView' processes this
--- signal.
---
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1197
-setAnchor = Signal (connect_NONE__NONE "set-anchor")
+setAnchor = Signal (connect_NONE__NONE "set_anchor")
hunk ./gtk/Graphics/UI/Gtk/Multiline/TextView.chs 1199
--- | The scroll-bars changed.
---
-setTextViewScrollAdjustments :: TextBufferClass self => Signal self (Adjustment -> Adjustment -> IO ())
-setTextViewScrollAdjustments = Signal (connect_OBJECT_OBJECT__NONE "set-scroll-adjustments")
+setScrollAdjustments :: TextBufferClass self => Signal self (Adjustment -> Adjustment -> IO ())
+setScrollAdjustments = Signal (connect_OBJECT_OBJECT__NONE "set_scroll_adjustments")
+
+toggleCursorVisible :: TextBufferClass self => Signal self (IO ())
+toggleCursorVisible = Signal (connect_NONE__NONE "toggle_cursor_visible")
+
+toggleOverwrite :: TextBufferClass self => Signal self (IO ())
+toggleOverwrite = Signal (connect_NONE__NONE "toggle_overwrite")
|
|
From: Andy S. <And...@co...> - 2010-05-01 22:05:52
|
Sat May 1 18:04:34 EDT 2010 Andy Stewart <laz...@gm...>
* Add bootstrap.sh.
Ignore-this: bdcf47e2a0b99436967f6338c8f00141
addfile ./bootstrap.sh
hunk ./bootstrap.sh 1
+#!/bin/sh
+
+# A script to bootstrap gtk2hs
+
+for pkg in glib cairo pango gtk gconf gio glade gnomevfs gtkglext gtksourceview2 soegtk svgcairo vte webkit; do cd $pkg; cabal clean; cabal configure --user; cabal build; cabal haddock; cabal install; cd ..; done;
|
|
From: Andy S. <And...@co...> - 2010-05-01 21:42:44
|
Sat May 1 17:40:46 EDT 2010 Andy Stewart <laz...@gm...>
* Fix cairo demo.
Ignore-this: bb37935be21a3414d6540d39b74d57c6
hunk ./cairo/demo/Clock.hs 14
-import Graphics.UI.Gtk hiding (fill)
+import Graphics.UI.Gtk
hunk ./glib/glib.cabal 42
- exposed: False
- exposed-modules: System.Glib
+[_^I_][_^I_] [_$_]
+ exposed-modules: [_$_]
+ System.Glib
+ System.Glib.GError
hunk ./glib/glib.cabal 48
- System.Glib.GError
|
|
From: Andy S. <And...@co...> - 2010-05-01 21:42:43
|
Sat May 1 17:17:52 EDT 2010 Andy Stewart <laz...@gm...>
* Fix scaling demo and move to `gtk2hs/glade/demo`.
Ignore-this: 26b0499662347edb6067e8f8397a406c
binary ./demo/scaling/London_Eye.jpg
rmfile ./demo/scaling/London_Eye.jpg
hunk ./demo/scaling/Makefile 1
-
-PROG = scaling
-SOURCES = Scaling.hs
-#HCFLAGS = -prof -auto-all
-# use -fglasgow-exts since older ghc versions don't know about FlexibleContexts
-HCFLAGS = -O3 -fglasgow-exts
-#HCFLAGS = -O3 -fvia-C -optc-O3
-#HCFLAGS = -O0 -keep-hc-file -keep-s-files -fvia-C
-
-$(PROG) : $(SOURCES)
- $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
-
-HC=ghc
rmfile ./demo/scaling/Makefile
binary ./demo/scaling/Mountains.jpg
rmfile ./demo/scaling/Mountains.jpg
hunk ./demo/scaling/Scaling.hs 1
-{-# OPTIONS -O #-}
- --- {-# OPTIONS_GHC -XFlexibleContexts #-} see Makefile
--- Author: Pawel Bulkowski (paw...@gm...)
--- Thanks to Michal Palka for teaching me Haskell
--- Photos by: Magdalena Niedziela
--- based on other gtk2hs example applications
--- the code is public domain
-import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Gdk.EventM
-
-import Data.Array.MArray
-import Data.Array.IO
---import Data.Array.IO.Internals
-import Data.Array.Storable
-import Data.Bits
-import Data.Word
-import Data.Maybe
-import Data.IORef
-import Data.Ord
-import Control.Monad ( when, unless, liftM )
-import Control.Monad.Trans ( liftIO )
-import Control.Monad.ST
-import Data.Array.Base ( unsafeWrite, unsafeRead ) [_$_]
-import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Glade
-import Graphics.UI.Gtk.ModelView as New [_$_]
-import CPUTime
-import System.Environment ( getArgs )
-import System.Directory ( doesFileExist )
-type ArrayType = IOUArray
---type ArrayType = StorableArray
-
--- The state and GUI
-
-data ImageState = Empty|NonEmpty
-data State = State {
- pb :: Pixbuf,
- is :: ImageState
-}
-
- [_$_]
-main = do
- args <- getArgs
- case args of
- [fName] -> do
- exists <- doesFileExist fName
- if exists then runGUI fName else
- putStrLn ("File "++fName++" not found.")
- _ -> putStrLn "Usage: scaling <image.jpg>"
- [_$_]
-runGUI fName = do [_$_]
- initGUI
-
- window <- windowNew
- window `onDestroy` mainQuit
- set window [ windowTitle := "Scaling"
- , windowResizable := True ]
- label <- labelNew (Just "Content Aware Image Scaling")
- vboxOuter <- vBoxNew False 0
- vboxInner <- vBoxNew False 5
- [_$_]
- (mb,miOpen,miSave,miScale, miGradient, miSeamCarve, miQuit) <- makeMenuBar
- canvas <- drawingAreaNew
- containerAdd vboxInner canvas
- [_$_]
- [_$_]
- -- Assemble the bits
- set vboxOuter [ containerChild := mb
- , containerChild := vboxInner ]
- set vboxInner [ containerChild := label
- , containerBorderWidth := 10 ]
- set window [ containerChild := vboxOuter ]
- [_$_]
- -- create the Pixbuf
- pb <- pixbufNew ColorspaceRgb False 8 256 256
- -- Initialize the state
- state <- newIORef State { pb = pb, is = Empty }
- let modifyState f = readIORef state >>= f >>= writeIORef state
-
- canvas `onSizeRequest` return (Requisition 256 256)
- [_$_]
-
- -- Add action handlers
- onActivateLeaf miQuit mainQuit
--- onActivateLeaf miOpen $ modifyState $ reset gui
- onActivateLeaf miOpen $ modifyState $ loadImageDlg canvas window
- onActivateLeaf miSave $ modifyState $ saveImageDlg canvas window
- onActivateLeaf miScale $ modifyState $ scaleImageDlg canvas window
- onActivateLeaf miGradient $ modifyState $ gradientImageDlg canvas window
- onActivateLeaf miSeamCarve $ modifyState $ seamCarveImageDlg canvas window
-
- modifyState (loadImage canvas window fName)
- [_$_]
- canvas `on` exposeEvent $ updateCanvas state
- boxPackStartDefaults vboxInner canvas
- widgetShowAll window
- mainGUI
-
- return ()
-
- --uncomment for ghc < 6.8.3
---instance Show Rectangle where
--- show (Rectangle x y w h) = "x="++show x++", y="++show y++
--- ", w="++show w++", h="++show h++";"
-
-updateCanvas :: IORef State -> EventM EExpose Bool
-updateCanvas rstate = do
- region <- eventRegion
- win <- eventWindow
- liftIO $ do
- state <- readIORef rstate
- let (State pb is) = state
- gc <- gcNew win
- width <- pixbufGetWidth pb
- height <- pixbufGetHeight pb
- pbregion <- regionRectangle (Rectangle 0 0 width height)
- regionIntersect region pbregion
- rects <- regionGetRectangles region
- putStrLn ("redrawing: "++show rects)
- (flip mapM_) rects $ \(Rectangle x y w h) -> do
- drawPixbuf win gc pb x y x y w h RgbDitherNone 0 0
- return True
-
-{-# INLINE doFromTo #-}
--- do the action for [from..to], ie it's inclusive.
-doFromTo :: Int -> Int -> (Int -> IO ()) -> IO ()
-doFromTo from to action =
- let loop n | n > to = return ()
- | otherwise = do action n
- loop (n+1)
- in loop from
-
--- do the action for [to..from], ie it's inclusive.
-{-# INLINE doFromToDown #-}
-doFromToDown :: Int -> Int -> (Int -> IO ()) -> IO ()
-doFromToDown from to action =
- let loop n | n < to = return ()
- | otherwise = do action n
- loop (n-1)
- in loop from
-
--- do the action for [from..to] with step, ie it's inclusive.
-{-# INLINE doFromToStep #-}
-doFromToStep :: Int -> Int -> Int -> (Int -> IO ()) -> IO ()
-doFromToStep from to step action =
- let loop n | n > to = return ()
- | otherwise = do action n
- loop (n+step)
- in loop from
- [_$_]
---forM = flip mapM
- [_$_]
-makeMenuBar = do
- mb <- menuBarNew
- fileMenu <- menuNew
- open <- menuItemNewWithMnemonic "_Open"
- save <- menuItemNewWithMnemonic "_Save"
- scale <- menuItemNewWithMnemonic "_Scale"
- gradient <- menuItemNewWithMnemonic "_Gradient"
- seamCarve <- menuItemNewWithMnemonic "Seam _Carve"
- quit <- menuItemNewWithMnemonic "_Quit"
- file <- menuItemNewWithMnemonic "_File"
- menuShellAppend fileMenu open
- menuShellAppend fileMenu save
- menuShellAppend fileMenu scale
- menuShellAppend fileMenu gradient
- menuShellAppend fileMenu seamCarve
- menuShellAppend fileMenu quit
- menuItemSetSubmenu file fileMenu
- containerAdd mb file
- return (mb,open,save,scale,gradient,seamCarve,quit)
-
-loadImageDlg canvas window (State pb is) = do
- putStrLn ("loadImage")
- ret <- openFileDialog window
- case ret of
- Just (filename) -> (loadImage canvas window filename (State pb is))
- Nothing -> return (State pb is)
-
-
-loadImage canvas window filename (State pb is) = do
- putStrLn ("loadImage")
- pxb <- pixbufNewFromFile filename
- width <- pixbufGetWidth pxb
- height <- pixbufGetHeight pxb
- widgetSetSizeRequest canvas width height
- widgetQueueDraw canvas
--- updateCanvas canvas pxb
- return (State pxb NonEmpty)
-
- [_$_]
-saveImageDlg canvas window (State pb is) = do
- putStrLn ("saveImage")
- ret <- openFileDialog window
- case ret of
- Just (filename) -> do
- pixbufSave pb filename "png" []
- return (State pb is)
- Nothing -> return (State pb is)
-
-scaleImageDlg canvas window (State pb is) = do
- putStrLn ("scaleImage")
- [_$_]
- origWidth <- pixbufGetWidth pb
- origHeight <- pixbufGetHeight pb
- ret <- scaleDialog window origWidth origHeight
-
- let update w h = do
- putStrLn ("seamCarveImage::update w: "++show w++" h: "++show h)
- --scalePixbuf :: Pixbuf -> Int -> Int -> IO Pixbuf
- pxb <- scalePixbuf pb w h
- width <- pixbufGetWidth pxb
- height <- pixbufGetHeight pxb
- widgetSetSizeRequest canvas width height
- widgetQueueDraw canvas
- --updateCanvas canvas pxb
- return (State pxb NonEmpty)
-
- case ret of
- Nothing -> return (State pb NonEmpty)
- Just (w,h) -> (update w h)
-[_^I_][_$_]
-gradientImageDlg canvas window (State pb is) = do
- putStrLn ("gradientImageDlg")
- --scalePixbuf :: Pixbuf -> Int -> Int -> IO Pixbuf
- pxb <- gradientPixbuf pb
- width <- pixbufGetWidth pxb
- height <- pixbufGetHeight pxb
- widgetSetSizeRequest canvas width height
- widgetQueueDraw canvas
--- updateCanvas canvas pxb
- return (State pxb NonEmpty)
-[_^I_][_$_]
-seamCarveImageDlg canvas window (State pb is) = do
- origWidth <- pixbufGetWidth pb
- origHeight <- pixbufGetHeight pb
- ret <- seamCarveDialog window origWidth origHeight 2
-
- let update w h grdCnt = do
- putStrLn ("seamCarveImageDlg::update w: "++show w++" h: "++show h)
- --scalePixbuf :: Pixbuf -> Int -> Int -> IO Pixbuf
- --pxb <- scalePixbuf pb w h
- cpuStart <- getCPUTime
- pxb <- seamCarvePixbuf pb w h grdCnt
- cpuEnd <- getCPUTime
- putStrLn ("seamCarveImageDlg::cpu time: "++show ((fromIntegral (cpuEnd-cpuStart) :: Double) /1e12))
- width <- pixbufGetWidth pxb
- height <- pixbufGetHeight pxb
- widgetSetSizeRequest canvas width height
- widgetQueueDraw canvas
- --updateCanvas canvas pxb
- return (State pxb NonEmpty)
-
- case ret of
- Nothing -> return (State pb NonEmpty)
- Just (w,h,grdCnt) -> (update w h grdCnt)
-
-[_^I_][_$_]
-scaleDialog :: Window -> Int -> Int-> IO (Maybe (Int, Int))
-scaleDialog parent width height = do
-
- Just xml <- xmlNew "scaling.glade" [_$_]
-
- dia <- xmlGetWidget xml castToDialog "dialogScale"
- dialogAddButton dia stockCancel ResponseCancel
- dialogAddButton dia stockOk ResponseOk
- entryWidth <- xmlGetWidget xml castToEntry "entryScalingWidth" [_$_]
- entryHeight <- xmlGetWidget xml castToEntry "entryScalingHeight" [_$_]
- entrySetText entryWidth (show width)
- entrySetText entryHeight (show height)
- res <- dialogRun dia
- widthStr <- entryGetText entryWidth
- heightStr <- entryGetText entryHeight
- widgetDestroy dia
- putStrLn ("scaleDialog width: "++show width++" height: "++show height)
- case res of
- ResponseOk -> return (Just (read widthStr,read heightStr))
- _ -> return Nothing
-
-seamCarveDialog :: Window -> Int -> Int -> Int -> IO (Maybe (Int, Int, Int))
-seamCarveDialog parent width height grdCnt= do
-
- Just xml <- xmlNew "scaling.glade" [_$_]
-
- dia <- xmlGetWidget xml castToDialog "dialogSeamCarve"
- dialogAddButton dia stockCancel ResponseCancel
- dialogAddButton dia stockOk ResponseOk
- entryWidth <- xmlGetWidget xml castToEntry "entryWidth" [_$_]
- entryHeight <- xmlGetWidget xml castToEntry "entryHeight" [_$_]
- entryGrdCnt <- xmlGetWidget xml castToEntry "entryGrdCnt" [_$_]
- entrySetText entryWidth (show width)
- entrySetText entryHeight (show height)
- entrySetText entryGrdCnt (show grdCnt)
- res <- dialogRun dia
- widthStr <- entryGetText entryWidth
- heightStr <- entryGetText entryHeight
- grdCntStr <- entryGetText entryGrdCnt
- widgetDestroy dia
- putStrLn ("scaleDialog width: "++show width++" height: "++show height++" grdCnt: "++show grdCnt)
- case res of
- ResponseOk -> return (Just (read widthStr,read heightStr, read grdCntStr))
- _ -> return Nothing
-
- [_$_]
-openFileDialog :: Window -> IO (Maybe String)
-openFileDialog parentWindow = do
- dialog <- fileChooserDialogNew
- (Just "Open Profile... ")
- (Just parentWindow)
- FileChooserActionOpen
- [("gtk-cancel", ResponseCancel)
- ,("gtk-open", ResponseAccept)]
- widgetShow dialog
- response <- dialogRun dialog
- widgetHide dialog
- case response of
- ResponseAccept -> fileChooserGetFilename dialog
- _ -> return Nothing
-
---simple pixbuf scaling
-scalePixbuf :: Pixbuf -> Int -> Int -> IO Pixbuf
-scalePixbuf pb newWidth newHeight = do
- width <- pixbufGetWidth pb
- height <- pixbufGetHeight pb
- row <- pixbufGetRowstride pb
- chan <- pixbufGetNChannels pb
- bits <- pixbufGetBitsPerSample pb
- pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8))
- pbn <- pixbufNew ColorspaceRgb False 8 newWidth newHeight
- pbnData <- (pixbufGetPixels pbn :: IO (PixbufData Int Word8))
- newRow <- pixbufGetRowstride pbn
- putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan++
- ", bits per sample: "++show bits)
- putStrLn ("width: "++show width++", height: "++show height++", newWidth: "++show newWidth++", newHeight: "++show newHeight++" bytes per row new: "++show newRow)
- [_$_]
-[_^I_] [_$_]
- let stepX = (fromIntegral width) / (fromIntegral newWidth) :: Double
- let stepY = (fromIntegral height) / (fromIntegral newHeight) :: Double
-
- doFromTo 0 (newHeight-1) $ \y -> do
- let y1 = truncate ((fromIntegral y) * stepY)
- doFromTo 0 (newWidth-1) $ \x -> do
- let x1 = truncate ((fromIntegral x) * stepX)
- let off = (x1*chan+y1*row)
- let offNew = (x*chan+y*newRow)
- --putStrLn ("x: "++show x++", y: "++show y++" x1: "++show x1++", y1: "++show y1++" off:"++show off++" offNew:"++show offNew)
- r <- unsafeRead pbData (off)
- g <- unsafeRead pbData (1+off)
- b <- unsafeRead pbData (2+off)
- unsafeWrite pbnData (offNew) r
- unsafeWrite pbnData (1+offNew) g
- unsafeWrite pbnData (2+offNew) b
- return pbn
-
-
-{-# INLINE arrmove #-}
-arrmove :: (Ix i, MArray a e IO) => a i e -> Int -> Int -> Int -> IO ()
-arrmove arr src dst size = do
-
- --putStrLn("arrmove "++show src++" "++show dst++" "++show size)
- doFromTo 0 (size-1) $ \x -> do
- --forM [0..(size-1)] $ \x -> do
- v <- unsafeRead arr (src+x)
- unsafeWrite arr (dst+x) v
- --putStrLn("arrmove2 "++show src++" "++show dst++" "++show size)
- return ()
-
- [_$_]
-{-# INLINE arrmovesd #-}
-arrmovesd :: (Ix b, MArray a c IO) => a b c -> a b c -> Int -> Int -> Int -> IO ()
-arrmovesd arrsrc arrdst src dst size = do
- doFromTo 0 (size-1) $ \x -> do
- --forM [0..(size-1)] $ \x -> do
- v <- unsafeRead arrsrc (src+x)
- unsafeWrite arrdst (dst+x) v
- return ()
-
-{-# INLINE arrmoven #-}
-arrmoven :: (Ix i, MArray a e IO) => a i e -> Int -> Int -> Int -> Int -> Int -> IO ()
-arrmoven arr src dst size w n = do
- --putStrLn("arrmoven "++show src++" "++show dst++" "++show size++" "++show w++" "++show n)
- doFromToStep 0 ((n-1)*w) w $ \yoff -> do
- arrmove arr (src+yoff) (dst+yoff) size
- return ()
-
--- content Aware scaling
---TODO!
-seamCarvePixbuf :: Pixbuf -> Int -> Int -> Int -> IO Pixbuf
-seamCarvePixbuf pb newWidth newHeight grdCnt = do
- width <- pixbufGetWidth pb
- height <- pixbufGetHeight pb
- row <- pixbufGetRowstride pb
- chan <- pixbufGetNChannels pb
- bits <- pixbufGetBitsPerSample pb
- pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8))
- --pbn <- pixbufNew ColorspaceRgb False 8 newWidth newHeight
- pbn <- pixbufNew ColorspaceRgb False 8 newWidth newHeight
- pbnData <- (pixbufGetPixels pbn :: IO (PixbufData Int Word8))
- newRow <- pixbufGetRowstride pbn
- putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan++
- ", bits per sample: "++show bits)
- putStrLn ("width: "++show width++", height: "++show height++", newWidth: "++show newWidth++", newHeight: "++show newHeight++" bytes per row new: "++show newRow)
-
- tmpPB <- pixbufCopy pb
- tmpData <- (pixbufGetPixels tmpPB) :: IO (PixbufData Int Word8)
- ----double gradient
- [_$_]
- let computeSrcPic pb cnt | cnt <= 0 = do pixbufCopy pb
- | cnt > 0 = do
- pb <- computeSrcPic pb (cnt-1)
- gradientPixbuf pb
-
- --computing gradient but one more gradient
- --will be compute later by gradientArray function [_$_]
- tmpPB2 <- computeSrcPic tmpPB (grdCnt-1)
- tmpData2 <- (pixbufGetPixels tmpPB2) :: IO (PixbufData Int Word8)
-
- -- array to store x coord of removed pixels
- coordArr <- newArray (0, (max width height)) 0 :: IO (ArrayType Int Int) [_$_]
- [_$_]
- let removeVPixel pixData x y w = do
- --unsafeWrite pixData (0+x*chan+y*row) 255
- --unsafeWrite pixData (1+x*chan+y*row) 255
- --unsafeWrite pixData (2+x*chan+y*row) 255
- --store x-coord of removed pixel
- unsafeWrite coordArr y x
- arrmove pixData ((x+1)*chan+y*row) (x*chan+y*row) ((w-x-1)*chan)
- return () [_$_]
- [_$_]
- let removeHPixel pixData x y h = do
- --putStrLn("removeHPixel "++show x++" "++show y++" "++show h)
- --store y-coord of removed pixel
- unsafeWrite coordArr y x
- --putStrLn("removeHPixel1.5 "++show x++" "++show y++" "++show h)
- arrmoven pixData (y*chan+(x+1)*row) (y*chan+x*row) chan row (h-x-1)
- --putStrLn("removeHPixel2 "++show x++" "++show y++" "++show h)
- return () [_$_]
- [_$_]
- let removeVGrdPixel grdData x y w = do
- arrmove grdData (x+1+y*width) (x+y*width) (w-x-1)
- return ()
- [_$_]
- let removeHGrdPixel grdData x y h = do
- --putStrLn("removeHGrdPixel "++show x++" "++show y++" "++show h)
- arrmoven grdData (y+(x+1)*width) (y+x*width) 1 width (h-x-1)
- --putStrLn("removeHGrdPixel2 "++show x++" "++show y++" "++show h)
- return ()
- [_$_]
- let vPixIndex x y chan row = (x*chan)+(y*row)
- let hPixIndex x y chan row = (y*chan)+(x*row)
-
- -- possibly it can be made shorted
- let removeSeam pixIndex rmPixel rmGrdPixel seamArr grdArr x y w = do
- rmPixel tmpData x y w
- rmPixel tmpData2 x y w
- rmGrdPixel grdArr x y w
- unless (y == 0) $ do
- v0 <- if x==0 then return 0x7fffffff else unsafeRead seamArr (pixIndex (x-1) y 1 width)
- v1 <- unsafeRead seamArr (pixIndex x y 1 width)
- v2 <- if x==(w-1) then return 0x7fffffff else unsafeRead seamArr (pixIndex (x+1) y 1 width)
- let nextX | v0 < v1 && v0 < v2 = (x-1)
- | v2 < v1 = (x+1) [_$_]
- | True = x
- removeSeam pixIndex rmPixel rmGrdPixel seamArr grdArr nextX (y-1) w
-
- -- possibly it can be update to be more general
- let updateGradientArray pixIndex grdArr y w h = unless (y == -1) $ do
- x <- unsafeRead coordArr y
- unless (x == 0) $ do
- g <- pixelGradient pixIndex tmpData2 row chan w h (x-1) y
- unsafeWrite grdArr (pixIndex (x-1) y 1 width) g
- unless (y == 0) $ do
- g <- pixelGradient pixIndex tmpData2 row 1 w h (x-1) (y-1)
- unsafeWrite grdArr (pixIndex (x-1) (y-1) 1 width) g
- unless (y == (h-1)) $ do
- g <- pixelGradient pixIndex tmpData2 row 1 w h (x-1) (y+1)
- unsafeWrite grdArr (pixIndex (x-1) (y+1) 1 width) g
- g <- pixelGradient pixIndex tmpData2 row 1 w h x y
- unsafeWrite grdArr (pixIndex x y 1 width) g
- unless (y == 0) $ do
- g <- pixelGradient pixIndex tmpData2 row 1 w h x (y-1)
- unsafeWrite grdArr (pixIndex x (y-1) 1 width) g
- g <- pixelGradient pixIndex tmpData2 row 1 w h x (y+1)
- unless (y == (h-1)) $ do
- g <- pixelGradient pixIndex tmpData2 row 1 w h x (y+1)
- unsafeWrite grdArr (pixIndex x (y+1) 1 width) g
- updateGradientArray pixIndex grdArr (y-1) w h
- return ()
- [_$_]
- let findMinVal pixIndex seamArr w h = do
- v <- unsafeRead seamArr (pixIndex 0 (h-1) 1 width)
- xRef <- newIORef (v :: Int, 0 :: Int)
- --let modifyState f = readIORef state >>= f >>= writeIORef state
- doFromTo 1 (w-1) $ \x -> do
- --putStrLn("findMinVal loop x: "++show x++" (h-1): "++show (h-1))
- v <- unsafeRead seamArr (pixIndex x (h-1) 1 width)
- (mval, m) <- readIORef xRef
- writeIORef xRef (if v < mval then (v, x) else (mval, m))
- (mval, m) <- readIORef xRef
- [_$_]
- putStrLn("w: " ++show w++ " minSeam: " ++ show mval ++ " at: "++show m) [_$_]
- return m
-
- grdArr <- gradientArray tmpPB2 width height
- [_$_]
- let removeVSeam w = do
- seamArr <- (computeVSeamArray grdArr width height w)
- m <- findMinVal vPixIndex seamArr w (height-1)
- removeSeam vPixIndex removeVPixel removeVGrdPixel seamArr grdArr m (height-1) w
- updateGradientArray vPixIndex grdArr (height-1) w height
- return ()
-
- let removeHSeam h = do
- seamArr <- (computeHSeamArray grdArr width height h)
- m <- findMinVal hPixIndex seamArr h (width-1)
- removeSeam hPixIndex removeHPixel removeHGrdPixel seamArr grdArr m (width-1) h
- updateGradientArray hPixIndex grdArr (width-1) h width
- return ()
- [_$_]
- --let nextX | v0 < v1 && v0 < v2 = (x-1)
- -- | v2 < v1 = (x+1) [_$_]
- -- | True = x
- [_$_]
- let grdSeam w h | w > newWidth && h > newHeight = do
- --putStrLn("grdSeam: "++show w++" "++show h)
- vSeamArr <- (computeVSeamArray grdArr width height w)
- mv <- findMinVal vPixIndex vSeamArr w (height-1)
- hSeamArr <- (computeHSeamArray grdArr width height h)
- mh <- findMinVal hPixIndex hSeamArr h (width-1)
- if mv < mh
- then do
- removeSeam vPixIndex removeVPixel removeVGrdPixel vSeamArr grdArr mv (height-1) w
- updateGradientArray vPixIndex grdArr (height-1) w height
- grdSeam (w-1) h
- else do
- removeSeam hPixIndex removeHPixel removeHGrdPixel hSeamArr grdArr mh (width-1) h
- updateGradientArray hPixIndex grdArr (width-1) h width
- grdSeam w (h-1)
- | w > newWidth = do
- --putStrLn("grdSeam2: "++show w++" "++show h)
- removeVSeam w
- grdSeam (w-1) h
- [_$_]
- | h > newHeight = do
- --putStrLn("grdSeam3: "++show w++" "++show h)
- removeHSeam h
- grdSeam w (h-1)
- | True = do
- return ()
- [_$_]
- -- remove/add seams
- --doFromToDown width (newWidth+1) $ \w -> do
- -- removeVSeam w
- [_$_]
- --doFromToDown height (newHeight+1) $ \h -> do
- -- removeHSeam h
- [_$_]
- grdSeam width height
- [_$_]
- [_$_]
- doFromTo 0 (newHeight-1) $ \y -> do
- arrmovesd tmpData pbnData (y*row) (y*newRow) newRow
- [_$_]
- return pbn
-
--- compute the gradient map
-gradientPixbuf :: Pixbuf -> IO Pixbuf
-gradientPixbuf pb = do
- width <- pixbufGetWidth pb
- height <- pixbufGetHeight pb
- row <- pixbufGetRowstride pb
- chan <- pixbufGetNChannels pb
- bits <- pixbufGetBitsPerSample pb
- pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8))
- pbn <- pixbufNew ColorspaceRgb False 8 width height
- pbnData <- (pixbufGetPixels pbn :: IO (PixbufData Int Word8))
- putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan++", bits per sample: "++show bits)
- putStrLn ("width: "++show width++", height: "++show height)
-[_^I_][_$_]
- let getpix x y c = do
- case (x < 1 || x >= width || y < 1 || y >= height) of
- True -> return 0
- False -> (unsafeRead pbData (c+x*chan+y*row))
- [_$_]
- let gradient x y c = do
- let convM = liftM fromIntegral
- blah a b = convM (getpix a b c)
- v00 <- blah (x-1) (y-1)
- v10 <- blah x (y-1)
- v20 <- blah (x+1) (y-1)
- v01 <- blah (x-1) y
- v21 <- blah (x+1) y
- v02 <- blah (x-1) (y+1)
- v12 <- blah x (y+1)
- v22 <- blah (x+1) (y+1)
- [_$_]
- let gx = abs ((v20-v00)+2*(v21-v01)+(v22-v02))
- let gy = abs ((v02-v00)+2*(v12-v10)+(v22-v20))
- let g = (gx + gy)::Int
- --let g8 = (shiftR g 3)
- let g8 = if g > 255 then 255 else g
- return (fromIntegral(g8) :: Word8)
-
- let totalGradient x y = do
- rg <- gradient x y 0
- gg <- gradient x y 1
- bg <- gradient x y 2
- let g = rg + gg + bg
- return ((fromIntegral g)::Word8)
- [_$_]
-
- doFromTo 0 (height-1) $ \y -> do
- let offY = y*row
- doFromTo 0 (width-1) $ \x -> do
- let offX = x*chan
- doFromTo 0 2 $ \c -> do
- let off = offY+offX + c
- --putStrLn ("x: "++show x++", y: "++show y++" off:"++show off)
- --v <- (totalGradient x y)
- v <- (gradient x y c)
- unsafeWrite pbnData (off) v
- return pbn
-
--- compute gradient fo single pixel
-{-# INLINE pixelGradient #-}
-pixelGradient :: (Int -> Int -> Int -> Int -> Int) -> (PixbufData Int Word8) -> Int -> Int -> Int -> Int -> Int -> Int -> (IO Word16)
-pixelGradient pixIndex pbData row chan w h x y = do
-[_^I_][_$_]
- let getpix x y c = do
- case (x < 0 || x >= w || y < 0 || y >= h) of
- True -> return 0
- False -> (unsafeRead pbData (c+(pixIndex x y chan row)))
- --False -> (unsafeRead pbData (c+x*chan+y*row))
-
- let gradient x y c = do
- let convM = liftM fromIntegral
- blah a b = convM (getpix a b c)
- v00 <- blah (x-1) (y-1)
- v10 <- blah x (y-1)
- v20 <- blah (x+1) (y-1)
- v01 <- blah (x-1) y
- v21 <- blah (x+1) y
- v02 <- blah (x-1) (y+1)
- v12 <- blah x (y+1)
- v22 <- blah (x+1) (y+1)
- [_$_]
- let gx = abs ((v20-v00)+2*(v21-v01)+(v22-v02))
- let gy = abs ((v02-v00)+2*(v12-v10)+(v22-v20))
- let g = (gx + gy)::Int
- --let g8 = (shiftR g 3)
- let g8 = if g > 255 then 255 else g
- return (fromIntegral(g8) :: Word8)
- [_$_]
- [_$_]
- let gradient x y c = do
- let convM = liftM fromIntegral
- blah a b = convM (getpix a b c)
- v00 <- blah (x-1) (y-1)
- v10 <- blah x (y-1)
- v20 <- blah (x+1) (y-1)
- v01 <- blah (x-1) y
- v21 <- blah (x+1) y
- v02 <- blah (x-1) (y+1)
- v12 <- blah x (y+1)
- v22 <- blah (x+1) (y+1)
- let gx = abs ((v20-v00)+2*(v21-v01)+(v22-v02))
- let gy = abs ((v02-v00)+2*(v12-v10)+(v22-v20))
- let g = gx + gy
- return (g :: Int)
-
- rg <- gradient x y 0
- gg <- gradient x y 1
- bg <- gradient x y 2
- let g = rg + gg + bg
- return ((fromIntegral g) :: Word16)
-
- [_$_]
--- compute the gradient map
-gradientArray :: Pixbuf -> Int -> Int -> IO (ArrayType Int Word16)
-gradientArray pb w h = do
- width <- pixbufGetWidth pb
- height <- pixbufGetHeight pb
- row <- pixbufGetRowstride pb
- chan <- pixbufGetNChannels pb
- bits <- pixbufGetBitsPerSample pb
- pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8))
- grdArr <- newArray (0, width * height) 0
- putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan++", bits per sample: "++show bits)
- putStrLn ("width: "++show width++", height: "++show height)
-
- let vPixIndex x y chan row = x*chan+y*row
- [_$_]
- doFromTo 0 (h-1) $ \y -> do
- let offY = y*width
- doFromTo 0 (w-1) $ \x -> do
- let off = x + offY
- --v <- (totalGradient x y)
- v <- (pixelGradient vPixIndex pbData row chan w h x y)
- unsafeWrite grdArr (off) v
- --putStrLn ("x: "++show x++" y: "++show y++" v: "++show v)
- return grdArr
-
-computeVSeamArray :: (ArrayType Int Word16) -> Int -> Int -> Int -> IO (ArrayType Int Int)
-computeVSeamArray grdArr width height currentWidth = do
- [_$_]
- seamArr <- newArray (0, width * height) 0
- --grdArr <- gradientArr
- [_$_]
- doFromTo 0 (currentWidth-1) $ \x -> do
- v <- unsafeRead grdArr x
- unsafeWrite seamArr x (fromIntegral v :: Int)
- [_$_]
- doFromTo 1 (height-1) $ \y -> do
- let offY = y*width
- let prevOffY = offY-width
- doFromTo 1 (currentWidth-2) $ \x -> do
- p1 <- unsafeRead seamArr ((x-1)+prevOffY)
- p2 <- unsafeRead seamArr (x+prevOffY)
- p3 <- unsafeRead seamArr ((x+1)+prevOffY)
- v <- unsafeRead grdArr (x+offY)
- unsafeWrite seamArr (x+offY) ((fromIntegral v :: Int) +(min(min p1 p2) p3))
- p2l <- unsafeRead seamArr (0+prevOffY)
- p3l <- unsafeRead seamArr (1+prevOffY)
- vl <- unsafeRead grdArr (0+offY)
- unsafeWrite seamArr (0+offY) ((fromIntegral vl)+(min p2l p3l))
- p1r <- unsafeRead seamArr (currentWidth-2+prevOffY)
- p2r <- unsafeRead seamArr (currentWidth-1+prevOffY)
- vr <- unsafeRead grdArr (currentWidth-1+offY)
- unsafeWrite seamArr (currentWidth-1+offY) ((fromIntegral vr :: Int) +(min p1r p2r))
- [_$_]
- return seamArr
-
-computeHSeamArray :: (ArrayType Int Word16) -> Int -> Int -> Int -> IO (ArrayType Int Int)
-computeHSeamArray grdArr width height currentHeight = do
- [_$_]
- seamArr <- newArray (0, width * height) 0
- --grdArr <- gradientArr
- [_$_]
- doFromTo 0 (currentHeight-1) $ \y -> do
- v <- unsafeRead grdArr (y*width)
- unsafeWrite seamArr (y*width) (fromIntegral v :: Int)
- [_$_]
- doFromTo 1 (width-1) $ \x -> do
- doFromTo 1 (currentHeight-2) $ \y -> do
- let offY = y*width
- let prevOffY = offY-width
- let nextOffY = offY+width
- p1 <- unsafeRead seamArr (x-1+prevOffY)
- p2 <- unsafeRead seamArr (x-1+offY)
- p3 <- unsafeRead seamArr (x-1+nextOffY)
- v <- unsafeRead grdArr (x+offY)
- unsafeWrite seamArr (x+offY) ((fromIntegral v :: Int) +(min(min p1 p2) p3))
- p2l <- unsafeRead seamArr (x-1+0)
- p3l <- unsafeRead seamArr (x-1+width)
- vl <- unsafeRead grdArr (x+0)
- unsafeWrite seamArr (x+0) ((fromIntegral vl)+(min p2l p3l))
- p1r <- unsafeRead seamArr (x-1+((currentHeight-2)*width))
- p2r <- unsafeRead seamArr (x-1+((currentHeight-1)*width))
- vr <- unsafeRead grdArr (x+((currentHeight-1)*width))
- unsafeWrite seamArr (x+((currentHeight-1)*width)) ((fromIntegral vr :: Int) +(min p1r p2r))
- [_$_]
- return seamArr
rmfile ./demo/scaling/Scaling.hs
binary ./demo/scaling/Stones.jpg
rmfile ./demo/scaling/Stones.jpg
hunk ./demo/scaling/scaling.glade 1
-<?xml version="1.0" encoding="UTF-8" standalone="no"?>
-<!DOCTYPE glade-interface SYSTEM "glade-2.0.dtd">
-<!--Generated with glade3 3.0.2 on Sun Dec 14 03:54:14 2008 by btronic@EVO8-->
-<glade-interface>
- <widget class="GtkDialog" id="dialogScale">
- <property name="border_width">5</property>
- <property name="title" translatable="yes">Scale</property>
- <property name="resizable">False</property>
- <property name="modal">True</property>
- <property name="type_hint">GDK_WINDOW_TYPE_HINT_DIALOG</property>
- <property name="has_separator">False</property>
- <child internal-child="vbox">
- <widget class="GtkVBox" id="dialog-vbox2">
- <property name="visible">True</property>
- <property name="events">GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_ENTER_NOTIFY_MASK</property>
- <property name="spacing">2</property>
- <child>
- <placeholder/>
- </child>
- <child>
- <widget class="GtkHBox" id="hbox2">
- <property name="visible">True</property>
- <child>
- <widget class="GtkLabel" id="label1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Width:</property>
- </widget>
- </child>
- <child>
- <widget class="GtkEntry" id="entryScalingWidth">
- <property name="visible">True</property>
- </widget>
- <packing>
- <property name="position">1</property>
- </packing>
- </child>
- </widget>
- <packing>
- <property name="position">2</property>
- </packing>
- </child>
- <child>
- <widget class="GtkHBox" id="hbox3">
- <property name="visible">True</property>
- <child>
- <widget class="GtkLabel" id="label2">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Height:</property>
- </widget>
- </child>
- <child>
- <widget class="GtkEntry" id="entryScalingHeight">
- <property name="visible">True</property>
- </widget>
- <packing>
- <property name="position">1</property>
- </packing>
- </child>
- </widget>
- <packing>
- <property name="position">3</property>
- </packing>
- </child>
- <child>
- <placeholder/>
- </child>
- <child>
- <placeholder/>
- </child>
- <child internal-child="action_area">
- <widget class="GtkHButtonBox" id="dialog-action_area2">
- <property name="visible">True</property>
- <property name="events">GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_ENTER_NOTIFY_MASK</property>
- <property name="layout_style">GTK_BUTTONBOX_END</property>
- <child>
- <placeholder/>
- </child>
- <child>
- <placeholder/>
- </child>
- </widget>
- <packing>
- <property name="expand">False</property>
- <property name="pack_type">GTK_PACK_END</property>
- </packing>
- </child>
- </widget>
- </child>
- </widget>
- <widget class="GtkDialog" id="dialogSeamCarve">
- <property name="border_width">5</property>
- <property name="title" translatable="yes">Seam Carve</property>
- <property name="resizable">False</property>
- <property name="modal">True</property>
- <property name="type_hint">GDK_WINDOW_TYPE_HINT_DIALOG</property>
- <property name="has_separator">False</property>
- <child internal-child="vbox">
- <widget class="GtkVBox" id="dialog-vbox3">
- <property name="visible">True</property>
- <property name="events">GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_ENTER_NOTIFY_MASK</property>
- <property name="spacing">2</property>
- <child>
- <widget class="GtkHBox" id="hbox5">
- <property name="visible">True</property>
- <child>
- <widget class="GtkLabel" id="label5">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Gradient Count:</property>
- <property name="width_chars">16</property>
- </widget>
- </child>
- <child>
- <widget class="GtkEntry" id="entryGrdCnt">
- <property name="visible">True</property>
- </widget>
- <packing>
- <property name="position">1</property>
- </packing>
- </child>
- </widget>
- <packing>
- <property name="position">1</property>
- </packing>
- </child>
- <child>
- <widget class="GtkHBox" id="hbox1">
- <property name="visible">True</property>
- <child>
- <widget class="GtkLabel" id="label3">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Width:</property>
- <property name="width_chars">16</property>
- </widget>
- </child>
- <child>
- <widget class="GtkEntry" id="entryWidth">
- <property name="visible">True</property>
- </widget>
- <packing>
- <property name="position">1</property>
- </packing>
- </child>
- </widget>
- <packing>
- <property name="position">2</property>
- </packing>
- </child>
- <child>
- <widget class="GtkHBox" id="hbox4">
- <property name="visible">True</property>
- <child>
- <widget class="GtkLabel" id="label4">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Height:</property>
- <property name="width_chars">16</property>
- </widget>
- </child>
- <child>
- <widget class="GtkEntry" id="entryHeight">
- <property name="visible">True</property>
- </widget>
- <packing>
- <property name="position">1</property>
- </packing>
- </child>
- </widget>
- <packing>
- <property name="position">3</property>
- </packing>
- </child>
- <child>
- <placeholder/>
- </child>
- <child>
- <placeholder/>
- </child>
- <child internal-child="action_area">
- <widget class="GtkHButtonBox" id="dialog-action_area3">
- <property name="visible">True</property>
- <property name="events">GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_ENTER_NOTIFY_MASK</property>
- <property name="layout_style">GTK_BUTTONBOX_END</property>
- <child>
- <placeholder/>
- </child>
- <child>
- <placeholder/>
- </child>
- </widget>
- <packing>
- <property name="expand">False</property>
- <property name="pack_type">GTK_PACK_END</property>
- </packing>
- </child>
- </widget>
- </child>
- </widget>
-</glade-interface>
rmfile ./demo/scaling/scaling.glade
rmdir ./demo/scaling
adddir ./glade/demo/scaling
addfile ./glade/demo/scaling/London_Eye.jpg
binary ./glade/demo/scaling/London_Eye.jpg
addfile ./glade/demo/scaling/Makefile
hunk ./glade/demo/scaling/Makefile 1
+
+PROG = scaling
+SOURCES = Scaling.hs
+#HCFLAGS = -prof -auto-all
+# use -fglasgow-exts since older ghc versions don't know about FlexibleContexts
+HCFLAGS = -O3 -fglasgow-exts
+#HCFLAGS = -O3 -fvia-C -optc-O3
+#HCFLAGS = -O0 -keep-hc-file -keep-s-files -fvia-C
+
+$(PROG) : $(SOURCES)
+ $(HC) --make $< -o $@ $(HCFLAGS)
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
+
+HC=ghc
addfile ./glade/demo/scaling/Mountains.jpg
binary ./glade/demo/scaling/Mountains.jpg
addfile ./glade/demo/scaling/Scaling.hs
hunk ./glade/demo/scaling/Scaling.hs 1
+{-# OPTIONS -O #-}
+ --- {-# OPTIONS_GHC -XFlexibleContexts #-} see Makefile
+-- Author: Pawel Bulkowski (paw...@gm...)
+-- Thanks to Michal Palka for teaching me Haskell
+-- Photos by: Magdalena Niedziela
+-- based on other gtk2hs example applications
+-- the code is public domain
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Gdk.EventM
+
+import Data.Array.MArray
+import Data.Array.IO
+--import Data.Array.IO.Internals
+import Data.Array.Storable
+import Data.Bits
+import Data.Word
+import Data.Maybe
+import Data.IORef
+import Data.Ord
+import Control.Monad ( when, unless, liftM )
+import Control.Monad.Trans ( liftIO )
+import Control.Monad.ST
+import Data.Array.Base ( unsafeWrite, unsafeRead ) [_$_]
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Glade
+import Graphics.UI.Gtk.ModelView as New [_$_]
+import Graphics.UI.Gtk.Gdk.GC (gcNew)
+import CPUTime
+import System.Environment ( getArgs )
+import System.Directory ( doesFileExist )
+type ArrayType = IOUArray
+--type ArrayType = StorableArray
+
+-- The state and GUI
+
+data ImageState = Empty|NonEmpty
+data State = State {
+ pb :: Pixbuf,
+ is :: ImageState
+}
+
+ [_$_]
+main = do
+ args <- getArgs
+ case args of
+ [fName] -> do
+ exists <- doesFileExist fName
+ if exists then runGUI fName else
+ putStrLn ("File "++fName++" not found.")
+ _ -> putStrLn "Usage: scaling <image.jpg>"
+ [_$_]
+runGUI fName = do [_$_]
+ initGUI
+
+ window <- windowNew
+ window `onDestroy` mainQuit
+ set window [ windowTitle := "Scaling"
+ , windowResizable := True ]
+ label <- labelNew (Just "Content Aware Image Scaling")
+ vboxOuter <- vBoxNew False 0
+ vboxInner <- vBoxNew False 5
+ [_$_]
+ (mb,miOpen,miSave,miScale, miGradient, miSeamCarve, miQuit) <- makeMenuBar
+ canvas <- drawingAreaNew
+ containerAdd vboxInner canvas
+ [_$_]
+ [_$_]
+ -- Assemble the bits
+ set vboxOuter [ containerChild := mb
+ , containerChild := vboxInner ]
+ set vboxInner [ containerChild := label
+ , containerBorderWidth := 10 ]
+ set window [ containerChild := vboxOuter ]
+ [_$_]
+ -- create the Pixbuf
+ pb <- pixbufNew ColorspaceRgb False 8 256 256
+ -- Initialize the state
+ state <- newIORef State { pb = pb, is = Empty }
+ let modifyState f = readIORef state >>= f >>= writeIORef state
+
+ canvas `onSizeRequest` return (Requisition 256 256)
+ [_$_]
+
+ -- Add action handlers
+ onActivateLeaf miQuit mainQuit
+-- onActivateLeaf miOpen $ modifyState $ reset gui
+ onActivateLeaf miOpen $ modifyState $ loadImageDlg canvas window
+ onActivateLeaf miSave $ modifyState $ saveImageDlg canvas window
+ onActivateLeaf miScale $ modifyState $ scaleImageDlg canvas window
+ onActivateLeaf miGradient $ modifyState $ gradientImageDlg canvas window
+ onActivateLeaf miSeamCarve $ modifyState $ seamCarveImageDlg canvas window
+
+ modifyState (loadImage canvas window fName)
+ [_$_]
+ canvas `on` exposeEvent $ updateCanvas state
+ boxPackStartDefaults vboxInner canvas
+ widgetShowAll window
+ mainGUI
+
+ return ()
+
+ --uncomment for ghc < 6.8.3
+--instance Show Rectangle where
+-- show (Rectangle x y w h) = "x="++show x++", y="++show y++
+-- ", w="++show w++", h="++show h++";"
+
+updateCanvas :: IORef State -> EventM EExpose Bool
+updateCanvas rstate = do
+ region <- eventRegion
+ win <- eventWindow
+ liftIO $ do
+ state <- readIORef rstate
+ let (State pb is) = state
+ gc <- gcNew win
+ width <- pixbufGetWidth pb
+ height <- pixbufGetHeight pb
+ pbregion <- regionRectangle (Rectangle 0 0 width height)
+ regionIntersect region pbregion
+ rects <- regionGetRectangles region
+ putStrLn ("redrawing: "++show rects)
+ (flip mapM_) rects $ \(Rectangle x y w h) -> do
+ drawPixbuf win gc pb x y x y w h RgbDitherNone 0 0
+ return True
+
+{-# INLINE doFromTo #-}
+-- do the action for [from..to], ie it's inclusive.
+doFromTo :: Int -> Int -> (Int -> IO ()) -> IO ()
+doFromTo from to action =
+ let loop n | n > to = return ()
+ | otherwise = do action n
+ loop (n+1)
+ in loop from
+
+-- do the action for [to..from], ie it's inclusive.
+{-# INLINE doFromToDown #-}
+doFromToDown :: Int -> Int -> (Int -> IO ()) -> IO ()
+doFromToDown from to action =
+ let loop n | n < to = return ()
+ | otherwise = do action n
+ loop (n-1)
+ in loop from
+
+-- do the action for [from..to] with step, ie it's inclusive.
+{-# INLINE doFromToStep #-}
+doFromToStep :: Int -> Int -> Int -> (Int -> IO ()) -> IO ()
+doFromToStep from to step action =
+ let loop n | n > to = return ()
+ | otherwise = do action n
+ loop (n+step)
+ in loop from
+ [_$_]
+--forM = flip mapM
+ [_$_]
+makeMenuBar = do
+ mb <- menuBarNew
+ fileMenu <- menuNew
+ open <- menuItemNewWithMnemonic "_Open"
+ save <- menuItemNewWithMnemonic "_Save"
+ scale <- menuItemNewWithMnemonic "_Scale"
+ gradient <- menuItemNewWithMnemonic "_Gradient"
+ seamCarve <- menuItemNewWithMnemonic "Seam _Carve"
+ quit <- menuItemNewWithMnemonic "_Quit"
+ file <- menuItemNewWithMnemonic "_File"
+ menuShellAppend fileMenu open
+ menuShellAppend fileMenu save
+ menuShellAppend fileMenu scale
+ menuShellAppend fileMenu gradient
+ menuShellAppend fileMenu seamCarve
+ menuShellAppend fileMenu quit
+ menuItemSetSubmenu file fileMenu
+ containerAdd mb file
+ return (mb,open,save,scale,gradient,seamCarve,quit)
+
+loadImageDlg canvas window (State pb is) = do
+ putStrLn ("loadImage")
+ ret <- openFileDialog window
+ case ret of
+ Just (filename) -> (loadImage canvas window filename (State pb is))
+ Nothing -> return (State pb is)
+
+
+loadImage canvas window filename (State pb is) = do
+ putStrLn ("loadImage")
+ pxb <- pixbufNewFromFile filename
+ width <- pixbufGetWidth pxb
+ height <- pixbufGetHeight pxb
+ widgetSetSizeRequest canvas width height
+ widgetQueueDraw canvas
+-- updateCanvas canvas pxb
+ return (State pxb NonEmpty)
+
+ [_$_]
+saveImageDlg canvas window (State pb is) = do
+ putStrLn ("saveImage")
+ ret <- openFileDialog window
+ case ret of
+ Just (filename) -> do
+ pixbufSave pb filename "png" []
+ return (State pb is)
+ Nothing -> return (State pb is)
+
+scaleImageDlg canvas window (State pb is) = do
+ putStrLn ("scaleImage")
+ [_$_]
+ origWidth <- pixbufGetWidth pb
+ origHeight <- pixbufGetHeight pb
+ ret <- scaleDialog window origWidth origHeight
+
+ let update w h = do
+ putStrLn ("seamCarveImage::update w: "++show w++" h: "++show h)
+ --scalePixbuf :: Pixbuf -> Int -> Int -> IO Pixbuf
+ pxb <- scalePixbuf pb w h
+ width <- pixbufGetWidth pxb
+ height <- pixbufGetHeight pxb
+ widgetSetSizeRequest canvas width height
+ widgetQueueDraw canvas
+ --updateCanvas canvas pxb
+ return (State pxb NonEmpty)
+
+ case ret of
+ Nothing -> return (State pb NonEmpty)
+ Just (w,h) -> (update w h)
+[_^I_][_$_]
+gradientImageDlg canvas window (State pb is) = do
+ putStrLn ("gradientImageDlg")
+ --scalePixbuf :: Pixbuf -> Int -> Int -> IO Pixbuf
+ pxb <- gradientPixbuf pb
+ width <- pixbufGetWidth pxb
+ height <- pixbufGetHeight pxb
+ widgetSetSizeRequest canvas width height
+ widgetQueueDraw canvas
+-- updateCanvas canvas pxb
+ return (State pxb NonEmpty)
+[_^I_][_$_]
+seamCarveImageDlg canvas window (State pb is) = do
+ origWidth <- pixbufGetWidth pb
+ origHeight <- pixbufGetHeight pb
+ ret <- seamCarveDialog window origWidth origHeight 2
+
+ let update w h grdCnt = do
+ putStrLn ("seamCarveImageDlg::update w: "++show w++" h: "++show h)
+ --scalePixbuf :: Pixbuf -> Int -> Int -> IO Pixbuf
+ --pxb <- scalePixbuf pb w h
+ cpuStart <- getCPUTime
+ pxb <- seamCarvePixbuf pb w h grdCnt
+ cpuEnd <- getCPUTime
+ putStrLn ("seamCarveImageDlg::cpu time: "++show ((fromIntegral (cpuEnd-cpuStart) :: Double) /1e12))
+ width <- pixbufGetWidth pxb
+ height <- pixbufGetHeight pxb
+ widgetSetSizeRequest canvas width height
+ widgetQueueDraw canvas
+ --updateCanvas canvas pxb
+ return (State pxb NonEmpty)
+
+ case ret of
+ Nothing -> return (State pb NonEmpty)
+ Just (w,h,grdCnt) -> (update w h grdCnt)
+
+[_^I_][_$_]
+scaleDialog :: Window -> Int -> Int-> IO (Maybe (Int, Int))
+scaleDialog parent width height = do
+
+ Just xml <- xmlNew "scaling.glade" [_$_]
+
+ dia <- xmlGetWidget xml castToDialog "dialogScale"
+ dialogAddButton dia stockCancel ResponseCancel
+ dialogAddButton dia stockOk ResponseOk
+ entryWidth <- xmlGetWidget xml castToEntry "entryScalingWidth" [_$_]
+ entryHeight <- xmlGetWidget xml castToEntry "entryScalingHeight" [_$_]
+ entrySetText entryWidth (show width)
+ entrySetText entryHeight (show height)
+ res <- dialogRun dia
+ widthStr <- entryGetText entryWidth
+ heightStr <- entryGetText entryHeight
+ widgetDestroy dia
+ putStrLn ("scaleDialog width: "++show width++" height: "++show height)
+ case res of
+ ResponseOk -> return (Just (read widthStr,read heightStr))
+ _ -> return Nothing
+
+seamCarveDialog :: Window -> Int -> Int -> Int -> IO (Maybe (Int, Int, Int))
+seamCarveDialog parent width height grdCnt= do
+
+ Just xml <- xmlNew "scaling.glade" [_$_]
+
+ dia <- xmlGetWidget xml castToDialog "dialogSeamCarve"
+ dialogAddButton dia stockCancel ResponseCancel
+ dialogAddButton dia stockOk ResponseOk
+ entryWidth <- xmlGetWidget xml castToEntry "entryWidth" [_$_]
+ entryHeight <- xmlGetWidget xml castToEntry "entryHeight" [_$_]
+ entryGrdCnt <- xmlGetWidget xml castToEntry "entryGrdCnt" [_$_]
+ entrySetText entryWidth (show width)
+ entrySetText entryHeight (show height)
+ entrySetText entryGrdCnt (show grdCnt)
+ res <- dialogRun dia
+ widthStr <- entryGetText entryWidth
+ heightStr <- entryGetText entryHeight
+ grdCntStr <- entryGetText entryGrdCnt
+ widgetDestroy dia
+ putStrLn ("scaleDialog width: "++show width++" height: "++show height++" grdCnt: "++show grdCnt)
+ case res of
+ ResponseOk -> return (Just (read widthStr,read heightStr, read grdCntStr))
+ _ -> return Nothing
+
+ [_$_]
+openFileDialog :: Window -> IO (Maybe String)
+openFileDialog parentWindow = do
+ dialog <- fileChooserDialogNew
+ (Just "Open Profile... ")
+ (Just parentWindow)
+ FileChooserActionOpen
+ [("gtk-cancel", ResponseCancel)
+ ,("gtk-open", ResponseAccept)]
+ widgetShow dialog
+ response <- dialogRun dialog
+ widgetHide dialog
+ case response of
+ ResponseAccept -> fileChooserGetFilename dialog
+ _ -> return Nothing
+
+--simple pixbuf scaling
+scalePixbuf :: Pixbuf -> Int -> Int -> IO Pixbuf
+scalePixbuf pb newWidth newHeight = do
+ width <- pixbufGetWidth pb
+ height <- pixbufGetHeight pb
+ row <- pixbufGetRowstride pb
+ chan <- pixbufGetNChannels pb
+ bits <- pixbufGetBitsPerSample pb
+ pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8))
+ pbn <- pixbufNew ColorspaceRgb False 8 newWidth newHeight
+ pbnData <- (pixbufGetPixels pbn :: IO (PixbufData Int Word8))
+ newRow <- pixbufGetRowstride pbn
+ putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan++
+ ", bits per sample: "++show bits)
+ putStrLn ("width: "++show width++", height: "++show height++", newWidth: "++show newWidth++", newHeight: "++show newHeight++" bytes per row new: "++show newRow)
+ [_$_]
+[_^I_] [_$_]
+ let stepX = (fromIntegral width) / (fromIntegral newWidth) :: Double
+ let stepY = (fromIntegral height) / (fromIntegral newHeight) :: Double
+
+ doFromTo 0 (newHeight-1) $ \y -> do
+ let y1 = truncate ((fromIntegral y) * stepY)
+ doFromTo 0 (newWidth-1) $ \x -> do
+ let x1 = truncate ((fromIntegral x) * stepX)
+ let off = (x1*chan+y1*row)
+ let offNew = (x*chan+y*newRow)
+ --putStrLn ("x: "++show x++", y: "++show y++" x1: "++show x1++", y1: "++show y1++" off:"++show off++" offNew:"++show offNew)
+ r <- unsafeRead pbData (off)
+ g <- unsafeRead pbData (1+off)
+ b <- unsafeRead pbData (2+off)
+ unsafeWrite pbnData (offNew) r
+ unsafeWrite pbnData (1+offNew) g
+ unsafeWrite pbnData (2+offNew) b
+ return pbn
+
+
+{-# INLINE arrmove #-}
+arrmove :: (Ix i, MArray a e IO) => a i e -> Int -> Int -> Int -> IO ()
+arrmove arr src dst size = do
+
+ --putStrLn("arrmove "++show src++" "++show dst++" "++show size)
+ doFromTo 0 (size-1) $ \x -> do
+ --forM [0..(size-1)] $ \x -> do
+ v <- unsafeRead arr (src+x)
+ unsafeWrite arr (dst+x) v
+ --putStrLn("arrmove2 "++show src++" "++show dst++" "++show size)
+ return ()
+
+ [_$_]
+{-# INLINE arrmovesd #-}
+arrmovesd :: (Ix b, MArray a c IO) => a b c -> a b c -> Int -> Int -> Int -> IO ()
+arrmovesd arrsrc arrdst src dst size = do
+ doFromTo 0 (size-1) $ \x -> do
+ --forM [0..(size-1)] $ \x -> do
+ v <- unsafeRead arrsrc (src+x)
+ unsafeWrite arrdst (dst+x) v
+ return ()
+
+{-# INLINE arrmoven #-}
+arrmoven :: (Ix i, MArray a e IO) => a i e -> Int -> Int -> Int -> Int -> Int -> IO ()
+arrmoven arr src dst size w n = do
+ --putStrLn("arrmoven "++show src++" "++show dst++" "++show size++" "++show w++" "++show n)
+ doFromToStep 0 ((n-1)*w) w $ \yoff -> do
+ arrmove arr (src+yoff) (dst+yoff) size
+ return ()
+
+-- content Aware scaling
+--TODO!
+seamCarvePixbuf :: Pixbuf -> Int -> Int -> Int -> IO Pixbuf
+seamCarvePixbuf pb newWidth newHeight grdCnt = do
+ width <- pixbufGetWidth pb
+ height <- pixbufGetHeight pb
+ row <- pixbufGetRowstride pb
+ chan <- pixbufGetNChannels pb
+ bits <- pixbufGetBitsPerSample pb
+ pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8))
+ --pbn <- pixbufNew ColorspaceRgb False 8 newWidth newHeight
+ pbn <- pixbufNew ColorspaceRgb False 8 newWidth newHeight
+ pbnData <- (pixbufGetPixels pbn :: IO (PixbufData Int Word8))
+ newRow <- pixbufGetRowstride pbn
+ putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan++
+ ", bits per sample: "++show bits)
+ putStrLn ("width: "++show width++", height: "++show height++", newWidth: "++show newWidth++", newHeight: "++show newHeight++" bytes per row new: "++show newRow)
+
+ tmpPB <- pixbufCopy pb
+ tmpData <- (pixbufGetPixels tmpPB) :: IO (PixbufData Int Word8)
+ ----double gradient
+ [_$_]
+ let computeSrcPic pb cnt | cnt <= 0 = do pixbufCopy pb
+ | cnt > 0 = do
+ pb <- computeSrcPic pb (cnt-1)
+ gradientPixbuf pb
+
+ --computing gradient but one more gradient
+ --will be compute later by gradientArray function [_$_]
+ tmpPB2 <- computeSrcPic tmpPB (grdCnt-1)
+ tmpData2 <- (pixbufGetPixels tmpPB2) :: IO (PixbufData Int Word8)
+
+ -- array to store x coord of removed pixels
+ coordArr <- newArray (0, (max width height)) 0 :: IO (ArrayType Int Int) [_$_]
+ [_$_]
+ let removeVPixel pixData x y w = do
+ --unsafeWrite pixData (0+x*chan+y*row) 255
+ --unsafeWrite pixData (1+x*chan+y*row) 255
+ --unsafeWrite pixData (2+x*chan+y*row) 255
+ --store x-coord of removed pixel
+ unsafeWrite coordArr y x
+ arrmove pixData ((x+1)*chan+y*row) (x*chan+y*row) ((w-x-1)*chan)
+ return () [_$_]
+ [_$_]
+ let removeHPixel pixData x y h = do
+ --putStrLn("removeHPixel "++show x++" "++show y++" "++show h)
+ --store y-coord of removed pixel
+ unsafeWrite coordArr y x
+ --putStrLn("removeHPixel1.5 "++show x++" "++show y++" "++show h)
+ arrmoven pixData (y*chan+(x+1)*row) (y*chan+x*row) chan row (h-x-1)
+ --putStrLn("removeHPixel2 "++show x++" "++show y++" "++show h)
+ return () [_$_]
+ [_$_]
+ let removeVGrdPixel grdData x y w = do
+ arrmove grdData (x+1+y*width) (x+y*width) (w-x-1)
+ return ()
+ [_$_]
+ let removeHGrdPixel grdData x y h = do
+ --putStrLn("removeHGrdPixel "++show x++" "++show y++" "++show h)
+ arrmoven grdData (y+(x+1)*width) (y+x*width) 1 width (h-x-1)
+ --putStrLn("removeHGrdPixel2 "++show x++" "++show y++" "++show h)
+ return ()
+ [_$_]
+ let vPixIndex x y chan row = (x*chan)+(y*row)
+ let hPixIndex x y chan row = (y*chan)+(x*row)
+
+ -- possibly it can be made shorted
+ let removeSeam pixIndex rmPixel rmGr...
[truncated message content] |
|
From: Andy S. <And...@co...> - 2010-05-01 21:42:41
|
Sat May 1 17:13:35 EDT 2010 Andy Stewart <laz...@gm...>
* Move profileviewer demo to `gtk2hs/glade/demo.`
Ignore-this: 80f20961b905bca023b4813e7b99f2db
hunk ./demo/profileviewer/Makefile 1
-
-PROG = profileviewer
-SOURCES = ProfileViewer.hs ParseProfile.hs
-
-$(PROG) : $(SOURCES)
- $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
-
-HC=ghc
rmfile ./demo/profileviewer/Makefile
hunk ./demo/profileviewer/ParseProfile.hs 1
--- Copyright (c) 2004 Duncan Coutts
--- This library is liscenced under the GNU General Public License version 2
--- or (at your option) any later version.
-
--- This is a not-terribly-clever parser for ghc's time profile log files.
-
-module ParseProfile (
- Profile(..),
- ProfileNode(..),
- parseProfileFile,
- pruneOnThreshold
-) where
-
-import Char
-import Maybe (catMaybes)
-
-data Profile = Profile {
- title :: String,
- command :: String,
- totalTime :: Float,
- totalAlloc :: Integer, --can be several GB
- breakdown :: ProfileNode
- }
-
-data ProfileNode = ProfileNode {
- costCentre :: String,
- moduleName :: String,
- entries :: !Int,
- individualTime :: !Int, --scaled by 10
- individualAlloc :: !Int, --scaled by 10
- inheritedTime :: !Int, --scaled by 10
- inheritedAlloc :: !Int, --scaled by 10
- children :: [ProfileNode]
- }
-
-pruneOnThreshold :: Int -> ProfileNode -> Maybe ProfileNode
-pruneOnThreshold threshold node
- | inheritedTime node >= threshold
- || inheritedAlloc node >= threshold =
- let children' = catMaybes $ map (pruneOnThreshold threshold) (children node)
- in Just $ node { children = children' }
- | otherwise = Nothing
-
-
-parseProfileFile :: String -> IO Profile
-parseProfileFile filename = do
- content <- readFile filename
- let (titleLine:_:commandLine:_:timeLine:allocLine:theRest) = lines content
- profileDetail = dropWhile (\line -> take 4 line /= "MAIN") theRest
- return $ Profile {
- title = dropWhile isSpace titleLine,
- command = dropWhile isSpace commandLine,
- totalTime = read $ words timeLine !! 3,
- totalAlloc = read $ filter (/=',') $ words allocLine !! 3,
- breakdown = parseProfile profileDetail
- }
-
--- intermediate form
-data ProfileEntry = ProfileEntry {
- depth :: !Int,
- ecostCentre :: String,
- emoduleName :: String,
- eentries :: !Int,
- eindividualTime :: !Int, --scaled by 10
- eindividualAlloc :: !Int, --scaled by 10
- einheritedTime :: !Int, --scaled by 10
- einheritedAlloc :: !Int --scaled by 10
- }
-
-parseProfile :: [String] -> ProfileNode
-parseProfile file =
- case (profileEntriesToProfile [] 0 . map parseProfileEntry) file of
- ([profile],[]) -> profile
- _ -> error "multiple top level entries"
-
-parseProfileEntry :: String -> ProfileEntry
-parseProfileEntry line =
- let depth = length (takeWhile (==' ') line)
- in case words line of
- [costCentre, moduleName, _, entries,
- individualTime, individualAlloc,
- inheritedTime, inheritedAlloc] ->
- ProfileEntry {
- depth = depth,
- ecostCentre = costCentre,
- emoduleName = moduleName,
- eentries = read entries,
- eindividualTime = floor $ (read individualTime) * 10,
- eindividualAlloc = floor $ (read individualAlloc) * 10,
- einheritedTime = floor $ (read inheritedTime) * 10,
- einheritedAlloc = floor $ (read inheritedAlloc) * 10 [_$_]
- }
- _ -> error $ "bad profile line:\n\t" ++ line
-
-profileEntriesToProfile :: [ProfileNode] -> Int -> [ProfileEntry] -> ([ProfileNode], [ProfileEntry])
-profileEntriesToProfile acum curDepth [] = (acum, [])
-profileEntriesToProfile acum curDepth (entry:entries)
- | depth entry == curDepth =
- let (children, remaining) = profileEntriesToProfile
- [] (depth entry + 1) entries
- curNode = ProfileNode {
- costCentre = ecostCentre entry,
- moduleName = emoduleName entry,
- entries = eentries entry,
- individualTime = eindividualTime entry,
- individualAlloc = eindividualAlloc entry,
- inheritedTime = einheritedTime entry,
- inheritedAlloc = einheritedAlloc entry,
- children = children
- }
- in profileEntriesToProfile (curNode:acum) (depth entry) remaining
- | depth entry < curDepth = (acum, entry:entries) --we're done for this level
- | otherwise = error "bad indentation in file"
rmfile ./demo/profileviewer/ParseProfile.hs
hunk ./demo/profileviewer/ProfileViewer.glade 1
-<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
-<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
-
-<glade-interface>
-
-<widget class="GtkWindow" id="mainWindow">
- <property name="visible">True</property>
- <property name="title" translatable="yes">GHC timing profile viewer</property>
- <property name="type">GTK_WINDOW_TOPLEVEL</property>
- <property name="window_position">GTK_WIN_POS_NONE</property>
- <property name="modal">False</property>
- <property name="default_width">650</property>
- <property name="default_height">400</property>
- <property name="resizable">True</property>
- <property name="destroy_with_parent">False</property>
-
- <child>
- <widget class="GtkVBox" id="vbox1">
- <property name="visible">True</property>
- <property name="homogeneous">False</property>
- <property name="spacing">0</property>
-
- <child>
- <widget class="GtkMenuBar" id="menubar1">
- <property name="visible">True</property>
-
- <child>
- <widget class="GtkMenuItem" id="menuitem1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_File</property>
- <property name="use_underline">True</property>
-
- <child>
- <widget class="GtkMenu" id="menuitem1_menu">
-
- <child>
- <widget class="GtkImageMenuItem" id="openMenuItem">
- <property name="visible">True</property>
- <property name="label">gtk-open</property>
- <property name="use_stock">True</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkMenuItem" id="separatormenuitem1">
- <property name="visible">True</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkImageMenuItem" id="quitMenuItem">
- <property name="visible">True</property>
- <property name="label">gtk-quit</property>
- <property name="use_stock">True</property>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- </child>
-
- <child>
- <widget class="GtkMenuItem" id="view1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_View</property>
- <property name="use_underline">True</property>
-
- <child>
- <widget class="GtkMenu" id="view1_menu">
-
- <child>
- <widget class="GtkRadioMenuItem" id="allEntries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">All entries</property>
- <property name="use_underline">True</property>
- <property name="active">True</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkRadioMenuItem" id="0.1%Entries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Only entries with 0.1% or more</property>
- <property name="use_underline">True</property>
- <property name="active">False</property>
- <property name="group">allEntries</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkRadioMenuItem" id="0.5%Entries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Only entries with 0.5% or more</property>
- <property name="use_underline">True</property>
- <property name="active">False</property>
- <property name="group">allEntries</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkRadioMenuItem" id="1%Entries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Only entries with 1% or more</property>
- <property name="use_underline">True</property>
- <property name="active">False</property>
- <property name="group">allEntries</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkRadioMenuItem" id="5%Entries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Only entries with 5% or more</property>
- <property name="use_underline">True</property>
- <property name="active">False</property>
- <property name="group">allEntries</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkRadioMenuItem" id="10%Entries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Only entries with 10% or more</property>
- <property name="use_underline">True</property>
- <property name="active">False</property>
- <property name="group">allEntries</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkRadioMenuItem" id="50%Entries">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Only entries with 50% or more</property>
- <property name="use_underline">True</property>
- <property name="active">False</property>
- <property name="group">allEntries</property>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- </child>
-
- <child>
- <widget class="GtkMenuItem" id="menuitem4">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_Help</property>
- <property name="use_underline">True</property>
-
- <child>
- <widget class="GtkMenu" id="menuitem4_menu">
-
- <child>
- <widget class="GtkMenuItem" id="aboutMenuItem">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_About</property>
- <property name="use_underline">True</property>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">False</property>
- <property name="fill">False</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkTable" id="table1">
- <property name="border_width">5</property>
- <property name="visible">True</property>
- <property name="n_rows">4</property>
- <property name="n_columns">2</property>
- <property name="homogeneous">False</property>
- <property name="row_spacing">2</property>
- <property name="column_spacing">10</property>
-
- <child>
- <widget class="GtkLabel" id="label4">
- <property name="visible">True</property>
- <property name="label" translatable="yes"><b>Total time</b></property>
- <property name="use_underline">False</property>
- <property name="use_markup">True</property>
- <property name="justify">GTK_JUSTIFY_RIGHT</property>
- <property name="wrap">False</property>
- <property name="selectable">False</property>
- <property name="xalign">1</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">2</property>
- <property name="bottom_attach">3</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="label4">
- <property name="visible">True</property>
- <property name="label" translatable="yes"><b>Total alloc</b></property>
- <property name="use_underline">False</property>
- <property name="use_markup">True</property>
- <property name="justify">GTK_JUSTIFY_LEFT</property>
- <property name="wrap">False</property>
- <property name="selectable">False</property>
- <property name="xalign">1</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">3</property>
- <property name="bottom_attach">4</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="titleLabel">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes"></property>
- <property name="use_underline">False</property>
- <property name="use_markup">False</property>
- <property name="justify">GTK_JUSTIFY_LEFT</property>
- <property name="wrap">False</property>
- <property name="selectable">True</property>
- <property name="xalign">0</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">1</property>
- <property name="right_attach">2</property>
- <property name="top_attach">0</property>
- <property name="bottom_attach">1</property>
- <property name="x_options">expand|shrink|fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="totalTimeLabel">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes"></property>
- <property name="use_underline">False</property>
- <property name="use_markup">False</property>
- <property name="justify">GTK_JUSTIFY_LEFT</property>
- <property name="wrap">False</property>
- <property name="selectable">True</property>
- <property name="xalign">0</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">1</property>
- <property name="right_attach">2</property>
- <property name="top_attach">2</property>
- <property name="bottom_attach">3</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="totalAllocLabel">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes"></property>
- <property name="use_underline">False</property>
- <property name="use_markup">False</property>
- <property name="justify">GTK_JUSTIFY_LEFT</property>
- <property name="wrap">False</property>
- <property name="selectable">True</property>
- <property name="xalign">0</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">1</property>
- <property name="right_attach">2</property>
- <property name="top_attach">3</property>
- <property name="bottom_attach">4</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="label11">
- <property name="visible">True</property>
- <property name="label" translatable="yes"><b>Report</b></property>
- <property name="use_underline">False</property>
- <property name="use_markup">True</property>
- <property name="justify">GTK_JUSTIFY_RIGHT</property>
- <property name="wrap">False</property>
- <property name="selectable">False</property>
- <property name="xalign">1</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">0</property>
- <property name="bottom_attach">1</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="label12">
- <property name="visible">True</property>
- <property name="label" translatable="yes"><b>Command</b></property>
- <property name="use_underline">False</property>
- <property name="use_markup">True</property>
- <property name="justify">GTK_JUSTIFY_RIGHT</property>
- <property name="wrap">False</property>
- <property name="selectable">False</property>
- <property name="xalign">1</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">1</property>
- <property name="bottom_attach">2</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="commandLabel">
- <property name="visible">True</property>
- <property name="label" translatable="yes"></property>
- <property name="use_underline">False</property>
- <property name="use_markup">False</property>
- <property name="justify">GTK_JUSTIFY_LEFT</property>
- <property name="wrap">True</property>
- <property name="selectable">False</property>
- <property name="xalign">0</property>
- <property name="yalign">0</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="left_attach">1</property>
- <property name="right_attach">2</property>
- <property name="top_attach">1</property>
- <property name="bottom_attach">2</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">False</property>
- <property name="fill">False</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkScrolledWindow" id="scrolledwindow1">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
- <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
- <property name="shadow_type">GTK_SHADOW_NONE</property>
- <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
-
- <child>
- <widget class="GtkTreeView" id="mainView">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="headers_visible">True</property>
- <property name="rules_hint">True</property>
- <property name="reorderable">False</property>
- <property name="enable_search">True</property>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">True</property>
- <property name="fill">True</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkStatusbar" id="statusbar">
- <property name="visible">True</property>
- <property name="has_resize_grip">True</property>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">False</property>
- <property name="fill">False</property>
- </packing>
- </child>
- </widget>
- </child>
-</widget>
-
-</glade-interface>
rmfile ./demo/profileviewer/ProfileViewer.glade
hunk ./demo/profileviewer/ProfileViewer.gladep 1
-<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
-<!DOCTYPE glade-project SYSTEM "http://glade.gnome.org/glade-project-2.0.dtd">
-
-<glade-project>
- <name>ProfileViewer</name>
- <program_name>profileviewer</program_name>
- <gnome_support>FALSE</gnome_support>
-</glade-project>
rmfile ./demo/profileviewer/ProfileViewer.gladep
hunk ./demo/profileviewer/ProfileViewer.hs 1
--- Copyright (c) 2004 Duncan Coutts
--- This program is liscenced under the GNU General Public License version 2
--- or (at your option) any later version.
-
--- This is a slightly larger demo that combines use of glade, the file chooser
--- dialog, program state (IORefs) and use of the mogul tree view wrapper
--- interface. [_$_]
-
--- The program is a simple viewer for the log files that ghc produces when you
--- do time profiling. The parser is not very clever so loading large files can
--- take several seconds.
-
--- TODO: The gui will appear to hang when loading files. We should use threads
--- to keep the gui responsive.
-
-module Main where
-
-import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Glade
-import Graphics.UI.Gtk.ModelView as New
-
-import ParseProfile
-
-import Data.Maybe (isJust, fromJust)
-import Control.Monad (when)
-import Data.List (unfoldr, intersperse)
-import qualified Data.Tree as Tree
-import System.Environment (getArgs)
-import Data.IORef
-
-main :: IO ()
-main = do
- -- our global state
- thresholdVar <- newIORef 0 --current cuttoff/threshhold value
- profileVar <- newIORef Nothing --holds the current profile data structure
- [_$_]
- -- initialisation stuff
- initGUI
-
- Just dialogXml <- xmlNew "ProfileViewer.glade"
-
- -- get a handle on a various objects from the glade file
- mainWindow <- xmlGetWidget dialogXml castToWindow "mainWindow"
- onDestroy mainWindow mainQuit
-
- mainView <- xmlGetWidget dialogXml castToTreeView "mainView"
-
- titleLabel <- xmlGetWidget dialogXml castToLabel "titleLabel"
- commandLabel <- xmlGetWidget dialogXml castToLabel "commandLabel"
- totalTimeLabel <- xmlGetWidget dialogXml castToLabel "totalTimeLabel"
- totalAllocLabel <- xmlGetWidget dialogXml castToLabel "totalAllocLabel"
- [_$_]
- -- create the tree model
- store <- New.treeStoreNew []
- New.treeViewSetModel mainView store
-
- let createTextColumn name field = do
- column <- New.treeViewColumnNew
- New.treeViewAppendColumn mainView column
- New.treeViewColumnSetTitle column name
- cell <- New.cellRendererTextNew
- New.treeViewColumnPackStart column cell True
- New.cellLayoutSetAttributes column cell store
- (\record -> [New.cellText := field record])
-
- -- create the various columns in both the model and view
- createTextColumn "Cost Centre" costCentre
- createTextColumn "Module" moduleName
- createTextColumn "Entries" (show.entries)
- createTextColumn "Individual %time" (show.(/10).fromIntegral.individualTime)
- createTextColumn "Individual %alloc" (show.(/10).fromIntegral.individualAlloc)
- createTextColumn "Inherited %time" (show.(/10).fromIntegral.inheritedTime)
- createTextColumn "Inherited %alloc" (show.(/10).fromIntegral.inheritedAlloc)
-
- -- this action clears the tree model and then populates it with the
- -- profile contained in the profileVar, taking into account the current
- -- threshold value kept in the thresholdVar [_$_]
- let repopulateTreeStore = do
- profile <- readIORef profileVar
- maybe (return ()) repopulateTreeStore' profile
-
- repopulateTreeStore' profile = do
- New.treeStoreClear store
-
- titleLabel `labelSetText` (title profile)
- commandLabel `labelSetText` (command profile)
- totalTimeLabel `labelSetText` (show (totalTime profile) ++ " sec")
- totalAllocLabel `labelSetText` (formatNumber (totalAlloc profile) ++ " bytes")
- [_$_]
- threshold <- readIORef thresholdVar
- let node = if threshold > 0
- then pruneOnThreshold threshold (breakdown profile)
- else Just (breakdown profile)
- toTree :: ProfileNode -> Tree.Tree ProfileNode
- toTree = Tree.unfoldTree (\node -> (node, children node))
- case node of
- Nothing -> return ()
- Just node -> New.treeStoreInsertTree store [] 0 (toTree node)
-
- -- associate actions with the menus
- [_$_]
- -- the open menu item, opens a file dialog and then loads and displays
- -- the the profile (unless the user cancleled the dialog)
- openMenuItem <- xmlGetWidget dialogXml castToMenuItem "openMenuItem"
- openMenuItem `onActivateLeaf` do
- filename <- openFileDialog mainWindow
- when (isJust filename)
- (do profile <- parseProfileFile (fromJust filename)
- writeIORef profileVar (Just profile)
- repopulateTreeStore)
-
- quitMenuItem <- xmlGetWidget dialogXml castToMenuItem "quitMenuItem"
- quitMenuItem `onActivateLeaf` mainQuit
- [_$_]
- aboutMenuItem <- xmlGetWidget dialogXml castToMenuItem "aboutMenuItem"
- aboutMenuItem `onActivateLeaf` showAboutDialog mainWindow
- [_$_]
- -- each menu item in the "View" menu sets the thresholdVar and re-displays
- -- the current profile
- let doThresholdMenuItem threshold itemName = do
- menuItem <- xmlGetWidget dialogXml castToMenuItem itemName
- menuItem `onActivateLeaf` do writeIORef thresholdVar threshold
- repopulateTreeStore
- mapM_ (uncurry doThresholdMenuItem)
- [(0, "allEntries"), (1, "0.1%Entries"), (5, "0.5%Entries"), (10, "1%Entries"),
- (50, "5%Entries"), (100, "10%Entries"), (500, "50%Entries")]
-
- -- Check the command line to see if a profile file was given
- commands <- getArgs
- when (not (null commands))
- (do profile <- parseProfileFile (head commands)
- writeIORef profileVar (Just profile)
- repopulateTreeStore)
-
- -- The final step is to display the main window and run the main loop
- widgetShowAll mainWindow
- mainGUI
-
-
--- display a standard file open dialog
-openFileDialog :: Window -> IO (Maybe String)
-openFileDialog parentWindow = do
- dialog <- fileChooserDialogNew
- (Just "Open Profile... ")
- (Just parentWindow)
- FileChooserActionOpen
- [("gtk-cancel", ResponseCancel)
- ,("gtk-open", ResponseAccept)]
- widgetShow dialog
- response <- dialogRun dialog
- widgetHide dialog
- case response of
- ResponseAccept -> fileChooserGetFilename dialog
- _ -> return Nothing
-
--- just to display a number using thousand seperators
--- eg "3,456,235,596"
-formatNumber :: Integer -> String
-formatNumber =
- reverse . concat . intersperse ","
- . unfoldr (\l -> case splitAt 3 l of
- ([], _) -> Nothing
- p -> Just p)
- . reverse . show
-
-showAboutDialog :: Window -> IO ()
-showAboutDialog parent = do
- -- create the about dialog
- aboutDialog <- aboutDialogNew
-
- -- set some attributes
- set aboutDialog [
- aboutDialogName := "profileviewer",
- aboutDialogVersion := "0.2",
- aboutDialogCopyright := "Duncan Coutts",
- aboutDialogComments := "A viewer for GHC time profiles.",
- aboutDialogWebsite := "http://haskell.org/gtk2hs/"
- ]
-
- -- make the about dialog appear above the main window
- windowSetTransientFor aboutDialog parent
-
- -- make the dialog non-modal. When the user closes the dialog destroy it.
- afterResponse aboutDialog $ \_ -> widgetDestroy aboutDialog
- widgetShow aboutDialog
rmfile ./demo/profileviewer/ProfileViewer.hs
rmdir ./demo/profileviewer
adddir ./glade/demo/profileviewer
addfile ./glade/demo/profileviewer/Makefile
hunk ./glade/demo/profileviewer/Makefile 1
+
+PROG = profileviewer
+SOURCES = ProfileViewer.hs ParseProfile.hs
+
+$(PROG) : $(SOURCES)
+ $(HC) --make $< -o $@ $(HCFLAGS)
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
+
+HC=ghc
addfile ./glade/demo/profileviewer/ParseProfile.hs
hunk ./glade/demo/profileviewer/ParseProfile.hs 1
+-- Copyright (c) 2004 Duncan Coutts
+-- This library is liscenced under the GNU General Public License version 2
+-- or (at your option) any later version.
+
+-- This is a not-terribly-clever parser for ghc's time profile log files.
+
+module ParseProfile (
+ Profile(..),
+ ProfileNode(..),
+ parseProfileFile,
+ pruneOnThreshold
+) where
+
+import Char
+import Maybe (catMaybes)
+
+data Profile = Profile {
+ title :: String,
+ command :: String,
+ totalTime :: Float,
+ totalAlloc :: Integer, --can be several GB
+ breakdown :: ProfileNode
+ }
+
+data ProfileNode = ProfileNode {
+ costCentre :: String,
+ moduleName :: String,
+ entries :: !Int,
+ individualTime :: !Int, --scaled by 10
+ individualAlloc :: !Int, --scaled by 10
+ inheritedTime :: !Int, --scaled by 10
+ inheritedAlloc :: !Int, --scaled by 10
+ children :: [ProfileNode]
+ }
+
+pruneOnThreshold :: Int -> ProfileNode -> Maybe ProfileNode
+pruneOnThreshold threshold node
+ | inheritedTime node >= threshold
+ || inheritedAlloc node >= threshold =
+ let children' = catMaybes $ map (pruneOnThreshold threshold) (children node)
+ in Just $ node { children = children' }
+ | otherwise = Nothing
+
+
+parseProfileFile :: String -> IO Profile
+parseProfileFile filename = do
+ content <- readFile filename
+ let (titleLine:_:commandLine:_:timeLine:allocLine:theRest) = lines content
+ profileDetail = dropWhile (\line -> take 4 line /= "MAIN") theRest
+ return $ Profile {
+ title = dropWhile isSpace titleLine,
+ command = dropWhile isSpace commandLine,
+ totalTime = read $ words timeLine !! 3,
+ totalAlloc = read $ filter (/=',') $ words allocLine !! 3,
+ breakdown = parseProfile profileDetail
+ }
+
+-- intermediate form
+data ProfileEntry = ProfileEntry {
+ depth :: !Int,
+ ecostCentre :: String,
+ emoduleName :: String,
+ eentries :: !Int,
+ eindividualTime :: !Int, --scaled by 10
+ eindividualAlloc :: !Int, --scaled by 10
+ einheritedTime :: !Int, --scaled by 10
+ einheritedAlloc :: !Int --scaled by 10
+ }
+
+parseProfile :: [String] -> ProfileNode
+parseProfile file =
+ case (profileEntriesToProfile [] 0 . map parseProfileEntry) file of
+ ([profile],[]) -> profile
+ _ -> error "multiple top level entries"
+
+parseProfileEntry :: String -> ProfileEntry
+parseProfileEntry line =
+ let depth = length (takeWhile (==' ') line)
+ in case words line of
+ [costCentre, moduleName, _, entries,
+ individualTime, individualAlloc,
+ inheritedTime, inheritedAlloc] ->
+ ProfileEntry {
+ depth = depth,
+ ecostCentre = costCentre,
+ emoduleName = moduleName,
+ eentries = read entries,
+ eindividualTime = floor $ (read individualTime) * 10,
+ eindividualAlloc = floor $ (read individualAlloc) * 10,
+ einheritedTime = floor $ (read inheritedTime) * 10,
+ einheritedAlloc = floor $ (read inheritedAlloc) * 10 [_$_]
+ }
+ _ -> error $ "bad profile line:\n\t" ++ line
+
+profileEntriesToProfile :: [ProfileNode] -> Int -> [ProfileEntry] -> ([ProfileNode], [ProfileEntry])
+profileEntriesToProfile acum curDepth [] = (acum, [])
+profileEntriesToProfile acum curDepth (entry:entries)
+ | depth entry == curDepth =
+ let (children, remaining) = profileEntriesToProfile
+ [] (depth entry + 1) entries
+ curNode = ProfileNode {
+ costCentre = ecostCentre entry,
+ moduleName = emoduleName entry,
+ entries = eentries entry,
+ individualTime = eindividualTime entry,
+ individualAlloc = eindividualAlloc entry,
+ inheritedTime = einheritedTime entry,
+ inheritedAlloc = einheritedAlloc entry,
+ children = children
+ }
+ in profileEntriesToProfile (curNode:acum) (depth entry) remaining
+ | depth entry < curDepth = (acum, entry:entries) --we're done for this level
+ | otherwise = error "bad indentation in file"
addfile ./glade/demo/profileviewer/ProfileViewer.glade
hunk ./glade/demo/profileviewer/ProfileViewer.glade 1
+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
+<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
+
+<glade-interface>
+
+<widget class="GtkWindow" id="mainWindow">
+ <property name="visible">True</property>
+ <property name="title" translatable="yes">GHC timing profile viewer</property>
+ <property name="type">GTK_WINDOW_TOPLEVEL</property>
+ <property name="window_position">GTK_WIN_POS_NONE</property>
+ <property name="modal">False</property>
+ <property name="default_width">650</property>
+ <property name="default_height">400</property>
+ <property name="resizable">True</property>
+ <property name="destroy_with_parent">False</property>
+
+ <child>
+ <widget class="GtkVBox" id="vbox1">
+ <property name="visible">True</property>
+ <property name="homogeneous">False</property>
+ <property name="spacing">0</property>
+
+ <child>
+ <widget class="GtkMenuBar" id="menubar1">
+ <property name="visible">True</property>
+
+ <child>
+ <widget class="GtkMenuItem" id="menuitem1">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">_File</property>
+ <property name="use_underline">True</property>
+
+ <child>
+ <widget class="GtkMenu" id="menuitem1_menu">
+
+ <child>
+ <widget class="GtkImageMenuItem" id="openMenuItem">
+ <property name="visible">True</property>
+ <property name="label">gtk-open</property>
+ <property name="use_stock">True</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkMenuItem" id="separatormenuitem1">
+ <property name="visible">True</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkImageMenuItem" id="quitMenuItem">
+ <property name="visible">True</property>
+ <property name="label">gtk-quit</property>
+ <property name="use_stock">True</property>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkMenuItem" id="view1">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">_View</property>
+ <property name="use_underline">True</property>
+
+ <child>
+ <widget class="GtkMenu" id="view1_menu">
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="allEntries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">All entries</property>
+ <property name="use_underline">True</property>
+ <property name="active">True</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="0.1%Entries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Only entries with 0.1% or more</property>
+ <property name="use_underline">True</property>
+ <property name="active">False</property>
+ <property name="group">allEntries</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="0.5%Entries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Only entries with 0.5% or more</property>
+ <property name="use_underline">True</property>
+ <property name="active">False</property>
+ <property name="group">allEntries</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="1%Entries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Only entries with 1% or more</property>
+ <property name="use_underline">True</property>
+ <property name="active">False</property>
+ <property name="group">allEntries</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="5%Entries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Only entries with 5% or more</property>
+ <property name="use_underline">True</property>
+ <property name="active">False</property>
+ <property name="group">allEntries</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="10%Entries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Only entries with 10% or more</property>
+ <property name="use_underline">True</property>
+ <property name="active">False</property>
+ <property name="group">allEntries</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkRadioMenuItem" id="50%Entries">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Only entries with 50% or more</property>
+ <property name="use_underline">True</property>
+ <property name="active">False</property>
+ <property name="group">allEntries</property>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkMenuItem" id="menuitem4">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">_Help</property>
+ <property name="use_underline">True</property>
+
+ <child>
+ <widget class="GtkMenu" id="menuitem4_menu">
+
+ <child>
+ <widget class="GtkMenuItem" id="aboutMenuItem">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">_About</property>
+ <property name="use_underline">True</property>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">False</property>
+ <property name="fill">False</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkTable" id="table1">
+ <property name="border_width">5</property>
+ <property name="visible">True</property>
+ <property name="n_rows">4</property>
+ <property name="n_columns">2</property>
+ <property name="homogeneous">False</property>
+ <property name="row_spacing">2</property>
+ <property name="column_spacing">10</property>
+
+ <child>
+ <widget class="GtkLabel" id="label4">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes"><b>Total time</b></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">True</property>
+ <property name="justify">GTK_JUSTIFY_RIGHT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">False</property>
+ <property name="xalign">1</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">2</property>
+ <property name="bottom_attach">3</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="label4">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes"><b>Total alloc</b></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">True</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">False</property>
+ <property name="xalign">1</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">3</property>
+ <property name="bottom_attach">4</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="titleLabel">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes"></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">False</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">True</property>
+ <property name="xalign">0</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">1</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">0</property>
+ <property name="bottom_attach">1</property>
+ <property name="x_options">expand|shrink|fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="totalTimeLabel">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes"></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">False</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">True</property>
+ <property name="xalign">0</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">1</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">2</property>
+ <property name="bottom_attach">3</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="totalAllocLabel">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes"></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">False</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">True</property>
+ <property name="xalign">0</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">1</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">3</property>
+ <property name="bottom_attach">4</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="label11">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes"><b>Report</b></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">True</property>
+ <property name="justify">GTK_JUSTIFY_RIGHT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">False</property>
+ <property name="xalign">1</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">0</property>
+ <property name="bottom_attach">1</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="label12">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes"><b>Command</b></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">True</property>
+ <property name="justify">GTK_JUSTIFY_RIGHT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">False</property>
+ <property name="xalign">1</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">1</property>
+ <property name="bottom_attach">2</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="commandLabel">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes"></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">False</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">True</property>
+ <property name="selectable">False</property>
+ <property name="xalign">0</property>
+ <property name="yalign">0</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="left_attach">1</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">1</property>
+ <property name="bottom_attach">2</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">False</property>
+ <property name="fill">False</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkScrolledWindow" id="scrolledwindow1">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+ <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>
+ <property name="shadow_type">GTK_SHADOW_NONE</property>
+ <property name="window_placement">GTK_CORNER_TOP_LEFT</property>
+
+ <child>
+ <widget class="GtkTreeView" id="mainView">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="headers_visible">True</property>
+ <property name="rules_hint">True</property>
+ <property name="reorderable">False</property>
+ <property name="enable_search">True</property>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">True</property>
+ <property name="fill">True</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkStatusbar" id="statusbar">
+ <property name="visible">True</property>
+ <property name="has_resize_grip">True</property>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">False</property>
+ <property name="fill">False</property>
+ </packing>
+ </child>
+ </widget>
+ </child>
+</widget>
+
+</glade-interface>
addfile ./glade/demo/profileviewer/ProfileViewer.gladep
hunk ./glade/demo/profileviewer/ProfileViewer.gladep 1
+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
+<!DOCTYPE glade-project SYSTEM "http://glade.gnome.org/glade-project-2.0.dtd">
+
+<glade-project>
+ <name>ProfileViewer</name>
+ <program_name>profileviewer</program_name>
+ <gnome_support>FALSE</gnome_support>
+</glade-project>
addfile ./glade/demo/profileviewer/ProfileViewer.hs
hunk ./glade/demo/profileviewer/ProfileViewer.hs 1
+-- Copyright (c) 2004 Duncan Coutts
+-- This program is liscenced under the GNU General Public License version 2
+-- or (at your option) any later version.
+
+-- This is a slightly larger demo that combines use of glade, the file chooser
+-- dialog, program state (IORefs) and use of the mogul tree view wrapper
+-- interface. [_$_]
+
+-- The program is a simple viewer for the log files that ghc produces when you
+-- do time profiling. The parser is not very clever so loading large files can
+-- take several seconds.
+
+-- TODO: The gui will appear to hang when loading files. We should use threads
+-- to keep the gui responsive.
+
+module Main where
+
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Glade
+import Graphics.UI.Gtk.ModelView as New
+
+import ParseProfile
+
+import Data.Maybe (isJust, fromJust)
+import Control.Monad (when)
+import Data.List (unfoldr, intersperse)
+import qualified Data.Tree as Tree
+import System.Environment (getArgs)
+import Data.IORef
+
+main :: IO ()
+main = do
+ -- our global state
+ thresholdVar <- newIORef 0 --current cuttoff/threshhold value
+ profileVar <- newIORef Nothing --holds the current profile data structure
+ [_$_]
+ -- initialisation stuff
+ initGUI
+
+ Just dialogXml <- xmlNew "ProfileViewer.glade"
+
+ -- get a handle on a various objects from the glade file
+ mainWindow <- xmlGetWidget dialogXml castToWindow "mainWindow"
+ onDestroy mainWindow mainQuit
+
+ mainView <- xmlGetWidget dialogXml castToTreeView "mainView"
+
+ titleLabel <- xmlGetWidget dialogXml castToLabel "titleLabel"
+ commandLabel <- xmlGetWidget dialogXml castToLabel "commandLabel"
+ totalTimeLabel <- xmlGetWidget dialogXml castToLabel "totalTimeLabel"
+ totalAllocLabel <- xmlGetWidget dialogXml castToLabel "totalAllocLabel"
+ [_$_]
+ -- create the tree model
+ store <- New.treeStoreNew []
+ New.treeViewSetModel mainView store
+
+ let createTextColumn name field = do
+ column <- New.treeViewColumnNew
+ New.treeViewAppendColumn mainView column
+ New.treeViewColumnSetTitle column name
+ cell <- New.cellRendererTextNew
+ New.treeViewColumnPackStart column cell True
+ New.cellLayoutSetAttributes column cell store
+ (\record -> [New.cellText := field record])
+
+ -- create the various columns in both the model and view
+ createTextColumn "Cost Centre" costCentre
+ createTextColumn "Module" moduleName
+ createTextColumn "Entries" (show.entries)
+ createTextColumn "Individual %time" (show.(/10).fromIntegral.individualTime)
+ createTextColumn "Individual %alloc" (show.(/10).fromIntegral.individualAlloc)
+ createTextColumn "Inherited %time" (show.(/10).fromIntegral.inheritedTime)
+ createTextColumn "Inherited %alloc" (show.(/10).fromIntegral.inheritedAlloc)
+
+ -- this action clears the tree model and then populates it with the
+ -- profile contained in the profileVar, taking into account the current
+ -- threshold value kept in the thresholdVar [_$_]
+ let repopulateTreeStore = do
+ profile <- readIORef profileVar
+ maybe (return ()) repopulateTreeStore' profile
+
+ repopulateTreeStore' profile = do
+ New.treeStoreClear store
+
+ titleLabel `labelSetText` (title profile)
+ commandLabel `labelSetText` (command profile)
+ totalTimeLabel `labelSetText` (show (totalTime profile) ++ " sec")
+ totalAllocLabel `labelSetText` (formatNumber (totalAlloc profile) ++ " bytes")
+ [_$_]
+ threshold <- readIORef thresholdVar
+ let node = if threshold > 0
+ then pruneOnThreshold threshold (breakdown profile)
+ else Just (breakdown profile)
+ toTree :: ProfileNode -> Tree.Tree ProfileNode
+ toTree = Tree.unfoldTree (\node -> (node, children node))
+ case node of
+ Nothing -> return ()
+ Just node -> New.treeStoreInsertTree store [] 0 (toTree node)
+
+ -- associate actions with the menus
+ [_$_]
+ -- the open menu item, opens a file dialog and then loads and displays
+ -- the the profile (unless the user cancleled the dialog)
+ openMenuItem <- xmlGetWidget dialogXml castToMenuItem "openMenuItem"
+ openMenuItem `onActivateLeaf` do
+ filename <- openFileDialog mainWindow
+ when (isJust filename)
+ (do profile <- parseProfileFile (fromJust filename)
+ writeIORef profileVar (Just profile)
+ repopulateTreeStore)
+
+ quitMenuItem <- xmlGetWidget dialogXml castToMenuItem "quitMenuItem"
+ quitMenuItem `onActivateLeaf` mainQuit
+ [_$_]
+ aboutMenuItem <- xmlGetWidget dialogXml castToMenuItem "aboutMenuItem"
+ aboutMenuItem `onActivateLeaf` showAboutDialog mainWindow
+ [_$_]
+ -- each menu item in the "View" menu sets the thresholdVar and re-displays
+ -- the current profile
+ let doThresholdMenuItem threshold itemName = do
+ menuItem <- xmlGetWidget dialogXml castToMenuItem itemName
+ menuItem `onActivateLeaf` do writeIORef thresholdVar threshold
+ ...
[truncated message content] |
|
From: Andy S. <And...@co...> - 2010-05-01 21:42:40
|
Sat May 1 17:11:26 EDT 2010 Andy Stewart <laz...@gm...>
* Fix noughty demo and move to `gtk2hs/glade/demo`.
Ignore-this: 598b67397619be71313289a86c3f1dc6
binary ./demo/noughty/Cross.png
rmfile ./demo/noughty/Cross.png
hunk ./demo/noughty/License 1
-Copyright (c) 2006, Wouter Swierstra
-All rights reserved.
hunk ./demo/noughty/License 2
-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 the University of Nottingham nor the names of
-its 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.
rmfile ./demo/noughty/License
hunk ./demo/noughty/Makefile 1
-
-PROGS = noughty noughty-glade
-SOURCES = Noughty.hs NoughtyGlade.hs
-
-all : $(PROGS)
-
-noughty : Noughty.hs
- $(HC_RULE)
-
-noughty-glade : NoughtyGlade.hs
- $(HC_RULE)
-
-HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
-
-HC=ghc
rmfile ./demo/noughty/Makefile
binary ./demo/noughty/Nought.png
rmfile ./demo/noughty/Nought.png
hunk ./demo/noughty/Noughty.hs 1
--- Copyright (c) 2006, Wouter Swierstra
--- All rights reserved.
--- This code is released under the BSD license
--- included in this distribution
-
--- Imports
-
-import IO
-import Maybe
-import List
-import Graphics.UI.Gtk
-import Data.IORef
-import Control.Monad
-
--- Players, boards and some useful pure functions
-
-data Player = Nought | Blank | Cross deriving (Ord, Eq, Show)
-
-next :: Player -> Player
-next Nought = Cross
-next Blank = Blank
-next Cross = Nought
-
-type Board = [[Player]]
-
-size :: Int
-size = 3
-
-empty :: Board
-empty = replicate size (replicate size Blank)
-
-move :: Int -> Player -> Board -> Maybe Board
-move n p b = case y of
- Blank -> Just (chop size (xs ++ (p : ys)))
- _ -> Nothing
- where
- (xs,y:ys) = splitAt n (concat b)
-
-chop :: Int -> [a] -> [[a]]
-chop n [] = []
-chop n xs = take n xs : chop n (drop n xs)
-
-diag :: [[a]] -> [a]
-diag xss = [xss !! n !! n | n <- [0 .. length xss - 1]]
-
-full :: Board -> Bool
-full b = all (all (/= Blank)) b
-
-wins :: Player -> Board -> Bool
-wins p b = any (all (== p)) b
- || any (all (== p)) (transpose b)
- || all (== p) (diag b)
- || all (== p) (diag (reverse b))
-
-won :: Board -> Bool
-won b = wins Nought b || wins Cross b
-
--- The state and GUI
-
-data State = State {
- board :: Board,
- turn :: Player
-}
-
-data GUI = GUI {
- disableBoard :: IO (),
- resetBoard :: IO (),
- setSquare :: Int -> Player -> IO (),
- setStatus :: String -> IO ()
-}
-
--- reset the game
-reset gui (State board turn) = do
- setStatus gui "Player Cross: make your move."
- resetBoard gui
- return (State empty Cross)
-
--- when a square is clicked on, try to make a move.
--- if the square is already occupied, nothing happens
--- otherwise, update the board, let the next player make his move,
--- and check whether someone has won or the board is full.
-occupy gui square st@(State board player) = do
- case move square player board of
- Nothing -> return st
- Just newBoard -> do
- setSquare gui square player
- handleMove gui newBoard player
- return (State newBoard (next player))
-
--- check whether a board is won or full
-handleMove gui board player
- | wins player board = do
- setStatus gui ("Player " ++ show player ++ " wins!")
- disableBoard gui
- | full board = do
- setStatus gui "It's a draw."
- disableBoard gui
- | otherwise = do
- setStatus gui ("Player " ++ show (next player) ++ ": make your move")
-
-main = do
- initGUI
- window <- windowNew
- window `onDestroy` mainQuit
- set window [ windowTitle := "Noughty"
- , windowResizable := False ]
- label <- labelNew (Just "Player Cross: make your move.")
- vboxOuter <- vBoxNew False 0
- vboxInner <- vBoxNew False 5
-
--- Add an initial board to the inner vBox and make the menu bar
- (squares, images) <- addFieldsTo vboxInner
- (mb,newGame,quit) <- makeMenuBar
-
- -- Construct the GUI actions that abstracts from the actual widgets
- gui <- guiActions squares images label
-
- -- Initialize the state
- state <- newIORef State { board = empty, turn = Cross }
- let modifyState f = readIORef state >>= f >>= writeIORef state
-
- -- Add action handlers
- onActivateLeaf quit mainQuit
- onActivateLeaf newGame $ modifyState $ reset gui
- zipWithM_ (\square i ->
- onPressed square $ modifyState $ occupy gui i)
- squares [0..8]
-
- -- Assemble the bits
- set vboxOuter [ containerChild := mb
- , containerChild := vboxInner ]
- set vboxInner [ containerChild := label
- , containerBorderWidth := 10 ]
- set window [ containerChild := vboxOuter ]
-
- widgetShowAll window
- mainGUI
-
-guiActions buttons images label = do
- noughtPic <- pixbufNewFromFile "Nought.png"
- crossPic <- pixbufNewFromFile "Cross.png"
- return GUI {
- disableBoard = mapM_ (flip widgetSetSensitivity False) buttons,
- resetBoard = do
- mapM_ (\i -> imageClear i >> widgetQueueDraw i) images
- mapM_ (flip widgetSetSensitivity True) buttons,
- setSquare = \ i player ->
- case player of
- Cross -> set (images !! i) [ imagePixbuf := crossPic ]
- Nought-> set (images !! i) [ imagePixbuf := noughtPic ],
- setStatus = labelSetText label}
-
-makeMenuBar = do
- mb <- menuBarNew
- fileMenu <- menuNew
- newGame <- menuItemNewWithMnemonic "_New Game"
- quit <- menuItemNewWithMnemonic "_Quit"
- file <- menuItemNewWithMnemonic "_Game"
- menuShellAppend fileMenu newGame
- menuShellAppend fileMenu quit
- menuItemSetSubmenu file fileMenu
- containerAdd mb file
- return (mb,newGame,quit)
-
-addFieldsTo container = do
- table <- tableNew 5 5 False
- buttons@[b0,b1,b2,b3,b4,b5,b6,b7,b8] <- replicateM 9 squareNew
- images <- replicateM 9 imageNew
- zipWithM_ containerAdd buttons images
- tableAttachDefaults table b0 0 1 0 1
- tableAttachDefaults table b1 2 3 0 1
- tableAttachDefaults table b2 4 5 0 1
- tableAttachDefaults table b3 0 1 2 3
- tableAttachDefaults table b4 2 3 2 3
- tableAttachDefaults table b5 4 5 2 3
- tableAttachDefaults table b6 0 1 4 5
- tableAttachDefaults table b7 2 3 4 5
- tableAttachDefaults table b8 4 5 4 5
- vline1 <- vSeparatorNew
- vline2 <- vSeparatorNew
- hline1 <- hSeparatorNew
- hline2 <- hSeparatorNew
- tableAttachDefaults table vline1 1 2 0 5
- tableAttachDefaults table vline2 3 4 0 5
- tableAttachDefaults table hline1 0 5 1 2
- tableAttachDefaults table hline2 0 5 3 4
- tableSetRowSpacings table 0
- tableSetColSpacings table 0
- containerAdd container table
- return (buttons, images)
-
-squareNew = do
- square <- buttonNew
- widgetSetSizeRequest square 100 100
- set square [ widgetCanFocus := False, buttonRelief := ReliefNone]
- return square
rmfile ./demo/noughty/Noughty.hs
hunk ./demo/noughty/NoughtyGlade.hs 1
--- Copyright (c) 2006, Wouter Swierstra
--- All rights reserved.
--- This code is released under the BSD license
--- included in this distribution
-
--- Imports
-
-import IO
-import Maybe
-import List
-import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Glade
-import Data.IORef
-import Control.Monad
-
--- Players, boards and some useful pure functions
-
-data Player = Nought | Blank | Cross deriving (Ord, Eq, Show)
-
-next :: Player -> Player
-next Nought = Cross
-next Blank = Blank
-next Cross = Nought
-
-type Board = [[Player]]
-
-size :: Int
-size = 3
-
-empty :: Board
-empty = replicate size (replicate size Blank)
-
-move :: Int -> Player -> Board -> Maybe Board
-move n p b = case y of
- Blank -> Just (chop size (xs ++ (p : ys)))
- _ -> Nothing
- where
- (xs,y:ys) = splitAt n (concat b)
-
-chop :: Int -> [a] -> [[a]]
-chop n [] = []
-chop n xs = take n xs : chop n (drop n xs)
-
-diag :: [[a]] -> [a]
-diag xss = [xss !! n !! n | n <- [0 .. length xss - 1]]
-
-full :: Board -> Bool
-full b = all (all (/= Blank)) b
-
-wins :: Player -> Board -> Bool
-wins p b = any (all (== p)) b
- || any (all (== p)) (transpose b)
- || all (== p) (diag b)
- || all (== p) (diag (reverse b))
-
-won :: Board -> Bool
-won b = wins Nought b || wins Cross b
-
--- The state and GUI
-
-data State = State {
- board :: Board,
- turn :: Player
-}
-
-data GUI = GUI {
- disableBoard :: IO (),
- resetBoard :: IO (),
- setSquare :: Int -> Player -> IO (),
- setStatus :: String -> IO ()
-}
-
--- reset the game
-reset gui (State board turn) = do
- setStatus gui "Player Cross: make your move."
- resetBoard gui
- return (State empty Cross)
-
--- when a square is clicked on, try to make a move.
--- if the square is already occupied, nothing happens
--- otherwise, update the board, let the next player make his move,
--- and check whether someone has won or the board is full.
-occupy gui square st@(State board player) = do
- case move square player board of
- Nothing -> return st
- Just newBoard -> do
- setSquare gui square player
- handleMove gui newBoard player
- return (State newBoard (next player))
-
--- check whether a board is won or full
-handleMove gui board player
- | wins player board = do
- setStatus gui ("Player " ++ show player ++ " wins!")
- disableBoard gui
- | full board = do
- setStatus gui "It's a draw."
- disableBoard gui
- | otherwise = do
- setStatus gui ("Player " ++ show (next player) ++ ": make your move")
-
-main = do
- initGUI
-
- -- Extract widgets from the glade xml file
- Just xml <- xmlNew "noughty.glade"
-
- window <- xmlGetWidget xml castToWindow "window"
- window `onDestroy` mainQuit
-
- newGame <- xmlGetWidget xml castToMenuItem "newGame"
- quit <- xmlGetWidget xml castToMenuItem "quit"
-
- squares <- flip mapM [1..9] $ \n -> do
- square <- xmlGetWidget xml castToButton ("button" ++ show n)
- -- we set this in the glde file but it doesn't seem to work there.
- set square [ widgetCanFocus := False ]
- return square
-
- images <- flip mapM [1..9] $ \n -> do
- xmlGetWidget xml castToImage ("image" ++ show n)
-
- statusbar <- xmlGetWidget xml castToStatusbar "statusbar"
- ctx <- statusbarGetContextId statusbar "state"
- statusbarPush statusbar ctx "Player Cross: make your move."
-
- -- Construct the GUI actions that abstracts from the actual widgets
- gui <- guiActions squares images statusbar ctx
-
- -- Initialize the state
- state <- newIORef State { board = empty, turn = Cross }
- let modifyState f = readIORef state >>= f >>= writeIORef state
-
- -- Add action handlers
- onActivateLeaf quit mainQuit
- onActivateLeaf newGame $ modifyState $ reset gui
- zipWithM_ (\square i ->
- onPressed square $ modifyState $ occupy gui i)
- squares [0..8]
-
- widgetShowAll window
- mainGUI
-
-guiActions buttons images statusbar ctx = do
- noughtPic <- pixbufNewFromFile "Nought.png"
- crossPic <- pixbufNewFromFile "Cross.png"
- return GUI {
- disableBoard = mapM_ (flip widgetSetSensitivity False) buttons,
- resetBoard = do
- mapM_ (\i -> imageClear i >> widgetQueueDraw i) images
- mapM_ (flip widgetSetSensitivity True) buttons,
- setSquare = \ i player ->
- case player of
- Cross -> set (images !! i) [ imagePixbuf := crossPic ]
- Nought-> set (images !! i) [ imagePixbuf := noughtPic ],
- setStatus = \msg -> do
- statusbarPop statusbar ctx
- statusbarPush statusbar ctx msg
- return ()
- }
rmfile ./demo/noughty/NoughtyGlade.hs
hunk ./demo/noughty/noughty.glade 1
-<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
-<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
-
-<glade-interface>
-
-<widget class="GtkWindow" id="window">
- <property name="title" translatable="yes">Noughty</property>
- <property name="type">GTK_WINDOW_TOPLEVEL</property>
- <property name="window_position">GTK_WIN_POS_NONE</property>
- <property name="modal">False</property>
- <property name="resizable">False</property>
- <property name="destroy_with_parent">False</property>
- <property name="decorated">True</property>
- <property name="skip_taskbar_hint">False</property>
- <property name="skip_pager_hint">False</property>
- <property name="type_hint">GDK_WINDOW_TYPE_HINT_NORMAL</property>
- <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>
- <property name="focus_on_map">True</property>
- <property name="urgency_hint">False</property>
-
- <child>
- <widget class="GtkVBox" id="vbox1">
- <property name="visible">True</property>
- <property name="homogeneous">False</property>
- <property name="spacing">0</property>
-
- <child>
- <widget class="GtkMenuBar" id="menubar1">
- <property name="visible">True</property>
- <property name="pack_direction">GTK_PACK_DIRECTION_LTR</property>
- <property name="child_pack_direction">GTK_PACK_DIRECTION_LTR</property>
-
- <child>
- <widget class="GtkMenuItem" id="menuitem1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_Game</property>
- <property name="use_underline">True</property>
-
- <child>
- <widget class="GtkMenu" id="menuitem1_menu">
-
- <child>
- <widget class="GtkMenuItem" id="newGame">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_New Game</property>
- <property name="use_underline">True</property>
- <accelerator key="n" modifiers="GDK_CONTROL_MASK" signal="activate"/>
- </widget>
- </child>
-
- <child>
- <widget class="GtkSeparatorMenuItem" id="separatormenuitem1">
- <property name="visible">True</property>
- </widget>
- </child>
-
- <child>
- <widget class="GtkMenuItem" id="quit">
- <property name="visible">True</property>
- <property name="label" translatable="yes">_Quit</property>
- <property name="use_underline">True</property>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">False</property>
- <property name="fill">False</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkTable" id="table1">
- <property name="border_width">10</property>
- <property name="visible">True</property>
- <property name="n_rows">5</property>
- <property name="n_columns">5</property>
- <property name="homogeneous">False</property>
- <property name="row_spacing">0</property>
- <property name="column_spacing">0</property>
-
- <child>
- <widget class="GtkHSeparator" id="hseparator1">
- <property name="visible">True</property>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">5</property>
- <property name="top_attach">1</property>
- <property name="bottom_attach">2</property>
- <property name="x_options">fill</property>
- <property name="y_options">fill</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkVSeparator" id="vseparator1">
- <property name="visible">True</property>
- </widget>
- <packing>
- <property name="left_attach">1</property>
- <property name="right_attach">2</property>
- <property name="top_attach">0</property>
- <property name="bottom_attach">5</property>
- <property name="x_options">fill</property>
- <property name="y_options">fill</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkVSeparator" id="vseparator2">
- <property name="visible">True</property>
- </widget>
- <packing>
- <property name="left_attach">3</property>
- <property name="right_attach">4</property>
- <property name="top_attach">0</property>
- <property name="bottom_attach">5</property>
- <property name="x_options">fill</property>
- <property name="y_options">fill</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="button1">
- <property name="width_request">100</property>
- <property name="height_request">100</property>
- <property name="visible">True</property>
- <property name="relief">GTK_RELIEF_NONE</property>
- <property name="focus_on_click">False</property>
-
- <child>
- <widget class="GtkImage" id="image1">
- <property name="visible">True</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">0</property>
- <property name="bottom_attach">1</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="button2">
- <property name="width_request">100</property>
- <property name="height_request">100</property>
- <property name="visible">True</property>
- <property name="relief">GTK_RELIEF_NONE</property>
- <property name="focus_on_click">False</property>
-
- <child>
- <widget class="GtkImage" id="image2">
- <property name="visible">True</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="left_attach">2</property>
- <property name="right_attach">3</property>
- <property name="top_attach">0</property>
- <property name="bottom_attach">1</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="button3">
- <property name="width_request">100</property>
- <property name="height_request">100</property>
- <property name="visible">True</property>
- <property name="relief">GTK_RELIEF_NONE</property>
- <property name="focus_on_click">False</property>
-
- <child>
- <widget class="GtkImage" id="image3">
- <property name="visible">True</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="left_attach">4</property>
- <property name="right_attach">5</property>
- <property name="top_attach">0</property>
- <property name="bottom_attach">1</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="button4">
- <property name="width_request">100</property>
- <property name="height_request">100</property>
- <property name="visible">True</property>
- <property name="relief">GTK_RELIEF_NONE</property>
- <property name="focus_on_click">False</property>
-
- <child>
- <widget class="GtkImage" id="image4">
- <property name="visible">True</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">2</property>
- <property name="bottom_attach">3</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="button5">
- <property name="width_request">100</property>
- <property name="height_request">100</property>
- <property name="visible">True</property>
- <property name="relief">GTK_RELIEF_NONE</property>
- <property name="focus_on_click">False</property>
-
- <child>
- <widget class="GtkImage" id="image5">
- <property name="visible">True</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="left_attach">2</property>
- <property name="right_attach">3</property>
- <property name="top_attach">2</property>
- <property name="bottom_attach">3</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="button6">
- <property name="width_request">100</property>
- <property name="height_request">100</property>
- <property name="visible">True</property>
- <property name="relief">GTK_RELIEF_NONE</property>
- <property name="focus_on_click">False</property>
-
- <child>
- <widget class="GtkImage" id="image6">
- <property name="visible">True</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="left_attach">4</property>
- <property name="right_attach">5</property>
- <property name="top_attach">2</property>
- <property name="bottom_attach">3</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="button7">
- <property name="width_request">100</property>
- <property name="height_request">100</property>
- <property name="visible">True</property>
- <property name="relief">GTK_RELIEF_NONE</property>
- <property name="focus_on_click">False</property>
-
- <child>
- <widget class="GtkImage" id="image7">
- <property name="visible">True</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">4</property>
- <property name="bottom_attach">5</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="button8">
- <property name="width_request">100</property>
- <property name="height_request">100</property>
- <property name="visible">True</property>
- <property name="relief">GTK_RELIEF_NONE</property>
- <property name="focus_on_click">False</property>
-
- <child>
- <widget class="GtkImage" id="image8">
- <property name="visible">True</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="left_attach">2</property>
- <property name="right_attach">3</property>
- <property name="top_attach">4</property>
- <property name="bottom_attach">5</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="button9">
- <property name="width_request">100</property>
- <property name="height_request">100</property>
- <property name="visible">True</property>
- <property name="relief">GTK_RELIEF_NONE</property>
- <property name="focus_on_click">False</property>
-
- <child>
- <widget class="GtkImage" id="image9">
- <property name="visible">True</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="left_attach">4</property>
- <property name="right_attach">5</property>
- <property name="top_attach">4</property>
- <property name="bottom_attach">5</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkHSeparator" id="hseparator2">
- <property name="visible">True</property>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">5</property>
- <property name="top_attach">3</property>
- <property name="bottom_attach">4</property>
- <property name="x_options">fill</property>
- <property name="y_options">fill</property>
- </packing>
- </child>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">True</property>
- <property name="fill">True</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkStatusbar" id="statusbar">
- <property name="visible">True</property>
- <property name="has_resize_grip">False</property>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">False</property>
- <property name="fill">False</property>
- </packing>
- </child>
- </widget>
- </child>
-</widget>
-
-</glade-interface>
rmfile ./demo/noughty/noughty.glade
rmdir ./demo/noughty
adddir ./glade/demo/noughty
addfile ./glade/demo/noughty/Cross.png
binary ./glade/demo/noughty/Cross.png
addfile ./glade/demo/noughty/License
hunk ./glade/demo/noughty/License 1
+Copyright (c) 2006, Wouter Swierstra
+All rights reserved.
hunk ./glade/demo/noughty/License 4
+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 the University of Nottingham nor the names of
+its 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.
addfile ./glade/demo/noughty/Makefile
hunk ./glade/demo/noughty/Makefile 1
+
+PROGS = noughty noughty-glade
+SOURCES = Noughty.hs NoughtyGlade.hs
+
+all : $(PROGS)
+
+noughty : Noughty.hs
+ $(HC_RULE)
+
+noughty-glade : NoughtyGlade.hs
+ $(HC_RULE)
+
+HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS)
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
+
+HC=ghc
addfile ./glade/demo/noughty/Nought.png
binary ./glade/demo/noughty/Nought.png
addfile ./glade/demo/noughty/Noughty.hs
hunk ./glade/demo/noughty/Noughty.hs 1
+-- Copyright (c) 2006, Wouter Swierstra
+-- All rights reserved.
+-- This code is released under the BSD license
+-- included in this distribution
+
+-- Imports
+
+import IO
+import Maybe
+import List
+import Graphics.UI.Gtk hiding (Cross)
+import Data.IORef
+import Control.Monad
+
+-- Players, boards and some useful pure functions
+
+data Player = Nought | Blank | Cross deriving (Ord, Eq, Show)
+
+next :: Player -> Player
+next Nought = Cross
+next Blank = Blank
+next Cross = Nought
+
+type Board = [[Player]]
+
+size :: Int
+size = 3
+
+empty :: Board
+empty = replicate size (replicate size Blank)
+
+move :: Int -> Player -> Board -> Maybe Board
+move n p b = case y of
+ Blank -> Just (chop size (xs ++ (p : ys)))
+ _ -> Nothing
+ where
+ (xs,y:ys) = splitAt n (concat b)
+
+chop :: Int -> [a] -> [[a]]
+chop n [] = []
+chop n xs = take n xs : chop n (drop n xs)
+
+diag :: [[a]] -> [a]
+diag xss = [xss !! n !! n | n <- [0 .. length xss - 1]]
+
+full :: Board -> Bool
+full b = all (all (/= Blank)) b
+
+wins :: Player -> Board -> Bool
+wins p b = any (all (== p)) b
+ || any (all (== p)) (transpose b)
+ || all (== p) (diag b)
+ || all (== p) (diag (reverse b))
+
+won :: Board -> Bool
+won b = wins Nought b || wins Cross b
+
+-- The state and GUI
+
+data State = State {
+ board :: Board,
+ turn :: Player
+}
+
+data GUI = GUI {
+ disableBoard :: IO (),
+ resetBoard :: IO (),
+ setSquare :: Int -> Player -> IO (),
+ setStatus :: String -> IO ()
+}
+
+-- reset the game
+reset gui (State board turn) = do
+ setStatus gui "Player Cross: make your move."
+ resetBoard gui
+ return (State empty Cross)
+
+-- when a square is clicked on, try to make a move.
+-- if the square is already occupied, nothing happens
+-- otherwise, update the board, let the next player make his move,
+-- and check whether someone has won or the board is full.
+occupy gui square st@(State board player) = do
+ case move square player board of
+ Nothing -> return st
+ Just newBoard -> do
+ setSquare gui square player
+ handleMove gui newBoard player
+ return (State newBoard (next player))
+
+-- check whether a board is won or full
+handleMove gui board player
+ | wins player board = do
+ setStatus gui ("Player " ++ show player ++ " wins!")
+ disableBoard gui
+ | full board = do
+ setStatus gui "It's a draw."
+ disableBoard gui
+ | otherwise = do
+ setStatus gui ("Player " ++ show (next player) ++ ": make your move")
+
+main = do
+ initGUI
+ window <- windowNew
+ window `onDestroy` mainQuit
+ set window [ windowTitle := "Noughty"
+ , windowResizable := False ]
+ label <- labelNew (Just "Player Cross: make your move.")
+ vboxOuter <- vBoxNew False 0
+ vboxInner <- vBoxNew False 5
+
+-- Add an initial board to the inner vBox and make the menu bar
+ (squares, images) <- addFieldsTo vboxInner
+ (mb,newGame,quit) <- makeMenuBar
+
+ -- Construct the GUI actions that abstracts from the actual widgets
+ gui <- guiActions squares images label
+
+ -- Initialize the state
+ state <- newIORef State { board = empty, turn = Cross }
+ let modifyState f = readIORef state >>= f >>= writeIORef state
+
+ -- Add action handlers
+ onActivateLeaf quit mainQuit
+ onActivateLeaf newGame $ modifyState $ reset gui
+ zipWithM_ (\square i ->
+ onPressed square $ modifyState $ occupy gui i)
+ squares [0..8]
+
+ -- Assemble the bits
+ set vboxOuter [ containerChild := mb
+ , containerChild := vboxInner ]
+ set vboxInner [ containerChild := label
+ , containerBorderWidth := 10 ]
+ set window [ containerChild := vboxOuter ]
+
+ widgetShowAll window
+ mainGUI
+
+guiActions buttons images label = do
+ noughtPic <- pixbufNewFromFile "Nought.png"
+ crossPic <- pixbufNewFromFile "Cross.png"
+ return GUI {
+ disableBoard = mapM_ (flip widgetSetSensitivity False) buttons,
+ resetBoard = do
+ mapM_ (\i -> imageClear i >> widgetQueueDraw i) images
+ mapM_ (flip widgetSetSensitivity True) buttons,
+ setSquare = \ i player ->
+ case player of
+ Cross -> set (images !! i) [ imagePixbuf := crossPic ]
+ Nought-> set (images !! i) [ imagePixbuf := noughtPic ],
+ setStatus = labelSetText label}
+
+makeMenuBar = do
+ mb <- menuBarNew
+ fileMenu <- menuNew
+ newGame <- menuItemNewWithMnemonic "_New Game"
+ quit <- menuItemNewWithMnemonic "_Quit"
+ file <- menuItemNewWithMnemonic "_Game"
+ menuShellAppend fileMenu newGame
+ menuShellAppend fileMenu quit
+ menuItemSetSubmenu file fileMenu
+ containerAdd mb file
+ return (mb,newGame,quit)
+
+addFieldsTo container = do
+ table <- tableNew 5 5 False
+ buttons@[b0,b1,b2,b3,b4,b5,b6,b7,b8] <- replicateM 9 squareNew
+ images <- replicateM 9 imageNew
+ zipWithM_ containerAdd buttons images
+ tableAttachDefaults table b0 0 1 0 1
+ tableAttachDefaults table b1 2 3 0 1
+ tableAttachDefaults table b2 4 5 0 1
+ tableAttachDefaults table b3 0 1 2 3
+ tableAttachDefaults table b4 2 3 2 3
+ tableAttachDefaults table b5 4 5 2 3
+ tableAttachDefaults table b6 0 1 4 5
+ tableAttachDefaults table b7 2 3 4 5
+ tableAttachDefaults table b8 4 5 4 5
+ vline1 <- vSeparatorNew
+ vline2 <- vSeparatorNew
+ hline1 <- hSeparatorNew
+ hline2 <- hSeparatorNew
+ tableAttachDefaults table vline1 1 2 0 5
+ tableAttachDefaults table vline2 3 4 0 5
+ tableAttachDefaults table hline1 0 5 1 2
+ tableAttachDefaults table hline2 0 5 3 4
+ tableSetRowSpacings table 0
+ tableSetColSpacings table 0
+ containerAdd container table
+ return (buttons, images)
+
+squareNew = do
+ square <- buttonNew
+ widgetSetSizeRequest square 100 100
+ set square [ widgetCanFocus := False, buttonRelief := ReliefNone]
+ return square
addfile ./glade/demo/noughty/NoughtyGlade.hs
hunk ./glade/demo/noughty/NoughtyGlade.hs 1
+-- Copyright (c) 2006, Wouter Swierstra
+-- All rights reserved.
+-- This code is released under the BSD license
+-- included in this distribution
+
+-- Imports
+
+import IO
+import Maybe
+import List
+import Graphics.UI.Gtk hiding (Cross)
+import Graphics.UI.Gtk.Glade
+import Data.IORef
+import Control.Monad
+
+-- Players, boards and some useful pure functions
+
+data Player = Nought | Blank | Cross deriving (Ord, Eq, Show)
+
+next :: Player -> Player
+next Nought = Cross
+next Blank = Blank
+next Cross = Nought
+
+type Board = [[Player]]
+
+size :: Int
+size = 3
+
+empty :: Board
+empty = replicate size (replicate size Blank)
+
+move :: Int -> Player -> Board -> Maybe Board
+move n p b = case y of
+ Blank -> Just (chop size (xs ++ (p : ys)))
+ _ -> Nothing
+ where
+ (xs,y:ys) = splitAt n (concat b)
+
+chop :: Int -> [a] -> [[a]]
+chop n [] = []
+chop n xs = take n xs : chop n (drop n xs)
+
+diag :: [[a]] -> [a]
+diag xss = [xss !! n !! n | n <- [0 .. length xss - 1]]
+
+full :: Board -> Bool
+full b = all (all (/= Blank)) b
+
+wins :: Player -> Board -> Bool
+wins p b = any (all (== p)) b
+ || any (all (== p)) (transpose b)
+ || all (== p) (diag b)
+ || all (== p) (diag (reverse b))
+
+won :: Board -> Bool
+won b = wins Nought b || wins Cross b
+
+-- The state and GUI
+
+data State = State {
+ board :: Board,
+ turn :: Player
+}
+
+data GUI = GUI {
+ disableBoard :: IO (),
+ resetBoard :: IO (),
+ setSquare :: Int -> Player -> IO (),
+ setStatus :: String -> IO ()
+}
+
+-- reset the game
+reset gui (State board turn) = do
+ setStatus gui "Player Cross: make your move."
+ resetBoard gui
+ return (State empty Cross)
+
+-- when a square is clicked on, try to make a move.
+-- if the square is already occupied, nothing happens
+-- otherwise, update the board, let the next player make his move,
+-- and check whether someone has won or the board is full.
+occupy gui square st@(State board player) = do
+ case move square player board of
+ Nothing -> return st
+ Just newBoard -> do
+ setSquare gui square player
+ handleMove gui newBoard player
+ return (State newBoard (next player))
+
+-- check whether a board is won or full
+handleMove gui board player
+ | wins player board = do
+ setStatus gui ("Player " ++ show player ++ " wins!")
+ disableBoard gui
+ | full board = do
+ setStatus gui "It's a draw."
+ disableBoard gui
+ | otherwise = do
+ setStatus gui ("Player " ++ show (next player) ++ ": make your move")
+
+main = do
+ initGUI
+
+ -- Extract widgets from the glade xml file
+ Just xml <- xmlNew "noughty.glade"
+
+ window <- xmlGetWidget xml castToWindow "window"
+ window `onDestroy` mainQuit
+
+ newGame <- xmlGetWidget xml castToMenuItem "newGame"
+ quit <- xmlGetWidget xml castToMenuItem "quit"
+
+ squares <- flip mapM [1..9] $ \n -> do
+ square <- xmlGetWidget xml castToButton ("button" ++ show n)
+ -- we set this in the glde file but it doesn't seem to work there.
+ set square [ widgetCanFocus := False ]
+ return square
+
+ images <- flip mapM [1..9] $ \n -> do
+ xmlGetWidget xml castToImage ("image" ++ show n)
+
+ statusbar <- xmlGetWidget xml castToStatusbar "statusbar"
+ ctx <- statusbarGetContextId statusbar "state"
+ statusbarPush statusbar ctx "Player Cross: make your move."
+
+ -- Construct the GUI actions that abstracts from the actual widgets
+ gui <- guiActions squares images statusbar ctx
+
+ -- Initialize the state
+ state <- newIORef State { board = empty, turn = Cross }
+ let modifyState f = readIORef state >>= f >>= writeIORef state
+
+ -- Add action handlers
+ onActivateLeaf quit mainQuit
+ onActivateLeaf newGame $ modifyState $ reset gui
+ zipWithM_ (\square i ->
+ onPressed square $ modifyState $ occupy gui i)
+ squares [0..8]
+
+ widgetShowAll window
+ mainGUI
+
+guiActions buttons images statusbar ctx = do
+ noughtPic <- pixbufNewFromFile "Nought.png"
+ crossPic <- pixbufNewFromFile "Cross.png"
+ return GUI {
+ disableBoard = mapM_ (flip widgetSetSensitivity False) buttons,
+ resetBoard = do
+ mapM_ (\i -> imageClear i >> widgetQueueDraw i) images
+ mapM_ (flip widgetSetSensitivity True) buttons,
+ setSquare = \ i player ->
+ case player of
+ Cross -> set (images !! i) [ imagePixbuf := crossPic ]
+ Nought-> set (images !! i) [ imagePixbuf := noughtPic ],
+ setStatus = \msg -> do
+ statusbarPop statusbar ctx
+ statusbarPush statusbar ctx msg
+ return ()
+ }
addfile ./glade/demo/noughty/noughty.glade
hunk ./glade/demo/noughty/noughty.glade 1
+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
+<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
+
+<glade-interface>
+
+<widget class="GtkWindow" id="window">
+ <property name="title" translatable="yes">Noughty</property>
+ <property name="type">GTK_WINDOW_TOPLEVEL</property>
+ <property name="window_position">GTK_WIN_POS_NONE</property>
+ <property name="modal">False</property>
+ <property name="resizable">False</property>
+ <property name="destroy_with_parent">False</property>
+ <property name="decorated">True</property>
+ <property name="skip_taskbar_hint">False</property>
+ <property name="skip_pager_hint">False</property>
+ <property name="type_hint">GDK_WINDOW_TYPE_HINT_NORMAL</property>
+ <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>
+ <property name="focus_on_map">True</property>
+ <property name="urgency_hint">False</property>
+
+ <child>
+ <widget class="GtkVBox" id="vbox1">
+ <property name="visible">True</property>
+ <property name="homogeneous">False</property>
+ <property name="spacing">0</property>
+
+ <child>
+ <widget class="GtkMenuBar" id="menubar1">
+ <property name="visible">True</property>
+ <property name="pack_direction">GTK_PACK_DIRECTION_LTR</property>
+ <property name="child_pack_direction">GTK_PACK_DIRECTION_LTR</property>
+
+ <child>
+ <widget class="GtkMenuItem" id="menuitem1">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">_Game</property>
+ <property name="use_underline">True</property>
+
+ <child>
+ <widget class="GtkMenu" id="menuitem1_menu">
+
+ <child>
+ <widget class="GtkMenuItem" id="newGame">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">_New Game</property>
+ <property name="use_underline">True</property>
+ <accelerator key="n" modifiers="GDK_CONTROL_MASK" signal="activate"/>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkSeparatorMenuItem" id="separatormenuitem1">
+ <property name="visible">True</property>
+ </widget>
+ </child>
+
+ <child>
+ <widget class="GtkMenuItem" id="quit">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">_Quit</property>
+ <property name="use_underline">True</property>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">False</property>
+ <property name="fill">False</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkTable" id="table1">
+ <property name="border_width">10</property>
+ <property name="visible">True</property>
+ <property name="n_rows">5</property>
+ <property name="n_columns">5</property>
+ <property name="homogeneous">False</property>
+ <property name="row_spacing">0</property>
+ <property name="column_spacing">0</property>
+
+ <child>
+ <widget class="GtkHSeparator" id="hseparator1">
+ <property name="visible">True</property>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">5</property>
+ <property name="top_attach">1</property>
+ <property name="bottom_attach">2</property>
+ <property name="x_options">fill</property>
+ <property name="y_options">fill</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkVSeparator" id="vseparator1">
+ <property name="visible">True</property>
+ </widget>
+ <packing>
+ <property name="left_attach">1</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">0</property>
+ <property name="bottom_attach">5</property>
+ <property name="x_options">fill</property>
+ <property name="y_options">fill</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkVSeparator" id="vseparator2">
+ <property name="visible">True</property>
+ </widget>
+ <packing>
+ <property name="left_attach">3</property>
+ <property name="right_attach">4</property>
+ <property name="top_attach">0</property>
+ <property name="bottom_attach">5</property>
+ <property name="x_options">fill</property>
+ <property name="y_options">fill</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="button1">
+ <property name="width_request">100</property>
+ <property name="height_request">100</property>
+ <property name="visible">True</property>
+ <property name="relief">GTK_RELIEF_NONE</property>
+ <property name="focus_on_click">False</property>
+
+ <child>
+ <widget class="GtkImage" id="image1">
+ <property name="visible">True</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">0</property>
+ <property name="bottom_attach">1</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="button2">
+ <property name="width_request">100</property>
+ <property name="height_request">100</property>
+ <property name="visible">True</property>
+ <property name="relief">GTK_RELIEF_NONE</property>
+ <property name="focus_on_click">False</property>
+
+ <child>
+ <widget class="GtkImage" id="image2">
+ <property name="visible">True</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="left_attach">2</property>
+ <property name="right_attach">3</property>
+ <property name="top_attach">0</property>
+ <property name="bottom_attach">1</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="button3">
+ <property name="width_request">100</property>
+ <property name="height_request">100</property>
+ <property name="visible">True</property>
+ <property name="relief">GTK_RELIEF_NONE</property>
+ <property name="focus_on_click">False</property>
+
+ <child>
+ <widget class="GtkImage" id="image3">
+ <property name="visible">True</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="left_attach">4</property>
+ <property name="right_attach">5</property>
+ <property name="top_attach">0</property>
+ <property name="bottom_attach">1</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="button4">
+ <property name="width_request">100</property>
+ <property name="height_request">100</property>
+ <property name="visible">True</property>
+ <property name="relief">GTK_RELIEF_NONE</property>
+ <property name="focus_on_click">False</property>
+
+ <child>
+ <widget class="GtkImage" id="image4">
+ <property name="visible">True</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">2</property>
+ <property name="bottom_attach">3</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="button5">
+ <property name="width_request">100</property>
+ <property name="height_request">100</property>
+ <property name="visible">True</property>
+ <property name="relief">GTK_RELIEF_NONE</property>
+ <property name="focus_on_click">False</property>
+
+ <child>
+ <widget class="GtkImage" id="image5">
+ <property name="visible">True</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="left_attach">2</property>
+ <property name="right_attach">3</property>
+ <property name="top_attach">2</property>
+ <property name="bottom_attach">3</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="button6">
+ <property name="width_request">100</property>
+ <property name="height_request">100</property>
+ <property name="visible">True</property>
+ <property name="relief">GTK_RELIEF_NONE</property>
+ <property name="focus_on_click">False</property>
+
+ <child>
+ <widget class="GtkImage" id="image6">
+ <property name="visible">True</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="left_attach">4</property>
+ <property name="right_attach">5</property>
+ <property name="top_attach">2</property>
+ <property name="bottom_attach">3</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="button7">
+ <property name="width_request">100</property>
+ <property name="height_request">100</property>
+ <property name="visible">True</property>
+ <property name="relief">GTK_RELIEF_NONE</property>
+ <property name="focus_on_click">False</property>
+
+ <child>
+ <widget class="GtkImage" id="image7">
+ <property name="visible">True</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">4</property>
+ <property name="bottom_attach">5</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="button8">
+ <property name="width_request">100</property>
+ <property name="height_request">100</property>
+ <property name="visible">True</property>
+ <property name="relief">GTK_RELIEF_NONE</property>
+ <property name="focus_on_click">False</property>
+
+ <child>
+ <widget class="GtkImage" id="image8">
+ <property name="visible">True</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="left_attach">2</property>
+ <property name="right_attach">3</property>
+ <property name="top_attach">4</property>
+ <property name="bottom_attach">5</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="button9">
+ <property name="width_request">100</property>
+ <property name="height_request">100</property>
+ <property name="visible">True</property>
+ <property name="relief">GTK_RELIEF_NONE</property>
+ <property name="focus_on_click">False</property>
+
+ <child>
+ <widget class="GtkImage" id="image9">
+ <property name="visible">True</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="left_attach">4</property>
+ <property name="right_attach">5</property>
+ <property name="top_attach">4</property>
+ <property name="bottom_attach">5</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkHSeparator" id="hseparator2">
+ <property name="visible">True</property>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">5</property>
+ <property name="top_attach">3</property>
+ <property name="bottom_attach">4</property>
+ <property name="x_options">fill</property>
+ <property name="y_options">fill</property>
+ </packing>
+ </child>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">True</property>
+ <property name="fill">True</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkStatusbar" id="statusbar">
+ <property name="visible">True</property>
+ <property name="has_resize_grip">False</property>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">False</property>
+ <property name="fill">False</property>
+ </packing>
+ </child>
+ </widget>
+ </child>
+</widget>
+
+</glade-interface>
|
|
From: Andy S. <And...@co...> - 2010-05-01 21:42:40
|
Sat May 1 17:05:42 EDT 2010 Andy Stewart <laz...@gm...>
* Move calc demo to `gtk2hs/glade/demo` and adjust glade demo.
Ignore-this: 152abe8888a55ec4a2c106292a58b6cf
hunk ./demo/calc/Calc.hs 1
-module Main where
-
-import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Glade
-
-import Data.IORef
-
-import qualified CalcModel as Calc
-
-main = do
- initGUI
-[_^I_] [_$_]
- -- load up the glade file
- calcXmlM <- xmlNew "calc.glade"
- let calcXml = case calcXmlM of
- (Just calcXml) -> calcXml
- Nothing -> error "can't find the glade file \"calc.glade\" \
- \in the current directory"
-[_^I_] [_$_]
- -- get a handle on a some widgets from the glade file
- window <- xmlGetWidget calcXml castToWindow "calcwindow"
- display <- xmlGetWidget calcXml castToLabel "display"
- [_$_]
- -- a list of the names of the buttons and the actions associated with them
- let buttonNamesAndOperations = numbericButtons ++ otherButtons
- numbericButtons = [ ("num-" ++ show n, Calc.enterDigit n)
- | n <- [0..9] ]
- otherButtons =
- [("decimal", Calc.enterDecimalPoint)
- ,("op-plus", Calc.enterBinOp Calc.plus)
- ,("op-minus", Calc.enterBinOp Calc.minus)
- ,("op-times", Calc.enterBinOp Calc.times)
- ,("op-divide", Calc.enterBinOp Calc.divide)
- ,("equals", Calc.evaluate)
- ,("clear", \_ -> Just ("0", Calc.clearCalc))]
- [_$_]
- -- action to do when a button corresponding to a calculator operation gets
- -- pressed: we update the calculator state and display the new result.
- -- These calculator operations can return Nothing for when the operation
- -- makes no sense, we do nothing in this case.
- calcRef <- newIORef Calc.clearCalc
- let calcOperation operation = do
- calc <- readIORef calcRef
- case operation calc of
- Nothing -> return ()
- Just (result, calc') -> do
- display `labelSetLabel` ("<big>" ++ result ++ "</big>")
- writeIORef calcRef calc'
-
- -- get a reference to a button from the glade file and attach the
- -- handler for when the button is pressed
- connectButtonToOperation name operation = do
- button <- xmlGetWidget calcXml castToButton name
- button `onClicked` calcOperation operation
- [_$_]
- -- connect up all the buttons with their actions.
- mapM_ (uncurry connectButtonToOperation) buttonNamesAndOperations
- [_$_]
- -- make the program exit when the main window is closed
- window `onDestroy` mainQuit
- [_$_]
- -- show everything and run the main loop
- widgetShowAll window
- mainGUI
rmfile ./demo/calc/Calc.hs
hunk ./demo/calc/CalcModel.hs 1
--- A simple push button calcualtor without operator precedence
-
-module CalcModel (
- Number,
- Calc,
- BinOp, plus, minus, times, divide,
- clearCalc, enterDigit, enterDecimalPoint, enterBinOp, evaluate
- ) where
-
-import Char (isDigit)
-import Monad (when)
-import Numeric (showGFloat)
-
--- we could change this to rational
-type Number = Double
-
-data Calc = Calc {
- number :: [Digit],
- operator :: BinOp,
- total :: Number,
- resetOnNum :: Bool -- a state flag, after pressing '=', if we enter an
- } -- operator then we're carrying on the previous
- -- calculation, otherwise we should start a new one.
-
-data Digit = Digit Int -- in range [0..9]
- | DecimalPoint
- deriving Eq
-
-data BinOp = BinOp (Number -> Number -> Number)
-
-plus, minus, times, divide :: BinOp
-plus = BinOp (+)
-minus = BinOp (-)
-times = BinOp (*)
-divide = BinOp (/)
-
-clearCalc :: Calc
-clearCalc = Calc {
- number = [],
- operator = plus,
- total = 0,
- resetOnNum = True
- }
-
--- Maybe for the case when the operation makes no sense
-enterDigit :: Int -> Calc -> Maybe (String, Calc)
-enterDigit digit calc
- | digit `elem` [0..9]
- && not (number calc == [] && digit == 0)
- = let newNumber = number calc ++ [Digit digit]
- in if resetOnNum calc
- then Just (show newNumber,
- calc {
- number = newNumber,
- total = 0,
- resetOnNum = False
- })
- else Just (show newNumber, calc { number = newNumber })
- | otherwise = Nothing
-
-enterDecimalPoint :: Calc -> Maybe (String, Calc)
-enterDecimalPoint calc
- | DecimalPoint `notElem` number calc
- = let newNumber = number calc ++ [DecimalPoint]
- in if resetOnNum calc
- then Just (show newNumber,
- calc {
- number = newNumber,
- total = 0,
- resetOnNum = False
- })
- else Just (show newNumber, calc { number = newNumber })
- | otherwise = Nothing
-
-enterBinOp :: BinOp -> Calc -> Maybe (String, Calc)
-enterBinOp binop calc =
- let newTotal = (case operator calc of BinOp op -> op)
- (total calc)
- (digitsToNumber (number calc))
- in Just (showNumber newTotal,
- Calc {
- number = [],
- operator = binop,
- total = newTotal,
- resetOnNum = False
- })
-
-evaluate :: Calc -> Maybe (String, Calc)
-evaluate calc = [_$_]
- let newTotal = (case operator calc of BinOp op -> op)
- (total calc)
- (digitsToNumber (number calc))
- in Just (showNumber newTotal,
- Calc {
- number = [],
- operator = plus,
- total = newTotal,
- resetOnNum = True
- })
-
-instance Show Digit where
- show (Digit n) = show n
- show DecimalPoint = "."
- showList = showString . concatMap show
-
-digitsToNumber :: [Digit] -> Number
-digitsToNumber [] = 0
-digitsToNumber digits@(DecimalPoint:_) = digitsToNumber (Digit 0:digits)
-digitsToNumber digits | last digits == DecimalPoint
- = digitsToNumber (init digits)
- | otherwise = read (show digits) --CHEAT!
-
-precision = Just 5 --digits of precision, or Nothing for as much as possible
-
-showNumber :: Number -> String
-showNumber num =
- if '.' `elem` numStr then stripTrailingZeros numStr
- else numStr
- where numStr = showGFloat precision num ""
- stripTrailingZeros =
- reverse
- . (\str -> if head str == '.' then tail str else str)
- . dropWhile (\c -> c=='0')
- . reverse
-
-testProg :: IO ()
-testProg = do
- evalLoop clearCalc
- [_$_]
- where evalLoop :: Calc -> IO ()
- evalLoop calc = do
- putStr "calc> "
- line <- getLine
- when (line /= "q") $ do
- result <- case line of
- [digit] | isDigit digit
- -> return $ enterDigit (read [digit]) calc [_$_]
- "." -> return $ enterDecimalPoint calc
- "+" -> return $ enterBinOp plus calc
- "-" -> return $ enterBinOp minus calc
- "*" -> return $ enterBinOp times calc
- "/" -> return $ enterBinOp divide calc
- "=" -> return $ evaluate calc
- "c" -> return $ Just ("0",clearCalc)
- _ -> do putStrLn "invalid input"
- return Nothing
- case result of
- Nothing -> evalLoop calc
- Just (display, calc') -> do putStrLn display
- evalLoop calc'
rmfile ./demo/calc/CalcModel.hs
hunk ./demo/calc/Makefile 1
-
-PROG = calc
-SOURCES = Calc.hs CalcModel.hs
-
-$(PROG) : $(SOURCES)
- $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
-
-HC=ghc
rmfile ./demo/calc/Makefile
hunk ./demo/calc/calc.glade 1
-<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
-<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
-
-<glade-interface>
-
-<widget class="GtkWindow" id="calcwindow">
- <property name="border_width">4</property>
- <property name="visible">True</property>
- <property name="title" translatable="yes">Calculator</property>
- <property name="type">GTK_WINDOW_TOPLEVEL</property>
- <property name="window_position">GTK_WIN_POS_CENTER</property>
- <property name="modal">False</property>
- <property name="resizable">True</property>
- <property name="destroy_with_parent">False</property>
-
- <child>
- <widget class="GtkVBox" id="vbox1">
- <property name="visible">True</property>
- <property name="homogeneous">False</property>
- <property name="spacing">4</property>
-
- <child>
- <widget class="GtkLabel" id="display">
- <property name="visible">True</property>
- <property name="label" translatable="yes"><big>0</big></property>
- <property name="use_underline">False</property>
- <property name="use_markup">True</property>
- <property name="justify">GTK_JUSTIFY_RIGHT</property>
- <property name="wrap">False</property>
- <property name="selectable">False</property>
- <property name="xalign">1</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">False</property>
- <property name="fill">False</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkTable" id="table1">
- <property name="visible">True</property>
- <property name="n_rows">5</property>
- <property name="n_columns">4</property>
- <property name="homogeneous">True</property>
- <property name="row_spacing">4</property>
- <property name="column_spacing">4</property>
-
- <child>
- <widget class="GtkButton" id="decimal">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">.</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="period" modifiers="0" signal="clicked"/>
- <accelerator key="KP_Decimal" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">2</property>
- <property name="right_attach">3</property>
- <property name="top_attach">4</property>
- <property name="bottom_attach">5</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="num-0">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">0</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="0" modifiers="0" signal="clicked"/>
- <accelerator key="KP_0" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">2</property>
- <property name="top_attach">4</property>
- <property name="bottom_attach">5</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="num-1">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">1</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="1" modifiers="0" signal="clicked"/>
- <accelerator key="KP_1" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">3</property>
- <property name="bottom_attach">4</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="num-2">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">2</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="2" modifiers="0" signal="clicked"/>
- <accelerator key="KP_2" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">1</property>
- <property name="right_attach">2</property>
- <property name="top_attach">3</property>
- <property name="bottom_attach">4</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="num-4">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">4</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="4" modifiers="0" signal="clicked"/>
- <accelerator key="KP_4" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">2</property>
- <property name="bottom_attach">3</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="num-5">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">5</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="5" modifiers="0" signal="clicked"/>
- <accelerator key="KP_5" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">1</property>
- <property name="right_attach">2</property>
- <property name="top_attach">2</property>
- <property name="bottom_attach">3</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="num-7">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">7</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="7" modifiers="0" signal="clicked"/>
- <accelerator key="KP_7" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">1</property>
- <property name="bottom_attach">2</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="num-8">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">8</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="8" modifiers="0" signal="clicked"/>
- <accelerator key="KP_8" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">1</property>
- <property name="right_attach">2</property>
- <property name="top_attach">1</property>
- <property name="bottom_attach">2</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="num-3">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">3</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="3" modifiers="0" signal="clicked"/>
- <accelerator key="KP_3" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">2</property>
- <property name="right_attach">3</property>
- <property name="top_attach">3</property>
- <property name="bottom_attach">4</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="num-6">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">6</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="6" modifiers="0" signal="clicked"/>
- <accelerator key="KP_6" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">2</property>
- <property name="right_attach">3</property>
- <property name="top_attach">2</property>
- <property name="bottom_attach">3</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="num-9">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">9</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="9" modifiers="0" signal="clicked"/>
- <accelerator key="KP_9" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">2</property>
- <property name="right_attach">3</property>
- <property name="top_attach">1</property>
- <property name="bottom_attach">2</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="op-divide">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">[_\c3_][_\b7_]</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="KP_Divide" modifiers="0" signal="clicked"/>
- <accelerator key="slash" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">1</property>
- <property name="right_attach">2</property>
- <property name="top_attach">0</property>
- <property name="bottom_attach">1</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="op-times">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">[_\c3_][_\97_]</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="KP_Multiply" modifiers="0" signal="clicked"/>
- <accelerator key="asterisk" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">2</property>
- <property name="right_attach">3</property>
- <property name="top_attach">0</property>
- <property name="bottom_attach">1</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="op-minus">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">-</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="minus" modifiers="0" signal="clicked"/>
- <accelerator key="KP_Subtract" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">3</property>
- <property name="right_attach">4</property>
- <property name="top_attach">0</property>
- <property name="bottom_attach">1</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="op-plus">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">+</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="plus" modifiers="0" signal="clicked"/>
- <accelerator key="KP_Add" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">3</property>
- <property name="right_attach">4</property>
- <property name="top_attach">1</property>
- <property name="bottom_attach">3</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="equals">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">=</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="equal" modifiers="0" signal="clicked"/>
- <accelerator key="Return" modifiers="0" signal="clicked"/>
- <accelerator key="KP_Equal" modifiers="0" signal="clicked"/>
- <accelerator key="KP_Enter" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">3</property>
- <property name="right_attach">4</property>
- <property name="top_attach">3</property>
- <property name="bottom_attach">5</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="clear">
- <property name="width_request">45</property>
- <property name="height_request">40</property>
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="label" translatable="yes">AC</property>
- <property name="use_underline">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
- <accelerator key="Delete" modifiers="0" signal="clicked"/>
- <accelerator key="BackSpace" modifiers="0" signal="clicked"/>
- </widget>
- <packing>
- <property name="left_attach">0</property>
- <property name="right_attach">1</property>
- <property name="top_attach">0</property>
- <property name="bottom_attach">1</property>
- <property name="x_options">fill</property>
- <property name="y_options"></property>
- </packing>
- </child>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">True</property>
- <property name="fill">True</property>
- </packing>
- </child>
- </widget>
- </child>
-</widget>
-
-</glade-interface>
rmfile ./demo/calc/calc.glade
rmdir ./demo/calc
adddir ./glade/demo/calc
adddir ./glade/demo/glade
hunk ./glade/demo/GladeTest.hs 1
-module Main where
-
-import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Glade
-
-main = do
- initGUI
-[_^I_] [_$_]
- -- load up the glade file
- dialogXmlM <- xmlNew "simple.glade"
- let dialogXml = case dialogXmlM of
- (Just dialogXml) -> dialogXml
- Nothing -> error "can't find the glade file \"simple.glade\" \
- \in the current directory"
-[_^I_] [_$_]
- -- get a handle on a couple widgets from the glade file
- window <- xmlGetWidget dialogXml castToWindow "window1"
- button <- xmlGetWidget dialogXml castToButton "button1"
-[_^I_] [_$_]
- -- do something with the widgets, just to prove it works
- button `onClicked` putStrLn "button pressed!"
- window `onDestroy` mainQuit
-[_^I_] [_$_]
- -- show everything
- widgetShowAll window
- mainGUI
rmfile ./glade/demo/GladeTest.hs
hunk ./glade/demo/Makefile 1
-
-PROG = gladetest
-SOURCES = GladeTest.hs
-
-$(PROG) : $(SOURCES)
- $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
-
-HC=ghc
rmfile ./glade/demo/Makefile
addfile ./glade/demo/calc/Calc.hs
hunk ./glade/demo/calc/Calc.hs 1
+module Main where
+
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Glade
+
+import Data.IORef
+
+import qualified CalcModel as Calc
+
+main = do
+ initGUI
+[_^I_] [_$_]
+ -- load up the glade file
+ calcXmlM <- xmlNew "calc.glade"
+ let calcXml = case calcXmlM of
+ (Just calcXml) -> calcXml
+ Nothing -> error "can't find the glade file \"calc.glade\" \
+ \in the current directory"
+[_^I_] [_$_]
+ -- get a handle on a some widgets from the glade file
+ window <- xmlGetWidget calcXml castToWindow "calcwindow"
+ display <- xmlGetWidget calcXml castToLabel "display"
+ [_$_]
+ -- a list of the names of the buttons and the actions associated with them
+ let buttonNamesAndOperations = numbericButtons ++ otherButtons
+ numbericButtons = [ ("num-" ++ show n, Calc.enterDigit n)
+ | n <- [0..9] ]
+ otherButtons =
+ [("decimal", Calc.enterDecimalPoint)
+ ,("op-plus", Calc.enterBinOp Calc.plus)
+ ,("op-minus", Calc.enterBinOp Calc.minus)
+ ,("op-times", Calc.enterBinOp Calc.times)
+ ,("op-divide", Calc.enterBinOp Calc.divide)
+ ,("equals", Calc.evaluate)
+ ,("clear", \_ -> Just ("0", Calc.clearCalc))]
+ [_$_]
+ -- action to do when a button corresponding to a calculator operation gets
+ -- pressed: we update the calculator state and display the new result.
+ -- These calculator operations can return Nothing for when the operation
+ -- makes no sense, we do nothing in this case.
+ calcRef <- newIORef Calc.clearCalc
+ let calcOperation operation = do
+ calc <- readIORef calcRef
+ case operation calc of
+ Nothing -> return ()
+ Just (result, calc') -> do
+ display `labelSetLabel` ("<big>" ++ result ++ "</big>")
+ writeIORef calcRef calc'
+
+ -- get a reference to a button from the glade file and attach the
+ -- handler for when the button is pressed
+ connectButtonToOperation name operation = do
+ button <- xmlGetWidget calcXml castToButton name
+ button `onClicked` calcOperation operation
+ [_$_]
+ -- connect up all the buttons with their actions.
+ mapM_ (uncurry connectButtonToOperation) buttonNamesAndOperations
+ [_$_]
+ -- make the program exit when the main window is closed
+ window `onDestroy` mainQuit
+ [_$_]
+ -- show everything and run the main loop
+ widgetShowAll window
+ mainGUI
addfile ./glade/demo/calc/CalcModel.hs
hunk ./glade/demo/calc/CalcModel.hs 1
+-- A simple push button calcualtor without operator precedence
+
+module CalcModel (
+ Number,
+ Calc,
+ BinOp, plus, minus, times, divide,
+ clearCalc, enterDigit, enterDecimalPoint, enterBinOp, evaluate
+ ) where
+
+import Char (isDigit)
+import Monad (when)
+import Numeric (showGFloat)
+
+-- we could change this to rational
+type Number = Double
+
+data Calc = Calc {
+ number :: [Digit],
+ operator :: BinOp,
+ total :: Number,
+ resetOnNum :: Bool -- a state flag, after pressing '=', if we enter an
+ } -- operator then we're carrying on the previous
+ -- calculation, otherwise we should start a new one.
+
+data Digit = Digit Int -- in range [0..9]
+ | DecimalPoint
+ deriving Eq
+
+data BinOp = BinOp (Number -> Number -> Number)
+
+plus, minus, times, divide :: BinOp
+plus = BinOp (+)
+minus = BinOp (-)
+times = BinOp (*)
+divide = BinOp (/)
+
+clearCalc :: Calc
+clearCalc = Calc {
+ number = [],
+ operator = plus,
+ total = 0,
+ resetOnNum = True
+ }
+
+-- Maybe for the case when the operation makes no sense
+enterDigit :: Int -> Calc -> Maybe (String, Calc)
+enterDigit digit calc
+ | digit `elem` [0..9]
+ && not (number calc == [] && digit == 0)
+ = let newNumber = number calc ++ [Digit digit]
+ in if resetOnNum calc
+ then Just (show newNumber,
+ calc {
+ number = newNumber,
+ total = 0,
+ resetOnNum = False
+ })
+ else Just (show newNumber, calc { number = newNumber })
+ | otherwise = Nothing
+
+enterDecimalPoint :: Calc -> Maybe (String, Calc)
+enterDecimalPoint calc
+ | DecimalPoint `notElem` number calc
+ = let newNumber = number calc ++ [DecimalPoint]
+ in if resetOnNum calc
+ then Just (show newNumber,
+ calc {
+ number = newNumber,
+ total = 0,
+ resetOnNum = False
+ })
+ else Just (show newNumber, calc { number = newNumber })
+ | otherwise = Nothing
+
+enterBinOp :: BinOp -> Calc -> Maybe (String, Calc)
+enterBinOp binop calc =
+ let newTotal = (case operator calc of BinOp op -> op)
+ (total calc)
+ (digitsToNumber (number calc))
+ in Just (showNumber newTotal,
+ Calc {
+ number = [],
+ operator = binop,
+ total = newTotal,
+ resetOnNum = False
+ })
+
+evaluate :: Calc -> Maybe (String, Calc)
+evaluate calc = [_$_]
+ let newTotal = (case operator calc of BinOp op -> op)
+ (total calc)
+ (digitsToNumber (number calc))
+ in Just (showNumber newTotal,
+ Calc {
+ number = [],
+ operator = plus,
+ total = newTotal,
+ resetOnNum = True
+ })
+
+instance Show Digit where
+ show (Digit n) = show n
+ show DecimalPoint = "."
+ showList = showString . concatMap show
+
+digitsToNumber :: [Digit] -> Number
+digitsToNumber [] = 0
+digitsToNumber digits@(DecimalPoint:_) = digitsToNumber (Digit 0:digits)
+digitsToNumber digits | last digits == DecimalPoint
+ = digitsToNumber (init digits)
+ | otherwise = read (show digits) --CHEAT!
+
+precision = Just 5 --digits of precision, or Nothing for as much as possible
+
+showNumber :: Number -> String
+showNumber num =
+ if '.' `elem` numStr then stripTrailingZeros numStr
+ else numStr
+ where numStr = showGFloat precision num ""
+ stripTrailingZeros =
+ reverse
+ . (\str -> if head str == '.' then tail str else str)
+ . dropWhile (\c -> c=='0')
+ . reverse
+
+testProg :: IO ()
+testProg = do
+ evalLoop clearCalc
+ [_$_]
+ where evalLoop :: Calc -> IO ()
+ evalLoop calc = do
+ putStr "calc> "
+ line <- getLine
+ when (line /= "q") $ do
+ result <- case line of
+ [digit] | isDigit digit
+ -> return $ enterDigit (read [digit]) calc [_$_]
+ "." -> return $ enterDecimalPoint calc
+ "+" -> return $ enterBinOp plus calc
+ "-" -> return $ enterBinOp minus calc
+ "*" -> return $ enterBinOp times calc
+ "/" -> return $ enterBinOp divide calc
+ "=" -> return $ evaluate calc
+ "c" -> return $ Just ("0",clearCalc)
+ _ -> do putStrLn "invalid input"
+ return Nothing
+ case result of
+ Nothing -> evalLoop calc
+ Just (display, calc') -> do putStrLn display
+ evalLoop calc'
addfile ./glade/demo/calc/Makefile
hunk ./glade/demo/calc/Makefile 1
+
+PROG = calc
+SOURCES = Calc.hs CalcModel.hs
+
+$(PROG) : $(SOURCES)
+ $(HC) --make $< -o $@ $(HCFLAGS)
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
+
+HC=ghc
addfile ./glade/demo/calc/calc.glade
hunk ./glade/demo/calc/calc.glade 1
+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
+<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
+
+<glade-interface>
+
+<widget class="GtkWindow" id="calcwindow">
+ <property name="border_width">4</property>
+ <property name="visible">True</property>
+ <property name="title" translatable="yes">Calculator</property>
+ <property name="type">GTK_WINDOW_TOPLEVEL</property>
+ <property name="window_position">GTK_WIN_POS_CENTER</property>
+ <property name="modal">False</property>
+ <property name="resizable">True</property>
+ <property name="destroy_with_parent">False</property>
+
+ <child>
+ <widget class="GtkVBox" id="vbox1">
+ <property name="visible">True</property>
+ <property name="homogeneous">False</property>
+ <property name="spacing">4</property>
+
+ <child>
+ <widget class="GtkLabel" id="display">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes"><big>0</big></property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">True</property>
+ <property name="justify">GTK_JUSTIFY_RIGHT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">False</property>
+ <property name="xalign">1</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">False</property>
+ <property name="fill">False</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkTable" id="table1">
+ <property name="visible">True</property>
+ <property name="n_rows">5</property>
+ <property name="n_columns">4</property>
+ <property name="homogeneous">True</property>
+ <property name="row_spacing">4</property>
+ <property name="column_spacing">4</property>
+
+ <child>
+ <widget class="GtkButton" id="decimal">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">.</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="period" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_Decimal" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">2</property>
+ <property name="right_attach">3</property>
+ <property name="top_attach">4</property>
+ <property name="bottom_attach">5</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="num-0">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">0</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="0" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_0" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">4</property>
+ <property name="bottom_attach">5</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="num-1">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">1</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="1" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_1" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">3</property>
+ <property name="bottom_attach">4</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="num-2">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">2</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="2" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_2" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">1</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">3</property>
+ <property name="bottom_attach">4</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="num-4">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">4</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="4" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_4" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">2</property>
+ <property name="bottom_attach">3</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="num-5">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">5</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="5" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_5" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">1</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">2</property>
+ <property name="bottom_attach">3</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="num-7">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">7</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="7" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_7" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">1</property>
+ <property name="bottom_attach">2</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="num-8">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">8</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="8" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_8" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">1</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">1</property>
+ <property name="bottom_attach">2</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="num-3">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">3</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="3" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_3" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">2</property>
+ <property name="right_attach">3</property>
+ <property name="top_attach">3</property>
+ <property name="bottom_attach">4</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="num-6">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">6</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="6" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_6" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">2</property>
+ <property name="right_attach">3</property>
+ <property name="top_attach">2</property>
+ <property name="bottom_attach">3</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="num-9">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">9</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="9" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_9" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">2</property>
+ <property name="right_attach">3</property>
+ <property name="top_attach">1</property>
+ <property name="bottom_attach">2</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="op-divide">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">[_\c3_][_\b7_]</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="KP_Divide" modifiers="0" signal="clicked"/>
+ <accelerator key="slash" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">1</property>
+ <property name="right_attach">2</property>
+ <property name="top_attach">0</property>
+ <property name="bottom_attach">1</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="op-times">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">[_\c3_][_\97_]</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="KP_Multiply" modifiers="0" signal="clicked"/>
+ <accelerator key="asterisk" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">2</property>
+ <property name="right_attach">3</property>
+ <property name="top_attach">0</property>
+ <property name="bottom_attach">1</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="op-minus">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">-</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="minus" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_Subtract" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">3</property>
+ <property name="right_attach">4</property>
+ <property name="top_attach">0</property>
+ <property name="bottom_attach">1</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="op-plus">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">+</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="plus" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_Add" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">3</property>
+ <property name="right_attach">4</property>
+ <property name="top_attach">1</property>
+ <property name="bottom_attach">3</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="equals">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">=</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="equal" modifiers="0" signal="clicked"/>
+ <accelerator key="Return" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_Equal" modifiers="0" signal="clicked"/>
+ <accelerator key="KP_Enter" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">3</property>
+ <property name="right_attach">4</property>
+ <property name="top_attach">3</property>
+ <property name="bottom_attach">5</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="clear">
+ <property name="width_request">45</property>
+ <property name="height_request">40</property>
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="label" translatable="yes">AC</property>
+ <property name="use_underline">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+ <accelerator key="Delete" modifiers="0" signal="clicked"/>
+ <accelerator key="BackSpace" modifiers="0" signal="clicked"/>
+ </widget>
+ <packing>
+ <property name="left_attach">0</property>
+ <property name="right_attach">1</property>
+ <property name="top_attach">0</property>
+ <property name="bottom_attach">1</property>
+ <property name="x_options">fill</property>
+ <property name="y_options"></property>
+ </packing>
+ </child>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">True</property>
+ <property name="fill">True</property>
+ </packing>
+ </child>
+ </widget>
+ </child>
+</widget>
+
+</glade-interface>
addfile ./glade/demo/glade/GladeTest.hs
hunk ./glade/demo/glade/GladeTest.hs 1
+module Main where
+
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Glade
+
+main = do
+ initGUI
+[_^I_] [_$_]
+ -- load up the glade file
+ dialogXmlM <- xmlNew "simple.glade"
+ let dialogXml = case dialogXmlM of
+ (Just dialogXml) -> dialogXml
+ Nothing -> error "can't find the glade file \"simple.glade\" \
+ \in the current directory"
+[_^I_] [_$_]
+ -- get a handle on a couple widgets from the glade file
+ window <- xmlGetWidget dialogXml castToWindow "window1"
+ button <- xmlGetWidget dialogXml castToButton "button1"
+[_^I_] [_$_]
+ -- do something with the widgets, just to prove it works
+ button `onClicked` putStrLn "button pressed!"
+ window `onDestroy` mainQuit
+[_^I_] [_$_]
+ -- show everything
+ widgetShowAll window
+ mainGUI
addfile ./glade/demo/glade/Makefile
hunk ./glade/demo/glade/Makefile 1
+
+PROG = gladetest
+SOURCES = GladeTest.hs
+
+$(PROG) : $(SOURCES)
+ $(HC) --make $< -o $@ $(HCFLAGS)
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
+
+HC=ghc
addfile ./glade/demo/glade/simple.glade
hunk ./glade/demo/glade/simple.glade 1
+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
+<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
+
+<glade-interface>
+
+<widget class="GtkWindow" id="window1">
+ <property name="visible">True</property>
+ <property name="title" translatable="yes">window1</property>
+ <property name="type">GTK_WINDOW_TOPLEVEL</property>
+ <property name="window_position">GTK_WIN_POS_NONE</property>
+ <property name="modal">False</property>
+ <property name="resizable">True</property>
+ <property name="destroy_with_parent">False</property>
+
+ <child>
+ <widget class="GtkVBox" id="vbox1">
+ <property name="border_width">6</property>
+ <property name="visible">True</property>
+ <property name="homogeneous">False</property>
+ <property name="spacing">0</property>
+
+ <child>
+ <widget class="GtkLabel" id="label1">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">A simple dialog created in Glade</property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">False</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">False</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">True</property>
+ <property name="fill">True</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="button1">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+
+ <child>
+ <widget class="GtkAlignment" id="alignment1">
+ <property name="visible">True</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xscale">0</property>
+ <property name="yscale">0</property>
+
+ <child>
+ <widget class="GtkHBox" id="hbox1">
+ <property name="visible">True</property>
+ <property name="homogeneous">False</property>
+ <property name="spacing">2</property>
+
+ <child>
+ <widget class="GtkImage" id="image1">
+ <property name="visible">True</property>
+ <property name="stock">gtk-apply</property>
+ <property name="icon_size">4</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">False</property>
+ <property name="fill">False</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="label2">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Press me!</property>
+ <property name="use_underline">True</property>
+ <property name="use_markup">False</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">False</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">False</property>
+ <property name="fill">False</property>
+ </packing>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">True</property>
+ <property name="fill">True</property>
+ </packing>
+ </child>
+ </widget>
+ </child>
+</widget>
+
+</glade-interface>
hunk ./glade/demo/simple.glade 1
-<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
-<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
-
-<glade-interface>
-
-<widget class="GtkWindow" id="window1">
- <property name="visible">True</property>
- <property name="title" translatable="yes">window1</property>
- <property name="type">GTK_WINDOW_TOPLEVEL</property>
- <property name="window_position">GTK_WIN_POS_NONE</property>
- <property name="modal">False</property>
- <property name="resizable">True</property>
- <property name="destroy_with_parent">False</property>
-
- <child>
- <widget class="GtkVBox" id="vbox1">
- <property name="border_width">6</property>
- <property name="visible">True</property>
- <property name="homogeneous">False</property>
- <property name="spacing">0</property>
-
- <child>
- <widget class="GtkLabel" id="label1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">A simple dialog created in Glade</property>
- <property name="use_underline">False</property>
- <property name="use_markup">False</property>
- <property name="justify">GTK_JUSTIFY_LEFT</property>
- <property name="wrap">False</property>
- <property name="selectable">False</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">True</property>
- <property name="fill">True</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="button1">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
-
- <child>
- <widget class="GtkAlignment" id="alignment1">
- <property name="visible">True</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xscale">0</property>
- <property name="yscale">0</property>
-
- <child>
- <widget class="GtkHBox" id="hbox1">
- <property name="visible">True</property>
- <property name="homogeneous">False</property>
- <property name="spacing">2</property>
-
- <child>
- ...
[truncated message content] |
|
From: Andy S. <And...@co...> - 2010-05-01 21:42:37
|
Sat May 1 17:01:32 EDT 2010 Andy Stewart <laz...@gm...>
* Fix carsim demo.
Ignore-this: 1502949718304229aa7d6d82084eb442
hunk ./demo/carsim/CarSim.hs 8
-import Graphics.UI.Gtk hiding (fill)
+import Graphics.UI.Gtk
|
|
From: Andy S. <And...@co...> - 2010-05-01 20:57:22
|
Sat May 1 16:56:23 EDT 2010 Andy Stewart <laz...@gm...>
* Remove warning for GtkInternal.
Ignore-this: b1b60e69e87208431f7f287ae8174f26
hunk ./gio/gio.cabal 24
-x-Types-Forward: *System.Glib.GObject Graphics.UI.GtkInternals
+x-Types-Forward: Graphics.UI.GtkInternals
hunk ./gnomevfs/gnomevfs.cabal 25
-x-Types-Forward: *System.Glib.GObject Graphics.UI.GtkInternals
+x-Types-Forward: Graphics.UI.GtkInternals
hunk ./svgcairo/svgcairo.cabal 19
-x-Types-Forward: *System.Glib.GObject *Graphics.UI.GtkInternals
+x-Types-Forward: *Graphics.UI.GtkInternals
|
|
From: Andy S. <And...@co...> - 2010-05-01 18:04:29
|
Sat May 1 14:01:34 EDT 2010 Andy Stewart <laz...@gm...>
* Axel, Gtk2HsSetup.hs can't works with pango, so i rollback your patche to make pango can compile pass. Please push new patches when you fix it.
Ignore-this: db2796b94f08260401cff17b638ef6a4
hunk ./pango/Gtk2HsSetup.hs 1
-{-# LANGUAGE CPP #-}
-
-#define CABAL_VERSION_ENCODE(major, minor, micro) ( \
- ((major) * 10000) \
- + ((minor) * 100) \
- + ((micro) * 1))
-
-#define CABAL_VERSION_CHECK(major,minor,micro) \
- (CABAL_VERSION >= CABAL_VERSION_ENCODE(major,minor,micro))
-
--- now, this is bad, but Cabal doesn't seem to actually pass any information about
--- its version to CPP, so guess the version depending on the version of GHC
-#ifdef CABAL_VERSION_MINOR
-#ifndef CABAL_VERSION_MAJOR
-#define CABAL_VERSION_MAJOR 1
-#endif
-#ifndef CABAL_VERSION_MICRO
-#define CABAL_VERSION_MICRO 0
-#endif
-#define CABAL_VERSION CABAL_VERSION_ENCODE( \
- CABAL_VERSION_MAJOR, \
- CABAL_VERSION_MINOR, \
- CABAL_VERSION_MICRO)
-#else
-#warning Setup.hs is guessing the version of Cabal. If compilation of Setup.hs fails use -DCABAL_VERSION_MINOR=x for Cabal version 1.x.0 when building (prefixed by --ghc-option= when using the 'cabal' command)
-#if (__GLASGOW_HASKELL__ >= 612)
-#define CABAL_VERSION CABAL_VERSION_ENCODE(1,8,0)
-#else
-#define CABAL_VERSION CABAL_VERSION_ENCODE(1,6,0)
-#endif
-#endif
-
--- | Build a Gtk2hs package.
---
-module Gtk2HsSetup ( gtk2hsUserHooks, getPkgConfigPackages ) where
-
-import Distribution.Simple
-import Distribution.Simple.PreProcess
-import Distribution.InstalledPackageInfo ( importDirs )
-import Distribution.Simple.PackageIndex (
-#if CABAL_VERSION_CHECK(1,8,0)
- lookupInstalledPackageId
-#else
- lookupPackageId
-#endif
- )
-import Distribution.PackageDescription as PD ( PackageDescription(..),
- updatePackageDescription,
- BuildInfo(..),
- emptyBuildInfo, allBuildInfo,
- Library(..),
- libModules)
-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..),
- InstallDirs(..),
-#if CABAL_VERSION_CHECK(1,8,0)
- componentPackageDeps,
-#else
- packageDeps,
-#endif
- absoluteInstallDirs)
-import Distribution.Simple.Compiler ( Compiler(..) )
-import Distribution.Simple.Program (
- Program(..), ConfiguredProgram(..),
- rawSystemProgramConf, rawSystemProgramStdoutConf,
- c2hsProgram, pkgConfigProgram,
- simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg)
-import Distribution.ModuleName ( ModuleName, components, toFilePath )
-import Distribution.Simple.Utils
-import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..),
- defaultCopyFlags, ConfigFlags(configVerbosity),
- fromFlag, toFlag)
-import Distribution.Simple.BuildPaths ( autogenModulesDir )
-import Distribution.Text ( simpleParse, display )
-import System.FilePath
-import System.Directory ( doesFileExist )
-import Distribution.Version (Version(..))
-import Distribution.Verbosity
-import Control.Monad (unless)
-import Data.Maybe (fromMaybe)
-import Data.List (isPrefixOf, nub)
-import Data.Char (isAlpha)
-import qualified Data.Map as M
-import qualified Data.Set as S
-
-
--- the name of the c2hs pre-compiled header file
-precompFile = "precompchs.bin"
-
-gtk2hsUserHooks = simpleUserHooks {
- hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal],
- hookedPreProcessors = [("chs", ourC2hs)],
- confHook = \pd cf ->
- confHook simpleUserHooks pd cf >>= return . adjustLocalBuildInfo,
- postConf = \args cf pd lbi -> do
- genSynthezisedFiles (fromFlag (configVerbosity cf)) pd lbi
- postConf simpleUserHooks args cf pd lbi,
- buildHook = \pd lbi uh bf -> fixDeps pd >>= \pd ->
- (buildHook simpleUserHooks) pd lbi uh bf,
- copyHook = \pd lbi uh flags -> (copyHook simpleUserHooks) pd lbi uh flags >>
- installCHI pd lbi (fromFlag (copyVerbosity flags)) (fromFlag (copyDest flags)),
- instHook = \pd lbi uh flags -> (instHook simpleUserHooks) pd lbi uh flags >>
- installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest
- }
-
--- This is a hack for Cabal-1.8, It is not needed in Cabal-1.9.1 or later
-adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo
-adjustLocalBuildInfo lbi =
- let extra = (Just libBi, [])
- libBi = emptyBuildInfo { includeDirs = [ autogenModulesDir lbi
- , buildDir lbi ] }
- in lbi { localPkgDescr = updatePackageDescription extra (localPkgDescr lbi) }
-
-ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor
-ourC2hs bi lbi = PreProcessor {
- platformIndependent = False,
- runPreProcessor = runC2HS bi lbi
-}
-
-runC2HS :: BuildInfo -> LocalBuildInfo ->
- (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO ()
-runC2HS bi lbi (inDir, inFile) (outDir, outFile) verbosity = do
- -- have the header file name if we don't have the precompiled header yet
- header <- case lookup "x-c2hs-header" (customFieldsBI bi) of
- Just h -> return h
- Nothing -> die ("Need x-c2hs-Header definition in the .cabal Library section "++
- "that sets the C header file to process .chs.pp files.")
-
- -- c2hs will output files in out dir, removing any leading path of the input file.
- -- Thus, append the dir of the input file to the output dir.
- let (outFileDir, newOutFile) = splitFileName outFile
- let newOutDir = outDir </> outFileDir
- -- additional .chi files might be needed that other packages have installed;
- -- we assume that these are installed in the same place as .hi files
- let chiDirs = [ dir |
-#if CABAL_VERSION_CHECK(1,8,0)
- ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi),
- dir <- maybe [] importDirs (lookupInstalledPackageId (installedPkgs lbi) ipi) ]
-#else
- ipi <- packageDeps lbi,
- dir <- maybe [] importDirs (lookupPackageId (installedPkgs lbi) ipi) ]
-#endif
- rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $
- map ("--include=" ++) (outDir:chiDirs)
- ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi]
- ++ ["--output-dir=" ++ newOutDir,
- "--output=" ++ newOutFile,
- "--precomp=" ++ buildDir lbi </> precompFile,
- header, inDir </> inFile]
-
-getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]
-getCppOptions bi lbi
- = nub $
- ["-I" ++ dir | dir <- PD.includeDirs bi]
- ++ [opt | opt@('-':c:_) <- (PD.cppOptions bi ++ PD.ccOptions bi), c `elem` "DIU"]
-
-installCHI :: PackageDescription -- ^information from the .cabal file
- -> LocalBuildInfo -- ^information from the configure step
- -> Verbosity -> CopyDest -- ^flags sent to copy or install
- -> IO ()
-installCHI pk...@PD...ckageDescription { library = Just lib } lbi verbosity copydest = do
- let InstallDirs { libdir = libPref } = absoluteInstallDirs pkg lbi copydest
- -- cannot use the recommended 'findModuleFiles' since it fails if there exists
- -- a modules that does not have a .chi file
- mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi])
- (map toFilePath
-#if CABAL_VERSION_CHECK(1,8,0)
- (PD.libModules lib)
-#else
- (PD.libModules pkg)
-#endif
- )
- let files = [ f | Just f <- mFiles ]
-#if CABAL_VERSION_CHECK(1,8,0)
- installOrdinaryFiles verbosity libPref files
-#else
- copyFiles verbosity libPref files
-#endif
-
- [_$_]
-installCHI _ _ _ _ = return ()
-
-------------------------------------------------------------------------------
--- Generating the type hierarchy and signal callback .hs files.
-------------------------------------------------------------------------------
-
-typeGenProgram :: Program
-typeGenProgram = (simpleProgram "gtk2hsTypeGen")
-
-signalGenProgram :: Program
-signalGenProgram = (simpleProgram "gtk2hsHookGenerator")
-
-c2hsLocal :: Program
-c2hsLocal = (simpleProgram "gtk2hsC2hs")
-
-genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
-genSynthezisedFiles verb pd lbi = do
-
- cPkgs <- getPkgConfigPackages verb lbi pd
-
- let xList = maybe [] (customFieldsBI . libBuildInfo) (library pd)
- ++customFieldsPD pd
- typeOpts :: [ProgArg]
- typeOpts = concat [ map (\val -> '-':'-':drop 8 field++'=':val) (words content)
- | (field,content) <- xList,
- "x-types-" `isPrefixOf` field,
- field /= "x-types-file"]
- ++ [ "--tag=" ++ tag
- | PackageIdentifier name (Version (major:minor:_) _) <- cPkgs
- , let name' = filter isAlpha (display name)
- , tag <- name'
- : [ name' ++ "-" ++ show major ++ "." ++ show digit
- | digit <- [0,2..minor] ]
- ]
-
- signalsOpts :: [ProgArg]
- signalsOpts = concat [ map (\val -> '-':'-':drop 10 field++'=':val) (words content)
- | (field,content) <- xList,
- "x-signals-" `isPrefixOf` field,
- field /= "x-signals-file"]
-
- genFile :: Program -> [ProgArg] -> FilePath -> IO ()
- genFile prog args outFile = do
- res <- rawSystemProgramStdoutConf verb prog (withPrograms lbi) args
- rewriteFile outFile res
-
- case lookup "x-types-file" xList of
- Nothing -> return ()
- Just f -> do
- info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.")
- genFile typeGenProgram typeOpts f
-
- case lookup "x-signals-file" xList of
- Nothing -> return ()
- Just f -> do
- info verb ("Ensuring that callback hooks in "++f++" are up-to-date.")
- genFile signalGenProgram signalsOpts f
-
---FIXME: Cabal should tell us the selected pkg-config package versions in the
--- LocalBuildInfo or equivalent.
--- In the mean time, ask pkg-config again.
-
-getPkgConfigPackages :: Verbosity -> LocalBuildInfo -> PackageDescription -> IO [PackageId]
-getPkgConfigPackages verbosity lbi pkg =
- sequence
- [ do version <- pkgconfig ["--modversion", display pkgname]
- case simpleParse version of
- Nothing -> die $ "parsing output of pkg-config --modversion failed"
- Just v -> return (PackageIdentifier pkgname v)
- | Dependency pkgname _ <- concatMap pkgconfigDepends (allBuildInfo pkg) ]
- where
- pkgconfig = rawSystemProgramStdoutConf verbosity
- pkgConfigProgram (withPrograms lbi)
-
-------------------------------------------------------------------------------
--- Dependency calculation amongst .chs files.
-------------------------------------------------------------------------------
-
--- Given all files of the package, find those that end in .chs and extract the
--- .chs files they depend upon. Then return the PackageDescription with these
--- files rearranged so that they are built in a sequence that files that are
--- needed by other files are built first.
-fixDeps :: PackageDescription -> IO PackageDescription
-fixDeps pd...@PD...ckageDescription {
- PD.library = Just li...@PD...brary {
- PD.exposedModules = expMods,
- PD.libBuildInfo = bi@PD.BuildInfo {
- PD.hsSourceDirs = srcDirs,
- PD.otherModules = othMods
- }}} = do
- let findModule m = findFileWithExtension [".chs.pp",".chs"] srcDirs
- (joinPath (components m))
- mExpFiles <- mapM findModule expMods
- mOthFiles <- mapM findModule othMods
-
- -- tag all exposed files with True so we throw an error if we need to build
- -- an exposed module before an internal modules (we cannot express this)
- let modDeps = zipWith (ModDep True []) expMods mExpFiles++
- zipWith (ModDep False []) othMods mOthFiles
- modDeps <- mapM extractDeps modDeps
- let (expMods, othMods) = span mdExposed $ sortTopological modDeps
- badOther = map (fromMaybe "<no file>" . mdLocation) $
- filter (not . mdExposed) expMods
- unless (null badOther) $
- die ("internal chs modules "++intercalate "," badOther++
- " depend on exposed chs modules; cabal needs to build internal modules first")
- return pd { PD.library = Just lib {
- PD.exposedModules = map mdOriginal expMods,
- PD.libBuildInfo = bi { PD.otherModules = map mdOriginal othMods }
- }}
-
-data ModDep = ModDep {
- mdExposed :: Bool,
- mdRequires :: [ModuleName],
- mdOriginal :: ModuleName,
- mdLocation :: Maybe FilePath
-}
-
-instance Show ModDep where
- show x = show (mdLocation x)
-
-instance Eq ModDep where
- ModDep { mdOriginal = m1 } == ModDep { mdOriginal = m2 } = m1==m2
-instance Ord ModDep where
- compare ModDep { mdOriginal = m1 } ModDep { mdOriginal = m2 } = compare m1 m2
-
--- Extract the dependencies of this file. This is intentionally rather naive as it
--- ignores CPP conditionals. We just require everything which means that the
--- existance of a .chs module may not depend on some CPP condition. [_$_]
-extractDeps :: ModDep -> IO ModDep
-extractDeps md@ModDep { mdLocation = Nothing } = return md
-extractDeps md@ModDep { mdLocation = Just f } = withFileContents f $ \con -> do
- let findImports acc (('{':'#':xs):xxs) = case (dropWhile ((==) ' ') xs) of
- ('i':'m':'p':'o':'r':'t':' ':ys) ->
- case simpleParse (takeWhile ((/=) '#') ys) of
- Just m -> findImports (m:acc) xxs [_$_]
- Nothing -> die ("cannot parse chs import in "++f++":\n"++
- "offending line is {#"++xs)
- -- no more imports after the first non-import hook
- _ -> return acc
- findImports acc (_:xxs) = findImports acc xxs
- findImports acc [] = return acc
- mods <- findImports [] (lines con)
- return md { mdRequires = mods }
-
--- Find a total order of the set of modules that are partially sorted by their
--- dependencies on each other. The function returns the sorted list of modules
--- together with a list of modules that are required but not supplied by this
--- in the input set of modules.
-sortTopological :: [ModDep] -> [ModDep]
-sortTopological ms = reverse $ fst $ foldl visit ([], S.empty) (map mdOriginal ms)
- where
- set = M.fromList (map (\m -> (mdOriginal m, m)) ms)
- visit (out,visited) m
- | m `S.member` visited = (out,visited)
- | otherwise = case m `M.lookup` set of
- Nothing -> (out, m `S.insert` visited)
- Just md -> (md:out', visited')
- where
- (out',visited') = foldl visit (out, m `S.insert` visited) (mdRequires md)
rmfile ./pango/Gtk2HsSetup.hs
hunk ./pango/Setup.hs 1
--- Setup file for a Gtk2Hs module. Contains only adjustments specific to this module,
--- all Gtk2Hs-specific boilerplate is stored in Gtk2HsSetup.hs which should be kept
--- identical across all modules.
-import Distribution.Simple ( defaultMainWithHooks, UserHooks(postConf),
- PackageIdentifier(..), PackageName(..) )
-import Gtk2HsSetup ( gtk2hsUserHooks, getPkgConfigPackages )
-import Distribution.Simple.Setup ( ConfigFlags(configVerbosity), fromFlag)
-import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
-import Distribution.Simple.BuildPaths ( autogenModulesDir )
-import Distribution.Text ( display )
-import Distribution.Version ( Version(..) )
-import Distribution.Verbosity
+{-# LANGUAGE CPP #-}
+
+#define CABAL_VERSION_ENCODE(major, minor, micro) ( \
+ ((major) * 10000) \
+ + ((minor) * 100) \
+ + ((micro) * 1))
+
+#define CABAL_VERSION_CHECK(major,minor,micro) \
+ (CABAL_VERSION >= CABAL_VERSION_ENCODE(major,minor,micro))
+
+-- now, this is bad, but Cabal doesn't seem to actually pass any information about
+-- its version to CPP, so guess the version depending on the version of GHC
+#ifdef CABAL_VERSION_MINOR
+#ifndef CABAL_VERSION_MAJOR
+#define CABAL_VERSION_MAJOR 1
+#endif
+#ifndef CABAL_VERSION_MICRO
+#define CABAL_VERSION_MICRO 0
+#endif
+#define CABAL_VERSION CABAL_VERSION_ENCODE( \
+ CABAL_VERSION_MAJOR, \
+ CABAL_VERSION_MINOR, \
+ CABAL_VERSION_MICRO)
+#else
+#warning Setup.hs is guessing the version of Cabal. If compilation of Setup.hs fails use -DCABAL_VERSION_MINOR=x for Cabal version 1.x.0 when building (prefixed by --ghc-option= when using the 'cabal' command)
+#if (__GLASGOW_HASKELL__ >= 612)
+#define CABAL_VERSION CABAL_VERSION_ENCODE(1,8,0)
+#else
+#define CABAL_VERSION CABAL_VERSION_ENCODE(1,6,0)
+#endif
+#endif
+
+-- | Build a Gtk2hs package.
+--
+import Distribution.Simple
+import Distribution.Simple.PreProcess
+import Distribution.InstalledPackageInfo ( importDirs )
+import Distribution.Simple.PackageIndex (
+#if CABAL_VERSION_CHECK(1,8,0)
+ lookupInstalledPackageId
+#else
+ lookupPackageId
+#endif
+ )
+import Distribution.Package ( PackageId(..) )
+import Distribution.PackageDescription as PD ( PackageDescription(..),
+ updatePackageDescription,
+ BuildInfo(..),
+ emptyBuildInfo, allBuildInfo,
+ Library(..),
+ libModules)
+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..),
+ InstallDirs(..),
+#if CABAL_VERSION_CHECK(1,8,0)
+ componentPackageDeps,
+#else
+ packageDeps,
+#endif
+ absoluteInstallDirs)
+import Distribution.Simple.Compiler ( Compiler(..) )
+import Distribution.Simple.Program (
+ Program(..), ConfiguredProgram(..),
+ rawSystemProgramConf, rawSystemProgramStdoutConf,
+ c2hsProgram, pkgConfigProgram,
+ simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg)
+import Distribution.ModuleName ( ModuleName, components, toFilePath )
hunk ./pango/Setup.hs 68
+import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..),
+ defaultCopyFlags, ConfigFlags(configVerbosity),
+ fromFlag, toFlag)
+import Distribution.Simple.BuildPaths ( autogenModulesDir )
+import Distribution.Text ( simpleParse, display )
hunk ./pango/Setup.hs 74
+import System.Directory ( doesFileExist )
+import Distribution.Version (Version(..))
+import Distribution.Verbosity
+import Control.Monad (unless)
+import Data.Maybe (fromMaybe)
+import Data.List (isPrefixOf, nub)
+import Data.Char (isAlpha)
+import qualified Data.Map as M
+import qualified Data.Set as S
+
hunk ./pango/Setup.hs 85
-main = defaultMainWithHooks gtk2hsUserHooks {
+-- the name of the c2hs pre-compiled header file
+precompFile = "precompchs.bin"
hunk ./pango/Setup.hs 88
+main = defaultMainWithHooks simpleUserHooks {
+ hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal],
+ hookedPreProcessors = [("chs", ourC2hs)],
+ confHook = \pd cf ->
+ confHook simpleUserHooks pd cf >>= return . adjustLocalBuildInfo,
hunk ./pango/Setup.hs 94
- let verb = (fromFlag (configVerbosity cf))
- cPkgs <- getPkgConfigPackages verb lbi pd
- let [pangoVersion] = [ v | PackageIdentifier (PackageName "pango") v <- cPkgs ]
- writePangoVersionHeaderFile verb lbi pangoVersion
+ genSynthezisedFiles (fromFlag (configVerbosity cf)) pd lbi
+ postConf simpleUserHooks args cf pd lbi,
+ buildHook = \pd lbi uh bf -> fixDeps pd >>= \pd ->
+ (buildHook simpleUserHooks) pd lbi uh bf,
+ copyHook = \pd lbi uh flags -> (copyHook simpleUserHooks) pd lbi uh flags >>
+ installCHI pd lbi (fromFlag (copyVerbosity flags)) (fromFlag (copyDest flags)),
+ instHook = \pd lbi uh flags -> (instHook simpleUserHooks) pd lbi uh flags >>
+ installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest
hunk ./pango/Setup.hs 104
+-- This is a hack for Cabal-1.8, It is not needed in Cabal-1.9.1 or later
+adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo
+adjustLocalBuildInfo lbi =
+ let extra = (Just libBi, [])
+ libBi = emptyBuildInfo { includeDirs = [ autogenModulesDir lbi
+ , buildDir lbi ] }
+ in lbi { localPkgDescr = updatePackageDescription extra (localPkgDescr lbi) }
+
+ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor
+ourC2hs bi lbi = PreProcessor {
+ platformIndependent = False,
+ runPreProcessor = runC2HS bi lbi
+}
+
+runC2HS :: BuildInfo -> LocalBuildInfo ->
+ (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO ()
+runC2HS bi lbi (inDir, inFile) (outDir, outFile) verbosity = do
+ -- have the header file name if we don't have the precompiled header yet
+ header <- case lookup "x-c2hs-header" (customFieldsBI bi) of
+ Just h -> return h
+ Nothing -> die ("Need x-c2hs-Header definition in the .cabal Library section "++
+ "that sets the C header file to process .chs.pp files.")
+
+ -- c2hs will output files in out dir, removing any leading path of the input file.
+ -- Thus, append the dir of the input file to the output dir.
+ let (outFileDir, newOutFile) = splitFileName outFile
+ let newOutDir = outDir </> outFileDir
+ -- additional .chi files might be needed that other packages have installed;
+ -- we assume that these are installed in the same place as .hi files
+ let chiDirs = [ dir |
+#if CABAL_VERSION_CHECK(1,8,0)
+ ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi),
+ dir <- maybe [] importDirs (lookupInstalledPackageId (installedPkgs lbi) ipi) ]
+#else
+ ipi <- packageDeps lbi,
+ dir <- maybe [] importDirs (lookupPackageId (installedPkgs lbi) ipi) ]
+#endif
+ rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $
+ map ("--include=" ++) (outDir:chiDirs)
+ ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi]
+ ++ ["--output-dir=" ++ newOutDir,
+ "--output=" ++ newOutFile,
+ "--precomp=" ++ buildDir lbi </> precompFile,
+ header, inDir </> inFile]
+
+getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]
+getCppOptions bi lbi
+ = nub $
+ ["-I" ++ dir | dir <- PD.includeDirs bi]
+ ++ [opt | opt@('-':c:_) <- (PD.cppOptions bi ++ PD.ccOptions bi), c `elem` "DIU"]
+
+installCHI :: PackageDescription -- ^information from the .cabal file
+ -> LocalBuildInfo -- ^information from the configure step
+ -> Verbosity -> CopyDest -- ^flags sent to copy or install
+ -> IO ()
+installCHI pk...@PD...ckageDescription { library = Just lib } lbi verbosity copydest = do
+ let InstallDirs { libdir = libPref } = absoluteInstallDirs pkg lbi copydest
+ -- cannot use the recommended 'findModuleFiles' since it fails if there exists
+ -- a modules that does not have a .chi file
+ mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi])
+ (map toFilePath
+#if CABAL_VERSION_CHECK(1,8,0)
+ (PD.libModules lib)
+#else
+ (PD.libModules pkg)
+#endif
+ )
+ let files = [ f | Just f <- mFiles ]
+#if CABAL_VERSION_CHECK(1,8,0)
+ installOrdinaryFiles verbosity libPref files
+#else
+ copyFiles verbosity libPref files
+#endif
+
+ [_$_]
+installCHI _ _ _ _ = return ()
+
+------------------------------------------------------------------------------
+-- Generating the type hierarchy and signal callback .hs files.
+------------------------------------------------------------------------------
+
+typeGenProgram :: Program
+typeGenProgram = (simpleProgram "gtk2hsTypeGen")
+
+signalGenProgram :: Program
+signalGenProgram = (simpleProgram "gtk2hsHookGenerator")
+
+c2hsLocal :: Program
+c2hsLocal = (simpleProgram "gtk2hsC2hs")
+
+genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
+genSynthezisedFiles verb pd lbi = do
+
+ cPkgs <- getPkgConfigPackages verb lbi pd
+
+ let xList = maybe [] (customFieldsBI . libBuildInfo) (library pd)
+ ++customFieldsPD pd
+ typeOpts :: [ProgArg]
+ typeOpts = concat [ map (\val -> '-':'-':drop 8 field++'=':val) (words content)
+ | (field,content) <- xList,
+ "x-types-" `isPrefixOf` field,
+ field /= "x-types-file"]
+ ++ [ "--tag=" ++ tag
+ | PackageIdentifier name (Version (major:minor:_) _) <- cPkgs
+ , let name' = filter isAlpha (display name)
+ , tag <- name'
+ : [ name' ++ "-" ++ show major ++ "." ++ show digit
+ | digit <- [0,2..minor] ]
+ ]
+
+ genFile :: Program -> [ProgArg] -> FilePath -> IO ()
+ genFile prog args outFile = do
+ res <- rawSystemProgramStdoutConf verb prog (withPrograms lbi) args
+ rewriteFile outFile res
+
+ case lookup "x-types-file" xList of
+ Nothing -> return ()
+ Just f -> do
+ info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.")
+ genFile typeGenProgram typeOpts f
+
+ case (lookup "x-signals-file" xList,
+ lookup "x-signals-modname" xList) of
+ (Just _, Nothing) -> die "You need to specify the module name (X-Signals-ModName) \
+ \to generate a signal file."
+ (Just f, Just mod) -> do
+ info verb ("Ensuring that callback hooks in "++f++" are up-to-date.")
+ genFile signalGenProgram [mod] f
+ (_,_) -> return ()
+
+ let [pangoVersion] = [ v | PackageIdentifier (PackageName "pango") v <- cPkgs ]
+ writePangoVersionHeaderFile verb lbi pangoVersion
+
+--FIXME: Cabal should tell us the selected pkg-config package versions in the
+-- LocalBuildInfo or equivalent.
+-- In the mean time, ask pkg-config again.
+
+getPkgConfigPackages :: Verbosity -> LocalBuildInfo -> PackageDescription -> IO [PackageId]
+getPkgConfigPackages verbosity lbi pkg =
+ sequence
+ [ do version <- pkgconfig ["--modversion", display pkgname]
+ case simpleParse version of
+ Nothing -> die $ "parsing output of pkg-config --modversion failed"
+ Just v -> return (PackageIdentifier pkgname v)
+ | Dependency pkgname _ <- concatMap pkgconfigDepends (allBuildInfo pkg) ]
+ where
+ pkgconfig = rawSystemProgramStdoutConf verbosity
+ pkgConfigProgram (withPrograms lbi)
+
hunk ./pango/Setup.hs 271
+
+------------------------------------------------------------------------------
+-- Dependency calculation amongst .chs files.
+------------------------------------------------------------------------------
+
+-- Given all files of the package, find those that end in .chs and extract the
+-- .chs files they depend upon. Then return the PackageDescription with these
+-- files rearranged so that they are built in a sequence that files that are
+-- needed by other files are built first.
+fixDeps :: PackageDescription -> IO PackageDescription
+fixDeps pd...@PD...ckageDescription {
+ PD.library = Just li...@PD...brary {
+ PD.exposedModules = expMods,
+ PD.libBuildInfo = bi@PD.BuildInfo {
+ PD.hsSourceDirs = srcDirs,
+ PD.otherModules = othMods
+ }}} = do
+ let findModule m = findFileWithExtension [".chs.pp",".chs"] srcDirs
+ (joinPath (components m))
+ mExpFiles <- mapM findModule expMods
+ mOthFiles <- mapM findModule othMods
+
+ -- tag all exposed files with True so we throw an error if we need to build
+ -- an exposed module before an internal modules (we cannot express this)
+ let modDeps = zipWith (ModDep True []) expMods mExpFiles++
+ zipWith (ModDep False []) othMods mOthFiles
+ modDeps <- mapM extractDeps modDeps
+ let (expMods, othMods) = span mdExposed $ sortTopological modDeps
+ badOther = map (fromMaybe "<no file>" . mdLocation) $
+ filter (not . mdExposed) expMods
+ unless (null badOther) $
+ die ("internal chs modules "++intercalate "," badOther++
+ " depend on exposed chs modules; cabal needs to build internal modules first")
+ return pd { PD.library = Just lib {
+ PD.exposedModules = map mdOriginal expMods,
+ PD.libBuildInfo = bi { PD.otherModules = map mdOriginal othMods }
+ }}
+
+data ModDep = ModDep {
+ mdExposed :: Bool,
+ mdRequires :: [ModuleName],
+ mdOriginal :: ModuleName,
+ mdLocation :: Maybe FilePath
+}
+
+instance Show ModDep where
+ show x = show (mdLocation x)
+
+instance Eq ModDep where
+ ModDep { mdOriginal = m1 } == ModDep { mdOriginal = m2 } = m1==m2
+instance Ord ModDep where
+ compare ModDep { mdOriginal = m1 } ModDep { mdOriginal = m2 } = compare m1 m2
+
+-- Extract the dependencies of this file. This is intentionally rather naive as it
+-- ignores CPP conditionals. We just require everything which means that the
+-- existance of a .chs module may not depend on some CPP condition. [_$_]
+extractDeps :: ModDep -> IO ModDep
+extractDeps md@ModDep { mdLocation = Nothing } = return md
+extractDeps md@ModDep { mdLocation = Just f } = withFileContents f $ \con -> do
+ let findImports acc (('{':'#':xs):xxs) = case (dropWhile ((==) ' ') xs) of
+ ('i':'m':'p':'o':'r':'t':' ':ys) ->
+ case simpleParse (takeWhile ((/=) '#') ys) of
+ Just m -> findImports (m:acc) xxs [_$_]
+ Nothing -> die ("cannot parse chs import in "++f++":\n"++
+ "offending line is {#"++xs)
+ -- no more imports after the first non-import hook
+ _ -> return acc
+ findImports acc (_:xxs) = findImports acc xxs
+ findImports acc [] = return acc
+ mods <- findImports [] (lines con)
+ return md { mdRequires = mods }
+
+-- Find a total order of the set of modules that are partially sorted by their
+-- dependencies on each other. The function returns the sorted list of modules
+-- together with a list of modules that are required but not supplied by this
+-- in the input set of modules.
+sortTopological :: [ModDep] -> [ModDep]
+sortTopological ms = reverse $ fst $ foldl visit ([], S.empty) (map mdOriginal ms)
+ where
+ set = M.fromList (map (\m -> (mdOriginal m, m)) ms)
+ visit (out,visited) m
+ | m `S.member` visited = (out,visited)
+ | otherwise = case m `M.lookup` set of
+ Nothing -> (out, m `S.insert` visited)
+ Just md -> (md:out', visited')
+ where
+ (out',visited') = foldl visit (out, m `S.insert` visited) (mdRequires md)
+
|
|
From: Andy S. <And...@co...> - 2010-05-01 17:43:01
|
Sat May 1 13:41:06 EDT 2010 Andy Stewart <laz...@gm...>
* Move cairo demo to `gtk2hs/cairo/demo`.
Ignore-this: 59379042dbc12ed64d7c6fa67da613a6
adddir ./cairo/demo
hunk ./demo/cairo/CairoGhci.hs 1
--- Example of an drawing graphics onto a canvas.
-import Graphics.UI.Gtk
-import Graphics.Rendering.Cairo
-import Control.Monad.Trans ( liftIO )
-
-run :: Render () -> IO ()
-run act = do
- initGUI
- dia <- dialogNew
- dialogAddButton dia stockClose ResponseClose
- contain <- dialogGetUpper dia
- canvas <- drawingAreaNew
- canvas `onSizeRequest` return (Requisition 250 250)
- canvas `onExpose` updateCanvas canvas act
- boxPackStartDefaults contain canvas
- widgetShow canvas
- dialogRun dia
- widgetDestroy dia
- -- Flush all commands that are waiting to be sent to the graphics server.
- -- This ensures that the window is actually closed before ghci displays the
- -- prompt again.
- flush
-
- where updateCanvas :: DrawingArea -> Render () -> Event -> IO Bool
- updateCanvas canvas act (Expose {}) = do
- win <- widgetGetDrawWindow canvas
- renderWithDrawable win act
- return True
- updateCanvas canvas act _ = return False
-
-
-
-setRed :: Render ()
-setRed = do
- setSourceRGB 1 0 0
-
-
-
-setFat :: Render ()
-setFat = do
- setLineWidth 20
- setLineCap LineCapRound
-
-
-
-drawSquare :: Double -> Double -> Render ()
-drawSquare width height = do
- (x,y) <- getCurrentPoint
- lineTo (x+width) y
- lineTo (x+width) (y+height)
- lineTo x (y+height)
- closePath
- stroke
-
-
-
-drawHCirc :: Double -> Double -> Double -> Render ()
-drawHCirc x y radius = do
- arc x y radius 0 pi
- stroke
-
-
-
-drawStr :: String -> Render ()
-drawStr txt = do
- lay <- createLayout txt
- showLayout lay
-
-
-
-drawStr_ :: String -> Render ()
-drawStr_ txt = do
- lay <- liftIO $ do
- ctxt <- cairoCreateContext Nothing
- descr <- contextGetFontDescription ctxt
- descr `fontDescriptionSetSize` 20
- ctxt `contextSetFontDescription` descr
- layoutText ctxt txt
- showLayout lay
rmfile ./demo/cairo/CairoGhci.hs
hunk ./demo/cairo/Clock.hs 1
--- original author:
--- Mirco "MacSlow" Mueller <ma...@ba...>
---
--- created: [_$_]
--- 10.1.2006 (or so)
---
--- http://www.gnu.org/licenses/licenses.html#GPL
---
--- ported to Haskell by:
--- Duncan Coutts <dun...@wo...>
---
-
-import Graphics.Rendering.Cairo
-import Graphics.UI.Gtk hiding (fill)
-import Graphics.UI.Gtk.Gdk.EventM
-import System.Glib (handleGError, GError(..))
-import System.Time
-import Control.Monad (when)
-import Data.Maybe (isJust)
-import Data.IORef
-
-drawClockBackground :: Bool -> Int -> Int -> Render ()
-drawClockBackground quality width height = do
- save
- scale (fromIntegral width) (fromIntegral height)
-
- save
- setOperator OperatorOver
- when quality drawDropShadow
- drawClockFace quality
- restore
-
- translate 0.5 0.5
- scale 0.4 0.4
- setSourceRGB 0.16 0.18 0.19
- setLineWidth (1.5/60)
- setLineCap LineCapRound
- setLineJoin LineJoinRound [_$_]
- drawHourMarks [_$_]
- [_$_]
- restore
-
-drawClockHands :: Bool -> Int -> Int -> Render ()
-drawClockHands quality width height = do
- save
- scale (fromIntegral width) (fromIntegral height)
-
- translate 0.5 0.5
- scale 0.4 0.4
- setSourceRGB 0.16 0.18 0.19
- setLineWidth (1.5/60)
- setLineCap LineCapRound
- setLineJoin LineJoinRound
- [_$_]
- time <- liftIO (getClockTime >>= toCalendarTime)
- let hours = fromIntegral (if ctHour time >= 12
- then ctHour time - 12
- else ctHour time)
- minutes = fromIntegral (ctMin time)
- seconds = fromIntegral (ctSec time)
- [_$_]
- drawHourHand quality hours minutes seconds
- drawMinuteHand quality minutes seconds
- drawSecondHand quality seconds
- [_$_]
- restore
-
-drawClockForeground :: Bool -> Int -> Int -> Render ()
-drawClockForeground quality width height = do
- scale (fromIntegral width) (fromIntegral height)
-
- save
- translate 0.5 0.5
- scale 0.4 0.4
- setSourceRGB 0.16 0.18 0.19
- setLineWidth (1.5/60)
- setLineCap LineCapRound
- setLineJoin LineJoinRound
-
- when quality drawInnerShadow
- when quality drawReflection
- drawFrame quality [_$_]
- restore
- [_$_]
-drawDropShadow =
- withRadialPattern 0.55 0.55 0.25 0.5 0.5 0.525 $ \pattern -> do
- patternAddColorStopRGBA pattern 0 0 0 0 0.811
- patternAddColorStopRGBA pattern 0.64 0.345 0.345 0.345 0.317
- patternAddColorStopRGBA pattern 0.84 0.713 0.713 0.713 0.137
- patternAddColorStopRGBA pattern 1 1 1 1 0
- patternSetFilter pattern FilterFast
- setSource pattern
- arc 0.5 0.5 (142/150) 0 (pi*2)
- fill
-
-drawClockFace True =
- withLinearPattern 0.5 0 0.5 1 $ \pattern -> do
- patternAddColorStopRGB pattern 0 0.91 0.96 0.93
- patternAddColorStopRGB pattern 1 0.65 0.68 0.68
- patternSetFilter pattern FilterFast
- setSource pattern
- translate 0.5 0.5
- arc 0 0 (60/150) 0 (pi*2)
- fill
-drawClockFace False = do
- setSourceRGB 0.78 0.82 0.805
- translate 0.5 0.5
- arc 0 0 (60/150) 0 (pi*2)
- fill
-
-drawHourMarks = do
- save
- forM_ [1..12] $ \_ -> do
- rotate (pi/6)
- moveTo (4.5/6) 0
- lineTo (5.0/6) 0
- stroke
- restore
-
-forM_ = flip mapM_
-
-drawHourHand quality hours minutes seconds = do
- save
- rotate (-pi/2)
- setLineCap LineCapSquare
- setLineJoin LineJoinMiter
- rotate ( (pi/6) * hours
- + (pi/360) * minutes
- + (pi/21600) * seconds)
- [_$_]
- -- hour hand's shadow
- when quality $ do
- setLineWidth (1.75/60)
- setOperator OperatorAtop
- setSourceRGBA 0.16 0.18 0.19 0.125
- moveTo (-2/15 + 0.025) 0.025
- lineTo (7/15 + 0.025) 0.025
- stroke
- [_$_]
- -- the hand itself
- setLineWidth (1/60)
- setOperator OperatorOver
- setSourceRGB 0.16 0.18 0.19
- moveTo (-2/15) 0
- lineTo (7/15) 0
- stroke
- restore
-
-drawMinuteHand quality minutes seconds = do
- save
- rotate (-pi/2)
- setLineCap LineCapSquare
- setLineJoin LineJoinMiter
- rotate ( (pi/30) * minutes
- + (pi/1800) * seconds)
- [_$_]
- -- minute hand's shadow
- when quality $ do
- setLineWidth (1.75/60)
- setOperator OperatorAtop
- setSourceRGBA 0.16 0.18 0.19 0.125
- moveTo (-16/75 - 0.025) (-0.025)
- lineTo (2/3 - 0.025) (-0.025)
- stroke
- [_$_]
- -- the minute hand itself
- setLineWidth (1/60)
- setOperator OperatorOver
- setSourceRGB 0.16 0.18 0.19
- moveTo (-16/75) 0
- lineTo (2/3) 0
- stroke
- restore
-
-drawSecondHand quality seconds = do
- save
- rotate (-pi/2)
- setLineCap LineCapSquare
- setLineJoin LineJoinMiter
- rotate (seconds * pi/30);
-
- -- shadow of second hand-part
- when quality $ do
- setOperator OperatorAtop
- setSourceRGBA 0.16 0.18 0.19 0.125
- setLineWidth (1.3125 / 60)
- moveTo (-1.5/5 + 0.025) 0.025
- lineTo (3/5 + 0.025) 0.025
- stroke
-
- -- second hand
- setOperator OperatorOver
- setSourceRGB 0.39 0.58 0.77
- setLineWidth (0.75/60)
- moveTo (-1.5/5) 0
- lineTo (3/5) 0
- stroke
-
- arc 0 0 (1/20) 0 (pi*2)
- fill
- arc (63/100) 0 (1/35) 0 (pi*2)
- stroke
- setLineWidth (1/100)
- moveTo (10/15) 0
- lineTo (12/15) 0
- stroke
- setSourceRGB 0.31 0.31 0.31
- arc 0 0 (1/25) 0 (pi*2)
- fill
- restore
-
-drawInnerShadow = do
- save
- setOperator OperatorOver
- arc 0 0 (142/150) 0 (pi*2)
- clip
- withRadialPattern 0.3 0.3 0.1 0 0 0.95 $ \pattern -> do
- patternAddColorStopRGBA pattern 0 1 1 1 0
- patternAddColorStopRGBA pattern 0.64 0.713 0.713 0.713 0.137
- patternAddColorStopRGBA pattern 0.84 0.345 0.345 0.345 0.317
- patternAddColorStopRGBA pattern 1 0 0 0 0.811
- patternSetFilter pattern FilterFast
- setSource pattern
- arc 0 0 (142/150) 0 (pi*2)
- fill
- restore
-
-drawReflection = do
- save
- arc 0 0 (142/150) 0 (pi*2)
- clip
- rotate (-75 * pi/180)
- setSourceRGBA 0.87 0.9 0.95 0.25
- moveTo (-1) (-1)
- lineTo 1 (-1)
- lineTo 1 1
- curveTo 1 0.15 (-0.15) (-1) (-1) (-1)
- fill
- moveTo (-1) (-1)
- lineTo (-1) 1
- lineTo 1 1
- curveTo (-0.5) 1 (-1) 0.5 (-1) (-1)
- fill
- restore
-
-drawFrame True = do
- save
- withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do
- patternAddColorStopRGB pattern 0 0.4 0.4 0.4
- patternAddColorStopRGB pattern 0.2 0.95 0.95 0.95
- patternSetFilter pattern FilterFast
- setSource pattern
- setLineWidth (10/75)
- arc 0 0 (142/150) 0 (pi*2)
- stroke
-
- withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do
- patternAddColorStopRGB pattern 0 0.9 0.9 0.9
- patternAddColorStopRGB pattern 0.2 0.35 0.35 0.35
- patternSetFilter pattern FilterFast
- setSource pattern
- setLineWidth (10/75)
- arc 0 0 (150/150) 0 (pi*2)
- stroke
- restore
-drawFrame False = do
- save
- setSourceRGB 0 0 0
- setLineWidth (10/75)
- arc 0 0 1 0 (pi*2)
- stroke
- restore
-
-initialSize :: Int
-initialSize = 256
-
-main = do
- initGUI
- [_$_]
- window <- windowNew
- windowSetDecorated window False
- windowSetResizable window True
- windowSetPosition window WinPosCenterAlways
-
- widgetSetAppPaintable window True
- handleGError (\_ -> return ()) $
- windowSetIconFromFile window "cairo-clock-icon.png"
- windowSetTitle window "Gtk2Hs Cairo Clock"
- windowSetDefaultSize window initialSize initialSize
- windowSetGeometryHints window (Just window)
- (Just (32, 32)) (Just (512, 512))
- Nothing Nothing (Just (1,1))
-
- let setAlpha widget = do
- screen <- widgetGetScreen widget
- colormap <- screenGetRGBAColormap screen
- maybe (return ()) (widgetSetColormap widget) colormap
- setAlpha window --TODO: also call setAlpha on alpha screen change
-
- window `on` keyPressEvent $ tryEvent $ do
- "Escape" <- eventKeyName
- liftIO mainQuit
- [_$_]
- window `on` buttonPressEvent $ tryEvent $ do
- LeftButton <- eventButton
- time <- eventTime
- (x,y) <- eventRootCoordinates
- liftIO $ windowBeginMoveDrag window LeftButton (round x) (round y) time
- [_$_]
- window `on` buttonPressEvent $ tryEvent $ do
- MiddleButton <- eventButton
- time <- eventTime
- (x,y) <- eventRootCoordinates
- liftIO $ windowBeginResizeDrag window WindowEdgeSouthEast MiddleButton
- (round x) (round y) time
-
- timeoutAdd (widgetQueueDraw window >> return True) 1000
-
- backgroundRef <- newIORef (Just undefined)
- foregroundRef <- newIORef (Just undefined)
-
- let redrawStaticLayers = do
- (width, height) <- widgetGetSize window
- drawWin <- widgetGetDrawWindow window
- background <- createImageSurface FormatARGB32 width height
- foreground <- createImageSurface FormatARGB32 width height
- let clear = do [_$_]
- save
- setOperator OperatorClear
- paint
- restore
- renderWith background $ do
- clear
- drawClockBackground True width height
- renderWith foreground $ do
- clear
- drawClockForeground True width height
- writeIORef backgroundRef (Just background)
- writeIORef foregroundRef (Just foreground)
- [_$_]
- onRealize window redrawStaticLayers
-
- sizeRef <- newIORef (initialSize, initialSize)
- timeoutHandlerRef <- newIORef Nothing
- window `on` configureEvent $ do
- (w,h) <- eventSize
- liftIO $ do
- size <- readIORef sizeRef
- writeIORef sizeRef (w,h)
- when (size /= (w,h)) $ do
- [_$_]
- background <- readIORef backgroundRef
- foreground <- readIORef foregroundRef
- maybe (return ()) surfaceFinish background
- maybe (return ()) surfaceFinish foreground
-
- writeIORef backgroundRef Nothing
- writeIORef foregroundRef Nothing
- [_$_]
- timeoutHandler <- readIORef timeoutHandlerRef
- maybe (return ()) timeoutRemove timeoutHandler
- [_$_]
- handler <- timeoutAddFull (do
- writeIORef timeoutHandlerRef Nothing
- redrawStaticLayers
- widgetQueueDraw window
- return False
- ) priorityDefaultIdle 300
- writeIORef timeoutHandlerRef (Just handler)
- [_$_]
- return False
-
- window `on` exposeEvent $ do
- drawWin <- eventWindow
- exposeRegion <- eventRegion
- liftIO $ do
- (width, height) <- drawableGetSize drawWin
-
- background <- readIORef backgroundRef
- foreground <- readIORef foregroundRef
-
- renderWithDrawable drawWin $ do
- region exposeRegion
- clip
-
- save
- setOperator OperatorSource
- setSourceRGBA 0 0 0 0
- paint
- restore
-
- case background of
- Nothing -> drawClockBackground False width height
- Just background -> do
- setSourceSurface background 0 0
- paint
-
- drawClockHands (isJust background) width height
-
- case foreground of
- Nothing -> drawClockForeground False width height
- Just foreground -> do
- setSourceSurface foreground 0 0
- paint
-
- return True
-
- widgetShowAll window
- mainGUI
rmfile ./demo/cairo/Clock.hs
hunk ./demo/cairo/Drawing.hs 1
--- Example of an drawing graphics onto a canvas.
-import Graphics.UI.Gtk
-import Graphics.Rendering.Cairo
-import Graphics.UI.Gtk.Gdk.EventM
-
-main = do
- initGUI
- dia <- dialogNew
- dialogAddButton dia stockOk ResponseOk
- contain <- dialogGetUpper dia
- canvas <- drawingAreaNew
- canvas `on` sizeRequest $ return (Requisition 40 40)
- ctxt <- cairoCreateContext Nothing
- text <- layoutEmpty ctxt
- text `layoutSetText` "Hello World."
- canvas `on` exposeEvent $ updateCanvas text
- boxPackStartDefaults contain canvas
- widgetShow canvas
- dialogRun dia
- return ()
-
-updateCanvas :: PangoLayout -> EventM EExpose Bool
-updateCanvas text = do
- win <- eventWindow
- liftIO $ do
- (width',height') <- drawableGetSize win
- let width = realToFrac width'
- height = realToFrac height'
-
- -- Draw using the cairo api
- renderWithDrawable win $ do
- setSourceRGB 1 0 0
- setLineWidth 20
- setLineCap LineCapRound
- setLineJoin LineJoinRound
-
- moveTo 30 30
- lineTo (width-30) (height-30)
- lineTo (width-30) 30
- lineTo 30 (height-30)
- stroke
-
- setSourceRGB 1 1 0
- setLineWidth 4
- [_$_]
- save
- translate (width / 2) (height / 2)
- scale (width / 2) (height / 2)
- arc 0 0 1 (135 * pi/180) (225 * pi/180)
- restore
- stroke
- [_$_]
- setSourceRGB 0 0 0
- moveTo 30 (realToFrac height / 4)
- rotate (pi/4)
- showLayout text
-
-
- return True
rmfile ./demo/cairo/Drawing.hs
hunk ./demo/cairo/Drawing2.hs 1
---
--- Author: Johan Bockg[_\c3_][_\a5_]rd <bo...@dd...>
---
--- This code is in the public domain.
---
-
-import qualified Graphics.UI.Gtk as G
-import qualified Graphics.Rendering.Cairo as C
-import qualified Graphics.Rendering.Cairo.Matrix as M
-
-
-windowWidth, windowHeight :: Int
-windowWidth = 500
-windowHeight = 500
-
--- Write image to file
-writePng :: IO ()
-writePng =
- C.withImageSurface C.FormatARGB32 width height $ \ result -> do
- C.renderWith result $ example width height
- C.surfaceWriteToPNG result "Draw.png"
- where width = windowWidth
- height = windowHeight
-
--- Display image in window
-main = do
- G.initGUI
- window <- G.windowNew
- canvas <- G.drawingAreaNew
- -- fix size
- -- G.windowSetResizable window False
- G.widgetSetSizeRequest window windowWidth windowHeight
- -- press any key to quit
- G.onKeyPress window $ const (do G.widgetDestroy window; return True)
- G.onDestroy window G.mainQuit
- G.onExpose canvas $ const (updateCanvas canvas)
- G.set window [G.containerChild G.:= canvas]
- G.widgetShowAll window
- G.mainGUI
-
-updateCanvas :: G.DrawingArea -> IO Bool
-updateCanvas canvas = do
- win <- G.widgetGetDrawWindow canvas
- (width, height) <- G.widgetGetSize canvas
- G.renderWithDrawable win $
- example width height
- return True
-
-----------------------------------------------------------------
-
-foreach :: (Monad m) => [a] -> (a -> m b) -> m [b]
-foreach = flip mapM
-
-keepState render = do
- C.save
- render
- C.restore
-
-drawCircle x y r = do
- C.arc x y r 0 (2 * pi)
- fillStroke
-
-drawRectangle x y w h = do
- C.rectangle x y w h
- fillStroke
-
-stroke =
- keepState $ do
- C.setSourceRGBA 0 0 0 0.7
- C.stroke
-
-fillStroke = do
- C.fillPreserve
- stroke
-
-----------------------------------------------------------------
-
--- Example
-
-example width height = do
- prologue width height
- example1
-
--- Set up stuff
-prologue wWidth wHeight = do
- let width = 10
- height = 10
- xmax = width / 2
- xmin = - xmax
- ymax = height / 2
- ymin = - ymax
- scaleX = realToFrac wWidth / width
- scaleY = realToFrac wHeight / height
-
- -- style and color
- C.setLineCap C.LineCapRound
- C.setLineJoin C.LineJoinRound
- C.setLineWidth $ 1 / max scaleX scaleY
- C.setSourceRGBA 0.5 0.7 0.5 0.5
-
- -- Set up user coordinates
- C.scale scaleX scaleY
- -- center origin
- C.translate (width / 2) (height / 2)
- -- positive y-axis upwards
- let flipY = M.Matrix 1 0 0 (-1) 0 0
- C.transform flipY
-
- grid xmin xmax ymin ymax
-
-
--- Grid and axes
-grid xmin xmax ymin ymax =
- keepState $ do
- C.setSourceRGBA 0 0 0 0.7
- -- axes
- C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke
- C.moveTo xmin 0; C.lineTo xmax 0; C.stroke
- -- grid
- C.setDash [0.01, 0.99] 0
- foreach [xmin .. xmax] $ \ x ->
- do C.moveTo x ymin
- C.lineTo x ymax
- C.stroke
-
-example1 = do
- -- circles
- drawCircle 0 0 1
- drawCircle 2 2 3
- -- a bunch of rectangles
- keepState $
- foreach [1 .. 5] $ \ _ ->
- do drawRectangle 0 1 2 3
- C.rotate (pi/8)
- -- some cute stuff
- thought
- apple
- snake
-
-thought =
- keepState $ do
- C.scale 0.04 0.04
- C.translate (200) (380)
- C.rotate pi
- C.setSourceRGBA 0.5 0.5 1 0.7
- C.setLineWidth 1
- image
- fillStroke
- where
- m = C.moveTo
- c = C.curveTo
- z = C.closePath
- image = do
- m 184 327
- c 176 327 170 332 168 339
- c 166 333 160 329 153 329
- c 147 329 141 333 138 339
- c 137 339 136 338 134 338
- c 125 338 118 345 118 354
- c 118 363 125 371 134 371
- c 137 371 140 370 142 368
- c 142 368 142 368 142 369
- c 142 377 149 385 158 385
- c 162 385 166 383 168 381
- c 171 386 176 390 183 390
- c 188 390 193 387 196 383
- c 198 384 201 385 204 385
- c 212 385 220 378 220 369
- c 222 371 225 372 228 372
- c 237 372 244 364 244 355
- c 244 346 237 339 228 339
- c 227 339 226 339 225 340
- c 223 332 217 327 209 327
- c 204 327 199 330 196 333
- c 193 330 189 327 184 327
- z
- m 164 387
- c 158 387 153 391 153 397
- c 153 402 158 407 164 407
- c 170 407 174 402 174 397
- c 174 391 170 387 164 387
- z
- m 152 408
- c 149 408 146 411 146 414
- c 146 417 149 420 152 420
- c 155 420 158 417 158 414
- c 158 411 155 408 152 408
- z
- m 143 422
- c 141 422 139 424 139 426
- c 139 428 141 429 143 429
- c 144 429 146 428 146 426
- c 146 424 144 422 143 422
- z
-
-apple =
- keepState $ do
- C.scale 0.05 0.05
- C.translate (1110) (220)
- C.rotate pi
- C.setLineWidth 0.5
- C.setSourceRGBA 0 0 0 0.7
- image1
- fillStroke
- C.setSourceRGBA 1 0 0 0.7
- image2
- fillStroke
- where
- m = C.moveTo
- c = C.curveTo
- z = C.closePath
- l = C.lineTo
- image1 = do
- m 1149 245
- l 1156 244
- l 1155 252
- l 1149 245
- z
- image2 = do
- m 1151 249
- c 1145 249 1140 254 1140 261
- c 1140 268 1145 273 1151 273
- c 1152 273 1153 273 1154 272
- c 1156 273 1157 273 1158 273
- c 1164 273 1169 268 1169 261
- c 1169 254 1164 249 1158 249
- c 1157 249 1156 249 1154 250
- c 1153 249 1152 249 1151 249
- z
-
-snake =
- keepState $ do
- C.scale 0.04 0.04
- C.translate (150) (220)
- C.rotate pi
- C.setLineWidth 0.5
- C.setSourceRGBA 0.1 0.1 0 0.7
- image
- fillStroke
- where
- m = C.moveTo
- c = C.curveTo
- z = C.closePath
- l = C.lineTo
- image = do
- m 146 320
- c 143 308 130 314 123 319
- c 115 324 108 311 100 314
- c 93 317 92 319 81 318
- c 76 318 60 309 60 320
- c 60 328 73 321 82 323
- c 94 326 98 317 106 320
- c 113 323 120 330 128 323
- c 133 318 142 312 146 320
- l 146 320
- z
-
-----------------------------------------------------------------
rmfile ./demo/cairo/Drawing2.hs
hunk ./demo/cairo/Graph.hs 1
---
--- Author: Michael Sloan <mg...@gm...>
---
--- This code is in the public domain.
---
--- Based off Johan Bockg[_\c3_][_\a5_]rd's Drawing2.hs
---
-
-import qualified Graphics.UI.Gtk as G
-import qualified Graphics.Rendering.Cairo as C
-import qualified Graphics.Rendering.Cairo.Matrix as M
-
-f x = sin (x*5) / (x*5)
-
-main = graph f
-
-graph :: (Double -> Double) -> IO ()
-graph f = do
- G.initGUI
- window <- G.windowNew
- canvas <- G.drawingAreaNew
- G.windowSetResizable window False
- G.widgetSetSizeRequest window 600 600
- -- press any key to quit
- G.onKeyPress window $ const (do G.widgetDestroy window; return True)
- G.onDestroy window G.mainQuit
- G.onExpose canvas $ const $ render f canvas
- G.set window [G.containerChild G.:= canvas]
- G.widgetShowAll window
- G.mainGUI
-
-render :: (Double -> Double) -> G.DrawingArea -> IO Bool
-render f canvas = do
- win <- G.widgetGetDrawWindow canvas
- (width, height) <- G.widgetGetSize canvas
- G.renderWithDrawable win $ (prologue width height >> renderG f)
- return True
-
-foreach :: (Monad m) => [a] -> (a -> m b) -> m [b]
-foreach = flip mapM
-
-deriv :: (Double -> Double) -> Double -> Double
-deriv f x = ((f $ x + 0.05) - (f $ x - 0.05)) * 10
-
-gen :: Double -> Double -> (Double -> Double) -> [Double]
-gen v t f | v > t = []
-gen v t f = v : (gen (f v) t f)
-
-skipBy f = foldr (\x c -> if f x then c else x : c) []
-
-falloff x = 0.25 * (x + 1.5) / ((x+0.5)^5 + 1)
-
-renderG :: (Double -> Double) -> C.Render ()
-renderG f = do
- C.moveTo (-5) (f (-5))
- sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) [-4.9,-4.8..5]
- --Adaptive attempt (falloff func is what really needs work)
- --sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) $ tail $ gen (-5) 5 (\x -> x + (falloff $ abs $ deriv (deriv f) x))
- C.stroke
-
--- Set up stuff
-prologue wWidth wHeight = do
- let width = 10
- height = 10
- xmax = width / 2
- xmin = - xmax
- ymax = height / 2
- ymin = - ymax
- scaleX = realToFrac wWidth / width
- scaleY = realToFrac wHeight / height
-
- -- style and color
- C.setLineCap C.LineCapRound
- C.setLineJoin C.LineJoinRound
- C.setLineWidth $ 1 / max scaleX scaleY
-
- -- Set up user coordinates
- C.scale scaleX scaleY
- -- center origin
- C.translate (width / 2) (height / 2)
- -- positive y-axis upwards
- let flipY = M.Matrix 1 0 0 (-1) 0 0
- C.transform flipY
- C.setSourceRGBA 0 0 0 1
- grid xmin xmax ymin ymax
-
--- Grid and axes
-grid xmin xmax ymin ymax = do
- -- axes
- C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke
- C.moveTo xmin 0; C.lineTo xmax 0; C.stroke
- -- grid
- C.setDash [0.01, 0.99] 0
- foreach [xmin .. xmax] $ \ x ->
- do C.moveTo x ymin
- C.lineTo x ymax
- C.stroke
- C.setDash [] 0
rmfile ./demo/cairo/Graph.hs
hunk ./demo/cairo/Makefile 1
-
-PROGS = drawing drawing2 starandring text clock graph
-SOURCES = Drawing.hs Drawing2.hs StarAndRing.hs Text.hs Clock.hs Graph.hs
-
-all : $(PROGS)
-
-drawing : Drawing.hs
- $(HC_RULE)
-
-drawing2 : Drawing2.hs
- $(HC_RULE)
-
-starandring : StarAndRing.hs
- $(HC_RULE)
-
-text : Text.hs
- $(HC_RULE)
-
-clock : Clock.hs
- $(HC_RULE)
-
-graph : Graph.hs
- $(HC_RULE)
-
-HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
-
-HC=ghc
rmfile ./demo/cairo/Makefile
hunk ./demo/cairo/StarAndRing.hs 1
-import Graphics.Rendering.Cairo
-import qualified Graphics.Rendering.Cairo.Matrix as M
-
-ringPath :: Render ()
-ringPath = do
- moveTo 200.86568 667.80795
- curveTo 110.32266 562.62134 122.22863 403.77940 227.41524 313.23637
- curveTo 332.60185 222.69334 491.42341 234.57563 581.96644 339.76224
- curveTo 672.50948 444.94884 660.64756 603.79410 555.46095 694.33712
- curveTo 450.27436 784.88016 291.40871 772.99456 200.86568 667.80795
- closePath
- moveTo 272.14411 365.19927
- curveTo 195.64476 431.04875 186.97911 546.57972 252.82859 623.07908
- curveTo 318.67807 699.57844 434.23272 708.22370 510.73208 642.37422
- curveTo 587.23144 576.52474 595.85301 460.99047 530.00354 384.49112
- curveTo 464.15406 307.99176 348.64347 299.34979 272.14411 365.19927
- closePath
-
-starPath :: Render ()
-starPath = do
- transform (M.Matrix 0.647919 (-0.761710) 0.761710 0.647919 (-208.7977) 462.0608)
- moveTo 505.80857 746.23606
- lineTo 335.06870 555.86488
- lineTo 91.840384 635.31360
- lineTo 282.21157 464.57374
- lineTo 202.76285 221.34542
- lineTo 373.50271 411.71660
- lineTo 616.73103 332.26788
- lineTo 426.35984 503.00775
- lineTo 505.80857 746.23606
- closePath
-
-fillRing :: Render ()
-fillRing = do
- save
- translate (-90) (-205)
- ringPath
- setSourceRGBA 1.0 0.0 0.0 0.75
- fill
- restore
-
-fillStar :: Render ()
-fillStar = do
- save
- translate (-90) (-205)
- starPath
- setSourceRGBA 0.0 0.0 ((fromIntegral 0xae) / (fromIntegral 0xff)) 0.55135137
- fill
- restore
-
-clipToTopAndBottom :: Int -> Int -> Render ()
-clipToTopAndBottom width height = do
- moveTo 0 0
- lineTo (fromIntegral width) 0.0
- lineTo 0.0 (fromIntegral height)
- lineTo (fromIntegral width) (fromIntegral height)
- closePath
- clip
- newPath
-
-clipToLeftAndRight :: Int -> Int -> Render ()
-clipToLeftAndRight width height = do
- moveTo 0 0
- lineTo 0.0 (fromIntegral height)
- lineTo (fromIntegral width) 0.0
- lineTo (fromIntegral width) (fromIntegral height)
- closePath
- clip
- newPath
-
-starAndRing :: Int -> Int -> Render ()
-starAndRing width height = do
- setOperator OperatorClear
- paint
- [_$_]
- setOperator OperatorAdd
-
- renderWithSimilarSurface ContentColorAlpha width height $ \ringOverStar -> do
- renderWith ringOverStar $ do
- clipToTopAndBottom width height
- fillStar
- fillRing
- setSourceSurface ringOverStar 0 0
- paint
-
- renderWithSimilarSurface ContentColorAlpha width height $ \starOverRing -> do
- renderWith starOverRing $ do
- clipToLeftAndRight width height
- fillRing
- fillStar
- setSourceSurface starOverRing 0 0
- paint
-
-main :: IO ()
-main = do
- withImageSurface FormatARGB32 width height $ \result -> do
- renderWith result $ starAndRing width height
- surfaceWriteToPNG result "StarAndRing.png"
- putStrLn "wrote StarAndRing.png"
- withPDFSurface "StarAndRing.pdf" (fromIntegral width) (fromIntegral height)
- (flip renderWith $ starAndRing width height >> showPage)
- putStrLn "wrote StarAndRing.pdf"
- withPSSurface "StarAndRing.ps" (fromIntegral width) (fromIntegral height)
- (flip renderWith $ starAndRing width height >> showPage)
- putStrLn "wrote StarAndRing.ps"
- withSVGSurface "StarAndRing.svg" (fromIntegral width) (fromIntegral height)
- (flip renderWith $ starAndRing width height)
- putStrLn "wrote StarAndRing.svg"
-
- where width = 600
- height = 600
rmfile ./demo/cairo/StarAndRing.hs
hunk ./demo/cairo/Text.hs 1
-import Graphics.Rendering.Cairo
-import qualified Graphics.Rendering.Cairo.Matrix as M
-
-boxText :: String -> Double -> Double -> Render ()
-boxText text x y = do
- save
-
- lineWidth <- getLineWidth
-
- (TextExtents xb yb w h _ _) <- textExtents text
-
- rectangle (x + xb - lineWidth)
- (y + yb - lineWidth)
- (w + 2 * lineWidth)
- (h + 2 * lineWidth)
- stroke
- moveTo x y
- textPath text
- fillPreserve
- setSourceRGBA 0 0 1 0.5
- setLineWidth 3.0
- stroke
-
- restore
-
-transpSurface :: Double -> Double -> Render ()
-transpSurface w h = do
- save
- rectangle 0 0 w h
- setSourceRGBA 0 0 0 0
- setOperator OperatorSource
- fill
- restore
-
-width = 400
-height = 300
-
-main :: IO ()
-main = withImageSurface FormatARGB32 width height $ \surface -> do
- renderWith surface $ do
- setSourceRGB 0.0 0.0 0.0
- setLineWidth 2.0
-
- transpSurface (fromIntegral width) (fromIntegral height)
-
- selectFontFace "sans" FontSlantNormal FontWeightNormal
- setFontSize 40
-
- extents <- fontExtents
- let fontHeight = fontExtentsHeight extents
-
- boxText "Howdy, world!" 10 fontHeight
-
- translate 0 fontHeight
-
- save
- translate 10 fontHeight
- rotate (10.0 * pi / 180.0)
- boxText "Yay for Haskell!" 0 0
- restore
-
- translate 0 (3 * fontHeight)
-
- save
- setFontMatrix $ M.rotate ((-10.0) * pi / 180.0) $ M.scale 40.0 40.0 M.identity
- boxText "...and Cairo!" 10 fontHeight
- restore
-
- surfaceWriteToPNG surface "Text.png"
-
- return ()
rmfile ./demo/cairo/Text.hs
binary ./demo/cairo/cairo-clock-icon.png
rmfile ./demo/cairo/cairo-clock-icon.png
rmdir ./demo/cairo
addfile ./cairo/demo/CairoGhci.hs
hunk ./cairo/demo/CairoGhci.hs 1
+-- Example of an drawing graphics onto a canvas.
+import Graphics.UI.Gtk
+import Graphics.Rendering.Cairo
+import Control.Monad.Trans ( liftIO )
+
+run :: Render () -> IO ()
+run act = do
+ initGUI
+ dia <- dialogNew
+ dialogAddButton dia stockClose ResponseClose
+ contain <- dialogGetUpper dia
+ canvas <- drawingAreaNew
+ canvas `onSizeRequest` return (Requisition 250 250)
+ canvas `onExpose` updateCanvas canvas act
+ boxPackStartDefaults contain canvas
+ widgetShow canvas
+ dialogRun dia
+ widgetDestroy dia
+ -- Flush all commands that are waiting to be sent to the graphics server.
+ -- This ensures that the window is actually closed before ghci displays the
+ -- prompt again.
+ flush
+
+ where updateCanvas :: DrawingArea -> Render () -> Event -> IO Bool
+ updateCanvas canvas act (Expose {}) = do
+ win <- widgetGetDrawWindow canvas
+ renderWithDrawable win act
+ return True
+ updateCanvas canvas act _ = return False
+
+
+
+setRed :: Render ()
+setRed = do
+ setSourceRGB 1 0 0
+
+
+
+setFat :: Render ()
+setFat = do
+ setLineWidth 20
+ setLineCap LineCapRound
+
+
+
+drawSquare :: Double -> Double -> Render ()
+drawSquare width height = do
+ (x,y) <- getCurrentPoint
+ lineTo (x+width) y
+ lineTo (x+width) (y+height)
+ lineTo x (y+height)
+ closePath
+ stroke
+
+
+
+drawHCirc :: Double -> Double -> Double -> Render ()
+drawHCirc x y radius = do
+ arc x y radius 0 pi
+ stroke
+
+
+
+drawStr :: String -> Render ()
+drawStr txt = do
+ lay <- createLayout txt
+ showLayout lay
+
+
+
+drawStr_ :: String -> Render ()
+drawStr_ txt = do
+ lay <- liftIO $ do
+ ctxt <- cairoCreateContext Nothing
+ descr <- contextGetFontDescription ctxt
+ descr `fontDescriptionSetSize` 20
+ ctxt `contextSetFontDescription` descr
+ layoutText ctxt txt
+ showLayout lay
addfile ./cairo/demo/Clock.hs
hunk ./cairo/demo/Clock.hs 1
+-- original author:
+-- Mirco "MacSlow" Mueller <ma...@ba...>
+--
+-- created: [_$_]
+-- 10.1.2006 (or so)
+--
+-- http://www.gnu.org/licenses/licenses.html#GPL
+--
+-- ported to Haskell by:
+-- Duncan Coutts <dun...@wo...>
+--
+
+import Graphics.Rendering.Cairo
+import Graphics.UI.Gtk hiding (fill)
+import Graphics.UI.Gtk.Gdk.EventM
+import System.Glib (handleGError, GError(..))
+import System.Time
+import Control.Monad (when)
+import Data.Maybe (isJust)
+import Data.IORef
+
+drawClockBackground :: Bool -> Int -> Int -> Render ()
+drawClockBackground quality width height = do
+ save
+ scale (fromIntegral width) (fromIntegral height)
+
+ save
+ setOperator OperatorOver
+ when quality drawDropShadow
+ drawClockFace quality
+ restore
+
+ translate 0.5 0.5
+ scale 0.4 0.4
+ setSourceRGB 0.16 0.18 0.19
+ setLineWidth (1.5/60)
+ setLineCap LineCapRound
+ setLineJoin LineJoinRound [_$_]
+ drawHourMarks [_$_]
+ [_$_]
+ restore
+
+drawClockHands :: Bool -> Int -> Int -> Render ()
+drawClockHands quality width height = do
+ save
+ scale (fromIntegral width) (fromIntegral height)
+
+ translate 0.5 0.5
+ scale 0.4 0.4
+ setSourceRGB 0.16 0.18 0.19
+ setLineWidth (1.5/60)
+ setLineCap LineCapRound
+ setLineJoin LineJoinRound
+ [_$_]
+ time <- liftIO (getClockTime >>= toCalendarTime)
+ let hours = fromIntegral (if ctHour time >= 12
+ then ctHour time - 12
+ else ctHour time)
+ minutes = fromIntegral (ctMin time)
+ seconds = fromIntegral (ctSec time)
+ [_$_]
+ drawHourHand quality hours minutes seconds
+ drawMinuteHand quality minutes seconds
+ drawSecondHand quality seconds
+ [_$_]
+ restore
+
+drawClockForeground :: Bool -> Int -> Int -> Render ()
+drawClockForeground quality width height = do
+ scale (fromIntegral width) (fromIntegral height)
+
+ save
+ translate 0.5 0.5
+ scale 0.4 0.4
+ setSourceRGB 0.16 0.18 0.19
+ setLineWidth (1.5/60)
+ setLineCap LineCapRound
+ setLineJoin LineJoinRound
+
+ when quality drawInnerShadow
+ when quality drawReflection
+ drawFrame quality [_$_]
+ restore
+ [_$_]
+drawDropShadow =
+ withRadialPattern 0.55 0.55 0.25 0.5 0.5 0.525 $ \pattern -> do
+ patternAddColorStopRGBA pattern 0 0 0 0 0.811
+ patternAddColorStopRGBA pattern 0.64 0.345 0.345 0.345 0.317
+ patternAddColorStopRGBA pattern 0.84 0.713 0.713 0.713 0.137
+ patternAddColorStopRGBA pattern 1 1 1 1 0
+ patternSetFilter pattern FilterFast
+ setSource pattern
+ arc 0.5 0.5 (142/150) 0 (pi*2)
+ fill
+
+drawClockFace True =
+ withLinearPattern 0.5 0 0.5 1 $ \pattern -> do
+ patternAddColorStopRGB pattern 0 0.91 0.96 0.93
+ patternAddColorStopRGB pattern 1 0.65 0.68 0.68
+ patternSetFilter pattern FilterFast
+ setSource pattern
+ translate 0.5 0.5
+ arc 0 0 (60/150) 0 (pi*2)
+ fill
+drawClockFace False = do
+ setSourceRGB 0.78 0.82 0.805
+ translate 0.5 0.5
+ arc 0 0 (60/150) 0 (pi*2)
+ fill
+
+drawHourMarks = do
+ save
+ forM_ [1..12] $ \_ -> do
+ rotate (pi/6)
+ moveTo (4.5/6) 0
+ lineTo (5.0/6) 0
+ stroke
+ restore
+
+forM_ = flip mapM_
+
+drawHourHand quality hours minutes seconds = do
+ save
+ rotate (-pi/2)
+ setLineCap LineCapSquare
+ setLineJoin LineJoinMiter
+ rotate ( (pi/6) * hours
+ + (pi/360) * minutes
+ + (pi/21600) * seconds)
+ [_$_]
+ -- hour hand's shadow
+ when quality $ do
+ setLineWidth (1.75/60)
+ setOperator OperatorAtop
+ setSourceRGBA 0.16 0.18 0.19 0.125
+ moveTo (-2/15 + 0.025) 0.025
+ lineTo (7/15 + 0.025) 0.025
+ stroke
+ [_$_]
+ -- the hand itself
+ setLineWidth (1/60)
+ setOperator OperatorOver
+ setSourceRGB 0.16 0.18 0.19
+ moveTo (-2/15) 0
+ lineTo (7/15) 0
+ stroke
+ restore
+
+drawMinuteHand quality minutes seconds = do
+ save
+ rotate (-pi/2)
+ setLineCap LineCapSquare
+ setLineJoin LineJoinMiter
+ rotate ( (pi/30) * minutes
+ + (pi/1800) * seconds)
+ [_$_]
+ -- minute hand's shadow
+ when quality $ do
+ setLineWidth (1.75/60)
+ setOperator OperatorAtop
+ setSourceRGBA 0.16 0.18 0.19 0.125
+ moveTo (-16/75 - 0.025) (-0.025)
+ lineTo (2/3 - 0.025) (-0.025)
+ stroke
+ [_$_]
+ -- the minute hand itself
+ setLineWidth (1/60)
+ setOperator OperatorOver
+ setSourceRGB 0.16 0.18 0.19
+ moveTo (-16/75) 0
+ lineTo (2/3) 0
+ stroke
+ restore
+
+drawSecondHand quality seconds = do
+ save
+ rotate (-pi/2)
+ setLineCap LineCapSquare
+ setLineJoin LineJoinMiter
+ rotate (seconds * pi/30);
+
+ -- shadow of second hand-part
+ when quality $ do
+ setOperator OperatorAtop
+ setSourceRGBA 0.16 0.18 0.19 0.125
+ setLineWidth (1.3125 / 60)
+ moveTo (-1.5/5 + 0.025) 0.025
+ lineTo (3/5 + 0.025) 0.025
+ stroke
+
+ -- second hand
+ setOperator OperatorOver
+ setSourceRGB 0.39 0.58 0.77
+ setLineWidth (0.75/60)
+ moveTo (-1.5/5) 0
+ lineTo (3/5) 0
+ stroke
+
+ arc 0 0 (1/20) 0 (pi*2)
+ fill
+ arc (63/100) 0 (1/35) 0 (pi*2)
+ stroke
+ setLineWidth (1/100)
+ moveTo (10/15) 0
+ lineTo (12/15) 0
+ stroke
+ setSourceRGB 0.31 0.31 0.31
+ arc 0 0 (1/25) 0 (pi*2)
+ fill
+ restore
+
+drawInnerShadow = do
+ save
+ setOperator OperatorOver
+ arc 0 0 (142/150) 0 (pi*2)
+ clip
+ withRadialPattern 0.3 0.3 0.1 0 0 0.95 $ \pattern -> do
+ patternAddColorStopRGBA pattern 0 1 1 1 0
+ patternAddColorStopRGBA pattern 0.64 0.713 0.713 0.713 0.137
+ patternAddColorStopRGBA pattern 0.84 0.345 0.345 0.345 0.317
+ patternAddColorStopRGBA pattern 1 0 0 0 0.811
+ patternSetFilter pattern FilterFast
+ setSource pattern
+ arc 0 0 (142/150) 0 (pi*2)
+ fill
+ restore
+
+drawReflection = do
+ save
+ arc 0 0 (142/150) 0 (pi*2)
+ clip
+ rotate (-75 * pi/180)
+ setSourceRGBA 0.87 0.9 0.95 0.25
+ moveTo (-1) (-1)
+ lineTo 1 (-1)
+ lineTo 1 1
+ curveTo 1 0.15 (-0.15) (-1) (-1) (-1)
+ fill
+ moveTo (-1) (-1)
+ lineTo (-1) 1
+ lineTo 1 1
+ curveTo (-0.5) 1 (-1) 0.5 (-1) (-1)
+ fill
+ restore
+
+drawFrame True = do
+ save
+ withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do
+ patternAddColorStopRGB pattern 0 0.4 0.4 0.4
+ patternAddColorStopRGB pattern 0.2 0.95 0.95 0.95
+ patternSetFilter pattern FilterFast
+ setSource pattern
+ setLineWidth (10/75)
+ arc 0 0 (142/150) 0 (pi*2)
+ stroke
+
+ withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do
+ patternAddColorStopRGB pattern 0 0.9 0.9 0.9
+ patternAddColorStopRGB pattern 0.2 0.35 0.35 0.35
+ patternSetFilter pattern FilterFast
+ setSource pattern
+ setLineWidth (10/75)
+ arc 0 0 (150/150) 0 (pi*2)
+ stroke
+ restore
+drawFrame False = do
+ save
+ setSourceRGB 0 0 0
+ setLineWidth (10/75)
+ arc 0 0 1 0 (pi*2)
+ stroke
+ restore
+
+initialSize :: Int
+initialSize = 256
+
+main = do
+ initGUI
+ [_$_]
+ window <- windowNew
+ windowSetDecorated window False
+ windowSetResizable window True
+ windowSetPosition window WinPosCenterAlways
+
+ widgetSetAppPaintable window True
+ handleGError (\_ -> return ()) $
+ windowSetIconFromFile window "cairo-clock-icon.png"
+ windowSetTitle window "Gtk2Hs Cairo Clock"
+ windowSetDefaultSize window initialSize initialSize
+ windowSetGeometryHints window (Just window)
+ (Just (32, 32)) (Just (512, 512))
+ Nothing Nothing (Just (1,1))
+
+ let setAlpha widget = do
+ screen <- widgetGetScreen widget
+ colormap <- screenGetRGBAColormap screen
+ maybe (return ()) (widgetSetColormap widget) colormap
+ setAlpha window --TODO: also call setAlpha on alpha screen change
+
+ window `on` keyPressEvent $ tryEvent $ do
+ "Escape" <- eventKeyName
+ liftIO mainQuit
+ [_$_]
+ window `on` buttonPressEvent $ tryEvent $ do
+ LeftButton <- eventButton
+ time <- eventTime
+ (x,y) <- eventRootCoordinates
+ liftIO $ windowBeginMoveDrag window LeftButton (round x) (round y) time
+ [_$_]
+ window `on` buttonPressEvent $ tryEvent $ do
+ MiddleButton <- eventButton
+ time <- eventTime
+ (x,y) <- eventRootCoordinates
+ liftIO $ windowBeginResizeDrag window WindowEdgeSouthEast MiddleButton
+ (round x) (round y) time
+
+ timeoutAdd (widgetQueueDraw window >> return True) 1000
+
+ backgroundRef <- newIORef (Just undefined)
+ foregroundRef <- newIORef (Just undefined)
+
+ let redrawStaticLayers = do
+ (width, height) <- widgetGetSize window
+ drawWin <- widgetGetDrawWindow window
+ background <- createImageSurface FormatARGB32 width height
+ foreground <- createImageSurface FormatARGB32 width height
+ let clear = do [_$_]
+ save
+ setOperator OperatorClear
+ paint
+ restore
+ renderWith background $ do
+ clear
+ drawClockBackground True width height
+ renderWith foreground $ do
+ clear
+ drawClockForeground True width height
+ writeIORef backgroundRef (Just background)
+ writeIORef foregroundRef (Just foreground)
+ [_$_]
+ onRealize window redrawStaticLayers
+
+ sizeRef <- newIORef (initialSize, initialSize)
+ timeoutHandlerRef <- newIORef Nothing
+ window `on` configureEvent $ do
+ (w,h) <- eventSize
+ liftIO $ do
+ size <- readIORef sizeRef
+ writeIORef sizeRef (w,h)
+ when (size /= (w,h)) $ do
+ [_$_]
+ background <- readIORef backgroundRef
+ foreground <- readIORef foregroundRef
+ maybe (return ()) surfaceFinish background
+ maybe (return ()) surfaceFinish foreground
+
+ writeIORef backgroundRef Nothing
+ writeIORef foregroundRef Nothing
+ [_$_]
+ timeoutHandler <- readIORef timeoutHandlerRef
+ maybe (return ()) timeoutRemove timeoutHandler
+ [_$_]
+ handler <- timeoutAddFull (do
+ writeIORef timeoutHandlerRef Nothing
+ redrawStaticLayers
+ widgetQueueDraw window
+ return False
+ ) priorityDefaultIdle 300
+ writeIORef timeoutHandlerRef (Just handler)
+ [_$_]
+ return False
+
+ window `on` exposeEvent $ do
+ drawWin <- eventWindow
+ exposeRegion <- eventRegion
+ liftIO $ do
+ (width, height) <- drawableGetSize drawWin
+
+ background <- readIORef backgroundRef
+ foreground <- readIORef foregroundRef
+
+ renderWithDrawable drawWin $ do
+ region exposeRegion
+ clip
+
+ save
+ setOperator OperatorSource
+ setSourceRGBA 0 0 0 0
+ paint
+ restore
+
+ case background of
+ Nothing -> drawClockBackground False width height
+ Just background -> do
+ setSourceSurface background 0 0
+ paint
+
+ drawClockHands (isJust background) width height
+
+ case foreground of
+ Nothing -> drawClockForeground False width height
+ Just foreground -> do
+ setSourceSurface foreground 0 0
+ paint
+
+ return True
+
+ widgetShowAll window
+ mainGUI
addfile ./cairo/demo/Drawing.hs
hunk ./cairo/demo/Drawing.hs 1
+-- Example of an drawing graphics onto a canvas.
+import Graphics.UI.Gtk
+import Graphics.Rendering.Cairo
+import Graphics.UI.Gtk.Gdk.EventM
+
+main = do
+ initGUI
+ dia <- dialogNew
+ dialogAddButton dia stockOk ResponseOk
+ contain <- dialogGetUpper dia
+ canvas <- drawingAreaNew
+ canvas `on` sizeRequest $ return (Requisition 40 40)
+ ctxt <- cairoCreateContext Nothing
+ text <- layoutEmpty ctxt
+ text `layoutSetText` "Hello World."
+ canvas `on` exposeEvent $ updateCanvas text
+ boxPackStartDefaults contain canvas
+ widgetShow canvas
+ dialogRun dia
+ return ()
+
+updateCanvas :: PangoLayout -> EventM EExpose Bool
+updateCanvas text = do
+ win <- eventWindow
+ liftIO $ do
+ (width',height') <- drawableGetSize win
+ let width = realToFrac width'
+ height = realToFrac height'
+
+ -- Draw using the cairo api
+ renderWithDrawable win $ do
+ setSourceRGB 1 0 0
+ setLineWidth 20
+ setLineCap LineCapRound
+ setLineJoin LineJoinRound
+
+ moveTo 30 30
+ lineTo (width-30) (height-30)
+ lineTo (width-30) 30
+ lineTo 30 (height-30)
+ stroke
+
+ setSourceRGB 1 1 0
+ setLineWidth 4
+ [_$_]
+ save
+ translate (width / 2) (height / 2)
+ scale (width / 2) (height / 2)
+ arc 0 0 1 (135 * pi/180) (225 * pi/180)
+ restore
+ stroke
+ [_$_]
+ setSourceRGB 0 0 0
+ moveTo 30 (realToFrac height / 4)
+ rotate (pi/4)
+ showLayout text
+
+
+ return True
addfile ./cairo/demo/Drawing2.hs
hunk ./cairo/demo/Drawing2.hs 1
+--
+-- Author: Johan Bockg[_\c3_][_\a5_]rd <bo...@dd...>
+--
+-- This code is in the public domain.
+--
+
+import qualified Graphics.UI.Gtk as G
+import qualified Graphics.Rendering.Cairo as C
+import qualified Graphics.Rendering.Cairo.Matrix as M
+
+
+windowWidth, windowHeight :: Int
+windowWidth = 500
+windowHeight = 500
+
+-- Write image to file
+writePng :: IO ()
+writePng =
+ C.withImageSurface C.FormatARGB32 width height $ \ result -> do
+ C.renderWith result $ example width height
+ C.surfaceWriteToPNG result "Draw.png"
+ where width = windowWidth
+ height = windowHeight
+
+-- Display image in window
+main = do
+ G.initGUI
+ window <- G.windowNew
+ canvas <- G.drawingAreaNew
+ -- fix size
+ -- G.windowSetResizable window False
+ G.widgetSetSizeRequest window windowWidth windowHeight
+ -- press any key to quit
+ G.onKeyPress window $ const (do G.widgetDestroy window; return True)
+ G.onDestroy window G.mainQuit
+ G.onExpose canvas $ const (updateCanvas canvas)
+ G.set window [G.containerChild G.:= canvas]
+ G.widgetShowAll window
+ G.mainGUI
+
+updateCanvas :: G.DrawingArea -> IO Bool
+updateCanvas canvas = do
+ win <- G.widgetGetDrawWindow canvas
+ (width, height) <- G.widgetGetSize canvas
+ G.renderWithDrawable win $
+ example width height
+ return True
+
+----------------------------------------------------------------
+
+foreach :: (Monad m) => [a] -> (a -> m b) -> m [b]
+foreach = flip mapM
+
+keepState render = do
+ C.save
+ render
+ C.restore
+
+drawCircle x y r = do
+ C.arc x y r 0 (2 * pi)
+ fillStroke
+
+drawRectangle x y w h = do
+ C.rectangle x y w h
+ fillStroke
+
+stroke =
+ keepState $ do
+ C.setSourceRGBA 0 0 0 0.7
+ C.stroke
+
+fillStroke = do
+ C.fillPreserve
+ stroke
+
+----------------------------------------------------------------
+
+-- Example
+
+example width height = do
+ prologue width height
+ example1
+
+-- Set up stuff
+prologue wWidth wHeight = do
+ let width = 10
+ height = 10
+ xmax = width / 2
+ xmin = - xmax
+ ymax = height / 2
+ ymin = - ymax
+ scaleX = realToFrac wWidth / width
+ scaleY = realToFrac wHeight / height
+
+ -- style and color
+ C.setLineCap C.LineCapRound
+ C.setLineJoin C.LineJoinRound
+ C.setLineWidth $ 1 / max scaleX scaleY
+ C.setSourceRGBA 0.5 0.7 0.5 0.5
+
+ -- Set up user coordinates
+ C.scale scaleX scaleY
+ -- center origin
+ C.translate (width / 2) (height / 2)
+ -- positive y-axis upwards
+ let flipY = M.Matrix 1 0 0 (-1) 0 0
+ C.transform flipY
+
+ grid xmin xmax ymin ymax
+
+
+-- Grid and axes
+grid xmin xmax ymin ymax =
+ keepState $ do
+ C.setSourceRGBA 0 0 0 0.7
+ -- axes
+ C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke
+ C.moveTo xmin 0; C.lineTo xmax 0; C.stroke
+ -- grid
+ C.setDash [0.01, 0.99] 0
+ foreach [xmin .. xmax] $ \ x ->
+ do C.moveTo x ymin
+ C.lineTo x ymax
+ C.stroke
+
+example1 = do
+ -- circles
+ drawCircle 0 0 1
+ drawCircle 2 2 3
+ -- a bunch of rectangles
+ keepState $
+ foreach [1 .. 5] $ \ _ ->
+ do drawRectangle 0 1 2 3
+ C.rotate (pi/8)
+ -- some cute stuff
+ thought
+ apple
+ snake
+
+thought =
+ keepState $ do
+ C.scale 0.04 0.04
+ C.translate (200) (380)
+ C.rotate pi
+ C.setSourceRGBA 0.5 0.5 1 0.7
+ C.setLineWidth 1
+ image
+ fillStroke
+ where
+ m = C.moveTo
+ c = C.curveTo
+ z = C.closePath
+ image = do
+ m 184 327
+ c 176 327 170 332 168 339
+ c 166 333 160 329 153 329
+ c 147 329 141 333 138 339
+ c 137 339 136 338 134 338
+ c 125 338 118 345 118 354
+ c 118 363 125 371 134 371
+ c 137 371 140 370 142 368
+ c 142 368 142 368 142 369
+ c 142 377 149 385 158 385
+ c 162 385 166 383 168 381
+ c 171 386 176 390 183 390
+ c 188 390 193 387 196 383
+ c 198 384 201 385 204 385
+ c 212 385 220 378 220 369
+ c 222 371 225 372 228 372
+ c 237 372 244 364 244 355
+ c 244 346 237 339 228 339
+ c 227 339 226 339 225 340
+ c 223 332 217 327 209 327
+ c 204 327 199 330 196 333
+ c 193 330 189 327 184 327
+ z
+ m 164 387
+ c 158 387 153 391 153 397
+ c 153 402 158 407 164 407
+ c 170 407 174 402 174 397
+ c 174 391 170 387 164 387
+ z
+ m 152 408
+ c 149 408 146 411 146 414
+ c 146 417 149 420 152 420
+ c 155 420 158 417 158 414
+ c 158 411 155 408 152 408
+ z
+ m 143 422
+ c 141 422 139 424 139 426
+ c 139 428 141 429 143 429
+ c 144 429 146 428 146 426
+ c 146 424 144 422 143 422
+ z
+
+apple =
+ keepState $ do
+ C.scale 0.05 0.05
+ C.translate (1110) (220)
+ C.rotate pi
+ C.setLineWidth 0.5
+ C.setSourceRGBA 0 0 0 0.7
+ image1
+ fillStroke
+ C.setSourceRGBA 1 0 0 0.7
+ image2
+ fillStroke
+ where
+ m = C.moveTo
+ c = C.curveTo
+ z = C.closePath
+ l = C.lineTo
+ image1 = do
+ m 1149 245
+ l 1156 244
+ l 1155 252
+ l 1149 245
+ z
+ image2 = do
+ m 1151 249
+ c 1145 249 1140 254 1140 261
+ c 1140 268 1145 273 1151 273
+ c 1152 273 1153 273 1154 272
+ c 1156 273 1157 273 1158 273
+ c 1164 273 1169 268 1169 261
+ c 1169 254 1164 249 1158 249
+ c 1157 249 1156 249 1154 250
+ c 1153 249 1152 249 1151 249
+ z
+
+snake =
+ keepState $ do
+ C.scale 0.04 0.04
+ C.translate (150) (220)
+ C.rotate pi
+ C.setLineWidth 0.5
+ C.setSourceRGBA 0.1 0.1 0 0.7
+ image
+ fillStroke
+ where
+ m = C.moveTo
+ c = C.curveTo
+ z = C.closePath
+ l = C.lineTo
+ image = do
+ m 146 320
+ c 143 308 130 314 123 319
+ c 115 324 108 311 100 314
+ c 93 317 92 319 81 318
+ c 76 318 60 309 60 320
+ c 60 328 73 321 82 323
+ c 94 326 98 317 106 320
+ c 113 323 120 330 128 323
+ c 133 318 142 312 146 320
+ l 146 320
+ z
+
+----------------------------------------------------------------
addfile ./cairo/demo/Graph.hs
hunk ./cairo/demo/Graph.hs 1
+--
+-- Author: Michael Sloan <mg...@gm...>
+--
+-- This code is in the public domain.
+--
+-- Based off Johan Bockg[_\c3_][_\a5_]rd's Drawing2.hs
+--
+
+import qualified Graphics.UI.Gtk as G
+import qualified Graphics.Rendering.Cairo as C
+import qualified Graphics.Rendering.Cairo.Matrix as M
+
+f x = sin (x*5) / (x*5)
+
+main = graph f
+
+graph :: (Double -> Double) -> IO ()
+graph f = do
+ G.initGUI
+ window <- G.windowNew
+ canvas <- G.drawingAreaNew
+ G.windowSetResizable window False
+ G.widgetSetSizeRequest window 600 600
+ -- press any key to quit
+ G.onKeyPress window $ const (do G.widgetDestroy window; return True)
+ G.onDestroy window G.mainQuit
+ G.onExpose canvas $ const $ render f canvas
+ G.set window [G.containerChild G.:= canvas]
+ G.widgetShowAll window
+ G.mainGUI
+
+render :: (Double -> Double) -> G.DrawingArea -> IO Bool
+render f canvas = do
+ win <- G.widgetGetDrawWindow canvas
+ (width, height) <- G.widgetGetSize canvas
+ G.renderWithDrawable win $ (prologue width height >> renderG f)
+ return True
+
+foreach :: (Monad m) => [a] -> (a -> m b) -> m [b]
+foreach = flip mapM
+
+deriv :: (Double -> Double) -> Double -> Double
+deriv f x = ((f $ x + 0.05) - (f $ x - 0.05)) * 10
+
+gen :: Double -> Double -> (Double -> Double) -> [Double]
+gen v t f | v > t = []
+gen v t f = v : (gen (f v) t f)
+
+skipBy f = foldr (\x c -> if f x then c else x : c) []
+
+falloff x = 0.25 * (x + 1.5) / ((x+0.5)^5 + 1)
+
+renderG :: (Double -> Double) -> C.Render ()
+renderG f = do
+ C.moveTo (-5) (f (-5))
+ sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) [-4.9,-4.8..5]
+ --Adaptive attempt (falloff func is what really needs work)
+ --sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) $ tail $ gen (-5) 5 (\x -> x + (falloff $ abs $ deriv (deriv f) x))
+ C.stroke
+
+-- Set up stuff
+prologue wWidth wHeight = do
+ let width = 10
+ height = 10
+ xmax = width / 2
+ xmin = - xmax
+ ymax = height / 2
+ ymin = - ymax
+ ...
[truncated message content] |
|
From: Andy S. <And...@co...> - 2010-05-01 17:42:57
|
Sat May 1 13:36:21 EDT 2010 Andy Stewart <laz...@gm...>
* Move pango demo to `gtk2hs/pango/demo`.
Ignore-this: f93de2952148b90d739bf4e06f31fcaa
hunk ./demo/pango/Layout.hs 1
--- Example of using a PangoLayout
-import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Gdk.EventM
-import Graphics.Rendering.Cairo
-
-loremIpsum = "Lorem ipsum dolor sit amet, consectetur adipisicing elit,\
- \ sed do eiusmod tempor incididunt ut labore et dolore magna\
- \ aliqua. Ut enim ad minim veniam, quis nostrud exercitation\
- \ ullamco laboris nisi ut aliquip ex ea commodo consequat.\
- \ Duis aute irure dolor in reprehenderit in voluptate\
- \ velit esse cillum dolore eu fugiat nulla pariatur.\
- \ Excepteur sint occaecat cupidatat non proident, sunt in culpa\
- \ qui officia deserunt mollit anim id est laborum."
-
-main = do
- initGUI
- -- Create the main window.
- win <- windowNew
- on win objectDestroy mainQuit
- -- Create a drawing area in which we can render text.
- area <- drawingAreaNew
- containerAdd win area
- on area sizeRequest $ return (Requisition 100 100)
- [_$_]
- -- Create a Cairo Context that contains information about the current font,
- -- etc.
- ctxt <- cairoCreateContext Nothing
- lay <- layoutText ctxt loremIpsum
- layoutSetWrap lay WrapWholeWords
- [_$_]
- -- Wrap the layout to a different width each time the window is resized.
- on area sizeAllocate $ \(Rectangle _ _ w _) -> do
- layoutSetWidth lay (Just (fromIntegral w))
-
- -- Setup the handler to draw the layout.
- on area exposeEvent $ updateArea area lay
- [_$_]
- -- Run the whole thing.
- widgetShowAll win
- mainGUI
-
-updateArea :: DrawingArea -> PangoLayout -> EventM EExpose Bool
-updateArea area lay = do
- win <- eventWindow
- liftIO $ do
- renderWithDrawable win $ do
- moveTo 0 0
- showLayout lay
-
- return True
- [_$_]
rmfile ./demo/pango/Layout.hs
hunk ./demo/pango/Makefile 1
-
-PROG = layout [_$_]
-SOURCES = Layout.hs
-
-$(PROG) : $(SOURCES)
- $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
-
-HC=ghc
rmfile ./demo/pango/Makefile
rmdir ./demo/pango
adddir ./pango/demo
addfile ./pango/demo/Layout.hs
hunk ./pango/demo/Layout.hs 1
+-- Example of using a PangoLayout
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Gdk.EventM
+import Graphics.Rendering.Cairo
+
+loremIpsum = "Lorem ipsum dolor sit amet, consectetur adipisicing elit,\
+ \ sed do eiusmod tempor incididunt ut labore et dolore magna\
+ \ aliqua. Ut enim ad minim veniam, quis nostrud exercitation\
+ \ ullamco laboris nisi ut aliquip ex ea commodo consequat.\
+ \ Duis aute irure dolor in reprehenderit in voluptate\
+ \ velit esse cillum dolore eu fugiat nulla pariatur.\
+ \ Excepteur sint occaecat cupidatat non proident, sunt in culpa\
+ \ qui officia deserunt mollit anim id est laborum."
+
+main = do
+ initGUI
+ -- Create the main window.
+ win <- windowNew
+ on win objectDestroy mainQuit
+ -- Create a drawing area in which we can render text.
+ area <- drawingAreaNew
+ containerAdd win area
+ on area sizeRequest $ return (Requisition 100 100)
+ [_$_]
+ -- Create a Cairo Context that contains information about the current font,
+ -- etc.
+ ctxt <- cairoCreateContext Nothing
+ lay <- layoutText ctxt loremIpsum
+ layoutSetWrap lay WrapWholeWords
+ [_$_]
+ -- Wrap the layout to a different width each time the window is resized.
+ on area sizeAllocate $ \(Rectangle _ _ w _) -> do
+ layoutSetWidth lay (Just (fromIntegral w))
+
+ -- Setup the handler to draw the layout.
+ on area exposeEvent $ updateArea area lay
+ [_$_]
+ -- Run the whole thing.
+ widgetShowAll win
+ mainGUI
+
+updateArea :: DrawingArea -> PangoLayout -> EventM EExpose Bool
+updateArea area lay = do
+ win <- eventWindow
+ liftIO $ do
+ renderWithDrawable win $ do
+ moveTo 0 0
+ showLayout lay
+
+ return True
+ [_$_]
addfile ./pango/demo/Makefile
hunk ./pango/demo/Makefile 1
+
+PROG = layout [_$_]
+SOURCES = Layout.hs
+
+$(PROG) : $(SOURCES)
+ $(HC) --make $< -o $@ $(HCFLAGS)
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
+
+HC=ghc
|
|
From: Andy S. <And...@co...> - 2010-05-01 17:42:56
|
Sat May 1 13:35:18 EDT 2010 Andy Stewart <laz...@gm...>
* Move svg demo to `gtk2hs/svgcairo/demo`.
Ignore-this: da7867efa4d2c2c21fedd7a2335048e7
hunk ./demo/svg/Makefile 1
-
-PROGS = svg2png svgviewer
-SOURCES = Svg2Png.hs SvgViewer.hs
-
-all : $(PROGS)
-
-svg2png : Svg2Png.hs
- $(HC_RULE)
-
-svgviewer : SvgViewer.hs
- $(HC_RULE)
-
-HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
- rm -f *.png
-
-HC=ghc
rmfile ./demo/svg/Makefile
hunk ./demo/svg/Svg2Png.hs 1
-
-import System.Environment (getArgs)
-
-import Graphics.Rendering.Cairo
-import Graphics.Rendering.Cairo.SVG
-
-main :: IO ()
-main = do
- [inFile, outFile] <- getArgs
- svg <- svgNewFromFile inFile
- let (width, height) = svgGetSize svg
- withImageSurface FormatARGB32 width height $ \result -> do
- renderWith result $ do
- clear
- svgRender svg
- surfaceWriteToPNG result outFile
-
-clear :: Render ()
-clear = do
- save
- setOperator OperatorClear
- paint
- restore
rmfile ./demo/svg/Svg2Png.hs
hunk ./demo/svg/SvgViewer.hs 1
-
-import System.Environment (getArgs)
-
-import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Gdk.EventM
-import Graphics.Rendering.Cairo
-import Graphics.Rendering.Cairo.SVG
-
-main :: IO ()
-main = do
-
- (file:_) <- getArgs
- svg <- svgNewFromFile file
- let (width, height) = svgGetSize svg
-
- initGUI
- dia <- dialogNew
- dialogAddButton dia stockOk ResponseOk
- contain <- dialogGetUpper dia
- canvas <- drawingAreaNew
- onSizeRequest canvas $ return (Requisition width height)
- canvas `on` exposeEvent $ updateCanvas canvas svg
- boxPackStartDefaults contain canvas
- widgetShow canvas
- dialogRun dia
- return ()
-
-updateCanvas :: DrawingArea -> SVG -> EventM EExpose Bool
-updateCanvas canvas svg = do
- win <- eventWindow
- liftIO $ do
- let (width, height) = svgGetSize svg
- (width', height') <- widgetGetSize canvas
- renderWithDrawable win $ do
- scale (realToFrac width' / realToFrac width)
- (realToFrac height' / realToFrac height)
- svgRender svg
- return True
rmfile ./demo/svg/SvgViewer.hs
rmdir ./demo/svg
adddir ./svgcairo/demo
addfile ./svgcairo/demo/Makefile
hunk ./svgcairo/demo/Makefile 1
+
+PROGS = svg2png svgviewer
+SOURCES = Svg2Png.hs SvgViewer.hs
+
+all : $(PROGS)
+
+svg2png : Svg2Png.hs
+ $(HC_RULE)
+
+svgviewer : SvgViewer.hs
+ $(HC_RULE)
+
+HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS)
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
+ rm -f *.png
+
+HC=ghc
addfile ./svgcairo/demo/Svg2Png.hs
hunk ./svgcairo/demo/Svg2Png.hs 1
+
+import System.Environment (getArgs)
+
+import Graphics.Rendering.Cairo
+import Graphics.Rendering.Cairo.SVG
+
+main :: IO ()
+main = do
+ [inFile, outFile] <- getArgs
+ svg <- svgNewFromFile inFile
+ let (width, height) = svgGetSize svg
+ withImageSurface FormatARGB32 width height $ \result -> do
+ renderWith result $ do
+ clear
+ svgRender svg
+ surfaceWriteToPNG result outFile
+
+clear :: Render ()
+clear = do
+ save
+ setOperator OperatorClear
+ paint
+ restore
addfile ./svgcairo/demo/SvgViewer.hs
hunk ./svgcairo/demo/SvgViewer.hs 1
+
+import System.Environment (getArgs)
+
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Gdk.EventM
+import Graphics.Rendering.Cairo
+import Graphics.Rendering.Cairo.SVG
+
+main :: IO ()
+main = do
+
+ (file:_) <- getArgs
+ svg <- svgNewFromFile file
+ let (width, height) = svgGetSize svg
+
+ initGUI
+ dia <- dialogNew
+ dialogAddButton dia stockOk ResponseOk
+ contain <- dialogGetUpper dia
+ canvas <- drawingAreaNew
+ onSizeRequest canvas $ return (Requisition width height)
+ canvas `on` exposeEvent $ updateCanvas canvas svg
+ boxPackStartDefaults contain canvas
+ widgetShow canvas
+ dialogRun dia
+ return ()
+
+updateCanvas :: DrawingArea -> SVG -> EventM EExpose Bool
+updateCanvas canvas svg = do
+ win <- eventWindow
+ liftIO $ do
+ let (width, height) = svgGetSize svg
+ (width', height') <- widgetGetSize canvas
+ renderWithDrawable win $ do
+ scale (realToFrac width' / realToFrac width)
+ (realToFrac height' / realToFrac height)
+ svgRender svg
+ return True
|
|
From: Andy S. <And...@co...> - 2010-05-01 17:42:55
|
Sat May 1 13:33:50 EDT 2010 Andy Stewart <laz...@gm...>
* Move soe demo to `gtk2hs/soegtk/demo`.
Ignore-this: f861db155bcb0b0f266ccbcac2770ef5
hunk ./demo/soe/BouncingBall.hs 1
-{- Written by Antti-Juhani Kaijanaho.
- You may treat this file as if it were in the public domain.
--}
-module Main where
-
-import Graphics.SOE.Gtk
-
-main = runGraphics $
- do w <- openWindowEx "Bouncing Ball" Nothing (Just (300, 300)) drawBufferedGraphic
- let loop x y xd yd
- = do setGraphic w $ withColor Yellow $
- ellipse (x-5,y-5) (x+5,y+5)
- (xmax, ymax) <- getWindowSize w
- let x' = x + xd + 5
- y' = y + yd + 5
- xd' | x' >= xmax || x' < 0 = -xd
- | otherwise = xd
- yd' | y' >= ymax || y' < 0 = -yd
- | otherwise = yd
- x'' = x + xd'
- y'' = y + yd'
- x''' | x'' + 5 > xmax = xmax `div` 2
- | otherwise = x''
- y''' | y'' + 5 > ymax = ymax `div` 2
- | otherwise = y''
- e <- getWindowEvent w
- case e of Closed -> return ()
- _ -> loop x''' y''' xd' yd'
- loop 300 100 5 5
-
rmfile ./demo/soe/BouncingBall.hs
hunk ./demo/soe/Demo1.hs 1
-{- Written by Antti-Juhani Kaijanaho.
- You may treat this file as if it were in the public domain.
--}
-module Main where
-
-import Graphics.SOE.Gtk
-
-main = runGraphics $ do w <- openWindow "Testing" (200, 200)
- drawInWindow w $ text (100,100) "Hello"
- drawInWindow w $ line (50, 50) (75, 75)
- drawInWindow w $ withColor White $ polyline [(10,10), (10,40), (20,20)]
- drawInWindow w $ polygon [(60,60), (60,90), (80,90)]
- drawInWindow w $ withColor Yellow $
- ellipse (290, 190) (150, 150)
- drawInWindow w $ arc (20,190) (90,130) (45) (390)
- drawInWindow w $ withColor Blue $ line (20,190) (90,130)
- drawInWindow w $ withColor Yellow $
- shearEllipse (140, 10) (160, 90) (190, 50)
- loopEvents w
- closeWindow w
-
-loopEvents w = loop
- where loop = do e <- getWindowEvent w
- case e of Closed -> return ()
- _ -> loop
rmfile ./demo/soe/Demo1.hs
hunk ./demo/soe/Demo2.hs 1
-{- Written by Antti-Juhani Kaijanaho.
- You may treat this file as if it were in the public domain.
--}
-module Main where
-
-import Graphics.SOE.Gtk
-
-main = runGraphics $ do w <- openWindow "Testing" (200, 200)
- drawInWindow w $ text (10,180) "Hello"
- drawInWindow w $ withColor Blue $
- polyline [(20,20), (20,150), (150,150), (150,20), (20,20)]
- let region = createRectangle (20,20) (100,100)
- `orRegion` createRectangle (50,50) (150,150)
- `diffRegion` createRectangle (100,100) (150,150)
- drawInWindow w $ withColor Blue $
- polyline [(20,20), (20,100), (100,100), (100,20), (20,20)]
- drawInWindow w $ withColor Blue $
- polyline [(50,50), (50,150), (150,150), (150,50), (50,50)]
- drawInWindow w $ withColor Green $ drawRegion region
- loopEvents w
- closeWindow w
-
-loopEvents w = loop
- where loop = do e <- getWindowEvent w
- case e of Closed -> return ()
- _ -> loop
rmfile ./demo/soe/Demo2.hs
hunk ./demo/soe/Makefile 1
-
-PROGS = bouncingball snowflake demo1 demo2
-
-SOURCES = BouncingBall.hs Demo1.hs Demo2.hs Snowflake.hs
-PACKAGES = gtk soegtk
-
-all : $(PROGS)
-
-bouncingball : BouncingBall.hs
- $(HC_RULE)
-
-snowflake : Snowflake.hs
- $(HC_RULE)
-
-demo1 : Demo1.hs
- $(HC_RULE)
-
-demo2 : Demo2.hs
- $(HC_RULE)
-
-HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS) $(HCEXTRAFLAGS)
-
-HCEXTRAFLAGS = $(if $(HCNEEDSPACKAGE), $(addprefix -package ,$(PACKAGES)))
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
-
-HC=ghc
rmfile ./demo/soe/Makefile
hunk ./demo/soe/Snowflake.hs 1
-module Main where
-
-import Graphics.SOE.Gtk
-
-type Vector = (Double, Double)
-
-(<+>) :: Vector -> Vector -> Vector
-(a, b) <+> (c, d) = (a+c, b+d)
-
-(<->) :: Vector -> Vector -> Vector
-(a, b) <-> (c, d) = (a-c, b-d)
-
-(.*) :: Double -> Vector -> Vector
-k .* (a, b) = (k * a, k * b)
-
-(*.) :: Vector -> Double -> Vector
-(*.) = flip (.*)
-
-(<*>) :: Vector -> Vector -> Double
-(a, b) <*> (c, d) = a * c + b * d
-
-norm :: Vector -> Double
-norm v = sqrt (v <*> v)
-
-dist :: Vector -> Vector -> Double
-dist v1 v2 = norm (v1 <-> v2)
-
-xunit :: Vector
-xunit = (1, 0)
-
-yunit :: Vector
-yunit = (0,1)
-
-ortho :: Vector -> Vector
-ortho v@(a, b) = (m11*a + m12*b, m21*a+m22*b)
- where m11 = cos ang
- m12 = sin ang
- m21 = -sin ang
- m22 = cos ang
- ang = pi/2
-
-
-type Line = (Vector, Vector)
-
-gen :: [Line] -> [Line]
-gen [] = []
-gen (l@(v1,v2):ls)
- | dist v1 v2 < 3 = l : gen ls
- | otherwise = let dir = v1 <-> v2
- ort = ortho dir
- p = v2 <+> ((1/3) .* dir)
- q = v2 <+> ((2/3) .* dir)
- r = v2 <+> (0.5 .* dir) <+> ((1/3) .* ort)
- s = v2 <+> (0.5 .* dir) <+> ((-1/3) .* ort)
- in --(v2,p) : (q,v1) : gen ((p,r) : (q,r) : (p,s) : (q,s) : ls)
- gen ((v2,p) : (q,v1) : (p,r) : (q,r) : (p,s) : (q,s) : ls)
- -- kauniimpi kuva (mutta teht[_\c3_][_\a4_]v[_\c3_][_\a4_]nannon vastainen) tulee
- -- korvaamalla edellinen lauseke seuraavalla:
- -- gen ((v2,p) : (q,v1) : (p,r) : (q,r) : (p,s) : (q,s) : ls)
-
-draw :: [Line] -> Graphic
-draw [] = emptyGraphic
-draw ((p1,p2):ls) = overGraphic (line (f p1) (f p2)) (draw ls)
- where f (x,y) = (round (x), round (y))
-
-test = runGraphics $ do w <- openWindow "T 3.7-8" (200, 200)
- loop w
- closeWindow w
- where loop w = do (xmax', ymax') <- getWindowSize w
- let xmax = fromIntegral xmax'
- ymax = fromIntegral ymax'
- ls = gen [((1/8 * xmax, 1/2 * ymax),
- (7/8 * xmax, 1/2 * ymax))]
- setGraphic w (draw ls)
- e <- getWindowEvent w
- case e of Resize -> loop w
- _ -> return ()
-
-main = test
rmfile ./demo/soe/Snowflake.hs
rmdir ./demo/soe
adddir ./soegtk/demo
addfile ./soegtk/Setup.hs
hunk ./soegtk/Setup.hs 1
+{-# LANGUAGE CPP #-}
+
+#define CABAL_VERSION_ENCODE(major, minor, micro) ( \
+ ((major) * 10000) \
+ + ((minor) * 100) \
+ + ((micro) * 1))
+
+#define CABAL_VERSION_CHECK(major,minor,micro) \
+ (CABAL_VERSION >= CABAL_VERSION_ENCODE(major,minor,micro))
+
+-- now, this is bad, but Cabal doesn't seem to actually pass any information about
+-- its version to CPP, so guess the version depending on the version of GHC
+#ifdef CABAL_VERSION_MINOR
+#ifndef CABAL_VERSION_MAJOR
+#define CABAL_VERSION_MAJOR 1
+#endif
+#ifndef CABAL_VERSION_MICRO
+#define CABAL_VERSION_MICRO 0
+#endif
+#define CABAL_VERSION CABAL_VERSION_ENCODE( \
+ CABAL_VERSION_MAJOR, \
+ CABAL_VERSION_MINOR, \
+ CABAL_VERSION_MICRO)
+#else
+#warning Setup.hs is guessing the version of Cabal. If compilation of Setup.hs fails use -DCABAL_VERSION_MINOR=x for Cabal version 1.x.0 when building (prefixed by --ghc-option= when using the 'cabal' command)
+#if (__GLASGOW_HASKELL__ >= 612)
+#define CABAL_VERSION CABAL_VERSION_ENCODE(1,8,0)
+#else
+#define CABAL_VERSION CABAL_VERSION_ENCODE(1,6,0)
+#endif
+#endif
+
+-- | Build a Gtk2hs package.
+--
+import Distribution.Simple
+import Distribution.Simple.PreProcess
+import Distribution.InstalledPackageInfo ( importDirs )
+import Distribution.Simple.PackageIndex (
+#if CABAL_VERSION_CHECK(1,8,0)
+ lookupInstalledPackageId
+#else
+ lookupPackageId
+#endif
+ )
+import Distribution.PackageDescription as PD ( PackageDescription(..),
+ updatePackageDescription,
+ BuildInfo(..),
+ emptyBuildInfo, allBuildInfo,
+ Library(..),
+ libModules)
+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..),
+ InstallDirs(..),
+#if CABAL_VERSION_CHECK(1,8,0)
+ componentPackageDeps,
+#else
+ packageDeps,
+#endif
+ absoluteInstallDirs)
+import Distribution.Simple.Compiler ( Compiler(..) )
+import Distribution.Simple.Program (
+ Program(..), ConfiguredProgram(..),
+ rawSystemProgramConf, rawSystemProgramStdoutConf,
+ c2hsProgram, pkgConfigProgram,
+ simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg)
+import Distribution.ModuleName ( ModuleName, components, toFilePath )
+import Distribution.Simple.Utils
+import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..),
+ defaultCopyFlags, ConfigFlags(configVerbosity),
+ fromFlag, toFlag)
+import Distribution.Simple.BuildPaths ( autogenModulesDir )
+import Distribution.Text ( simpleParse, display )
+import System.FilePath
+import System.Directory ( doesFileExist )
+import Distribution.Version (Version(..))
+import Distribution.Verbosity
+import Control.Monad (unless)
+import Data.Maybe (fromMaybe)
+import Data.List (isPrefixOf, nub)
+import Data.Char (isAlpha)
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+
+-- the name of the c2hs pre-compiled header file
+precompFile = "precompchs.bin"
+
+main = defaultMainWithHooks simpleUserHooks {
+ hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal],
+ hookedPreProcessors = [("chs", ourC2hs)],
+ confHook = \pd cf ->
+ confHook simpleUserHooks pd cf >>= return . adjustLocalBuildInfo,
+ postConf = \args cf pd lbi -> do
+ genSynthezisedFiles (fromFlag (configVerbosity cf)) pd lbi
+ postConf simpleUserHooks args cf pd lbi,
+ buildHook = \pd lbi uh bf -> fixDeps pd >>= \pd ->
+ (buildHook simpleUserHooks) pd lbi uh bf,
+ copyHook = \pd lbi uh flags -> (copyHook simpleUserHooks) pd lbi uh flags >>
+ installCHI pd lbi (fromFlag (copyVerbosity flags)) (fromFlag (copyDest flags)),
+ instHook = \pd lbi uh flags -> (instHook simpleUserHooks) pd lbi uh flags >>
+ installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest
+ }
+
+-- This is a hack for Cabal-1.8, It is not needed in Cabal-1.9.1 or later
+adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo
+adjustLocalBuildInfo lbi =
+ let extra = (Just libBi, [])
+ libBi = emptyBuildInfo { includeDirs = [ autogenModulesDir lbi
+ , buildDir lbi ] }
+ in lbi { localPkgDescr = updatePackageDescription extra (localPkgDescr lbi) }
+
+ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor
+ourC2hs bi lbi = PreProcessor {
+ platformIndependent = False,
+ runPreProcessor = runC2HS bi lbi
+}
+
+runC2HS :: BuildInfo -> LocalBuildInfo ->
+ (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO ()
+runC2HS bi lbi (inDir, inFile) (outDir, outFile) verbosity = do
+ -- have the header file name if we don't have the precompiled header yet
+ header <- case lookup "x-c2hs-header" (customFieldsBI bi) of
+ Just h -> return h
+ Nothing -> die ("Need x-c2hs-Header definition in the .cabal Library section "++
+ "that sets the C header file to process .chs.pp files.")
+
+ -- c2hs will output files in out dir, removing any leading path of the input file.
+ -- Thus, append the dir of the input file to the output dir.
+ let (outFileDir, newOutFile) = splitFileName outFile
+ let newOutDir = outDir </> outFileDir
+ -- additional .chi files might be needed that other packages have installed;
+ -- we assume that these are installed in the same place as .hi files
+ let chiDirs = [ dir |
+#if CABAL_VERSION_CHECK(1,8,0)
+ ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi),
+ dir <- maybe [] importDirs (lookupInstalledPackageId (installedPkgs lbi) ipi) ]
+#else
+ ipi <- packageDeps lbi,
+ dir <- maybe [] importDirs (lookupPackageId (installedPkgs lbi) ipi) ]
+#endif
+ rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $
+ map ("--include=" ++) (outDir:chiDirs)
+ ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi]
+ ++ ["--output-dir=" ++ newOutDir,
+ "--output=" ++ newOutFile,
+ "--precomp=" ++ buildDir lbi </> precompFile,
+ header, inDir </> inFile]
+
+getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]
+getCppOptions bi lbi
+ = nub $
+ ["-I" ++ dir | dir <- PD.includeDirs bi]
+ ++ [opt | opt@('-':c:_) <- (PD.cppOptions bi ++ PD.ccOptions bi), c `elem` "DIU"]
+
+installCHI :: PackageDescription -- ^information from the .cabal file
+ -> LocalBuildInfo -- ^information from the configure step
+ -> Verbosity -> CopyDest -- ^flags sent to copy or install
+ -> IO ()
+installCHI pk...@PD...ckageDescription { library = Just lib } lbi verbosity copydest = do
+ let InstallDirs { libdir = libPref } = absoluteInstallDirs pkg lbi copydest
+ -- cannot use the recommended 'findModuleFiles' since it fails if there exists
+ -- a modules that does not have a .chi file
+ mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi])
+ (map toFilePath
+#if CABAL_VERSION_CHECK(1,8,0)
+ (PD.libModules lib)
+#else
+ (PD.libModules pkg)
+#endif
+ )
+ let files = [ f | Just f <- mFiles ]
+#if CABAL_VERSION_CHECK(1,8,0)
+ installOrdinaryFiles verbosity libPref files
+#else
+ copyFiles verbosity libPref files
+#endif
+
+ [_$_]
+installCHI _ _ _ _ = return ()
+
+------------------------------------------------------------------------------
+-- Generating the type hierarchy and signal callback .hs files.
+------------------------------------------------------------------------------
+
+typeGenProgram :: Program
+typeGenProgram = (simpleProgram "gtk2hsTypeGen")
+
+signalGenProgram :: Program
+signalGenProgram = (simpleProgram "gtk2hsHookGenerator")
+
+c2hsLocal :: Program
+c2hsLocal = (simpleProgram "gtk2hsC2hs")
+
+genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
+genSynthezisedFiles verb pd lbi = do
+
+ cPkgs <- getPkgConfigPackages verb lbi pd
+
+ let xList = maybe [] (customFieldsBI . libBuildInfo) (library pd)
+ ++customFieldsPD pd
+ typeOpts :: [ProgArg]
+ typeOpts = concat [ map (\val -> '-':'-':drop 8 field++'=':val) (words content)
+ | (field,content) <- xList,
+ "x-types-" `isPrefixOf` field,
+ field /= "x-types-file"]
+ ++ [ "--tag=" ++ tag
+ | PackageIdentifier name (Version (major:minor:_) _) <- cPkgs
+ , let name' = filter isAlpha (display name)
+ , tag <- name'
+ : [ name' ++ "-" ++ show major ++ "." ++ show digit
+ | digit <- [0,2..minor] ]
+ ]
+
+ genFile :: Program -> [ProgArg] -> FilePath -> IO ()
+ genFile prog args outFile = do
+ res <- rawSystemProgramStdoutConf verb prog (withPrograms lbi) args
+ rewriteFile outFile res
+
+ case lookup "x-types-file" xList of
+ Nothing -> return ()
+ Just f -> do
+ info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.")
+ genFile typeGenProgram typeOpts f
+
+ case (lookup "x-signals-file" xList,
+ lookup "x-signals-modname" xList) of
+ (Just _, Nothing) -> die "You need to specify the module name (X-Signals-ModName) \
+ \to generate a signal file."
+ (Just f, Just mod) -> do
+ info verb ("Ensuring that callback hooks in "++f++" are up-to-date.")
+ genFile signalGenProgram [mod] f
+ (_,_) -> return ()
+
+--FIXME: Cabal should tell us the selected pkg-config package versions in the
+-- LocalBuildInfo or equivalent.
+-- In the mean time, ask pkg-config again.
+
+getPkgConfigPackages :: Verbosity -> LocalBuildInfo -> PackageDescription -> IO [PackageId]
+getPkgConfigPackages verbosity lbi pkg =
+ sequence
+ [ do version <- pkgconfig ["--modversion", display pkgname]
+ case simpleParse version of
+ Nothing -> die $ "parsing output of pkg-config --modversion failed"
+ Just v -> return (PackageIdentifier pkgname v)
+ | Dependency pkgname _ <- concatMap pkgconfigDepends (allBuildInfo pkg) ]
+ where
+ pkgconfig = rawSystemProgramStdoutConf verbosity
+ pkgConfigProgram (withPrograms lbi)
+
+------------------------------------------------------------------------------
+-- Dependency calculation amongst .chs files.
+------------------------------------------------------------------------------
+
+-- Given all files of the package, find those that end in .chs and extract the
+-- .chs files they depend upon. Then return the PackageDescription with these
+-- files rearranged so that they are built in a sequence that files that are
+-- needed by other files are built first.
+fixDeps :: PackageDescription -> IO PackageDescription
+fixDeps pd...@PD...ckageDescription {
+ PD.library = Just li...@PD...brary {
+ PD.exposedModules = expMods,
+ PD.libBuildInfo = bi@PD.BuildInfo {
+ PD.hsSourceDirs = srcDirs,
+ PD.otherModules = othMods
+ }}} = do
+ let findModule m = findFileWithExtension [".chs.pp",".chs"] srcDirs
+ (joinPath (components m))
+ mExpFiles <- mapM findModule expMods
+ mOthFiles <- mapM findModule othMods
+
+ -- tag all exposed files with True so we throw an error if we need to build
+ -- an exposed module before an internal modules (we cannot express this)
+ let modDeps = zipWith (ModDep True []) expMods mExpFiles++
+ zipWith (ModDep False []) othMods mOthFiles
+ modDeps <- mapM extractDeps modDeps
+ let (expMods, othMods) = span mdExposed $ sortTopological modDeps
+ badOther = map (fromMaybe "<no file>" . mdLocation) $
+ filter (not . mdExposed) expMods
+ unless (null badOther) $
+ die ("internal chs modules "++intercalate "," badOther++
+ " depend on exposed chs modules; cabal needs to build internal modules first")
+ return pd { PD.library = Just lib {
+ PD.exposedModules = map mdOriginal expMods,
+ PD.libBuildInfo = bi { PD.otherModules = map mdOriginal othMods }
+ }}
+
+data ModDep = ModDep {
+ mdExposed :: Bool,
+ mdRequires :: [ModuleName],
+ mdOriginal :: ModuleName,
+ mdLocation :: Maybe FilePath
+}
+
+instance Show ModDep where
+ show x = show (mdLocation x)
+
+instance Eq ModDep where
+ ModDep { mdOriginal = m1 } == ModDep { mdOriginal = m2 } = m1==m2
+instance Ord ModDep where
+ compare ModDep { mdOriginal = m1 } ModDep { mdOriginal = m2 } = compare m1 m2
+
+-- Extract the dependencies of this file. This is intentionally rather naive as it
+-- ignores CPP conditionals. We just require everything which means that the
+-- existance of a .chs module may not depend on some CPP condition. [_$_]
+extractDeps :: ModDep -> IO ModDep
+extractDeps md@ModDep { mdLocation = Nothing } = return md
+extractDeps md@ModDep { mdLocation = Just f } = withFileContents f $ \con -> do
+ let findImports acc (('{':'#':xs):xxs) = case (dropWhile ((==) ' ') xs) of
+ ('i':'m':'p':'o':'r':'t':' ':ys) ->
+ case simpleParse (takeWhile ((/=) '#') ys) of
+ Just m -> findImports (m:acc) xxs [_$_]
+ Nothing -> die ("cannot parse chs import in "++f++":\n"++
+ "offending line is {#"++xs)
+ -- no more imports after the first non-import hook
+ _ -> return acc
+ findImports acc (_:xxs) = findImports acc xxs
+ findImports acc [] = return acc
+ mods <- findImports [] (lines con)
+ return md { mdRequires = mods }
+
+-- Find a total order of the set of modules that are partially sorted by their
+-- dependencies on each other. The function returns the sorted list of modules
+-- together with a list of modules that are required but not supplied by this
+-- in the input set of modules.
+sortTopological :: [ModDep] -> [ModDep]
+sortTopological ms = reverse $ fst $ foldl visit ([], S.empty) (map mdOriginal ms)
+ where
+ set = M.fromList (map (\m -> (mdOriginal m, m)) ms)
+ visit (out,visited) m
+ | m `S.member` visited = (out,visited)
+ | otherwise = case m `M.lookup` set of
+ Nothing -> (out, m `S.insert` visited)
+ Just md -> (md:out', visited')
+ where
+ (out',visited') = foldl visit (out, m `S.insert` visited) (mdRequires md)
addfile ./soegtk/demo/BouncingBall.hs
hunk ./soegtk/demo/BouncingBall.hs 1
+{- Written by Antti-Juhani Kaijanaho.
+ You may treat this file as if it were in the public domain.
+-}
+module Main where
+
+import Graphics.SOE.Gtk
+
+main = runGraphics $
+ do w <- openWindowEx "Bouncing Ball" Nothing (Just (300, 300)) drawBufferedGraphic
+ let loop x y xd yd
+ = do setGraphic w $ withColor Yellow $
+ ellipse (x-5,y-5) (x+5,y+5)
+ (xmax, ymax) <- getWindowSize w
+ let x' = x + xd + 5
+ y' = y + yd + 5
+ xd' | x' >= xmax || x' < 0 = -xd
+ | otherwise = xd
+ yd' | y' >= ymax || y' < 0 = -yd
+ | otherwise = yd
+ x'' = x + xd'
+ y'' = y + yd'
+ x''' | x'' + 5 > xmax = xmax `div` 2
+ | otherwise = x''
+ y''' | y'' + 5 > ymax = ymax `div` 2
+ | otherwise = y''
+ e <- getWindowEvent w
+ case e of Closed -> return ()
+ _ -> loop x''' y''' xd' yd'
+ loop 300 100 5 5
+
addfile ./soegtk/demo/Demo1.hs
hunk ./soegtk/demo/Demo1.hs 1
+{- Written by Antti-Juhani Kaijanaho.
+ You may treat this file as if it were in the public domain.
+-}
+module Main where
+
+import Graphics.SOE.Gtk
+
+main = runGraphics $ do w <- openWindow "Testing" (200, 200)
+ drawInWindow w $ text (100,100) "Hello"
+ drawInWindow w $ line (50, 50) (75, 75)
+ drawInWindow w $ withColor White $ polyline [(10,10), (10,40), (20,20)]
+ drawInWindow w $ polygon [(60,60), (60,90), (80,90)]
+ drawInWindow w $ withColor Yellow $
+ ellipse (290, 190) (150, 150)
+ drawInWindow w $ arc (20,190) (90,130) (45) (390)
+ drawInWindow w $ withColor Blue $ line (20,190) (90,130)
+ drawInWindow w $ withColor Yellow $
+ shearEllipse (140, 10) (160, 90) (190, 50)
+ loopEvents w
+ closeWindow w
+
+loopEvents w = loop
+ where loop = do e <- getWindowEvent w
+ case e of Closed -> return ()
+ _ -> loop
addfile ./soegtk/demo/Demo2.hs
hunk ./soegtk/demo/Demo2.hs 1
+{- Written by Antti-Juhani Kaijanaho.
+ You may treat this file as if it were in the public domain.
+-}
+module Main where
+
+import Graphics.SOE.Gtk
+
+main = runGraphics $ do w <- openWindow "Testing" (200, 200)
+ drawInWindow w $ text (10,180) "Hello"
+ drawInWindow w $ withColor Blue $
+ polyline [(20,20), (20,150), (150,150), (150,20), (20,20)]
+ let region = createRectangle (20,20) (100,100)
+ `orRegion` createRectangle (50,50) (150,150)
+ `diffRegion` createRectangle (100,100) (150,150)
+ drawInWindow w $ withColor Blue $
+ polyline [(20,20), (20,100), (100,100), (100,20), (20,20)]
+ drawInWindow w $ withColor Blue $
+ polyline [(50,50), (50,150), (150,150), (150,50), (50,50)]
+ drawInWindow w $ withColor Green $ drawRegion region
+ loopEvents w
+ closeWindow w
+
+loopEvents w = loop
+ where loop = do e <- getWindowEvent w
+ case e of Closed -> return ()
+ _ -> loop
addfile ./soegtk/demo/Makefile
hunk ./soegtk/demo/Makefile 1
+
+PROGS = bouncingball snowflake demo1 demo2
+
+SOURCES = BouncingBall.hs Demo1.hs Demo2.hs Snowflake.hs
+PACKAGES = gtk soegtk
+
+all : $(PROGS)
+
+bouncingball : BouncingBall.hs
+ $(HC_RULE)
+
+snowflake : Snowflake.hs
+ $(HC_RULE)
+
+demo1 : Demo1.hs
+ $(HC_RULE)
+
+demo2 : Demo2.hs
+ $(HC_RULE)
+
+HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS) $(HCEXTRAFLAGS)
+
+HCEXTRAFLAGS = $(if $(HCNEEDSPACKAGE), $(addprefix -package ,$(PACKAGES)))
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
+
+HC=ghc
addfile ./soegtk/demo/Snowflake.hs
hunk ./soegtk/demo/Snowflake.hs 1
+module Main where
+
+import Graphics.SOE.Gtk
+
+type Vector = (Double, Double)
+
+(<+>) :: Vector -> Vector -> Vector
+(a, b) <+> (c, d) = (a+c, b+d)
+
+(<->) :: Vector -> Vector -> Vector
+(a, b) <-> (c, d) = (a-c, b-d)
+
+(.*) :: Double -> Vector -> Vector
+k .* (a, b) = (k * a, k * b)
+
+(*.) :: Vector -> Double -> Vector
+(*.) = flip (.*)
+
+(<*>) :: Vector -> Vector -> Double
+(a, b) <*> (c, d) = a * c + b * d
+
+norm :: Vector -> Double
+norm v = sqrt (v <*> v)
+
+dist :: Vector -> Vector -> Double
+dist v1 v2 = norm (v1 <-> v2)
+
+xunit :: Vector
+xunit = (1, 0)
+
+yunit :: Vector
+yunit = (0,1)
+
+ortho :: Vector -> Vector
+ortho v@(a, b) = (m11*a + m12*b, m21*a+m22*b)
+ where m11 = cos ang
+ m12 = sin ang
+ m21 = -sin ang
+ m22 = cos ang
+ ang = pi/2
+
+
+type Line = (Vector, Vector)
+
+gen :: [Line] -> [Line]
+gen [] = []
+gen (l@(v1,v2):ls)
+ | dist v1 v2 < 3 = l : gen ls
+ | otherwise = let dir = v1 <-> v2
+ ort = ortho dir
+ p = v2 <+> ((1/3) .* dir)
+ q = v2 <+> ((2/3) .* dir)
+ r = v2 <+> (0.5 .* dir) <+> ((1/3) .* ort)
+ s = v2 <+> (0.5 .* dir) <+> ((-1/3) .* ort)
+ in --(v2,p) : (q,v1) : gen ((p,r) : (q,r) : (p,s) : (q,s) : ls)
+ gen ((v2,p) : (q,v1) : (p,r) : (q,r) : (p,s) : (q,s) : ls)
+ -- kauniimpi kuva (mutta teht[_\c3_][_\a4_]v[_\c3_][_\a4_]nannon vastainen) tulee
+ -- korvaamalla edellinen lauseke seuraavalla:
+ -- gen ((v2,p) : (q,v1) : (p,r) : (q,r) : (p,s) : (q,s) : ls)
+
+draw :: [Line] -> Graphic
+draw [] = emptyGraphic
+draw ((p1,p2):ls) = overGraphic (line (f p1) (f p2)) (draw ls)
+ where f (x,y) = (round (x), round (y))
+
+test = runGraphics $ do w <- openWindow "T 3.7-8" (200, 200)
+ loop w
+ closeWindow w
+ where loop w = do (xmax', ymax') <- getWindowSize w
+ let xmax = fromIntegral xmax'
+ ymax = fromIntegral ymax'
+ ls = gen [((1/8 * xmax, 1/2 * ymax),
+ (7/8 * xmax, 1/2 * ymax))]
+ setGraphic w (draw ls)
+ e <- getWindowEvent w
+ case e of Resize -> loop w
+ _ -> return ()
+
+main = test
|
|
From: Andy S. <And...@co...> - 2010-05-01 17:42:53
|
Sat May 1 13:32:31 EDT 2010 Andy Stewart <laz...@gm...>
* Move opengl demo to `gtk/gtkglext/demo`.
Ignore-this: 5c11b627899153dfec86424037ad147e
hunk ./demo/opengl/Makefile 1
-
-PROG = cube
-SOURCES = RotatingCube.hs
-
-$(PROG) : $(SOURCES)
- $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
-
-HC=ghc
rmfile ./demo/opengl/Makefile
hunk ./demo/opengl/RotatingCube.hs 1
-module Main (main) where
-
-import Data.IORef
-
-import qualified Graphics.UI.Gtk as Gtk
-import Graphics.UI.Gtk (AttrOp((:=)))
-import qualified Graphics.UI.Gtk.OpenGL as GtkGL
-
-import Graphics.Rendering.OpenGL as GL
-
-main :: IO ()
-main = do [_$_]
- Gtk.initGUI
- [_$_]
- -- Initialise the Gtk+ OpenGL extension
- -- (including reading various command line parameters)
- GtkGL.initGL
-
- -- We need a OpenGL frame buffer configuration to be able to create other
- -- OpenGL objects.
- glconfig <- GtkGL.glConfigNew [GtkGL.GLModeRGBA,
- GtkGL.GLModeDepth,
- GtkGL.GLModeDouble]
- [_$_]
- -- Create an OpenGL drawing area widget
- canvas <- GtkGL.glDrawingAreaNew glconfig
- [_$_]
- Gtk.widgetSetSizeRequest canvas 350 350
-
- -- Initialise some GL setting just before the canvas first gets shown
- -- (We can't initialise these things earlier since the GL resources that
- -- we are using wouldn't heve been setup yet)
- Gtk.onRealize canvas $ GtkGL.withGLDrawingArea canvas $ \_ -> do
- clearColor $= (Color4 0.0 0.0 0.0 0.0)
- matrixMode $= Projection
- loadIdentity
- ortho 0.0 1.0 0.0 1.0 (-1.0) 1.0
- depthFunc $= Just Less
- drawBuffer $= BackBuffers
-
- ref <- newIORef (0, 0, 0)
-
- -- Set the repaint handler
- Gtk.onExpose canvas $ \_ -> do
- GtkGL.withGLDrawingArea canvas $ \glwindow -> do
- (r_x, r_y, r_z) <- readIORef ref
- GL.clear [GL.DepthBuffer, GL.ColorBuffer]
- drawCube (r_x, r_y, r_z)
- GtkGL.glDrawableSwapBuffers glwindow
- return True
-
- -- Setup the animation
- Gtk.timeoutAddFull (do
- modifyIORef ref (\(r_x, r_y, r_z) -> (r_x + dx, r_y + dy, r_z + dz))
- Gtk.widgetQueueDraw canvas
- return True)
- Gtk.priorityDefaultIdle animationWaitTime
-
- --------------------------------
- -- Setup the rest of the GUI:
- --
- window <- Gtk.windowNew
- Gtk.onDestroy window Gtk.mainQuit
- Gtk.set window [ Gtk.containerBorderWidth := 8,
- Gtk.windowTitle := "Gtk2Hs + HOpenGL demo" ]
-
- vbox <- Gtk.vBoxNew False 4
- Gtk.set window [ Gtk.containerChild := vbox ]
-
- label <- Gtk.labelNew (Just "Gtk2Hs using OpenGL via HOpenGL!")
- button <- Gtk.buttonNewWithLabel "Close"
- Gtk.onClicked button Gtk.mainQuit
- Gtk.set vbox [ Gtk.containerChild := canvas,
- Gtk.containerChild := label,
- Gtk.containerChild := button ]
-
- Gtk.widgetShowAll window
- Gtk.mainGUI
-
-drawCube :: (GLfloat, GLfloat, GLfloat) -> IO ()
-drawCube (r_x, r_y, r_z) = do
- loadIdentity
- rotate r_x (Vector3 1 0 0 :: Vector3 GLfloat)
- rotate r_y (Vector3 0 1 0 :: Vector3 GLfloat)
- rotate r_z (Vector3 0 0 1 :: Vector3 GLfloat)
- mapM_ drawFace (zip colours faces)
-
- where drawFace :: (Color3 GLfloat, IO ()) -> IO ()
- drawFace (colour, face) = do color colour
- renderPrimitive Quads face
- faces = map (mapM_ vertex) faceVertices :: [IO ()]
- colours = [red, green, yellow, blue, purple, cyan]
- faceVertices = [
- [Vertex3 to to to,
- Vertex3 from to to,
- Vertex3 from from to,
- Vertex3 to from to],
- [Vertex3 to to from,
- Vertex3 from to from,
- Vertex3 from from from,
- Vertex3 to from from],
- [Vertex3 to to to,
- Vertex3 from to to,
- Vertex3 from to from,
- Vertex3 to to from],
- [Vertex3 to from to,
- Vertex3 from from to,
- Vertex3 from from from,
- Vertex3 to from from],
- [Vertex3 to to to,
- Vertex3 to from to,
- Vertex3 to from from,
- Vertex3 to to from],
- [Vertex3 from to to,
- Vertex3 from from to,
- Vertex3 from from from,
- Vertex3 from to from]]
-
-to, from :: GLfloat
-to = 0.4
-from = -0.4
-
-animationWaitTime :: Int
-animationWaitTime = 3
-
-dx, dy, dz :: GLfloat
-dx = 0.1
-dy = 0.3
-dz = 0.7
-
-red, green, yellow, blue, purple, cyan :: Color3 GLfloat
-red = Color3 1 0 0
-green = Color3 0 1 0
-yellow = Color3 1 1 0
-blue = Color3 0 0 1
-purple = Color3 1 0 1
-cyan = Color3 0 1 1
rmfile ./demo/opengl/RotatingCube.hs
rmdir ./demo/opengl
adddir ./gtkglext/demo
addfile ./gtkglext/demo/Makefile
hunk ./gtkglext/demo/Makefile 1
+
+PROG = cube
+SOURCES = RotatingCube.hs
+
+$(PROG) : $(SOURCES)
+ $(HC) --make $< -o $@ $(HCFLAGS)
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
+
+HC=ghc
addfile ./gtkglext/demo/RotatingCube.hs
hunk ./gtkglext/demo/RotatingCube.hs 1
+module Main (main) where
+
+import Data.IORef
+
+import qualified Graphics.UI.Gtk as Gtk
+import Graphics.UI.Gtk (AttrOp((:=)))
+import qualified Graphics.UI.Gtk.OpenGL as GtkGL
+
+import Graphics.Rendering.OpenGL as GL
+
+main :: IO ()
+main = do [_$_]
+ Gtk.initGUI
+ [_$_]
+ -- Initialise the Gtk+ OpenGL extension
+ -- (including reading various command line parameters)
+ GtkGL.initGL
+
+ -- We need a OpenGL frame buffer configuration to be able to create other
+ -- OpenGL objects.
+ glconfig <- GtkGL.glConfigNew [GtkGL.GLModeRGBA,
+ GtkGL.GLModeDepth,
+ GtkGL.GLModeDouble]
+ [_$_]
+ -- Create an OpenGL drawing area widget
+ canvas <- GtkGL.glDrawingAreaNew glconfig
+ [_$_]
+ Gtk.widgetSetSizeRequest canvas 350 350
+
+ -- Initialise some GL setting just before the canvas first gets shown
+ -- (We can't initialise these things earlier since the GL resources that
+ -- we are using wouldn't heve been setup yet)
+ Gtk.onRealize canvas $ GtkGL.withGLDrawingArea canvas $ \_ -> do
+ clearColor $= (Color4 0.0 0.0 0.0 0.0)
+ matrixMode $= Projection
+ loadIdentity
+ ortho 0.0 1.0 0.0 1.0 (-1.0) 1.0
+ depthFunc $= Just Less
+ drawBuffer $= BackBuffers
+
+ ref <- newIORef (0, 0, 0)
+
+ -- Set the repaint handler
+ Gtk.onExpose canvas $ \_ -> do
+ GtkGL.withGLDrawingArea canvas $ \glwindow -> do
+ (r_x, r_y, r_z) <- readIORef ref
+ GL.clear [GL.DepthBuffer, GL.ColorBuffer]
+ drawCube (r_x, r_y, r_z)
+ GtkGL.glDrawableSwapBuffers glwindow
+ return True
+
+ -- Setup the animation
+ Gtk.timeoutAddFull (do
+ modifyIORef ref (\(r_x, r_y, r_z) -> (r_x + dx, r_y + dy, r_z + dz))
+ Gtk.widgetQueueDraw canvas
+ return True)
+ Gtk.priorityDefaultIdle animationWaitTime
+
+ --------------------------------
+ -- Setup the rest of the GUI:
+ --
+ window <- Gtk.windowNew
+ Gtk.onDestroy window Gtk.mainQuit
+ Gtk.set window [ Gtk.containerBorderWidth := 8,
+ Gtk.windowTitle := "Gtk2Hs + HOpenGL demo" ]
+
+ vbox <- Gtk.vBoxNew False 4
+ Gtk.set window [ Gtk.containerChild := vbox ]
+
+ label <- Gtk.labelNew (Just "Gtk2Hs using OpenGL via HOpenGL!")
+ button <- Gtk.buttonNewWithLabel "Close"
+ Gtk.onClicked button Gtk.mainQuit
+ Gtk.set vbox [ Gtk.containerChild := canvas,
+ Gtk.containerChild := label,
+ Gtk.containerChild := button ]
+
+ Gtk.widgetShowAll window
+ Gtk.mainGUI
+
+drawCube :: (GLfloat, GLfloat, GLfloat) -> IO ()
+drawCube (r_x, r_y, r_z) = do
+ loadIdentity
+ rotate r_x (Vector3 1 0 0 :: Vector3 GLfloat)
+ rotate r_y (Vector3 0 1 0 :: Vector3 GLfloat)
+ rotate r_z (Vector3 0 0 1 :: Vector3 GLfloat)
+ mapM_ drawFace (zip colours faces)
+
+ where drawFace :: (Color3 GLfloat, IO ()) -> IO ()
+ drawFace (colour, face) = do color colour
+ renderPrimitive Quads face
+ faces = map (mapM_ vertex) faceVertices :: [IO ()]
+ colours = [red, green, yellow, blue, purple, cyan]
+ faceVertices = [
+ [Vertex3 to to to,
+ Vertex3 from to to,
+ Vertex3 from from to,
+ Vertex3 to from to],
+ [Vertex3 to to from,
+ Vertex3 from to from,
+ Vertex3 from from from,
+ Vertex3 to from from],
+ [Vertex3 to to to,
+ Vertex3 from to to,
+ Vertex3 from to from,
+ Vertex3 to to from],
+ [Vertex3 to from to,
+ Vertex3 from from to,
+ Vertex3 from from from,
+ Vertex3 to from from],
+ [Vertex3 to to to,
+ Vertex3 to from to,
+ Vertex3 to from from,
+ Vertex3 to to from],
+ [Vertex3 from to to,
+ Vertex3 from from to,
+ Vertex3 from from from,
+ Vertex3 from to from]]
+
+to, from :: GLfloat
+to = 0.4
+from = -0.4
+
+animationWaitTime :: Int
+animationWaitTime = 3
+
+dx, dy, dz :: GLfloat
+dx = 0.1
+dy = 0.3
+dz = 0.7
+
+red, green, yellow, blue, purple, cyan :: Color3 GLfloat
+red = Color3 1 0 0
+green = Color3 0 1 0
+yellow = Color3 1 1 0
+blue = Color3 0 0 1
+purple = Color3 1 0 1
+cyan = Color3 0 1 1
|
|
From: Andy S. <And...@co...> - 2010-05-01 17:42:52
|
Sat May 1 13:30:35 EDT 2010 Andy Stewart <laz...@gm...>
* Move gnomevfs demo to `gtk2hs/gnomevfs/demo`.
Ignore-this: 3c4019cd021cd9349e7a794f0c73bea6
hunk ./demo/gnomevfs/Makefile 1
-
-PROGS = test-sync test-dir test-xfer test-drive-volume test-volume-monitor
-SOURCES = TestSync.hs TestDir.hs TestXfer.hs TestDriveVolume.hs TestVolumeMonitor.hs
-
-all: $(PROGS)
-
-test-sync : TestSync.hs
- $(HC_RULE)
-test-dir : TestDir.hs
- $(HC_RULE)
-test-xfer : TestXfer.hs
- $(HC_RULE)
-test-drive-volume : TestDriveVolume.hs
- $(HC_RULE)
-test-volume-monitor : TestVolumeMonitor.hs
- $(HC_RULE)
-
-HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
-
-HC=ghc
rmfile ./demo/gnomevfs/Makefile
hunk ./demo/gnomevfs/TestDir.hs 1
-module Main where
-
-import qualified System.Gnome.VFS as VFS
-import Control.Exception ( handleJust )
-import Control.Monad ( when
- , liftM )
-import Data.Maybe ( fromMaybe )
-import Text.Printf ( printf )
-import System.Time ( ClockTime(..)
- , calendarTimeToString
- , toCalendarTime )
-import System.IO
-import System.Exit
-import System.Environment
-
-handleVFSError vfsError =
- let VFS.Error result = vfsError
- in do hPutStrLn stderr $ "VFS error: " ++ show result
- exitFailure
-
-directoryVisitCallback :: String
- -> VFS.FileInfo
- -> Bool
- -> IO VFS.DirectoryVisitResult
-directoryVisitCallback name fileInfo recursingWillLoop =
- do mTimeStr <- case VFS.fileInfoMTime fileInfo of
- Just mTime -> liftM calendarTimeToString $
- toCalendarTime $ TOD (fromIntegral $ fromEnum mTime) 0
- Nothing -> return "unknown"
- let name = fromMaybe "unknown" (VFS.fileInfoName fileInfo)
- size = VFS.formatFileSizeForDisplay (fromMaybe 0 (VFS.fileInfoSize fileInfo))
- [_$_]
- printf "%20s %20s %s\n" size mTimeStr name
- return VFS.DirectoryVisitContinue
-
-main :: IO ()
-main =
- handleJust VFS.errors handleVFSError $
- do progName <- getProgName
- args <- getArgs
- [_$_]
- when (length args /= 1) $
- do hPutStrLn stderr $ "Usage: " ++ progName ++ " <uri>"
- exitFailure
- [_$_]
- VFS.init >>= (\success ->
- when (not success) $
- do hPutStrLn stderr $ "could not initialize GnomeVFS"
- exitFailure)
- [_$_]
- let textURI = head args
- uri <- case VFS.uriFromString textURI of
- Nothing -> do hPutStrLn stderr $ "Invalid URI: " ++ textURI
- exitFailure
- Just uri -> return uri
- [_$_]
- VFS.directoryVisit textURI [] [] directoryVisitCallback
rmfile ./demo/gnomevfs/TestDir.hs
hunk ./demo/gnomevfs/TestDriveVolume.hs 1
-module Main where
-
-import qualified System.Gnome.VFS as VFS
-import Control.Exception ( handleJust )
-import Control.Monad ( when
- , liftM )
-import Data.Maybe ( fromMaybe )
-import Text.Printf ( printf )
-import System.IO
-import System.Exit
-
-handleVFSError vfsError =
- let VFS.Error result = vfsError
- in do hPutStrLn stderr $ "VFS error: " ++ show result
- exitFailure
-
-main :: IO ()
-main =
- handleJust VFS.errors handleVFSError $
- do VFS.init >>= (\success ->
- when (not success) $
- do hPutStrLn stderr $ "could not initialize GnomeVFS"
- exitFailure)
- [_$_]
- drives <- VFS.volumeMonitorGetConnectedDrives VFS.volumeMonitor
- flip mapM_ drives $ \drive ->
- do VFS.driveGetDisplayName drive >>= printf "Drive %s:\n"
- VFS.driveGetDeviceType drive >>= (printf "\tDevice Type: %s\n") . show
- VFS.driveGetDevicePath drive >>= (printf "\tDevice Path: %s\n") . show
- volumes <- VFS.driveGetMountedVolumes drive
- flip mapM_ volumes $ \volume ->
- do VFS.volumeGetDisplayName volume >>= printf "\tVolume %s:\n"
- VFS.volumeGetDevicePath volume >>= (printf "\t\tDevice Path: %s\n") . show
- VFS.volumeGetFilesystemType volume >>= (printf "\t\tFilesystem Type: %s\n") . show
- [_$_]
- return ()
rmfile ./demo/gnomevfs/TestDriveVolume.hs
hunk ./demo/gnomevfs/TestSync.hs 1
-module Main where
-
-import qualified System.Gnome.VFS as VFS
-import Control.Exception
-import Control.Monad (when)
-import Data.Maybe (fromMaybe)
-import System.IO
-import System.Exit
-import System.Environment
-import qualified Data.ByteString as BS
-
-handleVFSError vfsError =
- let VFS.Error result = vfsError
- in do hPutStrLn stderr $ "VFS error: " ++ show result
- exitFailure
-
-main :: IO ()
-main = [_$_]
- handleJust VFS.errors handleVFSError $
- do progName <- getProgName
- args <- getArgs
- [_$_]
- when (length args /= 1) $
- do hPutStrLn stderr $ "Usage: " ++ progName ++ " <uri>"
- exitFailure
- [_$_]
- VFS.init >>= (\success ->
- when (not success) $
- do hPutStrLn stderr $ "could not initialize GnomeVFS"
- exitFailure)
- [_$_]
- let textURI = head args
- uri <- case VFS.uriFromString textURI of
- Nothing -> do hPutStrLn stderr $ "Invalid URI: " ++ textURI
- exitFailure
- Just uri -> return uri
- [_$_]
- handle <- VFS.openURI uri VFS.OpenRead
- fileInfo <- VFS.getFileInfoFromHandle handle []
- let blockSize = fromMaybe 4096 $ VFS.fileInfoIOBlockSize fileInfo
- [_$_]
- let loop = handleJust VFS.errors
- (\(VFS.Error result) ->
- case result of
- VFS.ErrorEof -> return ()
- _ -> handleVFSError $ VFS.Error result) $
- do bytes <- VFS.read handle blockSize
- BS.putStr bytes
- loop
- loop
- [_$_]
- VFS.close handle
rmfile ./demo/gnomevfs/TestSync.hs
hunk ./demo/gnomevfs/TestVolumeMonitor.hs 1
-module Main where
-
-import qualified System.Gnome.VFS as VFS
-import Control.Exception ( handleJust )
-import Control.Monad ( when
- , liftM )
-import Data.Maybe ( fromMaybe )
-import Text.Printf ( printf )
-import System.Glib.MainLoop ( mainLoopNew
- , mainLoopRun )
-import System.IO
-import System.Exit
-import System.Environment
-
-main :: IO ()
-main =
- do VFS.init >>= (\success ->
- when (not success) $
- do hPutStrLn stderr $ "could not initialize GnomeVFS"
- exitFailure)
- [_$_]
- mainLoop <- mainLoopNew Nothing True
- [_$_]
- putStrLn "Waiting for Volume mount/unmount events..."
- VFS.onVolumeMonitorVolumeMounted VFS.volumeMonitor $ \volume ->
- do VFS.volumeGetDisplayName volume >>= printf "volume-mounted: %s\n"
- return ()
- VFS.onVolumeMonitorVolumePreUnmount VFS.volumeMonitor $ \volume ->
- do VFS.volumeGetDisplayName volume >>= printf "volume-pre-unmount: %s\n"
- return ()
- VFS.onVolumeMonitorVolumeUnmounted VFS.volumeMonitor $ \volume ->
- do VFS.volumeGetDisplayName volume >>= printf "volume-unmounted: %s\n"
- return ()
- [_$_]
- mainLoopRun mainLoop
- [_$_]
- return ()
rmfile ./demo/gnomevfs/TestVolumeMonitor.hs
hunk ./demo/gnomevfs/TestXfer.hs 1
-module Main where
-
-import qualified System.Gnome.VFS as VFS
-import Control.Exception ( handleJust )
-import Control.Monad ( when
- , liftM )
-import Data.Maybe ( fromMaybe )
-import Text.Printf ( printf )
-import System.IO
-import System.Exit
-import System.Environment
-
-handleVFSError vfsError =
- let VFS.Error result = vfsError
- in do hPutStrLn stderr $ "VFS error: " ++ show result
- exitFailure
-
-xferProgressCallback :: VFS.XferProgressCallback
-xferProgressCallback info =
- do printf "Status: %s\tPhase: %s\n"
- (show $ VFS.xferProgressInfoVFSStatus info)
- (show $ VFS.xferProgressInfoPhase info)
- printf "\tSource: %s\n\tTarget: %s\n"
- (show $ VFS.xferProgressInfoSourceName info)
- (show $ VFS.xferProgressInfoTargetName info)
- printf "\t%d of %d files\n"
- (toInteger $ VFS.xferProgressInfoFileIndex info)
- (toInteger $ VFS.xferProgressInfoFilesTotal info)
- printf "\t%s of %s\n"
- (VFS.formatFileSizeForDisplay $ VFS.xferProgressInfoBytesCopied info)
- (VFS.formatFileSizeForDisplay $ VFS.xferProgressInfoFileSize info)
- printf "\t%s of %s total\n"
- (VFS.formatFileSizeForDisplay $ VFS.xferProgressInfoTotalBytesCopied info)
- (VFS.formatFileSizeForDisplay $ VFS.xferProgressInfoBytesTotal info)
- return True
-
-xferErrorCallback :: VFS.XferErrorCallback
-xferErrorCallback info =
- do printf "error: %s; aborting transfer\n" $ show $ VFS.xferProgressInfoVFSStatus info
- return VFS.XferErrorActionAbort
-
-xferOverwriteCallback :: VFS.XferOverwriteCallback
-xferOverwriteCallback info =
- do printf "skipping file %s as it already exists\n" $ fromMaybe "unknown" $ VFS.xferProgressInfoSourceName info
- return VFS.XferOverwriteActionSkip
-
-main :: IO ()
-main =
- handleJust VFS.errors handleVFSError $
- do progName <- getProgName
- args <- getArgs
- [_$_]
- when (length args /= 2) $
- do hPutStrLn stderr $ "Usage: " ++ progName ++ " source target"
- exitFailure
- [_$_]
- VFS.init >>= (\success ->
- when (not success) $
- do hPutStrLn stderr $ "could not initialize GnomeVFS"
- exitFailure)
- [_$_]
- hPutStrLn stderr "vfs initialized"
- [_$_]
- let [source, target] = args
- [_$_]
- hPutStrLn stderr "parsing source URI"
- [_$_]
- sourceURI <- case VFS.uriFromString source of
- Just sourceURI -> return sourceURI
- Nothing -> do hPutStrLn stderr $ "invalid source URI"
- exitFailure
- [_$_]
- hPutStrLn stderr "parsing target URI"
- [_$_]
- targetURI <- case VFS.uriFromString target of
- Just targetURI -> return targetURI
- Nothing -> do hPutStrLn stderr $ "invalid target URI"
- exitFailure
- [_$_]
- hPutStrLn stderr "executing transfer"
- [_$_]
- VFS.xferURI sourceURI targetURI []
- (Just xferProgressCallback) (Just xferErrorCallback)
- (Right xferOverwriteCallback) Nothing
- [_$_]
- return ()
rmfile ./demo/gnomevfs/TestXfer.hs
rmdir ./demo/gnomevfs
adddir ./gnomevfs/demo
addfile ./gnomevfs/demo/Makefile
hunk ./gnomevfs/demo/Makefile 1
+
+PROGS = test-sync test-dir test-xfer test-drive-volume test-volume-monitor
+SOURCES = TestSync.hs TestDir.hs TestXfer.hs TestDriveVolume.hs TestVolumeMonitor.hs
+
+all: $(PROGS)
+
+test-sync : TestSync.hs
+ $(HC_RULE)
+test-dir : TestDir.hs
+ $(HC_RULE)
+test-xfer : TestXfer.hs
+ $(HC_RULE)
+test-drive-volume : TestDriveVolume.hs
+ $(HC_RULE)
+test-volume-monitor : TestVolumeMonitor.hs
+ $(HC_RULE)
+
+HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS)
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
+
+HC=ghc
addfile ./gnomevfs/demo/TestDir.hs
hunk ./gnomevfs/demo/TestDir.hs 1
+module Main where
+
+import qualified System.Gnome.VFS as VFS
+import Control.Exception ( handleJust )
+import Control.Monad ( when
+ , liftM )
+import Data.Maybe ( fromMaybe )
+import Text.Printf ( printf )
+import System.Time ( ClockTime(..)
+ , calendarTimeToString
+ , toCalendarTime )
+import System.IO
+import System.Exit
+import System.Environment
+
+handleVFSError vfsError =
+ let VFS.Error result = vfsError
+ in do hPutStrLn stderr $ "VFS error: " ++ show result
+ exitFailure
+
+directoryVisitCallback :: String
+ -> VFS.FileInfo
+ -> Bool
+ -> IO VFS.DirectoryVisitResult
+directoryVisitCallback name fileInfo recursingWillLoop =
+ do mTimeStr <- case VFS.fileInfoMTime fileInfo of
+ Just mTime -> liftM calendarTimeToString $
+ toCalendarTime $ TOD (fromIntegral $ fromEnum mTime) 0
+ Nothing -> return "unknown"
+ let name = fromMaybe "unknown" (VFS.fileInfoName fileInfo)
+ size = VFS.formatFileSizeForDisplay (fromMaybe 0 (VFS.fileInfoSize fileInfo))
+ [_$_]
+ printf "%20s %20s %s\n" size mTimeStr name
+ return VFS.DirectoryVisitContinue
+
+main :: IO ()
+main =
+ handleJust VFS.errors handleVFSError $
+ do progName <- getProgName
+ args <- getArgs
+ [_$_]
+ when (length args /= 1) $
+ do hPutStrLn stderr $ "Usage: " ++ progName ++ " <uri>"
+ exitFailure
+ [_$_]
+ VFS.init >>= (\success ->
+ when (not success) $
+ do hPutStrLn stderr $ "could not initialize GnomeVFS"
+ exitFailure)
+ [_$_]
+ let textURI = head args
+ uri <- case VFS.uriFromString textURI of
+ Nothing -> do hPutStrLn stderr $ "Invalid URI: " ++ textURI
+ exitFailure
+ Just uri -> return uri
+ [_$_]
+ VFS.directoryVisit textURI [] [] directoryVisitCallback
addfile ./gnomevfs/demo/TestDriveVolume.hs
hunk ./gnomevfs/demo/TestDriveVolume.hs 1
+module Main where
+
+import qualified System.Gnome.VFS as VFS
+import Control.Exception ( handleJust )
+import Control.Monad ( when
+ , liftM )
+import Data.Maybe ( fromMaybe )
+import Text.Printf ( printf )
+import System.IO
+import System.Exit
+
+handleVFSError vfsError =
+ let VFS.Error result = vfsError
+ in do hPutStrLn stderr $ "VFS error: " ++ show result
+ exitFailure
+
+main :: IO ()
+main =
+ handleJust VFS.errors handleVFSError $
+ do VFS.init >>= (\success ->
+ when (not success) $
+ do hPutStrLn stderr $ "could not initialize GnomeVFS"
+ exitFailure)
+ [_$_]
+ drives <- VFS.volumeMonitorGetConnectedDrives VFS.volumeMonitor
+ flip mapM_ drives $ \drive ->
+ do VFS.driveGetDisplayName drive >>= printf "Drive %s:\n"
+ VFS.driveGetDeviceType drive >>= (printf "\tDevice Type: %s\n") . show
+ VFS.driveGetDevicePath drive >>= (printf "\tDevice Path: %s\n") . show
+ volumes <- VFS.driveGetMountedVolumes drive
+ flip mapM_ volumes $ \volume ->
+ do VFS.volumeGetDisplayName volume >>= printf "\tVolume %s:\n"
+ VFS.volumeGetDevicePath volume >>= (printf "\t\tDevice Path: %s\n") . show
+ VFS.volumeGetFilesystemType volume >>= (printf "\t\tFilesystem Type: %s\n") . show
+ [_$_]
+ return ()
addfile ./gnomevfs/demo/TestSync.hs
hunk ./gnomevfs/demo/TestSync.hs 1
+module Main where
+
+import qualified System.Gnome.VFS as VFS
+import Control.Exception
+import Control.Monad (when)
+import Data.Maybe (fromMaybe)
+import System.IO
+import System.Exit
+import System.Environment
+import qualified Data.ByteString as BS
+
+handleVFSError vfsError =
+ let VFS.Error result = vfsError
+ in do hPutStrLn stderr $ "VFS error: " ++ show result
+ exitFailure
+
+main :: IO ()
+main = [_$_]
+ handleJust VFS.errors handleVFSError $
+ do progName <- getProgName
+ args <- getArgs
+ [_$_]
+ when (length args /= 1) $
+ do hPutStrLn stderr $ "Usage: " ++ progName ++ " <uri>"
+ exitFailure
+ [_$_]
+ VFS.init >>= (\success ->
+ when (not success) $
+ do hPutStrLn stderr $ "could not initialize GnomeVFS"
+ exitFailure)
+ [_$_]
+ let textURI = head args
+ uri <- case VFS.uriFromString textURI of
+ Nothing -> do hPutStrLn stderr $ "Invalid URI: " ++ textURI
+ exitFailure
+ Just uri -> return uri
+ [_$_]
+ handle <- VFS.openURI uri VFS.OpenRead
+ fileInfo <- VFS.getFileInfoFromHandle handle []
+ let blockSize = fromMaybe 4096 $ VFS.fileInfoIOBlockSize fileInfo
+ [_$_]
+ let loop = handleJust VFS.errors
+ (\(VFS.Error result) ->
+ case result of
+ VFS.ErrorEof -> return ()
+ _ -> handleVFSError $ VFS.Error result) $
+ do bytes <- VFS.read handle blockSize
+ BS.putStr bytes
+ loop
+ loop
+ [_$_]
+ VFS.close handle
addfile ./gnomevfs/demo/TestVolumeMonitor.hs
hunk ./gnomevfs/demo/TestVolumeMonitor.hs 1
+module Main where
+
+import qualified System.Gnome.VFS as VFS
+import Control.Exception ( handleJust )
+import Control.Monad ( when
+ , liftM )
+import Data.Maybe ( fromMaybe )
+import Text.Printf ( printf )
+import System.Glib.MainLoop ( mainLoopNew
+ , mainLoopRun )
+import System.IO
+import System.Exit
+import System.Environment
+
+main :: IO ()
+main =
+ do VFS.init >>= (\success ->
+ when (not success) $
+ do hPutStrLn stderr $ "could not initialize GnomeVFS"
+ exitFailure)
+ [_$_]
+ mainLoop <- mainLoopNew Nothing True
+ [_$_]
+ putStrLn "Waiting for Volume mount/unmount events..."
+ VFS.onVolumeMonitorVolumeMounted VFS.volumeMonitor $ \volume ->
+ do VFS.volumeGetDisplayName volume >>= printf "volume-mounted: %s\n"
+ return ()
+ VFS.onVolumeMonitorVolumePreUnmount VFS.volumeMonitor $ \volume ->
+ do VFS.volumeGetDisplayName volume >>= printf "volume-pre-unmount: %s\n"
+ return ()
+ VFS.onVolumeMonitorVolumeUnmounted VFS.volumeMonitor $ \volume ->
+ do VFS.volumeGetDisplayName volume >>= printf "volume-unmounted: %s\n"
+ return ()
+ [_$_]
+ mainLoopRun mainLoop
+ [_$_]
+ return ()
addfile ./gnomevfs/demo/TestXfer.hs
hunk ./gnomevfs/demo/TestXfer.hs 1
+module Main where
+
+import qualified System.Gnome.VFS as VFS
+import Control.Exception ( handleJust )
+import Control.Monad ( when
+ , liftM )
+import Data.Maybe ( fromMaybe )
+import Text.Printf ( printf )
+import System.IO
+import System.Exit
+import System.Environment
+
+handleVFSError vfsError =
+ let VFS.Error result = vfsError
+ in do hPutStrLn stderr $ "VFS error: " ++ show result
+ exitFailure
+
+xferProgressCallback :: VFS.XferProgressCallback
+xferProgressCallback info =
+ do printf "Status: %s\tPhase: %s\n"
+ (show $ VFS.xferProgressInfoVFSStatus info)
+ (show $ VFS.xferProgressInfoPhase info)
+ printf "\tSource: %s\n\tTarget: %s\n"
+ (show $ VFS.xferProgressInfoSourceName info)
+ (show $ VFS.xferProgressInfoTargetName info)
+ printf "\t%d of %d files\n"
+ (toInteger $ VFS.xferProgressInfoFileIndex info)
+ (toInteger $ VFS.xferProgressInfoFilesTotal info)
+ printf "\t%s of %s\n"
+ (VFS.formatFileSizeForDisplay $ VFS.xferProgressInfoBytesCopied info)
+ (VFS.formatFileSizeForDisplay $ VFS.xferProgressInfoFileSize info)
+ printf "\t%s of %s total\n"
+ (VFS.formatFileSizeForDisplay $ VFS.xferProgressInfoTotalBytesCopied info)
+ (VFS.formatFileSizeForDisplay $ VFS.xferProgressInfoBytesTotal info)
+ return True
+
+xferErrorCallback :: VFS.XferErrorCallback
+xferErrorCallback info =
+ do printf "error: %s; aborting transfer\n" $ show $ VFS.xferProgressInfoVFSStatus info
+ return VFS.XferErrorActionAbort
+
+xferOverwriteCallback :: VFS.XferOverwriteCallback
+xferOverwriteCallback info =
+ do printf "skipping file %s as it already exists\n" $ fromMaybe "unknown" $ VFS.xferProgressInfoSourceName info
+ return VFS.XferOverwriteActionSkip
+
+main :: IO ()
+main =
+ handleJust VFS.errors handleVFSError $
+ do progName <- getProgName
+ args <- getArgs
+ [_$_]
+ when (length args /= 2) $
+ do hPutStrLn stderr $ "Usage: " ++ progName ++ " source target"
+ exitFailure
+ [_$_]
+ VFS.init >>= (\success ->
+ when (not success) $
+ do hPutStrLn stderr $ "could not initialize GnomeVFS"
+ exitFailure)
+ [_$_]
+ hPutStrLn stderr "vfs initialized"
+ [_$_]
+ let [source, target] = args
+ [_$_]
+ hPutStrLn stderr "parsing source URI"
+ [_$_]
+ sourceURI <- case VFS.uriFromString source of
+ Just sourceURI -> return sourceURI
+ Nothing -> do hPutStrLn stderr $ "invalid source URI"
+ exitFailure
+ [_$_]
+ hPutStrLn stderr "parsing target URI"
+ [_$_]
+ targetURI <- case VFS.uriFromString target of
+ Just targetURI -> return targetURI
+ Nothing -> do hPutStrLn stderr $ "invalid target URI"
+ exitFailure
+ [_$_]
+ hPutStrLn stderr "executing transfer"
+ [_$_]
+ VFS.xferURI sourceURI targetURI []
+ (Just xferProgressCallback) (Just xferErrorCallback)
+ (Right xferOverwriteCallback) Nothing
+ [_$_]
+ return ()
|
|
From: Andy S. <And...@co...> - 2010-05-01 17:42:51
|
Sat May 1 13:18:08 EDT 2010 Andy Stewart <laz...@gm...>
* Move glade demo to `gtk2hs/glade/demo`.
Ignore-this: c3cc3e5a3fb50e9c97ea4d141e993151
hunk ./demo/glade/GladeTest.hs 1
-module Main where
-
-import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Glade
-
-main = do
- initGUI
-[_^I_] [_$_]
- -- load up the glade file
- dialogXmlM <- xmlNew "simple.glade"
- let dialogXml = case dialogXmlM of
- (Just dialogXml) -> dialogXml
- Nothing -> error "can't find the glade file \"simple.glade\" \
- \in the current directory"
-[_^I_] [_$_]
- -- get a handle on a couple widgets from the glade file
- window <- xmlGetWidget dialogXml castToWindow "window1"
- button <- xmlGetWidget dialogXml castToButton "button1"
-[_^I_] [_$_]
- -- do something with the widgets, just to prove it works
- button `onClicked` putStrLn "button pressed!"
- window `onDestroy` mainQuit
-[_^I_] [_$_]
- -- show everything
- widgetShowAll window
- mainGUI
rmfile ./demo/glade/GladeTest.hs
hunk ./demo/glade/Makefile 1
-
-PROG = gladetest
-SOURCES = GladeTest.hs
-
-$(PROG) : $(SOURCES)
- $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
-
-HC=ghc
rmfile ./demo/glade/Makefile
hunk ./demo/glade/simple.glade 1
-<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
-<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
-
-<glade-interface>
-
-<widget class="GtkWindow" id="window1">
- <property name="visible">True</property>
- <property name="title" translatable="yes">window1</property>
- <property name="type">GTK_WINDOW_TOPLEVEL</property>
- <property name="window_position">GTK_WIN_POS_NONE</property>
- <property name="modal">False</property>
- <property name="resizable">True</property>
- <property name="destroy_with_parent">False</property>
-
- <child>
- <widget class="GtkVBox" id="vbox1">
- <property name="border_width">6</property>
- <property name="visible">True</property>
- <property name="homogeneous">False</property>
- <property name="spacing">0</property>
-
- <child>
- <widget class="GtkLabel" id="label1">
- <property name="visible">True</property>
- <property name="label" translatable="yes">A simple dialog created in Glade</property>
- <property name="use_underline">False</property>
- <property name="use_markup">False</property>
- <property name="justify">GTK_JUSTIFY_LEFT</property>
- <property name="wrap">False</property>
- <property name="selectable">False</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">True</property>
- <property name="fill">True</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkButton" id="button1">
- <property name="visible">True</property>
- <property name="can_focus">True</property>
- <property name="relief">GTK_RELIEF_NORMAL</property>
-
- <child>
- <widget class="GtkAlignment" id="alignment1">
- <property name="visible">True</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xscale">0</property>
- <property name="yscale">0</property>
-
- <child>
- <widget class="GtkHBox" id="hbox1">
- <property name="visible">True</property>
- <property name="homogeneous">False</property>
- <property name="spacing">2</property>
-
- <child>
- <widget class="GtkImage" id="image1">
- <property name="visible">True</property>
- <property name="stock">gtk-apply</property>
- <property name="icon_size">4</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">False</property>
- <property name="fill">False</property>
- </packing>
- </child>
-
- <child>
- <widget class="GtkLabel" id="label2">
- <property name="visible">True</property>
- <property name="label" translatable="yes">Press me!</property>
- <property name="use_underline">True</property>
- <property name="use_markup">False</property>
- <property name="justify">GTK_JUSTIFY_LEFT</property>
- <property name="wrap">False</property>
- <property name="selectable">False</property>
- <property name="xalign">0.5</property>
- <property name="yalign">0.5</property>
- <property name="xpad">0</property>
- <property name="ypad">0</property>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">False</property>
- <property name="fill">False</property>
- </packing>
- </child>
- </widget>
- </child>
- </widget>
- </child>
- </widget>
- <packing>
- <property name="padding">0</property>
- <property name="expand">True</property>
- <property name="fill">True</property>
- </packing>
- </child>
- </widget>
- </child>
-</widget>
-
-</glade-interface>
rmfile ./demo/glade/simple.glade
rmdir ./demo/glade
adddir ./glade/demo
addfile ./glade/demo/GladeTest.hs
hunk ./glade/demo/GladeTest.hs 1
+module Main where
+
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Glade
+
+main = do
+ initGUI
+[_^I_] [_$_]
+ -- load up the glade file
+ dialogXmlM <- xmlNew "simple.glade"
+ let dialogXml = case dialogXmlM of
+ (Just dialogXml) -> dialogXml
+ Nothing -> error "can't find the glade file \"simple.glade\" \
+ \in the current directory"
+[_^I_] [_$_]
+ -- get a handle on a couple widgets from the glade file
+ window <- xmlGetWidget dialogXml castToWindow "window1"
+ button <- xmlGetWidget dialogXml castToButton "button1"
+[_^I_] [_$_]
+ -- do something with the widgets, just to prove it works
+ button `onClicked` putStrLn "button pressed!"
+ window `onDestroy` mainQuit
+[_^I_] [_$_]
+ -- show everything
+ widgetShowAll window
+ mainGUI
addfile ./glade/demo/Makefile
hunk ./glade/demo/Makefile 1
+
+PROG = gladetest
+SOURCES = GladeTest.hs
+
+$(PROG) : $(SOURCES)
+ $(HC) --make $< -o $@ $(HCFLAGS)
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
+
+HC=ghc
addfile ./glade/demo/simple.glade
hunk ./glade/demo/simple.glade 1
+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->
+<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">
+
+<glade-interface>
+
+<widget class="GtkWindow" id="window1">
+ <property name="visible">True</property>
+ <property name="title" translatable="yes">window1</property>
+ <property name="type">GTK_WINDOW_TOPLEVEL</property>
+ <property name="window_position">GTK_WIN_POS_NONE</property>
+ <property name="modal">False</property>
+ <property name="resizable">True</property>
+ <property name="destroy_with_parent">False</property>
+
+ <child>
+ <widget class="GtkVBox" id="vbox1">
+ <property name="border_width">6</property>
+ <property name="visible">True</property>
+ <property name="homogeneous">False</property>
+ <property name="spacing">0</property>
+
+ <child>
+ <widget class="GtkLabel" id="label1">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">A simple dialog created in Glade</property>
+ <property name="use_underline">False</property>
+ <property name="use_markup">False</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">False</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">True</property>
+ <property name="fill">True</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkButton" id="button1">
+ <property name="visible">True</property>
+ <property name="can_focus">True</property>
+ <property name="relief">GTK_RELIEF_NORMAL</property>
+
+ <child>
+ <widget class="GtkAlignment" id="alignment1">
+ <property name="visible">True</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xscale">0</property>
+ <property name="yscale">0</property>
+
+ <child>
+ <widget class="GtkHBox" id="hbox1">
+ <property name="visible">True</property>
+ <property name="homogeneous">False</property>
+ <property name="spacing">2</property>
+
+ <child>
+ <widget class="GtkImage" id="image1">
+ <property name="visible">True</property>
+ <property name="stock">gtk-apply</property>
+ <property name="icon_size">4</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">False</property>
+ <property name="fill">False</property>
+ </packing>
+ </child>
+
+ <child>
+ <widget class="GtkLabel" id="label2">
+ <property name="visible">True</property>
+ <property name="label" translatable="yes">Press me!</property>
+ <property name="use_underline">True</property>
+ <property name="use_markup">False</property>
+ <property name="justify">GTK_JUSTIFY_LEFT</property>
+ <property name="wrap">False</property>
+ <property name="selectable">False</property>
+ <property name="xalign">0.5</property>
+ <property name="yalign">0.5</property>
+ <property name="xpad">0</property>
+ <property name="ypad">0</property>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">False</property>
+ <property name="fill">False</property>
+ </packing>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ </child>
+ </widget>
+ <packing>
+ <property name="padding">0</property>
+ <property name="expand">True</property>
+ <property name="fill">True</property>
+ </packing>
+ </child>
+ </widget>
+ </child>
+</widget>
+
+</glade-interface>
|
|
From: Andy S. <And...@co...> - 2010-05-01 17:42:49
|
Sat May 1 13:16:29 EDT 2010 Andy Stewart <laz...@gm...>
* Move gconf demo to `gtk2hs/gconf/demo`.
Ignore-this: b4011619e7e1096307d5fb9bf7212982
hunk ./demo/gconf/GConfDemo.hs 1
-module Main where
-
-import Graphics.UI.Gtk (initGUI, mainGUI)
-import System.Gnome.GConf
-
-import Monad (when)
-import System.Exit (exitFailure)
-import List (intersperse)
-
-main = do
- -- connect to gconf
- conf <- gconfGetDefault
-
- -- for the purposes of this demo check for key and display usage message
- exists <- conf `gconfDirExists` "/apps/gtk2hs-gconf-demo"
- when (not exists) (do putStrLn usageMessage
- exitFailure)
-
- -- get and print initial values
- (intValue :: Int) <- conf `gconfGet` "/apps/gtk2hs-gconf-demo/intValue"
- (boolValue :: Maybe Bool) <- conf `gconfGet` "/apps/gtk2hs-gconf-demo/boolValue"
- (floatValue :: Double) <- conf `gconfGet` "/apps/gtk2hs-gconf-demo/floatValue"
- (stringValue :: String) <- conf `gconfGet` "/apps/gtk2hs-gconf-demo/stringValue"
- (pairValue :: (Int,Bool)) <- conf `gconfGet` "/apps/gtk2hs-gconf-demo/pairValue"
- (listValue :: [Int]) <- conf `gconfGet` "/apps/gtk2hs-gconf-demo/listValue"
- [_$_]
- print intValue
- print boolValue
- print floatValue
- print stringValue
- print pairValue
- print listValue
- [_$_]
- -- register for notification of changes
- conf `gconfAddDir` "/apps/gtk2hs-gconf-demo"
- [_$_]
- -- using the prefered API which allows you to specify the key/dir of interest.
- -- This is usuall what you want because you'll do different things in response
- -- to changes in different keys. Also, it allows you to use native types rather
- -- than converting from a dynamic type.
- gconfNotifyAdd conf "/apps/gtk2hs-gconf-demo/intValue"
- doSomethingWhenIntValueChanges
- gconfNotifyAdd conf "/apps/gtk2hs-gconf-demo/boolValue"
- doSomethingWhenBoolValueChanges
- gconfNotifyAdd conf "/apps/gtk2hs-gconf-demo/floatValue"
- doSomethingWhenFloatValueChanges
- gconfNotifyAdd conf "/apps/gtk2hs-gconf-demo/stringValue"
- doSomethingWhenStringValueChanges
- gconfNotifyAdd conf "/apps/gtk2hs-gconf-demo/pairValue"
- doSomethingWhenPairValueChanges
- gconfNotifyAdd conf "/apps/gtk2hs-gconf-demo/listValue"
- doSomethingWhenListValueChanges
-
- -- and the other API (which gives you notifications on everything)
- conf `afterValueChanged` doSomethingWhenAnyKeyChanges
- [_$_]
- -- run the glib main loop otherwise we wouldn't wait for changes
- putStrLn $ "waiting for any changes in the gconf dir"
- ++ "\"/apps/gtk2hs-gconf-demo\""
- initGUI
- mainGUI
-
-
--- Our various doSomething* functions
---
-doSomethingWhenIntValueChanges :: String -> Int -> IO ()
-doSomethingWhenIntValueChanges key value =
- putStrLn $ "[method1] intValue changed to " ++ show value
-
--- This one is designed to cope with the key being unset
-doSomethingWhenBoolValueChanges :: String -> Maybe Bool -> IO ()
-doSomethingWhenBoolValueChanges key (Just value) =
- putStrLn $ "[method1] boolValue changed to " ++ show value
-doSomethingWhenBoolValueChanges key Nothing =
- putStrLn $ "[method1] boolValue was unset"
-
-doSomethingWhenFloatValueChanges :: String -> Double -> IO ()
-doSomethingWhenFloatValueChanges key value =
- putStrLn $ "[method1] floatValue changed to " ++ show value
-
-doSomethingWhenStringValueChanges :: String -> String -> IO ()
-doSomethingWhenStringValueChanges key value =
- putStrLn $ "[method1] stringValue changed to " ++ show value
-
-doSomethingWhenPairValueChanges :: String -> (Int, Bool) -> IO ()
-doSomethingWhenPairValueChanges key value =
- putStrLn $ "[method1] pairValue changed to " ++ show value
-
-doSomethingWhenListValueChanges :: String -> [Int] -> IO ()
-doSomethingWhenListValueChanges key value =
- putStrLn $ "[method1] listValue changed to " ++ show value
-
-
-doSomethingWhenAnyKeyChanges :: String -> Maybe GConfValueDyn -> IO ()
-doSomethingWhenAnyKeyChanges key (Just value) =
- putStrLn $ "[method2] the key " ++ key ++ " changed to " ++ showGConfValue value
-doSomethingWhenAnyKeyChanges key Nothing =
- putStrLn $ "[method2] the key " ++ key ++ " was unset"
-
-
--- Helper function to display a value and its type
--- This is not an important part of the demo
---
-showGConfValue :: GConfValueDyn -> String
-showGConfValue value =
- showGConfValue_ValueOnly value ++ " :: " ++ showGConfValue_Type value
-
-showGConfValue_ValueOnly :: GConfValueDyn -> String
-showGConfValue_ValueOnly (GConfValueString s) = show s
-showGConfValue_ValueOnly (GConfValueInt n) = show n
-showGConfValue_ValueOnly (GConfValueBool b) = show b
-showGConfValue_ValueOnly (GConfValueFloat f) = show f
-showGConfValue_ValueOnly (GConfValueList as) =
- "[" ++ (concat $ intersperse "," $ map showGConfValue_ValueOnly as) ++ "]"
-showGConfValue_ValueOnly (GConfValuePair (a,b)) =
- "(" ++ showGConfValue_ValueOnly a
- ++ ", " ++ showGConfValue_ValueOnly b ++ ")"
-
-
-showGConfValue_Type :: GConfValueDyn -> String
-showGConfValue_Type (GConfValueString s) = "String"
-showGConfValue_Type (GConfValueInt n) = "Int"
-showGConfValue_Type (GConfValueBool b) = "Bool"
-showGConfValue_Type (GConfValueFloat f) = "Double"
--- gconf does type empty lists too but our GConfValueDyn cannot represent
--- them using the GConfValueClass is preferable in this sense as it can type
--- all the GConfValue stuff exactly (so long as that type is known statically)
-showGConfValue_Type (GConfValueList []) = "[unknown]"
-showGConfValue_Type (GConfValueList (a:_)) = "[" ++ showGConfValue_Type a ++ "]"
-showGConfValue_Type (GConfValuePair (a,b)) = "(" ++ showGConfValue_Type a ++ ", "
- ++ showGConfValue_Type b ++ ")"
-
-usageMessage =
- "To use this gconf demo program, first create the required gconf entrys.\n"
- ++ "Use the following commands:\n"
- ++ " gconftool-2 --set /apps/gtk2hs-gconf-demo/intValue --type int 3\n"
- ++ " gconftool-2 --set /apps/gtk2hs-gconf-demo/boolValue --type bool false\n"
- ++ " gconftool-2 --set /apps/gtk2hs-gconf-demo/floatValue --type float 3.141592\n"
- ++ " gconftool-2 --set /apps/gtk2hs-gconf-demo/stringValue --type string foo\n"
- ++ " gconftool-2 --set /apps/gtk2hs-gconf-demo/pairValue --type pair \\\n"
- ++ " --car-type int --cdr-type bool \"(3,false)\"\n"
- ++ " gconftool-2 --set /apps/gtk2hs-gconf-demo/listValue --type list \\\n"
- ++ " --list-type int \"[0,1,2,3,4]\"\n"
- ++ "This demo will display the values of these keys and then watch them for\n"
- ++ "changes. Use the gconf-editor program to change the values of these keys.\n"
- ++ "Hit ^C when you get bored.\n"
- ++ "To delete the keys when you're finnished with this demo use:\n"
- ++ " gconftool-2 --recursive-unset /apps/gtk2hs-gconf-demo"
rmfile ./demo/gconf/GConfDemo.hs
hunk ./demo/gconf/Makefile 1
-
-PROG = gconfdemo
-SOURCES = GConfDemo.hs
-
-$(PROG) : $(SOURCES)
- $(HC) --make $< -o $@ -fglasgow-exts -fallow-overlapping-instances $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
-
-HC=ghc
rmfile ./demo/gconf/Makefile
rmdir ./demo/gconf
adddir ./gconf/demo
addfile ./gconf/demo/GConfDemo.hs
hunk ./gconf/demo/GConfDemo.hs 1
+module Main where
+
+import Graphics.UI.Gtk (initGUI, mainGUI)
+import System.Gnome.GConf
+
+import Monad (when)
+import System.Exit (exitFailure)
+import List (intersperse)
+
+main = do
+ -- connect to gconf
+ conf <- gconfGetDefault
+
+ -- for the purposes of this demo check for key and display usage message
+ exists <- conf `gconfDirExists` "/apps/gtk2hs-gconf-demo"
+ when (not exists) (do putStrLn usageMessage
+ exitFailure)
+
+ -- get and print initial values
+ (intValue :: Int) <- conf `gconfGet` "/apps/gtk2hs-gconf-demo/intValue"
+ (boolValue :: Maybe Bool) <- conf `gconfGet` "/apps/gtk2hs-gconf-demo/boolValue"
+ (floatValue :: Double) <- conf `gconfGet` "/apps/gtk2hs-gconf-demo/floatValue"
+ (stringValue :: String) <- conf `gconfGet` "/apps/gtk2hs-gconf-demo/stringValue"
+ (pairValue :: (Int,Bool)) <- conf `gconfGet` "/apps/gtk2hs-gconf-demo/pairValue"
+ (listValue :: [Int]) <- conf `gconfGet` "/apps/gtk2hs-gconf-demo/listValue"
+ [_$_]
+ print intValue
+ print boolValue
+ print floatValue
+ print stringValue
+ print pairValue
+ print listValue
+ [_$_]
+ -- register for notification of changes
+ conf `gconfAddDir` "/apps/gtk2hs-gconf-demo"
+ [_$_]
+ -- using the prefered API which allows you to specify the key/dir of interest.
+ -- This is usuall what you want because you'll do different things in response
+ -- to changes in different keys. Also, it allows you to use native types rather
+ -- than converting from a dynamic type.
+ gconfNotifyAdd conf "/apps/gtk2hs-gconf-demo/intValue"
+ doSomethingWhenIntValueChanges
+ gconfNotifyAdd conf "/apps/gtk2hs-gconf-demo/boolValue"
+ doSomethingWhenBoolValueChanges
+ gconfNotifyAdd conf "/apps/gtk2hs-gconf-demo/floatValue"
+ doSomethingWhenFloatValueChanges
+ gconfNotifyAdd conf "/apps/gtk2hs-gconf-demo/stringValue"
+ doSomethingWhenStringValueChanges
+ gconfNotifyAdd conf "/apps/gtk2hs-gconf-demo/pairValue"
+ doSomethingWhenPairValueChanges
+ gconfNotifyAdd conf "/apps/gtk2hs-gconf-demo/listValue"
+ doSomethingWhenListValueChanges
+
+ -- and the other API (which gives you notifications on everything)
+ conf `afterValueChanged` doSomethingWhenAnyKeyChanges
+ [_$_]
+ -- run the glib main loop otherwise we wouldn't wait for changes
+ putStrLn $ "waiting for any changes in the gconf dir"
+ ++ "\"/apps/gtk2hs-gconf-demo\""
+ initGUI
+ mainGUI
+
+
+-- Our various doSomething* functions
+--
+doSomethingWhenIntValueChanges :: String -> Int -> IO ()
+doSomethingWhenIntValueChanges key value =
+ putStrLn $ "[method1] intValue changed to " ++ show value
+
+-- This one is designed to cope with the key being unset
+doSomethingWhenBoolValueChanges :: String -> Maybe Bool -> IO ()
+doSomethingWhenBoolValueChanges key (Just value) =
+ putStrLn $ "[method1] boolValue changed to " ++ show value
+doSomethingWhenBoolValueChanges key Nothing =
+ putStrLn $ "[method1] boolValue was unset"
+
+doSomethingWhenFloatValueChanges :: String -> Double -> IO ()
+doSomethingWhenFloatValueChanges key value =
+ putStrLn $ "[method1] floatValue changed to " ++ show value
+
+doSomethingWhenStringValueChanges :: String -> String -> IO ()
+doSomethingWhenStringValueChanges key value =
+ putStrLn $ "[method1] stringValue changed to " ++ show value
+
+doSomethingWhenPairValueChanges :: String -> (Int, Bool) -> IO ()
+doSomethingWhenPairValueChanges key value =
+ putStrLn $ "[method1] pairValue changed to " ++ show value
+
+doSomethingWhenListValueChanges :: String -> [Int] -> IO ()
+doSomethingWhenListValueChanges key value =
+ putStrLn $ "[method1] listValue changed to " ++ show value
+
+
+doSomethingWhenAnyKeyChanges :: String -> Maybe GConfValueDyn -> IO ()
+doSomethingWhenAnyKeyChanges key (Just value) =
+ putStrLn $ "[method2] the key " ++ key ++ " changed to " ++ showGConfValue value
+doSomethingWhenAnyKeyChanges key Nothing =
+ putStrLn $ "[method2] the key " ++ key ++ " was unset"
+
+
+-- Helper function to display a value and its type
+-- This is not an important part of the demo
+--
+showGConfValue :: GConfValueDyn -> String
+showGConfValue value =
+ showGConfValue_ValueOnly value ++ " :: " ++ showGConfValue_Type value
+
+showGConfValue_ValueOnly :: GConfValueDyn -> String
+showGConfValue_ValueOnly (GConfValueString s) = show s
+showGConfValue_ValueOnly (GConfValueInt n) = show n
+showGConfValue_ValueOnly (GConfValueBool b) = show b
+showGConfValue_ValueOnly (GConfValueFloat f) = show f
+showGConfValue_ValueOnly (GConfValueList as) =
+ "[" ++ (concat $ intersperse "," $ map showGConfValue_ValueOnly as) ++ "]"
+showGConfValue_ValueOnly (GConfValuePair (a,b)) =
+ "(" ++ showGConfValue_ValueOnly a
+ ++ ", " ++ showGConfValue_ValueOnly b ++ ")"
+
+
+showGConfValue_Type :: GConfValueDyn -> String
+showGConfValue_Type (GConfValueString s) = "String"
+showGConfValue_Type (GConfValueInt n) = "Int"
+showGConfValue_Type (GConfValueBool b) = "Bool"
+showGConfValue_Type (GConfValueFloat f) = "Double"
+-- gconf does type empty lists too but our GConfValueDyn cannot represent
+-- them using the GConfValueClass is preferable in this sense as it can type
+-- all the GConfValue stuff exactly (so long as that type is known statically)
+showGConfValue_Type (GConfValueList []) = "[unknown]"
+showGConfValue_Type (GConfValueList (a:_)) = "[" ++ showGConfValue_Type a ++ "]"
+showGConfValue_Type (GConfValuePair (a,b)) = "(" ++ showGConfValue_Type a ++ ", "
+ ++ showGConfValue_Type b ++ ")"
+
+usageMessage =
+ "To use this gconf demo program, first create the required gconf entrys.\n"
+ ++ "Use the following commands:\n"
+ ++ " gconftool-2 --set /apps/gtk2hs-gconf-demo/intValue --type int 3\n"
+ ++ " gconftool-2 --set /apps/gtk2hs-gconf-demo/boolValue --type bool false\n"
+ ++ " gconftool-2 --set /apps/gtk2hs-gconf-demo/floatValue --type float 3.141592\n"
+ ++ " gconftool-2 --set /apps/gtk2hs-gconf-demo/stringValue --type string foo\n"
+ ++ " gconftool-2 --set /apps/gtk2hs-gconf-demo/pairValue --type pair \\\n"
+ ++ " --car-type int --cdr-type bool \"(3,false)\"\n"
+ ++ " gconftool-2 --set /apps/gtk2hs-gconf-demo/listValue --type list \\\n"
+ ++ " --list-type int \"[0,1,2,3,4]\"\n"
+ ++ "This demo will display the values of these keys and then watch them for\n"
+ ++ "changes. Use the gconf-editor program to change the values of these keys.\n"
+ ++ "Hit ^C when you get bored.\n"
+ ++ "To delete the keys when you're finnished with this demo use:\n"
+ ++ " gconftool-2 --recursive-unset /apps/gtk2hs-gconf-demo"
addfile ./gconf/demo/Makefile
hunk ./gconf/demo/Makefile 1
+
+PROG = gconfdemo
+SOURCES = GConfDemo.hs
+
+$(PROG) : $(SOURCES)
+ $(HC) --make $< -o $@ -fglasgow-exts -fallow-overlapping-instances $(HCFLAGS)
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
+
+HC=ghc
|
|
From: Andy S. <And...@co...> - 2010-05-01 17:14:40
|
Sat May 1 13:13:14 EDT 2010 Andy Stewart <laz...@gm...>
* Remove vte and webkit demo from main repo (those demos have exist in `gtk2hs/vte/demo` and `gtk2hs/webkit/demo`)
Ignore-this: 1aa0f5ed4fc91b00ded2affad59061eb
hunk ./demo/webkit/Makefile 1
-
-PROGS = webkit
-SOURCES = Webkit.hs
-
-all : $(PROGS)
-
-webkit : Webkit.hs
- $(HC) --make $< -o $@ $(HCFLAGS)
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
-
-HC=ghc
rmfile ./demo/webkit/Makefile
hunk ./demo/webkit/Webkit.hs 1
--- | WebKit browser demo.
--- Author : Andy Stewart
--- Copyright : (c) 2010 Andy Stewart <laz...@gm...>
-
--- | This simple browser base on WebKit API.
--- For simple, i just make all link open in current window.
--- Of course, you can integrate signal `createWebView` with `notebook`
--- to build multi-tab browser.
---
--- You can click right-button for forward or backward page.
---
--- Usage:
--- webkit [uri]
---
-module Main where
-
-import Graphics.UI.Gtk
-import Graphics.UI.Gtk.General.Structs
-import Graphics.UI.Gtk.WebKit.WebView
-import Graphics.UI.Gtk.WebKit.WebFrame
-
-import System.Process
-import System.Environment [_$_]
-
--- | Main entry.
-main :: IO ()
-main = do
- -- Get program arguments.
- args <- getArgs
- case args of
- -- Display help
- ["--help"] -> do
- putStrLn $ "Welcome to Gtk2hs WebKit demo. :)\n\n" ++ [_$_]
- "Usage: webkit [uri]\n\n" ++
- " -- Gtk2hs Team"
- -- Start program.
- [arg] -> browser arg -- entry user input url
- _ -> browser "http://www.google.com" -- entry default url
-
--- | Internal browser fucntion.
-browser :: String -> IO ()
-browser url = do
- -- Init.
- initGUI
- [_$_]
- -- Create window.
- window <- windowNew
- windowSetDefaultSize window 900 600
- windowSetPosition window WinPosCenter
- windowSetOpacity window 0.8 -- this function need window-manager support Alpha channel in X11
-
- -- Create WebKit view.
- webView <- webViewNew
- [_$_]
- -- Create window box.
- winBox <- vBoxNew False 0
- [_$_]
- -- Create address bar.
- addressBar <- entryNew
-
- -- Create scroll window.
- scrollWin <- scrolledWindowNew Nothing Nothing
-
- -- Load uri.
- webViewLoadUri webView url
- entrySetText addressBar url
-
- -- Open uri when user press `return` at address bar.
- onEntryActivate addressBar $ do
- uri <- entryGetText addressBar -- get uri from address bar
- webViewLoadUri webView uri -- load new uri
-
- -- Add current uri to address bar when load start.
- webView `on` loadStarted $ \frame -> do
- currentUri <- webFrameGetUri frame
- case currentUri of
- Just uri -> entrySetText addressBar uri
- Nothing -> return ()
-
- -- Open all link in current window.
- webView `on` createWebView $ \frame -> do
- newUri <- webFrameGetUri frame
- case newUri of
- Just uri -> webViewLoadUri webView uri
- Nothing -> return ()
- return webView
-
- -- Connect and show.
- boxPackStart winBox addressBar PackNatural 0
- boxPackStart winBox scrollWin PackGrow 0
- window `containerAdd` winBox
- scrollWin `containerAdd` webView
- window `onDestroy` mainQuit
- widgetShowAll window
-
- mainGUI
rmfile ./demo/webkit/Webkit.hs
rmdir ./demo/webkit
hunk ./demo/vte/Makefile 1
-
-PROG = vte [_$_]
-SOURCES = Vte.hs
-
-$(PROG) : $(SOURCES)
- $(HC) --make $< -o $@ $(HCFLAGS) -XForeignFunctionInterface
-
-clean:
- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)
-
-HC=ghc
rmfile ./demo/vte/Makefile
hunk ./demo/vte/Vte.hs 1
- -- A simple program to demonstrate Vte Binding by Cjacker Huang
-module Main where
-
-import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Vte.Vte
-import Graphics.UI.Gtk.Pango.Font
-
-main = do
- initGUI
- window <- windowNew
- onDestroy window mainQuit
- widgetSetSizeRequest window 640 480
-
- scrolled <- scrolledWindowNew Nothing Nothing
- scrolledWindowSetPolicy scrolled PolicyAutomatic PolicyAutomatic
- vte <- terminalNew
- terminalForkCommand vte Nothing Nothing Nothing Nothing False False False
- font <- fontDescriptionFromString "DejaVu Sans Mono 10"
- terminalSetFont vte font
- containerAdd scrolled vte
- containerAdd window scrolled
- on vte childExited $ mainQuit
-
- widgetShowAll window
-
- mainGUI
rmfile ./demo/vte/Vte.hs
rmdir ./demo/vte
|
|
From: Andy S. <And...@co...> - 2010-05-01 16:23:28
|
Sat May 1 12:21:22 EDT 2010 Andy Stewart <laz...@gm...>
* Fix compile error of soegtk.
Ignore-this: f6661f25cb9a067a24d7db7242dcab3a
hunk ./soegtk/soegtk.cabal 8
-Build-Type: Simple
+Build-Type: Custom
hunk ./soegtk/soegtk.cabal 36
+ x-c2hs-Header: gtk/gtk.h
+ pkgconfig-depends: gtk+-2.0
+[_^I_][_^I_][_$_]
|
|
From: Andy S. <And...@co...> - 2010-05-01 16:23:27
|
Sat May 1 12:19:26 EDT 2010 Andy Stewart <laz...@gm...>
* Fix compile error of vte.
Ignore-this: b837e1f746a7f8779ec49758f9741c4c
hunk ./vte/Graphics/UI/Gtk/Vte/Vte.chs 207
-{#import Graphics.UI.Gtk.Vte.Signals#}
hunk ./vte/vte.cabal 46
- Graphics.UI.Gtk.Vte.Signals[_^I_][_^I_] [_$_]
hunk ./vte/vte.cabal 52
- x-Signals-File: Graphics/UI/Gtk/Vte/Signals.chs
- x-Signals-Modname: Graphics.UI.Gtk.Vte.Signals
|
2 messages has been excluded from this view by a project administrator.
