gtk3 0.14.2 → 0.14.3
raw patch · 17 files changed
+1377/−710 lines, 17 filesdep ~gtk3setup-changed
Dependency ranges changed: gtk3
Files
- Graphics/UI/Gtk.chs +20/−0
- Graphics/UI/Gtk/Display/Spinner.chs +2/−0
- Graphics/UI/Gtk/Display/Statusbar.chs +2/−2
- Graphics/UI/Gtk/Gdk/GLContext.chs +257/−0
- Graphics/UI/Gtk/General/Enums.chs +7/−0
- Graphics/UI/Gtk/Layout/Grid.chs +1/−1
- Graphics/UI/Gtk/Layout/Stack.chs +406/−0
- Graphics/UI/Gtk/Layout/StackSwitcher.chs +124/−0
- Graphics/UI/Gtk/Misc/GLArea.chs +393/−0
- Graphics/UI/Gtk/ModelView/ListStore.hs +8/−3
- Graphics/UI/Gtk/Types.chs +114/−0
- Gtk2HsSetup.hs +0/−500
- Setup.hs +9/−7
- SetupMain.hs +0/−13
- SetupWrapper.hs +0/−164
- gtk3.cabal +30/−20
- hierarchy3.list +4/−0
Graphics/UI/Gtk.chs view
@@ -66,6 +66,9 @@ #endif -- module Graphics.UI.Gtk.Gdk.GC, module Graphics.UI.Gtk.Gdk.EventM,+#if GTK_CHECK_VERSION(3,16,0)+ module Graphics.UI.Gtk.Gdk.GLContext,+#endif module Graphics.UI.Gtk.Gdk.Pixbuf, #if GTK_MAJOR_VERSION < 3 module Graphics.UI.Gtk.Gdk.Pixmap,@@ -229,6 +232,10 @@ module Graphics.UI.Gtk.Layout.VBox, module Graphics.UI.Gtk.Layout.VButtonBox, module Graphics.UI.Gtk.Layout.VPaned,+#if GTK_CHECK_VERSION(3,10,0)+ module Graphics.UI.Gtk.Layout.Stack,+ module Graphics.UI.Gtk.Layout.StackSwitcher,+#endif -- * Ornaments module Graphics.UI.Gtk.Ornaments.Frame, module Graphics.UI.Gtk.Ornaments.HSeparator,@@ -256,6 +263,9 @@ module Graphics.UI.Gtk.Misc.Arrow, module Graphics.UI.Gtk.Misc.Calendar, module Graphics.UI.Gtk.Misc.DrawingArea,+#if GTK_CHECK_VERSION(3,16,0)+ module Graphics.UI.Gtk.Misc.GLArea,+#endif module Graphics.UI.Gtk.Misc.EventBox, module Graphics.UI.Gtk.Misc.HandleBox, module Graphics.UI.Gtk.Misc.IMMulticontext,@@ -324,6 +334,9 @@ #endif --import Graphics.UI.Gtk.Gdk.GC import Graphics.UI.Gtk.Gdk.EventM+#if GTK_CHECK_VERSION(3,16,0)+import Graphics.UI.Gtk.Gdk.GLContext+#endif import Graphics.UI.Gtk.Gdk.Pixbuf #if GTK_MAJOR_VERSION < 3 import Graphics.UI.Gtk.Gdk.Pixmap@@ -490,6 +503,10 @@ import Graphics.UI.Gtk.Layout.Grid import Graphics.UI.Gtk.Layout.Overlay #endif+#if GTK_CHECK_VERSION(3,10,0)+import Graphics.UI.Gtk.Layout.Stack+import Graphics.UI.Gtk.Layout.StackSwitcher+#endif import Graphics.UI.Gtk.Layout.Expander import Graphics.UI.Gtk.Layout.Table -- ornaments@@ -519,6 +536,9 @@ import Graphics.UI.Gtk.Misc.Arrow import Graphics.UI.Gtk.Misc.Calendar import Graphics.UI.Gtk.Misc.DrawingArea+#if GTK_CHECK_VERSION(3,16,0)+import Graphics.UI.Gtk.Misc.GLArea+#endif import Graphics.UI.Gtk.Misc.EventBox import Graphics.UI.Gtk.Misc.HandleBox import Graphics.UI.Gtk.Misc.IMMulticontext
Graphics/UI/Gtk/Display/Spinner.chs view
@@ -37,6 +37,8 @@ -- * Types Spinner, SpinnerClass,+ castToSpinner, gTypeSpinner,+ toSpinner, -- * Constructors spinnerNew,
Graphics/UI/Gtk/Display/Statusbar.chs view
@@ -234,12 +234,12 @@ -- * Available since Gtk+ version 2.22 -- statusbarRemoveAll :: StatusbarClass self => self- -> Int -- ^ @contextId@ a context identifier+ -> ContextId -- ^ @contextId@ a context identifier -> IO () statusbarRemoveAll self contextId = {#call gtk_statusbar_remove_all #} (toStatusbar self)- (fromIntegral contextId)+ contextId #endif --------------------
+ Graphics/UI/Gtk/Gdk/GLContext.chs view
@@ -0,0 +1,257 @@+{-# LANGUAGE CPP #-}+-- -*-haskell-*-+-- GIMP Toolkit (GTK) GLContext+--+-- Author : Chris Mennie+--+-- Created: 23 April 2016+--+-- Copyright (C) 2016 Chis Mennie+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- OpenGL context+--+module Graphics.UI.Gtk.Gdk.GLContext (+-- * Detail+--+-- | GLContext is an object representing the platform-specific OpenGL drawing context.+--+-- GLContexts are created for a GdkWindow, and the context will match the GdkVisual of the window.+--+-- A 'GLContext' is not tied to any particular normal framebuffer. For instance, it cannot draw to+-- the Window back buffer. The GDK repaint system is in full control of the painting to that.+-- GDK will handle the integration of your rendering with that of other widgets.+--+-- Support for 'GLContext' is platform-specific, context creation can fail, returning NULL context.+--+-- A 'GLContext' has to be made "current" in order to start using it, otherwise any OpenGL call will+-- be ignored.++-- * Class Hierarchy+-- |+-- @+-- | 'GObject'+-- | +----'GLContext'+-- @+--++-- * Types+#if GTK_CHECK_VERSION(3,16,0)+ GLContext,+ GLContextClass,+ castToGLContext, gTypeGLContext,+#endif++-- * Methods+#if GTK_CHECK_VERSION(3,16,0)+ glContextGetDisplay,+ glContextGetWindow,+ glContextGetSharedContext,+ glContextGetVersion,+ glContextSetRequiredVersion,+ glContextGetRequiredVersion,+ glContextSetDebugEnabled,+ glContextGetDebugEnabled,+ glContextSetForwardCompatible,+ glContextGetForwardCompatible,+ glContextRealize,+#endif+#if GTK_CHECK_VERSION(3,20,0)+ glContextIsLegacy,+#endif+#if GTK_CHECK_VERSION(3,16,0)+ glContextMakeCurrent,+ glContextGetCurrent,+ glContextClearCurrent+#endif+ ) where++import Control.Monad (liftM)+import Data.Maybe (fromMaybe)++import System.Glib.FFI+import System.Glib.Flags (toFlags)+{#import Graphics.UI.Gtk.Types#}+{#import Graphics.UI.Gtk.Gdk.Enums#}+{#import Graphics.UI.Gtk.Gdk.Cursor#}+import Graphics.UI.Gtk.General.Structs+import System.Glib.GError (propagateGError)+import System.Glib.Attributes++{# context lib="gdk" prefix="gdk" #}+++--------------------+-- Methods+#if GTK_CHECK_VERSION(3,16,0)++-- | Retrieves the 'Graphics.UI.Gtk.Gdk.Display.Display' the context is created for.+--+glContextGetDisplay :: GLContextClass self => self -> IO (Maybe Display)+glContextGetDisplay self = do+ maybeNull (wrapNewGObject mkDisplay) $+ {# call gdk_gl_context_get_display #} (toGLContext self)+++-- | Retrieves the 'Graphics.UI.Gtk.Gdk.DrawWindow.DrawWindow' used by the context.+--+glContextGetWindow :: GLContextClass self => self -> IO (Maybe DrawWindow)+glContextGetWindow self = do+ maybeNull (wrapNewGObject mkDrawWindow) $+ {# call gdk_gl_context_get_window #} (toGLContext self)+++-- | Retrieves the 'GLContext' that this context share data with.+--+glContextGetSharedContext :: GLContextClass self => self -> IO (Maybe GLContext)+glContextGetSharedContext self = do+ maybeNull (wrapNewGObject mkGLContext) $+ {# call gdk_gl_context_get_shared_context #} (toGLContext self)+++-- | Retrieves the OpenGL version of the context.+--+-- The context must be realized prior to calling this function.+--+glContextGetVersion :: GLContextClass self => self -> IO (Int, Int)+glContextGetVersion self = do+ alloca $ \majorPtr -> alloca $ \minorPtr -> do+ {# call gdk_gl_context_get_version #} (toGLContext self) majorPtr minorPtr+ major <- peek majorPtr+ minor <- peek minorPtr+ return (fromIntegral major, fromIntegral minor)+++-- | Sets the major and minor version of OpenGL to request.+--+-- Setting major and minor to zero will use the default values.+--+-- The 'GLContext' must not be realized or made current prior to calling this function.+--+glContextSetRequiredVersion :: GLContextClass self => self -> Int -> Int -> IO ()+glContextSetRequiredVersion self major minor =+ {# call gdk_gl_context_set_required_version #}+ (toGLContext self) (fromIntegral major) (fromIntegral minor)+++-- | Retrieves the major and minor version requested by calling 'glContextSetRequiredVersion'.+--+glContextGetRequiredVersion :: GLContextClass self => self -> IO (Int, Int)+glContextGetRequiredVersion self = do+ alloca $ \majorPtr -> alloca $ \minorPtr -> do+ {# call gdk_gl_context_get_required_version #} (toGLContext self) majorPtr minorPtr+ major <- peek majorPtr+ minor <- peek minorPtr+ return (fromIntegral major, fromIntegral minor)+++-- | Sets whether the 'GLContext' should perform extra validations and run time checking. This is+-- useful during development, but has additional overhead.+--+-- The 'GLContext' must not be realized or made current prior to calling this function.+--+glContextSetDebugEnabled :: GLContextClass self => self -> Bool -> IO ()+glContextSetDebugEnabled self enabled = do+ {# call gdk_gl_context_set_debug_enabled #} (toGLContext self) (fromBool enabled)+++-- | Retrieves the value set using glContextSetDebugEnabled.+--+glContextGetDebugEnabled :: GLContextClass self => self -> IO Bool+glContextGetDebugEnabled self = do+ liftM toBool $ {# call gdk_gl_context_get_debug_enabled #} (toGLContext self)+++-- | Sets whether the 'GLContext' should be forward compatible.+--+-- Forward compatibile contexts must not support OpenGL functionality that has been marked as+-- deprecated in the requested version; non-forward compatible contexts, on the other hand, must+-- support both deprecated and non deprecated functionality.+--+-- The 'GLContext' must not be realized or made current prior to calling this function.+--+glContextSetForwardCompatible :: GLContextClass self => self -> Bool -> IO ()+glContextSetForwardCompatible self compatible = do+ {# call gdk_gl_context_set_forward_compatible #} (toGLContext self) (fromBool compatible)+++-- | Retrieves the value set using glContextSetForwardCompatible.+--+glContextGetForwardCompatible :: GLContextClass self => self -> IO Bool+glContextGetForwardCompatible self = do+ liftM toBool $ {# call gdk_gl_context_get_forward_compatible #} (toGLContext self)++#endif++#if GTK_CHECK_VERSION(3,20,0)+-- | Whether the 'GLContext' is in legacy mode or not.+--+-- The 'GLContext' must be realized before calling this function.+--+-- When realizing a GL context, GDK will try to use the OpenGL 3.2 core profile; this profile+-- removes all the OpenGL API that was deprecated prior to the 3.2 version of the specification.+-- If the realization is successful, this function will return False.+--+-- If the underlying OpenGL implementation does not support core profiles, GDK will fall back to+-- a pre-3.2 compatibility profile, and this function will return True.+--+-- You can use the value returned by this function to decide which kind of OpenGL API to use, or+-- whether to do extension discovery, or what kind of shader programs to load.+--+glContextIsLegacy :: GLContextClass self => self -> IO Bool+glContextIsLegacy self = do+ liftM toBool $ {# call gdk_gl_context_is_legacy #} (toGLContext self)+#endif+++#if GTK_CHECK_VERSION(3,16,0)+-- | Realizes the given 'GLContext'.+--+-- It is safe to call this function on a realized 'GLContext'.+--+glContextRealize :: GLContextClass self => self -> IO Bool+glContextRealize self =+ liftM toBool $+ propagateGError $ \errPtr ->+ {# call gdk_gl_context_realize #} (toGLContext self) errPtr+++-- | Makes the context the current one.+--+glContextMakeCurrent :: GLContextClass self => self -> IO ()+glContextMakeCurrent self = do+ {# call gdk_gl_context_make_current #} (toGLContext self)+++-- | Retrieves the current 'GLContext'.+--+glContextGetCurrent :: IO (Maybe GLContext)+glContextGetCurrent = do+ maybeNull (wrapNewGObject mkGLContext) $+ {# call gdk_gl_context_get_current #}+++-- | Clears the current 'GLContext'.+--+-- Any OpenGL call after this function returns will be ignored until glContextMakeCurrent+-- is called.+--+glContextClearCurrent :: IO ()+glContextClearCurrent = do+ {# call gdk_gl_context_clear_current #}++#endif
Graphics/UI/Gtk/General/Enums.chs view
@@ -111,6 +111,9 @@ #if GTK_MAJOR_VERSION < 3 AnchorType (..), #endif+#if GTK_CHECK_VERSION(3,10,0)+ StackTransitionType (..),+#endif module Graphics.UI.Gtk.Gdk.Enums ) where@@ -507,4 +510,8 @@ -- -- Removed in Gtk3. {#enum AnchorType {underscoreToCase} deriving (Eq,Show)#}+#endif++#if GTK_CHECK_VERSION(3,10,0)+{#enum StackTransitionType {underscoreToCase} deriving (Eq,Show)#} #endif
Graphics/UI/Gtk/Layout/Grid.chs view
@@ -201,7 +201,7 @@ -> Bool -- ^ @homogeneous@ - True to make columns homogeneous. -> IO () gridSetColumnHomogeneous self homogeneous =- {# call grid_set_row_homogeneous #}+ {# call grid_set_column_homogeneous #} (toGrid self) (fromBool homogeneous)
+ Graphics/UI/Gtk/Layout/Stack.chs view
@@ -0,0 +1,406 @@+{-# LANGUAGE CPP #-}+-- -*-haskell-*-+-- GIMP Toolkit (GTK) Widgets Stack+--+-- Author : Moritz Schulte+--+-- Created: 27 April 2016+--+-- Copyright (C) 2015 Moritz Schulte+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- A widget which controls the alignment and size of its child+--+module Graphics.UI.Gtk.Layout.Stack (+-- * Detail+--+-- The 'Stack' widget is a container which only shows one of its+-- children at a time. In contrast to 'Notebook', 'Stack' does not+-- provide a means for users to change the visible child. Instead, the+-- 'StackSwitcher' widget can be used with 'Stack' to provide this+-- functionality.+--+-- Transitions between pages can be animated as slides or fades. This+-- can be controlled with 'stackSetTransitionType'. These+-- animations respect the 'gtk-enable-animations' setting.+-- +-- The GtkStack widget was added in GTK+ 3.10.+--+-- * Class Hierarchy+-- |+-- @+-- | 'GObject'+-- | +----'Object'+-- | +----'Widget'+-- | +----'Container'+-- | +----'Stack'+-- @++-- * Types+#if GTK_CHECK_VERSION(3,10,0)+ Stack+ , castToStack+ , gTypeStack+ , toStack+ , StackTransitionType(..)+-- * Constructors+ , stackNew++-- * Methods+ , stackAddNamed+ , stackAddTitled+ , stackGetTransitionType+ , stackSetTransitionType+ , stackSetTransitionDuration+ , stackGetTransitionDuration+ , stackGetChildByName+ , stackSetVisibleChild+ , stackSetVisibleChildName+ , stackGetVisibleChildName+ , stackSetVisibleChildFull+ , stackSetHomogeneous+ , stackGetHomogeneous+ , stackSetHhomogeneous+ , stackGetHhomogeneous+ , stackSetVhomogeneous+ , stackGetVhomogeneous+ , stackGetTransitionRunning+ , stackSetInterpolateSize+ , stackGetInterpolateSize++-- * Attributes+ , stackHhomogeneous+ , stackHomogeneous+ , stackInterpolateSize+ , stackTransitionDuration+ , stackTransitionRunning+ , stackTransitionType+ , stackVhomogeneous+ , stackVisibleChild+ , stackVisibleChildName+#endif+) where++#if GTK_CHECK_VERSION(3,10,0)++import Control.Monad (liftM)++import System.Glib.FFI+import System.Glib.UTFString+import System.Glib.Attributes+import System.Glib.Properties+import Graphics.UI.Gtk.Abstract.Object (makeNewObject)+import Graphics.UI.Gtk.General.Enums (StackTransitionType(..))+{#import Graphics.UI.Gtk.Types#}++{# context lib="gtk" prefix="gtk" #}++--------------------+-- Constructors++-- | Creates a new 'Stack' container.+--+stackNew :: IO Stack+stackNew =+ makeNewObject mkStack $+ liftM (castPtr :: Ptr Widget -> Ptr Stack) $+ {# call unsafe stack_new #}++--------------------+-- Methods++-- | Adds a child to stack . The child is identified by the name.+stackAddNamed :: (StackClass self, WidgetClass child, GlibString name) => self+ -> child+ -> name+ -> IO ()+stackAddNamed self child name =+ withUTFString name $ \namePtr ->+ {# call stack_add_named #}+ (toStack self)+ (toWidget child)+ namePtr++-- | Adds a child to stack. The child is identified by the name. The+-- title will be used by 'StackSwitcher' to represent child in a tab+-- bar, so it should be short.+stackAddTitled :: (StackClass self, WidgetClass child,+ GlibString name, GlibString title) => self+ -> child+ -> name+ -> title+ -> IO ()+stackAddTitled self child name title =+ withUTFString name $ \namePtr ->+ withUTFString title $ \titlePtr ->+ {# call stack_add_titled #}+ (toStack self)+ (toWidget child)+ namePtr+ titlePtr++-- | Sets the type of animation that will be used for transitions+-- between pages in stack . Available types include various kinds of+-- fades and slides. The transition type can be changed without+-- problems at runtime, so it is possible to change the animation+-- based on the page that is about to become current.+stackSetTransitionType :: StackClass self => self+ -> StackTransitionType+ -> IO ()+stackSetTransitionType self transitionType =+ {# call unsafe stack_set_transition_type #}+ (toStack self)+ (fromIntegral $ fromEnum transitionType)++-- | Gets the type of animation that will be used for transitions+-- between pages in stack.+stackGetTransitionType :: StackClass self => self+ -> IO StackTransitionType+stackGetTransitionType self =+ liftM (toEnum . fromIntegral) $+ {# call unsafe stack_get_transition_type #}+ (toStack self)++-- | Sets the duration that transitions between pages in stack will+-- take.+stackSetTransitionDuration :: StackClass self => self+ -> Int+ -> IO ()+stackSetTransitionDuration self duration =+ {# call unsafe stack_set_transition_duration #}+ (toStack self)+ (fromIntegral duration)++-- | Returns the amount of time (in milliseconds) that transitions+-- between pages in stack will take.+stackGetTransitionDuration :: StackClass self => self+ -> IO Int+stackGetTransitionDuration self =+ liftM fromIntegral $+ {# call unsafe stack_get_transition_duration #}+ (toStack self)++-- | Finds the child of the GtkStack with the name given as the+-- argument. Returns Nothing if there is no child with this name.+stackGetChildByName :: (StackClass self, GlibString name) => self+ -> name+ -> IO Widget+stackGetChildByName self name =+ withUTFString name $ \namePtr ->+ makeNewObject mkWidget $+ {# call unsafe stack_get_child_by_name #}+ (toStack self)+ namePtr++-- | Gets Just the currently visible child of stack, or Nothing if+-- there are no visible children.+stackGetVisibleChild :: StackClass self => self+ -> IO (Maybe Widget)+stackGetVisibleChild self =+ maybeNull (makeNewObject mkWidget) $+ {# call unsafe stack_get_visible_child #}+ (toStack self)++-- | Makes child the visible child of stack. If child is different+-- from the currently visible child, the transition between the two+-- will be animated with the current transition type of stack. Note+-- that the child widget has to be visible itself (see 'widgetShow')+-- in order to become the visible child of stack.+stackSetVisibleChild :: (StackClass self, WidgetClass child) => self+ -> child+ -> IO ()+stackSetVisibleChild self child =+ {# call unsafe stack_set_visible_child #}+ (toStack self)+ (toWidget child)++-- | Makes the child with the given name visible. If child is+-- different from the currently visible child, the transition between+-- the two will be animated with the current transition type of stack.+-- Note that the child widget has to be visible itself (see+-- `widgetShow') in order to become the visible child of stack.+stackSetVisibleChildName :: (StackClass self, GlibString name) => self+ -> name+ -> IO ()+stackSetVisibleChildName self name =+ withUTFString name $ \namePtr ->+ {# call unsafe stack_set_visible_child_name #}+ (toStack self)+ namePtr++-- | Returns the name of the currently visible child of stack, or+-- Nothing if there is no visible child.+stackGetVisibleChildName :: (StackClass self, GlibString name) => self+ -> IO (Maybe name)+stackGetVisibleChildName self =+ {# call unsafe stack_get_visible_child_name #}+ (toStack self)+ >>= maybePeekUTFString++-- | Makes the child with the given name visible. Note that the child+-- widget has to be visible itself (see 'widgetShow') in order to+-- become the visible child of stack .+stackSetVisibleChildFull :: (StackClass self, GlibString name) => self+ -> name+ -> StackTransitionType+ -> IO ()+stackSetVisibleChildFull self name transitionType =+ withUTFString name $ \namePtr ->+ {# call unsafe stack_set_visible_child_full #}+ (toStack self)+ namePtr+ (fromIntegral $ fromEnum transitionType)++-- | Sets the stack to be homogeneous or not. If it is homogeneous,+-- the stack will request the same size for all its children. If it+-- isn't, the stack may change size when a different child becomes+-- visible.+stackSetHomogeneous :: StackClass self => self -> Bool -> IO ()+stackSetHomogeneous self homogeneous =+ {# call stack_set_homogeneous #}+ (toStack self)+ (fromBool homogeneous)++-- | Gets whether stack is homogeneous. See 'stackSetHomogeneous'.+stackGetHomogeneous :: StackClass self => self -> IO Bool+stackGetHomogeneous self =+ liftM toBool $+ {# call stack_get_homogeneous #}+ (toStack self)++-- | Sets the stack to be horizontally homogeneous or not. If it is+-- homogeneous, the stack will request the same width for all its+-- children. If it isn't, the stack may change width when a different+-- child becomes visible.+stackSetHhomogeneous :: StackClass self => self -> Bool -> IO ()+stackSetHhomogeneous self hhomogeneous =+ {# call stack_set_hhomogeneous #}+ (toStack self)+ (fromBool hhomogeneous)++-- | Gets whether stack is horizontally homogeneous. See+-- 'stackSetHhomogeneous'.+stackGetHhomogeneous :: StackClass self => self -> IO Bool+stackGetHhomogeneous self =+ liftM toBool $+ {# call stack_get_hhomogeneous #}+ (toStack self)++-- | Sets the stack to be vertically homogeneous or not. If it is+-- homogeneous, the stack will request the same height for all its+-- children. If it isn't, the stack may change height when a different+-- child becomes visible.+stackSetVhomogeneous :: StackClass self => self -> Bool -> IO ()+stackSetVhomogeneous self vhomogeneous =+ {# call stack_set_vhomogeneous #}+ (toStack self)+ (fromBool vhomogeneous)++-- | Gets whether stack is vertically homogeneous. See+-- 'stackSetVhomogeneous'.+stackGetVhomogeneous :: StackClass self => self -> IO Bool+stackGetVhomogeneous self =+ liftM toBool $+ {# call stack_get_vhomogeneous #}+ (toStack self)++-- | Returns whether the stack is currently in a transition from one+-- page to another.+stackGetTransitionRunning :: StackClass self => self -> IO Bool+stackGetTransitionRunning self =+ liftM toBool $+ {# call stack_get_transition_running #}+ (toStack self)++-- | Returns wether the stack is set up to interpolate between the+-- sizes of children on page switch.+stackGetInterpolateSize :: StackClass self => self -> IO Bool+stackGetInterpolateSize self =+ liftM toBool $+ {# call stack_get_interpolate_size #}+ (toStack self)++-- | Sets whether or not the stack will interpolate its size when+-- changing the visible child. If the 'interpolate-size' property is+-- set to True, stack will interpolate its size between the current+-- one and the one it'll take after changing the visible child,+-- according to the set transition duration.+stackSetInterpolateSize :: StackClass self => self -> Bool -> IO ()+stackSetInterpolateSize self interpolateSize =+ {# call stack_set_interpolate_size #}+ (toStack self)+ (fromBool interpolateSize)++--------------------+-- Attributes++-- | True if the stack allocates the same width for all children.+stackHhomogeneous :: StackClass self => Attr self Bool+stackHhomogeneous = newAttr+ stackGetHhomogeneous+ stackSetHhomogeneous++-- | Homogeneous sizing.+stackHomogeneous :: StackClass self => Attr self Bool+stackHomogeneous = newAttr+ stackGetHomogeneous+ stackSetHomogeneous++-- | Whether or not the size should smoothly change when changing+-- between differently sized children.+stackInterpolateSize :: StackClass self => Attr self Bool+stackInterpolateSize = newAttr+ stackGetInterpolateSize+ stackSetInterpolateSize++-- | The animation duration, in milliseconds.+stackTransitionDuration :: StackClass self => Attr self Int+stackTransitionDuration = newAttr+ stackGetTransitionDuration+ stackSetTransitionDuration++-- | Whether or not the transition is currently running.+stackTransitionRunning :: StackClass self => ReadAttr self Bool+stackTransitionRunning = readAttr+ stackGetTransitionRunning++-- | The type of animation used to transition.+stackTransitionType :: StackClass self => Attr self StackTransitionType+stackTransitionType = newAttr+ stackGetTransitionType+ stackSetTransitionType++-- | True if the stack allocates the same height for all children.+stackVhomogeneous :: StackClass self => Attr self Bool+stackVhomogeneous = newAttr+ stackGetVhomogeneous+ stackSetVhomogeneous++-- | The widget currently visible in the stack.+stackVisibleChild :: StackClass self =>+ ReadWriteAttr self (Maybe Widget) Widget+stackVisibleChild = newAttr+ stackGetVisibleChild+ stackSetVisibleChild++-- | The name of the widget currently visible in the stack.+stackVisibleChildName :: StackClass self => ReadWriteAttr self (Maybe String) String+stackVisibleChildName = newAttr+ stackGetVisibleChildName+ stackSetVisibleChildName++#endif
+ Graphics/UI/Gtk/Layout/StackSwitcher.chs view
@@ -0,0 +1,124 @@+{-# LANGUAGE CPP #-}+-- -*-haskell-*-+-- GIMP Toolkit (GTK) Widgets StackSwitcher+--+-- Author : Moritz Schulte+--+-- Created: 27 April 2016+--+-- Copyright (C) 2016 Moritz Schulte+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- A widget which controls the alignment and size of its child+--+module Graphics.UI.Gtk.Layout.StackSwitcher (+-- * Detail+--+-- [...]+--+-- * Class Hierarchy+-- |+-- @+-- | 'GObject'+-- | +----'Object'+-- | +----'Widget'+-- | +----'Container'+-- | +----'Box'+-- | +----'StackSwitcher'+-- @++-- * Types+#if GTK_CHECK_VERSION(3,10,0)+ StackSwitcher+ , castToStackSwitcher+ , gTypeStackSwitcher+ , toStackSwitcher++-- * Constructors+ , stackSwitcherNew++-- * Methods+ , stackSwitcherSetStack+ , stackSwitcherGetStack++-- * Attributes+ , stackSwitcherIconSize+ , stackSwitcherStack+#endif+) where++#if GTK_CHECK_VERSION(3,10,0)++import Control.Monad (liftM)++import System.Glib.FFI+import System.Glib.Attributes+import System.Glib.Properties+import Graphics.UI.Gtk.Abstract.Object (makeNewObject)+{#import Graphics.UI.Gtk.Types#}++{# context lib="gtk" prefix="gtk" #}++--------------------+-- Constructors++-- | Creates a new 'StackSwitcher'.+--+stackSwitcherNew :: IO StackSwitcher+stackSwitcherNew =+ makeNewObject mkStackSwitcher $+ liftM (castPtr :: Ptr Widget -> Ptr StackSwitcher) $+ {# call unsafe stack_switcher_new #}++--------------------+-- Methods++-- | Sets the stack to control.+stackSwitcherSetStack :: (StackSwitcherClass self, StackClass stack) => self+ -> stack+ -> IO ()+stackSwitcherSetStack self stack =+ {# call stack_switcher_set_stack #}+ (toStackSwitcher self)+ (toStack stack)++-- | Retrieves the stack.+stackSwitcherGetStack :: StackSwitcherClass self => self+ -> IO (Maybe Stack)+stackSwitcherGetStack self =+ maybeNull (makeNewObject mkStack) $+ {# call stack_switcher_get_stack #}+ (toStackSwitcher self)++--------------------+-- Attributes++-- | Use the "icon-size" property to change the size of the image+-- displayed when a GtkStackSwitcher is displaying icons.+--+-- Default value: @1@+--+stackSwitcherIconSize :: StackSwitcherClass self => Attr self Int+stackSwitcherIconSize = newAttrFromIntProperty "icon-size"++-- | The 'Stack' controlled by this 'StackSwitcher'.+--+stackSwitcherStack :: (StackSwitcherClass self, StackClass stack) =>+ ReadWriteAttr self (Maybe Stack) (Maybe stack)+stackSwitcherStack = newAttrFromMaybeObjectProperty "stack" gTypeContainer++#endif
+ Graphics/UI/Gtk/Misc/GLArea.chs view
@@ -0,0 +1,393 @@+{-# LANGUAGE CPP #-}+-- -*-haskell-*-+-- GIMP Toolkit (GTK) Widget GLArea+--+-- Author : Chris Mennie+--+-- Created: 23 April 2016+--+-- Copyright (C) 2016 Chis Mennie+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU Lesser General Public+-- License as published by the Free Software Foundation; either+-- version 2.1 of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- Lesser General Public License for more details.+--+-- |+-- Maintainer : gtk2hs-users@lists.sourceforge.net+-- Stability : provisional+-- Portability : portable (depends on GHC)+--+-- A widget for custom drawing with OpenGL+--+module Graphics.UI.Gtk.Misc.GLArea (+-- * Detail+--+-- | The 'GLArea' is a widget that allows drawing with OpenGL.+--+-- GLArea sets up its own 'Graphics.UI.Gtk.Gdk.GLContext.GLContext' for the window it creates, and creates a+-- custom GL framebuffer that the widget will do GL rendering onto. It also+-- ensures that this framebuffer is the default GL rendering target when+-- rendering.+--+-- In order to draw, you have to connect to the 'glAreaRender' signal.+--+-- The GLArea widget ensures that the 'Graphics.UI.Gtk.Gdk.GLContext.GLContext' is associated with the+-- widget's drawing area, and it is kept updated when the size and position+-- of the drawing area changes.+--+-- If you need to initialize OpenGL state, e.g. buffer objects or shaders,+-- you should use the 'Graphics.UI.Gtk.Abstract.Widget.realize' signal; you can use the 'Graphics.UI.Gtk.Abstract.Widget.unrealize' signal+-- to clean up.+--+-- To receive mouse events on a drawing area, you will need to enable them+-- with 'Graphics.UI.Gtk.Abstract.Widget.widgetAddEvents'. To receive keyboard events, you will need to set the+-- 'Graphics.UI.Gtk.Abstract.Widget.widgetCanFocus' attribute on the drawing area.++-- * Class Hierarchy+-- |+-- @+-- | 'GObject'+-- | +----'Object'+-- | +----'Widget'+-- | +----GLArea+-- @++-- * Types+#if GTK_CHECK_VERSION(3,16,0)+ GLArea,+ GLAreaClass,+ castToGLArea, gTypeGLArea,+ toGLArea,+#endif++-- * Constructors+#if GTK_CHECK_VERSION(3,16,0)+ glAreaNew,+#endif++-- * Methods+#if GTK_CHECK_VERSION(3,16,0)+ glAreaGetContext,+ glAreaMakeCurrent,+ glAreaQueueRender,+ glAreaAttachBuffers,+ glAreaSetAutoRender,+ glAreaGetAutoRender,+ glAreaSetHasAlpha,+ glAreaGetHasAlpha,+ glAreaSetHasDepthBuffer,+ glAreaGetHasDepthBuffer,+ glAreaSetHasStencilBuffer,+ glAreaGetHasStencilBuffer,+ glAreaGetRequiredVersion,+ glAreaSetRequiredVersion,+ glAreaGetError,+#endif++-- * Attributes+#if GTK_CHECK_VERSION(3,16,0)+ glAreaAutoRender,+ glAreaContext,+ glAreaHasAlpha,+ glAreaHasDepthBuffer,+ glAreaHasStencilBuffer,+#endif++-- * Signals+#if GTK_CHECK_VERSION(3,16,0)+ glAreaResize,+ glAreaRender+#endif++ ) where++import Control.Monad (liftM)+import Control.Monad.Trans ( liftIO )+import System.Glib.FFI+import System.Glib.UTFString+import System.Glib.Attributes+import System.Glib.Properties+import System.Glib.GError+import Graphics.UI.Gtk.Abstract.Object (makeNewObject)+import Graphics.UI.Gtk.Gdk.GLContext+{#import Graphics.UI.Gtk.Types#}+{#import Graphics.UI.Gtk.Signals#}++{# context lib="gtk" prefix="gtk" #}++--------------------+-- Constructors++#if GTK_CHECK_VERSION(3,16,0)+-- | Creates a new GLArea widget.+--+glAreaNew :: IO GLArea+glAreaNew =+ makeNewObject mkGLArea $+ liftM (castPtr :: Ptr Widget -> Ptr GLArea) $+ {# call unsafe gl_area_new #}+#endif+++--------------------+-- Methods+++#if GTK_CHECK_VERSION(3,16,0)+-- | Retrieves the 'Graphics.UI.Gtk.Gdk.GLContext.GLContext' used by area.+--+glAreaGetContext :: GLAreaClass self => self+ -> IO (Maybe GLContext)+glAreaGetContext self = do+ maybeNull (wrapNewGObject mkGLContext) $+ {# call gtk_gl_area_get_context #} (toGLArea self)+++-- | Ensures that the 'Graphics.UI.Gtk.Gdk.GLContext.GLContext' used by area is associated with the GLArea.+--+-- This function is automatically called before emitting the 'glAreaRender' signal,+-- and doesn't normally need to be called by application code.+--+glAreaMakeCurrent :: GLAreaClass self => self -> IO ()+glAreaMakeCurrent self =+ {# call gtk_gl_area_make_current #} (toGLArea self)+++-- | Marks the currently rendered data (if any) as invalid, and queues a redraw+-- of the widget, ensuring that the 'glAreaRender' signal is emitted during the draw.+--+-- This is only needed when 'glAreaSetAutoRender' has been called with a False+-- value. The default behaviour is to emit 'glAreaRender' on each draw.+--+glAreaQueueRender :: GLAreaClass self => self -> IO ()+glAreaQueueRender self =+ {# call gtk_gl_area_queue_render #} (toGLArea self)+++-- | Ensures that the area framebuffer object is made the current draw and read+-- target, and that all the required buffers for the area are created and+-- bound to the frambuffer.+--+-- This function is automatically called before emitting the 'glAreaRender' signal,+-- and doesn't normally need to be called by application code.+--+glAreaAttachBuffers :: GLAreaClass self => self -> IO ()+glAreaAttachBuffers self =+ {# call gtk_gl_area_attach_buffers #} (toGLArea self)+++-- | Gets the current error set on the area.+--+glAreaGetError :: GLAreaClass self => self -> IO (Maybe GError)+glAreaGetError self = do+ err <- {# call gtk_gl_area_get_error #} (toGLArea self)+ if err == nullPtr+ then return Nothing+ else liftM Just (peek $ castPtr err)+++-- | If hasAlpha is True the buffer allocated by the widget will have an alpha channel component,+-- and when rendering to the window the result will be composited over whatever is below the+-- widget.+--+-- If hasAlpha is False there will be no alpha channel, and the buffer will fully replace anything+-- below the widget.+--+glAreaSetHasAlpha :: GLAreaClass self => self -> Bool -> IO ()+glAreaSetHasAlpha self hasAlpha =+ {# call gl_area_set_has_alpha #}+ (toGLArea self)+ (fromBool hasAlpha)+++-- | Returns whether the area has an alpha component.+--+glAreaGetHasAlpha :: GLAreaClass self => self -> IO Bool+glAreaGetHasAlpha self =+ liftM toBool $+ {# call unsafe gl_area_get_has_alpha #} (toGLArea self)+++-- | If hasDepthBuffer is True the widget will allocate and enable a depth buffer for the target+-- framebuffer. Otherwise there will be none.+--+glAreaSetHasDepthBuffer :: GLAreaClass self => self -> Bool -> IO ()+glAreaSetHasDepthBuffer self hasDepthBuffer =+ {# call gl_area_set_has_depth_buffer #}+ (toGLArea self)+ (fromBool hasDepthBuffer)+++-- | Returns whether the area has a depth buffer.+--+glAreaGetHasDepthBuffer :: GLAreaClass self => self -> IO Bool+glAreaGetHasDepthBuffer self =+ liftM toBool $+ {# call unsafe gl_area_get_has_depth_buffer #} (toGLArea self)+++-- | If hasStencilBuffer is True the widget will allocate and enable a stencil buffer for the target+-- framebuffer. Otherwise there will be none.+--+glAreaSetHasStencilBuffer :: GLAreaClass self => self -> Bool -> IO ()+glAreaSetHasStencilBuffer self hasStencilBuffer =+ {# call gl_area_set_has_stencil_buffer #}+ (toGLArea self)+ (fromBool hasStencilBuffer)+++-- | Returns whether the area has a stencil buffer.+--+glAreaGetHasStencilBuffer :: GLAreaClass self => self -> IO Bool+glAreaGetHasStencilBuffer self =+ liftM toBool $+ {# call unsafe gl_area_get_has_stencil_buffer #} (toGLArea self)+++-- | If autoRender is True the 'glAreaRender' signal will be emitted every time the widget draws. This is+-- the default and is useful if drawing the widget is faster.+--+-- If autoRender is False the data from previous rendering is kept around and will be used for+-- drawing the widget the next time, unless the window is resized. In order to force a rendering+-- 'glAreaQueueRender' must be called. This mode is useful when the scene changes seldomly, but takes+-- a long time to redraw.+--+glAreaSetAutoRender :: GLAreaClass self => self -> Bool -> IO ()+glAreaSetAutoRender self autoRender =+ {# call gl_area_set_auto_render #}+ (toGLArea self)+ (fromBool autoRender)++-- | Returns whether the area is in auto render mode or not.+--+glAreaGetAutoRender :: GLAreaClass self => self -> IO Bool+glAreaGetAutoRender self =+ liftM toBool $+ {# call unsafe gl_area_get_auto_render #}+ (toGLArea self)+++-- | Retrieves the required version of OpenGL set using 'glAreaSetRequiredVersion'.+--+glAreaGetRequiredVersion :: GLAreaClass self => self -> IO (Int, Int)+glAreaGetRequiredVersion self = do+ alloca $ \majorPtr -> alloca $ \minorPtr -> do+ {# call gtk_gl_area_get_required_version #} (toGLArea self) majorPtr minorPtr+ major <- peek majorPtr+ minor <- peek minorPtr+ return (fromIntegral major, fromIntegral minor)+++-- | Sets the required version of OpenGL to be used when creating the context for the widget.+--+-- This function must be called before the area has been realized.+--+glAreaSetRequiredVersion :: GLAreaClass self => self -> Int -> Int -> IO ()+glAreaSetRequiredVersion self major minor =+ {# call gtk_gl_area_set_required_version #}+ (toGLArea self) (fromIntegral major) (fromIntegral minor)++#endif++--------------------+-- Attributes+++#if GTK_CHECK_VERSION(3,16,0)+-- | If set to True the 'glAreaRender' signal will be emitted every time the widget draws. This is the+-- default and is useful if drawing the widget is faster.+--+-- If set to False the data from previous rendering is kept around and will be used for drawing the+-- widget the next time, unless the window is resized. In order to force a rendering+-- 'glAreaQueueRender' must be called. This mode is useful when the scene changes seldomly, but+-- takes a long time to redraw.+--+-- Default value: True+--+glAreaAutoRender :: GLAreaClass self => Attr self Bool+glAreaAutoRender = newAttr+ glAreaGetAutoRender+ glAreaSetAutoRender+++-- | The 'Graphics.UI.Gtk.Gdk.GLContext.GLContext' used by the GLArea widget.+--+-- The GLArea widget is responsible for creating the 'Graphics.UI.Gtk.Gdk.GLContext.GLContext' instance. If you need to render with+-- other kinds of buffers (stencil, depth, etc), use render buffers.+--+glAreaContext :: GLAreaClass self => ReadAttr self (Maybe GLContext)+glAreaContext = readAttr glAreaGetContext+++-- | If set to True the buffer allocated by the widget will have an alpha channel component, and+-- when rendering to the window the result will be composited over whatever is below the widget.+--+-- If set to False there will be no alpha channel, and the buffer will fully replace anything below+-- the widget.+--+-- Default value: False+--+glAreaHasAlpha :: GLAreaClass self => Attr self Bool+glAreaHasAlpha = newAttr+ glAreaGetHasAlpha+ glAreaSetHasAlpha+++-- | If set to True the widget will allocate and enable a depth buffer for the target framebuffer.+--+-- Default value: False+--+glAreaHasDepthBuffer :: GLAreaClass self => Attr self Bool+glAreaHasDepthBuffer = newAttr+ glAreaGetHasDepthBuffer+ glAreaSetHasDepthBuffer+++-- | If set to True the widget will allocate and enable a stencil buffer for the target framebuffer.+--+-- Default value: False+--+glAreaHasStencilBuffer :: GLAreaClass self => Attr self Bool+glAreaHasStencilBuffer = newAttr+ glAreaGetHasStencilBuffer+ glAreaSetHasStencilBuffer++#endif++--------------------+-- Signals++#if GTK_CHECK_VERSION(3,16,0)++-- | The glAreaResize signal is emitted once when the widget is realized, and then each time the widget+-- is changed while realized. This is useful in order to keep GL state up to date with the widget+-- size, like for instance camera properties which may depend on the width/height ratio.+--+-- The GL context for the area is guaranteed to be current when this signal is emitted.+--+-- The default handler sets up the GL viewport.+--+glAreaResize :: GLAreaClass glac => Signal glac (Int -> Int -> IO ())+glAreaResize = Signal (connect_INT_INT__NONE "resize")+++-- | The glAreaRender signal is emitted every time the contents of the GLArea should be redrawn.+--+-- The context is bound to the area prior to emitting this function, and the buffers are painted+-- to the window once the emission terminates.+--+glAreaRender :: GLAreaClass glac => Signal glac (Maybe GLContext -> IO (Bool))+glAreaRender = Signal (connect_BOXED__BOOL "render" unwrapGLContextPtr)+++unwrapGLContextPtr :: Ptr GLContext -> IO (Maybe GLContext)+unwrapGLContextPtr ptr = do+ maybeNull (makeNewGObject mkGLContext) (return ptr)++#endif
Graphics/UI/Gtk/ModelView/ListStore.hs view
@@ -98,8 +98,9 @@ customStoreNew rows ListStore TreeModelIface { treeModelIfaceGetFlags = return [TreeModelListOnly], treeModelIfaceGetIter = \[n] -> readIORef rows >>= \rows ->- return (if Seq.null rows then Nothing else- Just (TreeIter 0 (fromIntegral n) 0 0)),+ return (if inRange (0, Seq.length rows - 1) n+ then Just (TreeIter 0 (fromIntegral n) 0 0)+ else Nothing), treeModelIfaceGetPath = \(TreeIter _ n _ _) -> return [fromIntegral n], treeModelIfaceGetRow = \(TreeIter _ n _ _) -> readIORef rows >>= \rows ->@@ -112,7 +113,11 @@ if inRange (0, Seq.length rows - 1) (fromIntegral (n+1)) then return (Just (TreeIter 0 (n+1) 0 0)) else return Nothing,- treeModelIfaceIterChildren = \_ -> return Nothing,+ treeModelIfaceIterChildren = \index -> readIORef rows >>= \rows ->+ case index of+ Nothing | not (Seq.null rows) ->+ return (Just (TreeIter 0 0 0 0))+ _ -> return Nothing, treeModelIfaceIterHasChild = \_ -> return False, treeModelIfaceIterNChildren = \index -> readIORef rows >>= \rows -> case index of
Graphics/UI/Gtk/Types.chs view
@@ -90,6 +90,10 @@ toDrawWindow, mkDrawWindow, unDrawWindow, castToDrawWindow, gTypeDrawWindow,+ GLContext(GLContext), GLContextClass,+ toGLContext, + mkGLContext, unGLContext,+ castToGLContext, gTypeGLContext, Screen(Screen), ScreenClass, toScreen, mkScreen, unScreen,@@ -206,6 +210,10 @@ toToolItemGroup, mkToolItemGroup, unToolItemGroup, castToToolItemGroup, gTypeToolItemGroup,+ Stack(Stack), StackClass,+ toStack, + mkStack, unStack,+ castToStack, gTypeStack, Bin(Bin), BinClass, toBin, mkBin, unBin,@@ -370,6 +378,10 @@ toSeparatorToolItem, mkSeparatorToolItem, unSeparatorToolItem, castToSeparatorToolItem, gTypeSeparatorToolItem,+ StackSwitcher(StackSwitcher), StackSwitcherClass,+ toStackSwitcher, + mkStackSwitcher, unStackSwitcher,+ castToStackSwitcher, gTypeStackSwitcher, Box(Box), BoxClass, toBox, mkBox, unBox,@@ -494,6 +506,10 @@ toCellView, mkCellView, unCellView, castToCellView, gTypeCellView,+ GLArea(GLArea), GLAreaClass,+ toGLArea, + mkGLArea, unGLArea,+ castToGLArea, gTypeGLArea, DrawingArea(DrawingArea), DrawingAreaClass, toDrawingArea, mkDrawingArea, unDrawingArea,@@ -1078,6 +1094,29 @@ gTypeDrawWindow = {# call fun unsafe gdk_window_get_type #} +-- ****************************************************************** GLContext++{#pointer *GdkGLContext as GLContext foreign newtype #} deriving (Eq,Ord)++mkGLContext = (GLContext, objectUnrefFromMainloop)+unGLContext (GLContext o) = o++class GObjectClass o => GLContextClass o+toGLContext :: GLContextClass o => o -> GLContext+toGLContext = unsafeCastGObject . toGObject++instance GLContextClass GLContext+instance GObjectClass GLContext where+ toGObject = GObject . castForeignPtr . unGLContext+ unsafeCastGObject = GLContext . castForeignPtr . unGObject++castToGLContext :: GObjectClass obj => obj -> GLContext+castToGLContext = castTo gTypeGLContext "GLContext"++gTypeGLContext :: GType+gTypeGLContext =+ {# call fun unsafe gdk_gl_context_get_type #}+ -- ********************************************************************* Screen {#pointer *GdkScreen as Screen foreign newtype #} deriving (Eq,Ord)@@ -1762,6 +1801,31 @@ gTypeToolItemGroup = {# call fun unsafe gtk_tool_item_group_get_type #} +-- ********************************************************************** Stack++{#pointer *GtkStack as Stack foreign newtype #} deriving (Eq,Ord)++mkStack = (Stack, objectUnrefFromMainloop)+unStack (Stack o) = o++class ContainerClass o => StackClass o+toStack :: StackClass o => o -> Stack+toStack = unsafeCastGObject . toGObject++instance StackClass Stack+instance ContainerClass Stack+instance WidgetClass Stack+instance GObjectClass Stack where+ toGObject = GObject . castForeignPtr . unStack+ unsafeCastGObject = Stack . castForeignPtr . unGObject++castToStack :: GObjectClass obj => obj -> Stack+castToStack = castTo gTypeStack "Stack"++gTypeStack :: GType+gTypeStack =+ {# call fun unsafe gtk_stack_get_type #}+ -- ************************************************************************ Bin {#pointer *GtkBin as Bin foreign newtype #} deriving (Eq,Ord)@@ -2868,6 +2932,32 @@ gTypeSeparatorToolItem = {# call fun unsafe gtk_separator_tool_item_get_type #} +-- ************************************************************** StackSwitcher++{#pointer *GtkStackSwitcher as StackSwitcher foreign newtype #} deriving (Eq,Ord)++mkStackSwitcher = (StackSwitcher, objectUnrefFromMainloop)+unStackSwitcher (StackSwitcher o) = o++class BinClass o => StackSwitcherClass o+toStackSwitcher :: StackSwitcherClass o => o -> StackSwitcher+toStackSwitcher = unsafeCastGObject . toGObject++instance StackSwitcherClass StackSwitcher+instance BinClass StackSwitcher+instance ContainerClass StackSwitcher+instance WidgetClass StackSwitcher+instance GObjectClass StackSwitcher where+ toGObject = GObject . castForeignPtr . unStackSwitcher+ unsafeCastGObject = StackSwitcher . castForeignPtr . unGObject++castToStackSwitcher :: GObjectClass obj => obj -> StackSwitcher+castToStackSwitcher = castTo gTypeStackSwitcher "StackSwitcher"++gTypeStackSwitcher :: GType+gTypeStackSwitcher =+ {# call fun unsafe gtk_stack_switcher_get_type #}+ -- ************************************************************************ Box {#pointer *GtkBox as Box foreign newtype #} deriving (Eq,Ord)@@ -3667,6 +3757,30 @@ gTypeCellView :: GType gTypeCellView = {# call fun unsafe gtk_cell_view_get_type #}++-- ********************************************************************* GLArea++{#pointer *GtkGLArea as GLArea foreign newtype #} deriving (Eq,Ord)++mkGLArea = (GLArea, objectUnrefFromMainloop)+unGLArea (GLArea o) = o++class WidgetClass o => GLAreaClass o+toGLArea :: GLAreaClass o => o -> GLArea+toGLArea = unsafeCastGObject . toGObject++instance GLAreaClass GLArea+instance WidgetClass GLArea+instance GObjectClass GLArea where+ toGObject = GObject . castForeignPtr . unGLArea+ unsafeCastGObject = GLArea . castForeignPtr . unGObject++castToGLArea :: GObjectClass obj => obj -> GLArea+castToGLArea = castTo gTypeGLArea "GLArea"++gTypeGLArea :: GType+gTypeGLArea =+ {# call fun unsafe gtk_gl_area_get_type #} -- **************************************************************** DrawingArea
− Gtk2HsSetup.hs
@@ -1,500 +0,0 @@-{-# LANGUAGE CPP, ViewPatterns #-}--#ifndef CABAL_VERSION_CHECK-#error This module has to be compiled via the Setup.hs program which generates the gtk2hs-macros.h file-#endif---- | Build a Gtk2hs package.----module Gtk2HsSetup (- gtk2hsUserHooks,- getPkgConfigPackages,- checkGtk2hsBuildtools,- typeGenProgram,- signalGenProgram,- c2hsLocal- ) where--import Distribution.Simple-import Distribution.Simple.PreProcess-import Distribution.InstalledPackageInfo ( importDirs,- showInstalledPackageInfo,- libraryDirs,- extraLibraries,- extraGHCiLibraries )-import Distribution.Simple.PackageIndex ( lookupInstalledPackageId )-import Distribution.PackageDescription as PD ( PackageDescription(..),- updatePackageDescription,- BuildInfo(..),- emptyBuildInfo, allBuildInfo,- Library(..),- libModules, hasLibs)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(withPackageDB, buildDir, localPkgDescr, installedPkgs, withPrograms),- InstallDirs(..),- componentPackageDeps,- absoluteInstallDirs)-import Distribution.Simple.Compiler ( Compiler(..) )-import Distribution.Simple.Program (- Program(..), ConfiguredProgram(..),- rawSystemProgramConf, rawSystemProgramStdoutConf, programName, programPath,- c2hsProgram, pkgConfigProgram, gccProgram, requireProgram, ghcPkgProgram,- 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, RegisterFlags(..), flagToMaybe,- fromFlagOrDefault, defaultRegisterFlags)-import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Simple.Install ( install )-import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage )-import Distribution.Text ( simpleParse, display )-import System.FilePath-import System.Exit (exitFailure)-import System.Directory ( doesFileExist, getDirectoryContents, doesDirectoryExist )-import Distribution.Version (Version(..))-import Distribution.Verbosity-import Control.Monad (when, unless, filterM, liftM, forM, forM_)-import Data.Maybe ( isJust, isNothing, fromMaybe, maybeToList, catMaybes )-import Data.List (isPrefixOf, isSuffixOf, nub, minimumBy, stripPrefix, tails )-import Data.Ord as Ord (comparing)-import Data.Char (isAlpha, isNumber)-import qualified Data.Map as M-import qualified Data.Set as S-import qualified Distribution.Simple.LocalBuildInfo as LBI-import Distribution.Simple.Compiler (compilerVersion)--import Control.Applicative ((<$>))--#if CABAL_VERSION_CHECK(1,17,0)-import Distribution.Simple.Program.Find ( defaultProgramSearchPath )-onDefaultSearchPath f a b = f a b defaultProgramSearchPath-libraryConfig lbi = case [clbi | (LBI.CLibName, clbi, _) <- LBI.componentsConfigs lbi] of- [clbi] -> Just clbi- _ -> Nothing-#else-onDefaultSearchPath = id-libraryConfig = LBI.libraryConfig-#endif---- the name of the c2hs pre-compiled header file-precompFile = "precompchs.bin"--gtk2hsUserHooks = simpleUserHooks {- hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal],- hookedPreProcessors = [("chs", ourC2hs)],- confHook = \pd cf ->- (fmap adjustLocalBuildInfo (confHook simpleUserHooks pd cf)),- 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 ->-#if defined(mingw32_HOST_OS) || defined(__MINGW32__)- installHook pd lbi uh flags >>- installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest,- regHook = registerHook-#else- instHook simpleUserHooks pd lbi uh flags >>- installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest-#endif- }----------------------------------------------------------------------------------- Lots of stuff for windows ghci support---------------------------------------------------------------------------------getDlls :: [FilePath] -> IO [FilePath]-getDlls dirs = filter ((== ".dll") . takeExtension) . concat <$>- mapM getDirectoryContents dirs--fixLibs :: [FilePath] -> [String] -> [String]-fixLibs dlls = concatMap $ \ lib ->- case filter (isLib lib) dlls of- dlls@(_:_) -> [dropExtension (pickDll dlls)]- _ -> if lib == "z" then [] else [lib]- where- -- If there are several .dll files matching the one we're after then we- -- just have to guess. For example for recent Windows cairo builds we get- -- libcairo-2.dll libcairo-gobject-2.dll libcairo-script-interpreter-2.dll- -- Our heuristic is to pick the one with the shortest name.- -- Yes this is a hack but the proper solution is hard: we would need to- -- parse the .a file and see which .dll file(s) it needed to link to.- pickDll = minimumBy (Ord.comparing length)- isLib lib dll =- case stripPrefix ("lib"++lib) dll of- Just ('.':_) -> True- Just ('-':n:_) | isNumber n -> True- _ -> False---- The following code is a big copy-and-paste job from the sources of--- Cabal 1.8 just to be able to fix a field in the package file. Yuck.--installHook :: PackageDescription -> LocalBuildInfo- -> UserHooks -> InstallFlags -> IO ()-installHook pkg_descr localbuildinfo _ flags = do- let copyFlags = defaultCopyFlags {- copyDistPref = installDistPref flags,- copyDest = toFlag NoCopyDest,- copyVerbosity = installVerbosity flags- }- install pkg_descr localbuildinfo copyFlags- let registerFlags = defaultRegisterFlags {- regDistPref = installDistPref flags,- regInPlace = installInPlace flags,- regPackageDB = installPackageDB flags,- regVerbosity = installVerbosity flags- }- when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags--registerHook :: PackageDescription -> LocalBuildInfo- -> UserHooks -> RegisterFlags -> IO ()-registerHook pkg_descr localbuildinfo _ flags =- if hasLibs pkg_descr- then register pkg_descr localbuildinfo flags- else setupMessage verbosity- "Package contains no library to register:" (packageId pkg_descr)- where verbosity = fromFlag (regVerbosity flags)--register :: PackageDescription -> LocalBuildInfo- -> RegisterFlags -- ^Install in the user's database?; verbose- -> IO ()-register pkg@PackageDescription { library = Just lib } lbi regFlags- = do- let clbi = LBI.getComponentLocalBuildInfo lbi LBI.CLibName-- installedPkgInfoRaw <- generateRegistrationInfo-#if CABAL_VERSION_CHECK(1,22,0)- verbosity pkg lib lbi clbi inplace False distPref packageDb-#else- verbosity pkg lib lbi clbi inplace distPref-#endif-- dllsInScope <- getSearchPath >>= (filterM doesDirectoryExist) >>= getDlls- let libs = fixLibs dllsInScope (extraLibraries installedPkgInfoRaw)- installedPkgInfo = installedPkgInfoRaw {- extraGHCiLibraries = libs }-- -- Three different modes:- case () of- _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo- | modeGenerateRegScript -> die "Generate Reg Script not supported"- | otherwise -> registerPackage verbosity- installedPkgInfo pkg lbi inplace-#if CABAL_VERSION_CHECK(1,10,0)- packageDbs-#else- packageDb-#endif-- where- modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))- regFile = fromMaybe (display (packageId pkg) <.> "conf")- (fromFlag (regGenPkgConf regFlags))- modeGenerateRegScript = fromFlag (regGenScript regFlags)- inplace = fromFlag (regInPlace regFlags)- packageDbs = nub $ withPackageDB lbi- ++ maybeToList (flagToMaybe (regPackageDB regFlags))- packageDb = registrationPackageDB packageDbs- distPref = fromFlag (regDistPref regFlags)- verbosity = fromFlag (regVerbosity regFlags)-- writeRegistrationFile installedPkgInfo = do- notice verbosity ("Creating package registration file: " ++ regFile)- writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo)--register _ _ regFlags = notice verbosity "No package to register"- where- verbosity = fromFlag (regVerbosity regFlags)------------------------------------------------------------------------------------ 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) }----------------------------------------------------------------------------------- Processing .chs files with our local c2hs.---------------------------------------------------------------------------------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 |- ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi),- dir <- maybe [] importDirs (lookupInstalledPackageId (installedPkgs lbi) ipi) ]- (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)- rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $- map ("--include=" ++) (outDir:chiDirs)- ++ [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ]- ++ ["--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"]- ++ ["-D__GLASGOW_HASKELL__="++show (ghcDefine . ghcVersion . compilerId $ LBI.compiler lbi)]- where- ghcDefine (v1:v2:_) = v1 * 100 + v2- ghcDefine _ = __GLASGOW_HASKELL__-- ghcVersion :: CompilerId -> [Int]--- This version is nicer, but we need to know the Cabal version that includes the new CompilerId--- #if CABAL_VERSION_CHECK(1,19,2)--- ghcVersion (CompilerId GHC v _) = versionBranch v--- ghcVersion (CompilerId _ _ (Just c)) = ghcVersion c--- #else--- ghcVersion (CompilerId GHC v) = versionBranch v--- #endif--- ghcVersion _ = []--- This version should work fine for now- ghcVersion = concat . take 1 . map (read . (++"]") . takeWhile (/=']')) . catMaybes- . map (stripPrefix "CompilerId GHC (Version {versionBranch = ") . tails . show--installCHI :: PackageDescription -- ^information from the .cabal file- -> LocalBuildInfo -- ^information from the configure step- -> Verbosity -> CopyDest -- ^flags sent to copy or install- -> IO ()-installCHI pkg@PD.PackageDescription { 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] . toFilePath)- (PD.libModules lib)-- let files = [ f | Just f <- mFiles ]- installOrdinaryFiles verbosity libPref files---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") {- programFindVersion = findProgramVersion "--version" $ \str ->- -- Invoking "gtk2hsC2hs --version" gives a string like:- -- C->Haskell Compiler, version 0.13.4 (gtk2hs branch) "Bin IO", 13 Nov 2004- case words str of- (_:_:_:ver:_) -> ver- _ -> ""- }---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 :: String -> [ProgArg]- typeOpts tag = concat [ map (\val -> '-':'-':drop (length tag) field ++ '=':val) (words content)- | (field,content) <- xList,- tag `isPrefixOf` field,- field /= (tag++"file")]- ++ [ "--tag=" ++ tag- | PackageIdentifier name (Version (major:minor:_) _) <- cPkgs- , let name' = filter isAlpha (display name)- , tag <- name'- :[ name' ++ "-" ++ show maj ++ "." ++ show d2- | (maj, d2) <- [(maj, d2) | maj <- [0..(major-1)], d2 <- [0,2..20]]- ++ [(major, d2) | d2 <- [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-- forM_ (filter (\(tag,_) -> "x-types-" `isPrefixOf` tag && "file" `isSuffixOf` tag) xList) $- \(fileTag, f) -> do- let tag = reverse (drop 4 (reverse fileTag))- info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.")- genFile typeGenProgram (typeOpts tag) 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-- writeFile "gtk2hs_macros.h" $ generateMacros cPkgs---- Based on Cabal/Distribution/Simple/Build/Macros.hs-generateMacros :: [PackageId] -> String-generateMacros cPkgs = concat $- "/* DO NOT EDIT: This file is automatically generated by Gtk2HsSetup.hs */\n\n" :- [ concat- ["/* package ",display pkgid," */\n"- ,"#define VERSION_",pkgname," ",show (display version),"\n"- ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n"- ," (major1) < ",major1," || \\\n"- ," (major1) == ",major1," && (major2) < ",major2," || \\\n"- ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"- ,"\n\n"- ]- | pkgid@(PackageIdentifier name version) <- cPkgs- , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)- pkgname = map fixchar (display name)- ]- where fixchar '-' = '_'- fixchar '.' = '_'- fixchar c = c----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.PackageDescription {- PD.library = Just lib@PD.Library {- 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 (othMods, expMods) = span (not . mdExposed) $ reverse $ sortTopological modDeps- return pd { PD.library = Just lib {- PD.exposedModules = map mdOriginal (reverse expMods),- PD.libBuildInfo = bi { PD.otherModules = map mdOriginal (reverse 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 } = withUTF8FileContents 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)---- Check user whether install gtk2hs-buildtools correctly.-checkGtk2hsBuildtools :: [Program] -> IO ()-checkGtk2hsBuildtools programs = do- programInfos <- mapM (\ prog -> do- location <- onDefaultSearchPath programFindLocation prog normal- return (programName prog, location)- ) programs- let printError name = do- putStrLn $ "Cannot find " ++ name ++ "\n"- ++ "Please install `gtk2hs-buildtools` first and check that the install directory is in your PATH (e.g. HOME/.cabal/bin)."- exitFailure- forM_ programInfos $ \ (name, location) ->- when (isNothing location) (printError name)
Setup.hs view
@@ -1,10 +1,12 @@--- Standard setup file for a Gtk2Hs module.+-- Adjustments specific to this package,+-- all Gtk2Hs-specific boilerplate is kept in+-- gtk2hs-buildtools:Gtk2HsSetup ----- See also:--- * SetupMain.hs : the real Setup script for this package--- * Gtk2HsSetup.hs : Gtk2Hs-specific boilerplate--- * SetupWrapper.hs : wrapper for compat with various ghc/cabal versions+import Gtk2HsSetup ( gtk2hsUserHooks, checkGtk2hsBuildtools,+ typeGenProgram, signalGenProgram, c2hsLocal)+import Distribution.Simple ( defaultMainWithHooks ) -import SetupWrapper ( setupWrapper )+main = do+ checkGtk2hsBuildtools [typeGenProgram, signalGenProgram, c2hsLocal]+ defaultMainWithHooks gtk2hsUserHooks -main = setupWrapper "SetupMain.hs"
− SetupMain.hs
@@ -1,13 +0,0 @@--- The real Setup file for a Gtk2Hs package (invoked via the SetupWrapper).--- It contains only adjustments specific to this package,--- all Gtk2Hs-specific boilerplate is kept in Gtk2HsSetup.hs--- which should be kept identical across all packages.----import Gtk2HsSetup ( gtk2hsUserHooks, checkGtk2hsBuildtools,- typeGenProgram, signalGenProgram, c2hsLocal)-import Distribution.Simple ( defaultMainWithHooks )--main = do- checkGtk2hsBuildtools [typeGenProgram, signalGenProgram, c2hsLocal]- defaultMainWithHooks gtk2hsUserHooks-
− SetupWrapper.hs
@@ -1,164 +0,0 @@--- A wrapper script for Cabal Setup.hs scripts. Allows compiling the real Setup--- conditionally depending on the Cabal version.--module SetupWrapper (setupWrapper) where--import Distribution.Package-import Distribution.Compiler-import Distribution.Simple.Utils-import Distribution.Simple.Program-import Distribution.Simple.Compiler-import Distribution.Simple.BuildPaths (exeExtension)-import Distribution.Simple.Configure (configCompilerEx)-import Distribution.Simple.GHC (getInstalledPackages)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Version-import Distribution.Verbosity-import Distribution.Text--import System.Environment-import System.Process-import System.Exit (ExitCode(..), exitWith)-import System.FilePath-import System.Directory (doesFileExist, getModificationTime)-import qualified Control.Exception as Exception-import System.IO.Error (isDoesNotExistError)--import Data.List-import Data.Char-import Control.Monad----- moreRecentFile is implemented in Distribution.Simple.Utils, but only in--- Cabal >= 1.18. For backwards-compatibility, we implement a copy with a new--- name here. Some desirable alternate strategies don't work:--- * We can't use CPP to check which version of Cabal we're up against because--- this is the file that's generating the macros for doing that.--- * We can't use the name moreRecentFiles and use--- import D.S.U hiding (moreRecentFiles)--- because on old GHC's (and according to the Report) hiding a name that--- doesn't exist is an error.-moreRecentFile' :: FilePath -> FilePath -> IO Bool-moreRecentFile' a b = do- exists <- doesFileExist b- if not exists- then return True- else do tb <- getModificationTime b- ta <- getModificationTime a- return (ta > tb)--setupWrapper :: FilePath -> IO ()-setupWrapper setupHsFile = do- args <- getArgs- createDirectoryIfMissingVerbose verbosity True setupDir- compileSetupExecutable- invokeSetupScript args-- where- setupDir = "dist/setup-wrapper"- setupVersionFile = setupDir </> "setup" <.> "version"- setupProgFile = setupDir </> "setup" <.> exeExtension- setupMacroFile = setupDir </> "wrapper-macros.h"-- useCabalVersion = Version [1,8] []- usePackageDB = [GlobalPackageDB, UserPackageDB]- verbosity = normal-- cabalLibVersionToUse comp conf = do- savedVersion <- savedCabalVersion- case savedVersion of- Just version- -> return version- _ -> do version <- installedCabalVersion comp conf- writeFile setupVersionFile (show version ++ "\n")- return version-- savedCabalVersion = do- versionString <- readFile setupVersionFile- `Exception.catch` \e -> if isDoesNotExistError e- then return ""- else Exception.throwIO e- case reads versionString of- [(version,s)] | all isSpace s -> return (Just version)- _ -> return Nothing-- installedCabalVersion comp conf = do- index <- getInstalledPackages verbosity usePackageDB conf-- let cabalDep = Dependency (PackageName "Cabal")- (orLaterVersion useCabalVersion)- case PackageIndex.lookupDependency index cabalDep of- [] -> die $ "The package requires Cabal library version "- ++ display useCabalVersion- ++ " but no suitable version is installed."- pkgs -> return $ bestVersion (map fst pkgs)- where- bestVersion = maximumBy (comparing preference)- preference version = (sameVersion, sameMajorVersion- ,stableVersion, latestVersion)- where- sameVersion = version == cabalVersion- sameMajorVersion = majorVersion version == majorVersion cabalVersion- majorVersion = take 2 . versionBranch- stableVersion = case versionBranch version of- (_:x:_) -> even x- _ -> False- latestVersion = version-- -- | If the Setup.hs is out of date wrt the executable then recompile it.- -- Currently this is GHC only. It should really be generalised.- --- compileSetupExecutable = do- setupHsNewer <- setupHsFile `moreRecentFile'` setupProgFile- cabalVersionNewer <- setupVersionFile `moreRecentFile'` setupProgFile- let outOfDate = setupHsNewer || cabalVersionNewer- when outOfDate $ do- debug verbosity "Setup script is out of date, compiling..."-- (comp, _, conf) <- configCompilerEx (Just GHC) Nothing Nothing- defaultProgramConfiguration verbosity- cabalLibVersion <- cabalLibVersionToUse comp conf- let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion- debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion-- writeFile setupMacroFile (generateVersionMacro cabalLibVersion)-- rawSystemProgramConf verbosity ghcProgram conf $- ["--make", setupHsFile, "-o", setupProgFile]- ++ ghcPackageDbOptions usePackageDB- ++ ["-package", display cabalPkgid- ,"-cpp", "-optP-include", "-optP" ++ setupMacroFile- ,"-odir", setupDir, "-hidir", setupDir]- where-- ghcPackageDbOptions dbstack = case dbstack of- (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs- (GlobalPackageDB:dbs) -> "-no-user-package-conf"- : concatMap specific dbs- _ -> ierror- where- specific (SpecificPackageDB db) = [ "-package-conf", db ]- specific _ = ierror- ierror = error "internal error: unexpected package db stack"-- generateVersionMacro :: Version -> String- generateVersionMacro version =- concat- ["/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n"- ,"#define CABAL_VERSION_CHECK(major1,major2,minor) (\\\n"- ," (major1) < ",major1," || \\\n"- ," (major1) == ",major1," && (major2) < ",major2," || \\\n"- ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"- ,"\n\n"- ]- where- (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)-- invokeSetupScript :: [String] -> IO ()- invokeSetupScript args = do- info verbosity $ unwords (setupProgFile : args)- process <- runProcess (currentDir </> setupProgFile) args- Nothing Nothing- Nothing Nothing Nothing- exitCode <- waitForProcess process- unless (exitCode == ExitSuccess) $ exitWith exitCode
gtk3.cabal view
@@ -1,12 +1,12 @@ Name: gtk3-Version: 0.14.2+Version: 0.14.3 License: LGPL-2.1 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team Author: Axel Simon, Duncan Coutts and many others Maintainer: gtk2hs-users@lists.sourceforge.net Build-Type: Custom-Cabal-Version: >= 1.18+Cabal-Version: >= 1.24 Stability: provisional homepage: http://projects.haskell.org/gtk2hs/ bug-reports: https://github.com/gtk2hs/gtk2hs/issues@@ -20,7 +20,6 @@ Graphics/UI/Gtk/ModelView/Gtk2HsStore.h Graphics/UI/Gtk/General/hsgthread.h template-hsc-gtk2hs.h- SetupWrapper.hs SetupMain.hs Gtk2HsSetup.hs marshal.list hierarchy3.list @@ -129,6 +128,11 @@ option off. Default: True +custom-setup+ setup-depends: base >= 4.6,+ Cabal >= 1.24 && < 1.25,+ gtk2hs-buildtools >= 0.13.1.0 && < 0.14+ Library build-depends: base >= 4 && < 5, array, containers, mtl, bytestring,@@ -202,6 +206,7 @@ Graphics.UI.Gtk.Gdk.EventM Graphics.UI.Gtk.Gdk.Events Graphics.UI.Gtk.Gdk.Gdk+ Graphics.UI.Gtk.Gdk.GLContext Graphics.UI.Gtk.Gdk.Keys Graphics.UI.Gtk.Gdk.Pixbuf Graphics.UI.Gtk.Gdk.PixbufAnimation@@ -234,6 +239,8 @@ Graphics.UI.Gtk.Layout.VBox Graphics.UI.Gtk.Layout.VButtonBox Graphics.UI.Gtk.Layout.VPaned+ Graphics.UI.Gtk.Layout.Stack+ Graphics.UI.Gtk.Layout.StackSwitcher Graphics.UI.Gtk.MenuComboToolbar.CheckMenuItem Graphics.UI.Gtk.MenuComboToolbar.ComboBox Graphics.UI.Gtk.MenuComboToolbar.ImageMenuItem@@ -258,6 +265,7 @@ Graphics.UI.Gtk.Misc.Arrow Graphics.UI.Gtk.Misc.Calendar Graphics.UI.Gtk.Misc.DrawingArea+ Graphics.UI.Gtk.Misc.GLArea Graphics.UI.Gtk.Misc.EventBox Graphics.UI.Gtk.Misc.HandleBox Graphics.UI.Gtk.Misc.IMMulticontext@@ -366,7 +374,9 @@ -- needs to be imported from this module: x-Signals-Import: Graphics.UI.Gtk.General.Threading include-dirs: .- cpp-options: -DDISABLE_DEPRECATED -U__BLOCKS__ -D__attribute__(A)=+ cpp-options: -DDISABLE_DEPRECATED -U__BLOCKS__+ if os(darwin)+ cpp-options: -D__attribute__(A)= if os(windows) cpp-options: -DWIN32 -fno-exceptions cc-options: -fno-exceptions@@ -391,7 +401,7 @@ main-is: ActionMenu.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers, text+ build-depends: gtk3==0.14.3, base, transformers, text Executable gtk2hs-demo-buttonBox default-language: Haskell98@@ -399,7 +409,7 @@ main-is: ButtonBox.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers+ build-depends: gtk3==0.14.3, base, transformers Executable gtk2hs-demo-carsim default-language: Haskell98@@ -407,7 +417,7 @@ main-is: CarSim.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers, time, cairo+ build-depends: gtk3==0.14.3, base, transformers, time, cairo Executable gtk2hs-demo-progress default-language: Haskell98@@ -415,7 +425,7 @@ main-is: Progress.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers+ build-depends: gtk3==0.14.3, base, transformers Executable gtk2hs-demo-progressThreadedRTS default-language: Haskell98@@ -423,7 +433,7 @@ main-is: ProgressThreadedRTS.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers+ build-depends: gtk3==0.14.3, base, transformers ghc-options: -threaded Executable gtk2hs-demo-fastDraw@@ -432,7 +442,7 @@ main-is: FastDraw.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers, array, cairo+ build-depends: gtk3==0.14.3, base, transformers, array, cairo Executable gtk2hs-demo-fonts default-language: Haskell98@@ -440,7 +450,7 @@ main-is: Fonts.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base+ build-depends: gtk3==0.14.3, base Executable gtk2hs-demo-builder default-language: Haskell98@@ -448,7 +458,7 @@ main-is: GtkBuilderTest.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers+ build-depends: gtk3==0.14.3, base, transformers Executable gtk2hs-demo-helloworld default-language: Haskell98@@ -456,7 +466,7 @@ main-is: World.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers+ build-depends: gtk3==0.14.3, base, transformers Executable gtk2hs-demo-layout default-language: Haskell98@@ -464,7 +474,7 @@ main-is: Layout.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers, cairo, text+ build-depends: gtk3==0.14.3, base, transformers, cairo, text Executable gtk2hs-demo-menudemo default-language: Haskell98@@ -472,7 +482,7 @@ main-is: MenuDemo.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers, text+ build-depends: gtk3==0.14.3, base, transformers, text Executable gtk2hs-demo-combodemo default-language: Haskell98@@ -480,7 +490,7 @@ main-is: ComboDemo.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, text, base, transformers+ build-depends: gtk3==0.14.3, text, base, transformers Executable gtk2hs-demo-notebook default-language: Haskell98@@ -488,7 +498,7 @@ main-is: Notebook.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers, text+ build-depends: gtk3==0.14.3, base, transformers, text Executable gtk2hs-demo-statusIcon default-language: Haskell98@@ -496,7 +506,7 @@ main-is: StatusIcon.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers+ build-depends: gtk3==0.14.3, base, transformers Executable gtk2hs-demo-arabic default-language: Haskell98@@ -504,7 +514,7 @@ main-is: Arabic.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers, text+ build-depends: gtk3==0.14.3, base, transformers, text Executable gtk2hs-demo-overlay default-language: Haskell98@@ -512,4 +522,4 @@ main-is: Overlay.hs if !flag(build-demos) buildable: False- build-depends: gtk3==0.14.2, base, transformers+ build-depends: gtk3==0.14.3, base, transformers
hierarchy3.list view
@@ -37,6 +37,7 @@ GdkWindow as DrawWindow, gdk_window_get_type GdkGLPixmap if gtkglext GdkGLWindow if gtkglext+ GdkGLContext if gtk-3.16 GdkScreen GdkDisplay GdkVisual@@ -72,6 +73,7 @@ GtkContainer GtkToolPalette GtkToolItemGroup + GtkStack if gtk-3.10 WebKitWebView as WebView, webkit_web_view_get_type if webkit GtkBin GtkAlignment@@ -116,6 +118,7 @@ GtkSeparatorToolItem GtkMozEmbed if mozembed VteTerminal as Terminal if vte+ GtkStackSwitcher if gtk-3.10 GtkBox GtkButtonBox GtkHButtonBox@@ -149,6 +152,7 @@ GtkTreeView GtkCalendar GtkCellView + GtkGLArea if gtk-3.16 GtkDrawingArea GtkSpinner GtkEntry