diff --git a/Graphics/UI/Gtk.chs b/Graphics/UI/Gtk.chs --- a/Graphics/UI/Gtk.chs +++ b/Graphics/UI/Gtk.chs @@ -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 diff --git a/Graphics/UI/Gtk/Display/Spinner.chs b/Graphics/UI/Gtk/Display/Spinner.chs --- a/Graphics/UI/Gtk/Display/Spinner.chs +++ b/Graphics/UI/Gtk/Display/Spinner.chs @@ -37,6 +37,8 @@ -- * Types Spinner, SpinnerClass, + castToSpinner, gTypeSpinner, + toSpinner, -- * Constructors spinnerNew, diff --git a/Graphics/UI/Gtk/Display/Statusbar.chs b/Graphics/UI/Gtk/Display/Statusbar.chs --- a/Graphics/UI/Gtk/Display/Statusbar.chs +++ b/Graphics/UI/Gtk/Display/Statusbar.chs @@ -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 -------------------- diff --git a/Graphics/UI/Gtk/Gdk/GLContext.chs b/Graphics/UI/Gtk/Gdk/GLContext.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Gtk/Gdk/GLContext.chs @@ -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 diff --git a/Graphics/UI/Gtk/General/Enums.chs b/Graphics/UI/Gtk/General/Enums.chs --- a/Graphics/UI/Gtk/General/Enums.chs +++ b/Graphics/UI/Gtk/General/Enums.chs @@ -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 diff --git a/Graphics/UI/Gtk/Layout/Grid.chs b/Graphics/UI/Gtk/Layout/Grid.chs --- a/Graphics/UI/Gtk/Layout/Grid.chs +++ b/Graphics/UI/Gtk/Layout/Grid.chs @@ -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) diff --git a/Graphics/UI/Gtk/Layout/Stack.chs b/Graphics/UI/Gtk/Layout/Stack.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Gtk/Layout/Stack.chs @@ -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 diff --git a/Graphics/UI/Gtk/Layout/StackSwitcher.chs b/Graphics/UI/Gtk/Layout/StackSwitcher.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Gtk/Layout/StackSwitcher.chs @@ -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 diff --git a/Graphics/UI/Gtk/Misc/GLArea.chs b/Graphics/UI/Gtk/Misc/GLArea.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Gtk/Misc/GLArea.chs @@ -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 diff --git a/Graphics/UI/Gtk/ModelView/ListStore.hs b/Graphics/UI/Gtk/ModelView/ListStore.hs --- a/Graphics/UI/Gtk/ModelView/ListStore.hs +++ b/Graphics/UI/Gtk/ModelView/ListStore.hs @@ -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 diff --git a/Graphics/UI/Gtk/Types.chs b/Graphics/UI/Gtk/Types.chs --- a/Graphics/UI/Gtk/Types.chs +++ b/Graphics/UI/Gtk/Types.chs @@ -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 diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs deleted file mode 100644 --- a/Gtk2HsSetup.hs +++ /dev/null @@ -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) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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" diff --git a/SetupMain.hs b/SetupMain.hs deleted file mode 100644 --- a/SetupMain.hs +++ /dev/null @@ -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 - diff --git a/SetupWrapper.hs b/SetupWrapper.hs deleted file mode 100644 --- a/SetupWrapper.hs +++ /dev/null @@ -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 diff --git a/gtk3.cabal b/gtk3.cabal --- a/gtk3.cabal +++ b/gtk3.cabal @@ -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 diff --git a/hierarchy3.list b/hierarchy3.list --- a/hierarchy3.list +++ b/hierarchy3.list @@ -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