diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,2 @@ +Matthew Arsenault + diff --git a/C2HS.hs b/C2HS.hs new file mode 100644 --- /dev/null +++ b/C2HS.hs @@ -0,0 +1,220 @@ +-- C->Haskell Compiler: Marshalling library +-- +-- Copyright (c) [1999...2005] Manuel M T Chakravarty +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- 1. Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- 2. Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- 3. The name of the author may not be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +-- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +-- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN +-- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED +-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- +--- Description --------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- +-- This module provides the marshaling routines for Haskell files produced by +-- C->Haskell for binding to C library interfaces. It exports all of the +-- low-level FFI (language-independent plus the C-specific parts) together +-- with the C->HS-specific higher-level marshalling routines. +-- + +module C2HS ( + + -- * Re-export the language-independent component of the FFI + module Foreign, + + -- * Re-export the C language component of the FFI + module CForeign, + + -- * Composite marshalling functions + withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv, + peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum, + + -- * Conditional results using 'Maybe' + nothingIf, nothingIfNull, + + -- * Bit masks + combineBitMasks, containsBitMask, extractBitMasks, + + -- * Conversion between C and Haskell types + cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum +) where + + +import Foreign + hiding (Word) + -- Should also hide the Foreign.Marshal.Pool exports in + -- compilers that export them +import CForeign + +import Monad (when, liftM) + + +-- Composite marshalling functions +-- ------------------------------- + +-- Strings with explicit length +-- +withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n) +peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n) + +-- Marshalling of numerals +-- + +withIntConv :: (Storable b, Integral a, Integral b) + => a -> (Ptr b -> IO c) -> IO c +withIntConv = with . cIntConv + +withFloatConv :: (Storable b, RealFloat a, RealFloat b) + => a -> (Ptr b -> IO c) -> IO c +withFloatConv = with . cFloatConv + +peekIntConv :: (Storable a, Integral a, Integral b) + => Ptr a -> IO b +peekIntConv = liftM cIntConv . peek + +peekFloatConv :: (Storable a, RealFloat a, RealFloat b) + => Ptr a -> IO b +peekFloatConv = liftM cFloatConv . peek + +-- Passing Booleans by reference +-- + +withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b +withBool = with . fromBool + +peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool +peekBool = liftM toBool . peek + + +-- Passing enums by reference +-- + +withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c +withEnum = with . cFromEnum + +peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a +peekEnum = liftM cToEnum . peek + + +-- Storing of 'Maybe' values +-- ------------------------- + +instance Storable a => Storable (Maybe a) where + sizeOf _ = sizeOf (undefined :: Ptr ()) + alignment _ = alignment (undefined :: Ptr ()) + + peek p = do + ptr <- peek (castPtr p) + if ptr == nullPtr + then return Nothing + else liftM Just $ peek ptr + + poke p v = do + ptr <- case v of + Nothing -> return nullPtr + Just v' -> new v' + poke (castPtr p) ptr + + +-- Conditional results using 'Maybe' +-- --------------------------------- + +-- Wrap the result into a 'Maybe' type. +-- +-- * the predicate determines when the result is considered to be non-existing, +-- ie, it is represented by `Nothing' +-- +-- * the second argument allows to map a result wrapped into `Just' to some +-- other domain +-- +nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b +nothingIf p f x = if p x then Nothing else Just $ f x + +-- |Instance for special casing null pointers. +-- +nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b +nothingIfNull = nothingIf (== nullPtr) + + +-- Support for bit masks +-- --------------------- + +-- Given a list of enumeration values that represent bit masks, combine these +-- masks using bitwise disjunction. +-- +combineBitMasks :: (Enum a, Bits b) => [a] -> b +combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum) + +-- Tests whether the given bit mask is contained in the given bit pattern +-- (i.e., all bits set in the mask are also set in the pattern). +-- +containsBitMask :: (Bits a, Enum b) => a -> b -> Bool +bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm + in + bm' .&. bits == bm' + +-- |Given a bit pattern, yield all bit masks that it contains. +-- +-- * This does *not* attempt to compute a minimal set of bit masks that when +-- combined yield the bit pattern, instead all contained bit masks are +-- produced. +-- +extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b] +extractBitMasks bits = + [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm] + + +-- Conversion routines +-- ------------------- + +-- |Integral conversion +-- +cIntConv :: (Integral a, Integral b) => a -> b +cIntConv = fromIntegral + +-- |Floating conversion +-- +cFloatConv :: (RealFloat a, RealFloat b) => a -> b +cFloatConv = realToFrac +-- As this conversion by default goes via `Rational', it can be very slow... +{-# RULES + "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; + "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x + #-} + +-- |Obtain C value from Haskell 'Bool'. +-- +cFromBool :: Num a => Bool -> a +cFromBool = fromBool + +-- |Obtain Haskell 'Bool' from C value. +-- +cToBool :: Num a => a -> Bool +cToBool = toBool + +-- |Convert a C enumeration to Haskell. +-- +cToEnum :: (Integral i, Enum e) => i -> e +cToEnum = toEnum . cIntConv + +-- |Convert a Haskell enumeration to C. +-- +cFromEnum :: (Enum e, Integral i) => e -> i +cFromEnum = cIntConv . fromEnum diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/Graphics/UI/Clutter.hs b/Graphics/UI/Clutter.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter.hs @@ -0,0 +1,133 @@ +-- -*-haskell-*- +-- Clutter +-- +-- Author : Matthew Arsenault +-- +-- Created: 5 September 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. + +-- | This module gathers all publicly available functions from the Clutter binding. +-- +module Graphics.UI.Clutter ( +-- * Core Reference +-- ** Types and general stuff + module Graphics.UI.Clutter.StoreValue, + +-- ** Abstract classes and interfaces + module Graphics.UI.Clutter.Actor, + module Graphics.UI.Clutter.Container, + module Graphics.UI.Clutter.ChildMeta, + module Graphics.UI.Clutter.Media, + +-- ** Base actors + module Graphics.UI.Clutter.Rectangle, + module Graphics.UI.Clutter.Texture, + module Graphics.UI.Clutter.Clone, + module Graphics.UI.Clutter.Text, + module Graphics.UI.Clutter.CairoTexture, + +-- ** Container actors + module Graphics.UI.Clutter.Group, + module Graphics.UI.Clutter.Stage, + +-- * Animation Framework + +-- ** Base classes + module Graphics.UI.Clutter.Timeline, + module Graphics.UI.Clutter.Score, + module Graphics.UI.Clutter.Alpha, + module Graphics.UI.Clutter.Behaviour, + +-- ** Behaviours + module Graphics.UI.Clutter.BehaviourDepth, + module Graphics.UI.Clutter.BehaviourEllipse, + module Graphics.UI.Clutter.BehaviourOpacity, + module Graphics.UI.Clutter.BehaviourPath, + module Graphics.UI.Clutter.Path, + module Graphics.UI.Clutter.BehaviourRotate, + module Graphics.UI.Clutter.BehaviourScale, + +-- ** High Level API + module Graphics.UI.Clutter.Interval, + module Graphics.UI.Clutter.Animation, + module Graphics.UI.Clutter.Animatable, + +-- * Clutter Tools +-- ** General purpose API + module Graphics.UI.Clutter.Color, + module Graphics.UI.Clutter.BindingPool, + module Graphics.UI.Clutter.Event, + module Graphics.UI.Clutter.General, + module Graphics.UI.Clutter.Shader, + module Graphics.UI.Clutter.Units, + module Graphics.UI.Clutter.Utilities, +--module Graphics.UI.Clutter.Versioning, + +-- ** User interface definition + module Graphics.UI.Clutter.Script, + module Graphics.UI.Clutter.Scriptable, + +-- ** Generic list model + module Graphics.UI.Clutter.Model, + module Graphics.UI.Clutter.ModelIter, + module Graphics.UI.Clutter.ListModel, +-- * Backends + module Graphics.UI.Clutter.X11, +--module Graphics.UI.Clutter.GLX, +--module Graphics.UI.Clutter.Win32, +--module Graphics.UI.Clutter.EGL, +--module Graphics.UI.Clutter.EGLX + ) where + +import Graphics.UI.Clutter.Event +import Graphics.UI.Clutter.Stage +import Graphics.UI.Clutter.Color +import Graphics.UI.Clutter.Actor +import Graphics.UI.Clutter.General +import Graphics.UI.Clutter.Rectangle +import Graphics.UI.Clutter.Group +import Graphics.UI.Clutter.Container +import Graphics.UI.Clutter.Texture +import Graphics.UI.Clutter.Text +import Graphics.UI.Clutter.Animation +import Graphics.UI.Clutter.Animatable +import Graphics.UI.Clutter.Timeline +import Graphics.UI.Clutter.Score +import Graphics.UI.Clutter.StoreValue +import Graphics.UI.Clutter.Alpha +import Graphics.UI.Clutter.CairoTexture +import Graphics.UI.Clutter.Media +import Graphics.UI.Clutter.ChildMeta +import Graphics.UI.Clutter.Clone +import Graphics.UI.Clutter.Behaviour +import Graphics.UI.Clutter.BehaviourScale +import Graphics.UI.Clutter.BehaviourDepth +import Graphics.UI.Clutter.BehaviourEllipse +import Graphics.UI.Clutter.BehaviourOpacity +import Graphics.UI.Clutter.BehaviourRotate +import Graphics.UI.Clutter.BehaviourPath +import Graphics.UI.Clutter.Interval +import Graphics.UI.Clutter.Path +import Graphics.UI.Clutter.Shader +import Graphics.UI.Clutter.Model +import Graphics.UI.Clutter.ModelIter +import Graphics.UI.Clutter.Script +import Graphics.UI.Clutter.Units +import Graphics.UI.Clutter.Scriptable +import Graphics.UI.Clutter.BindingPool +import Graphics.UI.Clutter.X11 +import Graphics.UI.Clutter.Utilities +import Graphics.UI.Clutter.ListModel + + diff --git a/Graphics/UI/Clutter/Actor.chs b/Graphics/UI/Clutter/Actor.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Actor.chs @@ -0,0 +1,2706 @@ +-- -*-haskell-*- +-- Clutter Actor +-- +-- Author : Matthew Arsenault +-- +-- Created: 10 Sep 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} +{-# CFILES csrc/clutter-macros.c #-} + +#include +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.Actor ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Actor' +-- | +----'Group' +-- | +----'Rectangle' +-- | +----'Texture' +-- | +----'Clone' +-- | +----'Text' +-- @ + +-- * Types + Actor, + ActorClass, + ActorBox, + Gravity(..), + Vertex(..), + ActorFlags(..), + AllocationFlags(..), + GID, + Callback, + +-- * Methods, + actorIsRealized, + actorIsMapped, + actorIsVisible, + actorIsReactive, + actorSetFlags, + actorUnsetFlags, + actorGetFlags, + actorShow, + actorShowAll, + actorHide, + actorHideAll, + actorRealize, + actorUnrealize, + actorPaint, + actorQueueRedraw, + actorQueueRelayout, + actorDestroy, + + actorShouldPickPaint, + actorMap, + actorUnmap, + actorAllocate, + actorAllocatePreferredSize, + actorAllocateAvailableSize, + actorGetAllocationBox, + actorGetAllocationGeometry, + actorGetAllocationVertices, + + actorGetPreferredSize, + actorGetPreferredWidth, + actorGetPreferredHeight, + actorSetFixedPositionSet, + actorGetFixedPositionSet, + actorSetGeometry, + actorGetGeometry, + + actorSetSize, + actorGetSize, + + actorSetPosition, + actorGetPosition, + + actorSetWidth, + actorGetWidth, + actorSetHeight, + actorGetHeight, + actorSetX, + actorGetX, + + actorSetY, + actorGetY, + + actorMoveBy, + actorSetRotation, + actorSetZRotationFromGravity, + actorGetZRotationGravity, + actorGetRotation, + actorIsRotated, + actorSetOpacity, + actorGetOpacity, + actorSetName, + actorGetName, + actorGetGid, + + actorSetClip, + actorRemoveClip, + actorHasClip, + actorGetClip, + + actorSetParent, + actorGetParent, + + actorReparent, + actorUnparent, + actorRaise, + actorLower, + actorRaiseTop, + actorLowerBottom, + actorGetStage, + actorSetDepth, + actorGetDepth, + + actorSetScale, + actorSetScaleFull, + actorSetScaleWithGravity, + actorGetScale, + actorGetScaleCenter, + actorGetScaleGravity, + actorIsScaled, + actorApplyTransformToPoint, + actorTransformStagePoint, + actorApplyRelativeTransformToPoint, + actorGetTransformedPosition, + actorGetTransformedSize, + + actorGetPaintOpacity, + actorGetPaintVisibility, + actorGetAbsAllocationVertices, +--actorGetTransformationMatrix, + actorSetAnchorPoint, + actorGetAnchorPoint, + actorSetAnchorPointFromGravity, + actorGetAnchorPointGravity, + actorMoveAnchorPoint, + actorMoveAnchorPointFromGravity, + actorSetReactive, + actorGetReactive, + + actorSetShader, + actorGetShader, + +--actorSetShaderParam, + actorSetShaderParamFloat, + actorSetShaderParamInt, + actorGrabKeyFocus, + actorGetPangoContext, + actorCreatePangoContext, + actorCreatePangoLayout, + actorIsInClonePaint, + +--actorBoxNew, +--actorBoxCopy, +--actorBoxFree, +--actorBoxEqual, + actorBoxGetX, + actorBoxGetY, + actorBoxGetWidth, + actorBoxGetHeight, + actorBoxGetOrigin, + actorBoxGetSize, + actorBoxGetArea, + actorBoxContains, + actorBoxFromVertices, +--vertexNew, +--vertexCopy, +--vertexFree, +--vertexEqual + +-- * Attributes + actorAllocation, + actorAnchorGravity, + actorAnchorX, + actorAnchorY, + actorClip, + actorClipToAllocation, + actorDepth, + actorFixedPositionSet, + actorFixedX, + actorFixedY, +--actorHasClip, + actorHeight, + actorMapped, + actorMinHeight, + actorMinHeightSet, + actorMinWidth, + actorMinWidthSet, + actorName, + actorNaturalHeight, + actorNaturalHeightSet, + actorNaturalWidth, + actorNaturalWidthSet, + actorOpacity, + actorReactive, + actorRealized, + actorRequestMode, + actorRotationAngleX, + actorRotationAngleY, + actorRotationAngleZ, + actorRotationCenterX, + actorRotationCenterY, + actorRotationCenterZ, + actorRotationCenterZGravity, + actorScaleCenterX, + actorScaleCenterY, + actorScaleGravity, + actorScaleX, + actorScaleY, + actorShowOnSetParent, + actorVisible, + actorWidth, + actorX, + actorY, + +-- * Signals + onAllocationChanged, + afterAllocationChanged, + allocationChanged, + + onDestroy, + afterDestroy, + destroy, + + onHide, + afterHide, + hide, + + onKeyFocusIn, + afterKeyFocusIn, + keyFocusIn, + + onKeyFocusOut, + afterKeyFocusOut, + keyFocusOut, + + onPaint, + afterPaint, + paint, + + onParentSet, + afterParentSet, + parentSet, + + onPick, + afterPick, + pick, + + onQueueRedraw, + afterQueueRedraw, + queueRedraw, + + onRealize, + afterRealize, + realize, + + onShow, + afterShow, + show, + + onUnrealize, + afterUnrealize, + unrealize, + +-- * Events + buttonPressEvent, + buttonReleaseEvent, + keyPressEvent, + keyReleaseEvent, + capturedEvent, + enterEvent, + event, + leaveEvent, + motionEvent, + scrollEvent + + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import qualified Graphics.UI.Clutter.GTypes #} as CGT +{# import Graphics.UI.Clutter.Utility #} +{# import Graphics.UI.Clutter.Event #} +{# import Graphics.UI.Clutter.Signals #} +{# import Graphics.UI.Clutter.CustomSignals #} + +--FIXME: should I do something about clutter/prelude conflicts? +import Prelude hiding (show) + +import C2HS +import Foreign +import Foreign.Ptr +import Data.IORef +import System.Glib.GObject +import System.Glib.Attributes +import System.Glib.Properties +import System.Glib.Signals + +--TODO: Export pango from types so you don't need this +import Graphics.UI.Gtk.Types (PangoContext, PangoLayoutRaw, mkPangoLayoutRaw) +import Graphics.UI.Gtk.Pango.Types +import Graphics.UI.Gtk.Pango.Layout +import Graphics.UI.Gtk.Pango.Attributes +import Graphics.UI.Gtk.Pango.Enums (EllipsizeMode) + + +{# fun unsafe actor_is_mapped as ^ `(ActorClass actor)' => { withActorClass* `actor' } -> `Bool' #} +{# fun unsafe actor_is_realized as ^ `(ActorClass actor)' => { withActorClass* `actor' } -> `Bool' #} +{# fun unsafe actor_is_visible as ^ `(ActorClass actor)' => { withActorClass* `actor' } -> `Bool' #} +{# fun unsafe actor_is_reactive as ^ `(ActorClass actor)' => { withActorClass* `actor' } -> `Bool' #} + + +--FIXME: A lot of these need to be marked as safe, not unsafe for callbacks to work + +-- | Sets flags on self +-- +-- This function will emit notifications for the changed properties +-- +-- [@self@] an actor +-- +-- [@flags@] a list of flags to set +-- +-- * Since 1.0 +-- +{# fun unsafe actor_set_flags as ^ + `(ActorClass self)' => { withActorClass* `self', cFromFlags `[ActorFlags]' } -> `()' #} + +-- | Unset /flags/ on /self/ +-- +-- This function will emit notifications for the changed properties. +-- +-- * Since 1.0 +-- +{# fun unsafe actor_unset_flags as ^ + `(ActorClass self)' => { withActorClass* `self', cFromFlags `[ActorFlags]' } -> `()' #} + +-- | Retrieves the flags set on an actor +-- +-- [@self@] an actor +-- +-- [@Returns@] a list of set flags +-- +-- * Since 1.0 +-- +{# fun unsafe actor_get_flags as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `[ActorFlags]' cToFlags #} + +-- | Flags an actor to be displayed. An actor that isn't shown will not be rendered on the stage. +-- +-- Actors are visible by default. +-- +-- If this function is called on an actor without a parent, the +-- "show-on-set-parent" will be set to @True@ as a side effect. +-- +{# fun actor_show as ^ `(ActorClass self)' => { withActorClass* `self'} -> `()' #} + +-- | Calls actor'Show' on all children of an actor (if any). +-- +-- * Since 0.2 +-- +{# fun actor_show_all as ^ `(ActorClass self)' => { withActorClass* `self'} -> `()' #} + +-- | Flags an actor to be hidden. A hidden actor will not be rendered on the stage. +-- +-- Actors are visible by default. +-- +-- If this function is called on an actor without a parent, the +-- "show-on-set-parent" property will be set to @False@ as a +-- side-effect. +-- +{# fun actor_hide as ^ `(ActorClass self)' => { withActorClass* `self'} -> `()' #} + +-- | Calls 'actorHide' on all child actors (if any). +-- +-- * Since 0.2 +-- +{# fun actor_hide_all as ^ `(ActorClass self)' => { withActorClass* `self'} -> `()' #} + +-- | Creates any underlying graphics resources needed by the actor to be displayed. +-- +-- Realization means the actor is now tied to a specific rendering +-- context (that is, a specific toplevel stage). +-- +-- This function does nothing if the actor is already realized. +-- +-- Because a realized actor must have realized parent actors, calling +-- 'actorRealize' will also realize all parents of the actor. +-- +-- This function does not realize child actors, except in the special +-- case that realizing the stage, when the stage is visible, will +-- suddenly map (and thus realize) the children of the stage. +-- +{# fun actor_realize as ^ `(ActorClass self)' => { withActorClass* `self' } -> `()' #} + +-- | Frees up any underlying graphics resources needed by the actor to be displayed. +-- +-- Unrealization means the actor is now independent of any specific +-- rendering context (is not attached to a specific toplevel stage). +-- +-- Because mapped actors must be realized, actors may not be unrealized +-- if they are mapped. This function hides the actor to be sure it +-- isn't mapped, an application-visible side effect that you may not be +-- expecting. +-- +-- This function should not really be in the public API, because there +-- isn't a good reason to call it. ClutterActor will already unrealize +-- things for you when it's important to do so. +-- +{# fun actor_unrealize as ^ `(ActorClass self)' => { withActorClass* `self' } -> `()' #} + + +-- | Renders the actor to display. +-- +-- This function should not be called directly by applications. Call +-- 'actorQueueRedraw' to queue paints, instead. +-- +-- This function will emit the 'paint' signal. +-- +{# fun actor_paint as ^ `(ActorClass self)' => { withActorClass* `self' } -> `()' #} + +-- | Queues up a redraw of an actor and any children. The redraw +-- occurs once the main loop becomes idle (after the current batch +-- of events has been processed, roughly). +-- +-- Applications rarely need to call this, as redraws are handled +-- automatically by modification functions. +-- +-- This function will not do anything if self is not visible, or if +-- the actor is inside an invisible part of the scenegraph. +-- +-- Also be aware that painting is a NOP for actors with an opacity of 0 +-- +{# fun actor_queue_redraw as ^ `(ActorClass self)' => { withActorClass* `self' } -> `()' #} + +-- | Indicates that the actor's size request or other layout-affecting +-- properties may have changed. This function is used inside +-- 'Actor' subclass implementations, not by applications +-- directly. +-- +-- +-- Queueing a new layout automatically queues a redraw as well. +-- +-- * Since 0.8 +-- +{# fun actor_queue_relayout as ^ `(ActorClass self)' => { withActorClass* `self'} -> `()' #} + +-- | Destroys an actor. When an actor is destroyed, it will break any +-- references it holds to other objects. If the actor is inside a +-- container, the actor will be removed. +-- +-- When you destroy a container, its children will be destroyed as well. +-- +-- Note: you cannot destroy the 'Stage' returned by 'stageGetDefault'. +-- +{# fun actor_destroy as ^ `(ActorClass self)' => { withActorClass* `self'} -> `()' #} + +{- +-- | This function is used to emit an event on the main stage. You +-- should rarely need to use this function, except for synthetising +-- events. +-- +-- [@actor@] an actor +-- +-- [@event@] an Event +-- +-- [@capture@] @True@ if event in in capture phase, @False@ otherwise. +-- +-- [@Returns@] the return value from the signal emission: @True@ if +-- the actor handled the event, or @False@ if the event was not handled +-- +-- * Since 0.6 +-- +{# fun actor_event as ^ `(ActorClass self)' => { withActorClass* `self', + `Event', + `Bool' } -> `()' #} +-} + +-- | Should be called inside the implementation of the "pick" virtual +-- function in order to check whether the actor should paint itself +-- in pick mode or not. +-- +-- This function should never be called directly by applications. +-- +-- [@self@] An Actor +-- +-- [@Returns@] @True@ if the actor should paint its silhouette, @False@ otherwise +-- +{# fun unsafe actor_should_pick_paint as ^ `(ActorClass self)' => { withActorClass* `self'} -> `Bool' #} + +-- | Sets the 'ActorMapped' flag on the actor and possibly maps +-- and realizes its children if they are visible. Does nothing if +-- the actor is not visible. +-- +-- Calling this is allowed in only one case: you are implementing the +-- "map" virtual function in an actor and you need to map the children +-- of that actor. It is not necessary to call this if you implement +-- ClutterContainer because the default implementation will +-- automatically map children of containers. +-- +-- When overriding map, it is mandatory to chain up to the parent implementation. +-- +-- * Since 1.0 +-- +{# fun unsafe actor_map as ^ `(ActorClass self)' => { withActorClass* `self' } -> `()' #} + + +-- | Unsets the 'ActorMapped' flag on the actor and possibly +-- unmaps its children if they were mapped. +-- +-- Calling this is allowed in only one case: you are implementing +-- the "unmap" virtual function in an actor and you need to unmap +-- the children of that actor. It is not necessary to call this if +-- you implement ClutterContainer because the default implementation +-- will automatically unmap children of containers. +-- +-- When overriding unmap, it is mandatory to chain up to the parent implementation. +-- +-- * Since 1.0 +-- +{# fun unsafe actor_unmap as ^ `(ActorClass self)' => { withActorClass* `self' } -> `()' #} + + +-- | Called by the parent of an actor to assign the actor its +-- size. Should never be called by applications (except when +-- implementing a container or layout manager). +-- +-- Actors can know from their allocation box whether they have moved +-- with respect to their parent actor. The flags parameter describes +-- additional information about the allocation, for instance whether +-- the parent has moved with respect to the stage, for example +-- because a grandparent's origin has moved. +-- +-- [@self@] An Actor +-- +-- [@box@]: new allocation of the actor, in parent-relative coordinates +-- +-- [@flags@] list of flags that control the allocation +-- +-- * Since 0.8 +-- +{# fun unsafe actor_allocate as ^ + `(ActorClass self)' => { withActorClass* `self', + withActorBox* `ActorBox', + cFromFlags `[AllocationFlags]' + } -> `()' #} + + +-- | Allocates the natural size of self. +-- +-- This function is a utility call for ClutterActor implementations +-- that allocates the actor's preferred natural size. It can be used +-- by fixed layout managers (like 'Group' or so called 'composite +-- actors') inside the ClutterActor::allocate implementation to give +-- each child exactly how much space it requires. +-- +-- This function is not meant to be used by applications. It is also +-- not meant to be used outside the implementation of the +-- ClutterActor::allocate virtual function. +-- +-- [@self@] an Actor +-- +-- [@flags@] flags controlling the allocation +-- +-- * Since 0.8 +-- +{# fun unsafe actor_allocate_preferred_size as ^ + `(ActorClass self)' => { withActorClass* `self', + cFromFlags `[AllocationFlags]' + } -> `()' #} + +--TODO: Redo the example function +-- | Allocates self taking into account the Actor's preferred +-- size, but limiting it to the maximum available width and height +-- provided. +-- +-- This function will do the right thing when dealing with the actor's request mode. +-- +-- This function can be used by fluid layout managers to allocate an +-- actor's preferred size without making it bigger than the area +-- available for the container. +-- +-- [@self@] an Actor +-- +-- [@x@] the actor's X coordinate +-- +-- [@y@] the actor's Y coordinate +-- +-- [@available_width@] the maximum available width, or -1 to use the actor's natural width +-- +-- [@available_height@] the maximum available height, or -1 to use the actor's natural height +-- +-- [@flags@] list of flags controlling the allocation +-- +-- * Since 1.0 +-- +{# fun unsafe actor_allocate_available_size as ^ + `(ActorClass self)' => { withActorClass* `self', + `Float', + `Float', + `Float', + `Float', + cFromFlags `[AllocationFlags]' + } -> `()' #} + + +-- | Gets the layout box an actor has been assigned. The allocation +-- can only be assumed valid inside a paint() method; anywhere else, +-- it may be out-of-date. +-- +-- An allocation does not incorporate the actor's scale or anchor +-- point; those transformations do not affect layout, only rendering. +-- +-- Note +-- +-- Do not call any of the actorGetAllocation* family of +-- functions inside the implementation of the 'getPreferredWidth' or +-- 'getPreferredHeight' virtual functions. +-- +-- [@self@] An Actor +-- +-- [@box@] the function fills this in with the actor's allocation. out. +-- +-- * Since 0.8 +-- +{# fun unsafe actor_get_allocation_box as ^ + `(ActorClass self)' => { withActorClass* `self', + alloca- `ActorBox' peek* } -> `()' #} + + +-- | Gets the layout box an actor has been assigned. The allocation +-- can only be assumed valid inside a paint() method; anywhere else, +-- it may be out-of-date. +-- +-- An allocation does not incorporate the actor's scale or anchor +-- point; those transformations do not affect layout, only rendering. +-- +-- The returned rectangle is in pixels. +-- +-- [@self@] An Actor +-- +-- [@Returns@] allocation geometry in pixels +-- +-- * Since 0.8 +-- +{# fun unsafe actor_get_allocation_geometry as ^ + `(ActorClass self)' => { withActorClass* `self', + alloca- `Geometry' peek* + } -> `()' #} + + +-- | Calculates the transformed coordinates of the four corners of the +-- actor in the plane of ancestor. The returned vertices relate to +-- the 'ActorBox' coordinates as follows: +-- +-- * [(x1, y1), (x2, y1), (x1, y2), (x2, y2)] +-- +-- If ancestor is NULL the ancestor will be the 'Stage'. In this +-- case, the coordinates returned will be the coordinates on the stage +-- before the projection is applied. This is different from the +-- behaviour of 'actorGetAbsAllocationVertices'. +-- +-- * Since 0.6 +-- +actorGetAllocationVertices :: (ActorClass self, ActorClass ancestor) => + self + -> ancestor + -> IO [Vertex] +actorGetAllocationVertices self ancestor = let func = {# call unsafe actor_get_allocation_vertices #} + in + withActorClass self $ \selfPtr -> + withActorClass ancestor $ \ancPtr -> + allocaArray 4 $ \vsPtr -> do + func selfPtr ancPtr vsPtr + peekArray 4 vsPtr + + + +-- | Computes the preferred minimum and natural size of an actor, +-- taking into account the actor's geometry management (either +-- height-for-width or width-for-height). +-- +-- The width and height used to compute the preferred height and +-- preferred width are the actor's natural ones. +-- +-- If you need to control the height for the preferred width, or the +-- width for the preferred height, you should use +-- 'actorGetPreferredWidth' and +-- 'actorGetPreferredHeight', and check the actor's +-- preferred geometry management using the "request-mode" property. +-- +-- * Since 0.8 +-- +{# fun unsafe actor_get_preferred_size as ^ + `(ActorClass self)' => { withActorClass* `self', + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv* + } -> `()' #} + +-- | Computes the requested minimum and natural widths for an actor, +-- optionally depending on the specified height, or if they are +-- already computed, returns the cached values. +-- +-- An actor may not get its request - depending on the layout manager that's in effect. +-- +-- A request should not incorporate the actor's scale or anchor point; +-- those transformations do not affect layout, only rendering. +-- +-- [@self@] An Actor +-- +-- [@for_height@] available height when computing the preferred width, +-- or a negative value to indicate that no height is defined +-- +-- [@min_width_p@] +-- +-- [@natural_width_p@] +-- +-- * Since 0.8 +-- +{# fun unsafe actor_get_preferred_width as ^ + `(ActorClass self)' => { withActorClass* `self', + `Float', + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv* + } -> `()' #} + + +-- | Computes the requested minimum and natural heights for an actor, +-- or if they are already computed, returns the cached values. +-- +-- An actor may not get its request - depending on the layout manager +-- that's in effect. +-- +-- A request should not incorporate the actor's scale or anchor point; +-- those transformations do not affect layout, only rendering. +-- +-- [@self@] An Actor +-- +-- [@for_width@] available width to assume in computing desired +-- height, or a negative value to indicate that no width is defined +-- +-- [@min_height_p@] +-- +-- [@ natural_height_p@] +-- +-- * Since 0.8 +-- +{# fun unsafe actor_get_preferred_height as ^ + `(ActorClass self)' => { withActorClass* `self', + `Float', + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv* + } -> `()' #} + +-- | Sets whether an actor has a fixed position set (and will thus be +-- unaffected by any layout manager). +-- +-- [@self@] An Actor +-- +-- [@is_set@] whether to use fixed position +-- +-- * Since 0.8 +-- +{# fun unsafe actor_set_fixed_position_set as ^ + `(ActorClass self)' => { withActorClass* `self', `Bool'} -> `()' #} + +-- | Checks whether an actor has a fixed position set (and will thus +-- be unaffected by any layout manager). +-- +-- [@self@] An Actor +-- +-- [@Returns@] @True@ if the fixed position is set on the actor +-- +-- * Since 0.8 +-- +{# fun unsafe actor_get_fixed_position_set as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `Bool' #} + +-- | Gets the size and position of an actor relative to its parent +-- actor. This is the same as calling 'actorGetPosition' +-- and 'actorGetSize'. It tries to \"do what you mean\" and +-- get the requested size and position if the actor's allocation is +-- invalid. +-- +{# fun unsafe actor_get_geometry as ^ + `(ActorClass self)' => { withActorClass* `self', alloca- `Geometry' peek* } -> `()' #} + +-- | Sets the actor's fixed position and forces its minimum and +-- natural size, in pixels. This means the untransformed actor | +-- will have the given geometry. This is the same as calling | +-- 'actorSetPosition' and 'actorSetSize'. +-- +{# fun unsafe actor_set_geometry as ^ + `(ActorClass self)' => { withActorClass* `self', withGeometry* `Geometry' } -> `()' #} + +-- | Sets the actor's size request in pixels. This overrides any +-- \"normal\" size request the actor would have. For example a text +-- actor might normally request the size of the text; this function +-- would force a specific size instead. +-- +-- If width and/or height are -1 the actor will use its \"normal\" size +-- request instead of overriding it, i.e. you can \"unset\" the size +-- with -1. +-- +-- This function sets or unsets both the minimum and natural size. +-- +-- [@self@] An Actor +-- +-- [@width@] New width of actor in pixels, or -1 +-- +-- [@height@] New height of actor in pixels, or -1 +-- +{# fun unsafe actor_set_size as ^ + `(ActorClass self)' => { withActorClass* `self', `Float', `Float' } -> `()' #} + +-- | This function tries to \"do what you mean\" and return the size an +-- actor will have. If the actor has a valid allocation, the +-- allocation will be returned; otherwise, the actors natural size +-- request will be returned. +-- +-- If you care whether you get the request vs. the allocation, you +-- should probably call a different function like +-- 'actorGetAllocationBox' or 'actorGetPreferredWidth'. +-- +-- * Since 0.2 +-- +{# fun unsafe actor_get_size as ^ + `(ActorClass self)' => { withActorClass* `self', + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv*} -> `()' #} + + +-- | Sets the actor's fixed position in pixels relative to any parent actor. +-- +-- If a layout manager is in use, this position will override the +-- layout manager and force a fixed position. +-- +-- [@self@] An Actor +-- +-- [@x@] New left position of actor in pixels. +-- +-- [@y@] New top position of actor in pixels. +-- +{# fun unsafe actor_set_position as ^ + `(ActorClass self)' => { withActorClass* `self', `Float', `Float' } -> `()' #} + +-- | This function tries to \"do what you mean\" and tell you where the +-- actor is, prior to any transformations. Retrieves the fixed +-- position of an actor in pixels, if one has been set; otherwise, +-- if the allocation is valid, returns the actor's allocated +-- position; otherwise, returns 0,0. +-- +-- The returned position is in pixels. +-- +-- * Since 0.6 +-- +{# fun unsafe actor_get_position as ^ + `(ActorClass self)' => { withActorClass* `self', alloca- `Float' peekFloatConv*, alloca- `Float' peekFloatConv*} -> `()' #} + + +-- | Forces a width on an actor, causing the actor's preferred width +-- and height (if any) to be ignored. +-- +-- This function sets both the minimum and natural size of the actor. +-- +-- [@self@] An Actor +-- +-- [@width@] Requested new width for the actor, in pixels +-- +-- * Since 0.2 +-- +{# fun unsafe actor_set_width as ^ + `(ActorClass self)' => { withActorClass* `self', `Float'} -> `()' #} + + +-- | Retrieves the width of an Actor. +-- +-- If the actor has a valid allocation, this function will return the +-- width of the allocated area given to the actor. +-- +-- If the actor does not have a valid allocation, this function will +-- return the actor's natural width, that is the preferred width of +-- the actor. +-- +-- If you care whether you get the preferred width or the width that +-- has been assigned to the actor, you should probably call a +-- different function like 'actorGetAllocationBox' to retrieve the +-- allocated size or 'actorGetPreferredWidth' to retrieve the +-- preferred width. +-- +-- If an actor has a fixed width, for instance a width that has been +-- assigned using clutter_actor_set_width(), the width returned will +-- be the same value. +-- +-- [@self@] An Actor +-- +-- [@Returns@] the width of the actor, in pixels +-- +{# fun unsafe actor_get_width as ^ + `(ActorClass self)' => { withActorClass* `self'} -> `Float' #} + +-- | Forces a height on an actor, causing the actor's preferred width +-- and height (if any) to be ignored. +-- +-- This function sets both the minimum and natural size of the actor. +-- +-- [@self@] An Actor +-- +-- [@height@] Requested new height for the actor, in pixels +-- +-- * Since 0.2 +-- +{# fun unsafe actor_set_height as ^ + `(ActorClass self)' => { withActorClass* `self', `Float'} -> `()' #} + + +-- | Retrieves the height of a ClutterActor. +-- +-- If the actor has a valid allocation, this function will return the +-- height of the allocated area given to the actor. +-- +-- If the actor does not have a valid allocation, this function will +-- return the actor's natural height, that is the preferred height of +-- the actor. +-- +-- If you care whether you get the preferred height or the height that +-- has been assigned to the actor, you should probably call a +-- different function like clutter_actor_get_allocation_box() to +-- retrieve the allocated size or clutter_actor_get_preferred_height() +-- to retrieve the preferred height. +-- +-- If an actor has a fixed height, for instance a height that has been +-- assigned using 'actorSetHeight', the height returned will be the +-- same value. +-- +-- [@self@] An Actor +-- +-- [@Returns@] the height of the actor, in pixels +-- +{# fun unsafe actor_get_height as ^ + `(ActorClass self)' => { withActorClass* `self'} -> `Float' #} + +-- | Sets the actor's X coordinate, relative to its parent, in pixels. +-- +-- Overrides any layout manager and forces a fixed position for the actor. +-- +-- [@self@] an Actor +-- +-- [@x@] the actor's position on the X axis +-- +-- * Since 0.6 +-- +{# fun unsafe actor_set_x as ^ + `(ActorClass self)' => { withActorClass* `self', `Float'} -> `()' #} + + +-- | Retrieves the X coordinate of an Actor. +-- +-- This function tries to \"do what you mean\", by returning the correct +-- value depending on the actor's state. +-- +-- If the actor has a valid allocation, this function will return the +-- X coordinate of the origin of the allocation box. +-- +-- If the actor has any fixed coordinate set using 'actorSetX', +-- 'actorSetPosition' or 'actorSetGeometry', this function will return +-- that coordinate. +-- +-- If both the allocation and a fixed position are missing, this +-- function will return 0. +-- +-- [@self@] An Actor +-- +-- [@Returns@] the X coordinate, in pixels, ignoring any +-- transformation (i.e. scaling, rotation) +-- +{# fun unsafe actor_get_x as ^ + `(ActorClass self)' => { withActorClass* `self'} -> `Float' #} + + +-- | Sets the actor's Y coordinate, relative to its parent, in +-- pixels. +-- +-- Overrides any layout manager and forces a fixed position for the actor. +-- +-- [@self@] an Actor +-- +-- [@y@] the actor's position on the Y axis +-- +-- * Since 0.6 +-- +{# fun unsafe actor_set_y as ^ + `(ActorClass self)' => { withActorClass* `self', `Float'} -> `()' #} + +-- | Retrieves the Y coordinate of an Actor. +-- +-- This function tries to \"do what you mean\", by returning the correct +-- value depending on the actor's state. +-- +-- If the actor has a valid allocation, this function will return the +-- Y coordinate of the origin of the allocation box. +-- +-- If the actor has any fixed coordinate set using 'actorSetY', +-- 'actorSetPosition' or 'actorSetGeometry', this function will return +-- that coordinate. +-- +-- If both the allocation and a fixed position are missing, this function will return 0. +-- +-- [@self@] An Actor +-- +-- [@Returns@] the Y coordinate, in pixels, ignoring any +-- transformation (i.e. scaling, rotation) +-- +{# fun unsafe actor_get_y as ^ + `(ActorClass self)' => { withActorClass* `self'} -> `Float' #} + + +-- | Moves an actor by the specified distance relative to its current +-- position in pixels. +-- +-- This function modifies the fixed position of an actor and thus +-- removes it from any layout management. Another way to move an actor +-- is with an anchor point, see clutter_actor_set_anchor_point(). +-- +-- [@self@] An Actor +-- +-- [@dx@] Distance to move Actor on X axis. +-- +-- [@dy@] Distance to move Actor on Y axis. +-- +-- * Since 0.2 +-- +{# fun unsafe actor_move_by as ^ + `(ActorClass self)' => { withActorClass* `self', `Float', `Float' } -> `()' #} + +-- | The rotation center coordinates used depend on the value of axis: +-- +-- * 'XAxis' requires y and z +-- +-- * 'YAxis' requires x and z +-- +-- * 'ZAxis' requires x and y +-- +-- The rotation coordinates are relative to the anchor point of the +-- actor, set using 'actorSetAnchorPoint'. If no anchor +-- point is set, the upper left corner is assumed as the origin. +-- +-- [@self@] an Actor +-- +-- [@axis@] the axis of rotation +-- +-- [@angle@] the angle of rotation +-- +-- [@x@] X coordinate of the rotation center +-- +-- [@y@] Y coordinate of the rotation center +-- +-- [@z@] Z coordinate of the rotation center +-- +-- * Since 0.8 +-- +{# fun unsafe actor_set_rotation as ^ + `(ActorClass self)' => { withActorClass* `self', + cFromEnum `RotateAxis', + `Double', + `Float', + `Float', + `Float' } -> `()' #} + + +-- | Sets the rotation angle of self around the Z axis using the +-- | center point specified as a compass point. For example to rotate +-- | such that the center of the actor remains static you can use +-- | 'GravityCenter'. If the actor changes size the center +-- | point will move accordingly. +-- +-- [@self@] an Actor +-- +-- [@angle@] the angle of rotation +-- +-- [@gravity@] the center point of the rotation +-- +-- * Since 1.0 +-- +{# fun unsafe actor_set_z_rotation_from_gravity as ^ + `(ActorClass self)' => { withActorClass* `self', `Double', cFromEnum `Gravity' } -> `()' #} + +-- TODO: Return something else, such as (angle, (x,y,z)) or anything not (angle,x,y,z)? +-- | Retrieves the angle and center of rotation on the given axis, set +-- using 'actorSetRotation'. +-- +-- [@self@] an Actor +-- +-- [@axis@] the axis of rotation +-- +-- [@Return@] (θ, X,Y,Z) the angle of rotation and X, Y, Z +-- coordinates of the center of rotation +-- +-- * Since 0.8 +-- +{# fun unsafe actor_get_rotation as ^ + `(ActorClass self)' => { withActorClass* `self', + cFromEnum `RotateAxis', + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv*} -> `Double' #} + + +-- | Retrieves the center for the rotation around the Z axis as a +-- compass direction. If the center was specified in pixels or units +-- this will return 'GravityNone'. +-- +-- [@self@] An Actor +-- +-- [@Returns@] the Z rotation center +-- +-- * Since 1.0 +-- +{# fun unsafe actor_get_z_rotation_gravity as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `Gravity' cToEnum #} + +-- | Checks whether any rotation is applied to the actor. +-- +-- [@self@] an Actor +-- +-- [@Returns@] @True@ if the actor is rotated. +-- +-- * Since 0.6 +-- +{# fun unsafe actor_is_rotated as ^ `(ActorClass self)' => { withActorClass* `self' } -> `Bool' #} + +-- | Sets the actor's opacity, with zero being completely transparent +-- and 255 (0xff) being fully opaque. +-- +-- [@self@] An Actor +-- +-- [@opacity@] New opacity value for the actor +-- +{# fun unsafe actor_set_opacity as ^ + `(ActorClass self)' => { withActorClass* `self', `Word8' } -> `()' #} + +-- | Retrieves the opacity value of an actor, as set by 'actorSetOpacity'. +-- +-- For retrieving the absolute opacity of the actor inside a paint +-- virtual function, see actorGetPaintOpacity'. +-- +-- [@self@] an Actor +-- +-- [@Returns@] the opacity of the actor +-- +{# fun unsafe actor_get_opacity as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `Word8' #} + +--CHECKME: setname, Bother passing in maybe, or just use String? +--CHECKME: OK to pass null? +-- | Sets the given name to self. The name can be used to identify an Actor. +-- +-- [@self@] An Actor +-- +-- [@name@] Textual tag to apply to actor +-- +{# fun unsafe actor_set_name as ^ + `(ActorClass self)' => { withActorClass* `self', withMaybeString* `Maybe String' } -> `()' #} + +-- | Retrieves the name of self. +-- +-- [@self@] An Actor +-- +-- [@Returns@] @Just@ the name of the actor, or @Nothing@ +-- +{# fun unsafe actor_get_name as ^ `(ActorClass self)' => + { withActorClass* `self' } -> `Maybe String' maybeString* #} + +-- | Retrieves the unique id for self. +-- +-- [@self@] An Actor +-- +-- [@Returns@] Globally unique value for this object instance. +-- +-- Since 0.6 +-- +{# fun unsafe actor_get_gid as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `GID' cIntConv #} + +-- | Sets clip area for self. The clip area is always computed from the +-- upper left corner of the actor, even if the anchor point is set +-- otherwise. +-- +-- [@self@] An Actor +-- +-- [@xoff@] X offset of the clip rectangle +-- +-- [@yoff@] Y offset of the clip rectangle +-- +-- [@width@] Width of the clip rectangle +-- +-- [@height@] Height of the clip rectangle +-- +-- * Since 0.6 +-- +{# fun unsafe actor_set_clip as ^ + `(ActorClass self)' => { withActorClass* `self', `Float', `Float', `Float', `Float' } -> `()' #} + + +-- | Gets the clip area for self, if any is set +-- +-- [@self@] an Actor +-- +-- [@Returns@] (xoff, yoff, width, height) +-- +-- * Since 0.6 +-- +{# fun unsafe actor_get_clip as ^ + `(ActorClass self)' => { withActorClass* `self', + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv* } -> `()' #} + +-- | Determines whether the actor has a clip area set or not. +-- +-- [@self@] an Actor +-- +-- [@Returns@] @True@ if the actor has a clip area set. +-- +-- * Since 0.1.1 +-- +{# fun unsafe actor_has_clip as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `Bool' #} + +-- | Removes clip area from self. +{# fun unsafe actor_remove_clip as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `()' #} + +-- | Sets the parent of self to parent. The opposite function is +-- 'actorUnparent'. +-- +-- This function should not be used by applications, but by custom container actor subclasses. +-- +-- [@self@] An Actor +-- +-- [@parent@] A new Actor parent +-- +{# fun unsafe actor_set_parent as ^ + `(ActorClass child, ActorClass parent)' => { withActorClass* `child', withActorClass* `parent' } -> `()' #} + +-- | Retrieves the parent of self. +{# fun unsafe actor_get_parent as ^ + `(ActorClass child)' => { withActorClass* `child' } -> `Actor' newActor* #} + +-- | Removes the parent of self. +-- +-- This function should not be used in applications. It should be +-- called by implementations of container actors, to dissociate a +-- child from the container. +-- +-- [@self@] an Actor +-- +-- * Since 0.1.1 +-- +{# fun unsafe actor_unparent as ^ + `(ActorClass child)' => { withActorClass* `child' } -> `()' #} + + +-- | This function resets the parent actor of self. It is logically +-- equivalent to calling 'actorUnparent' and 'actorSetParent', but +-- more efficiently implemented, ensures the child is not finalized +-- when unparented, and emits the parent-set signal only one time. +-- +-- [@self@] an Actor +-- +-- [@new_parent@] the new Actor parent +-- +-- * Since 0.2 +-- +{# fun unsafe actor_reparent as ^ + `(ActorClass child, ActorClass newparent)' => { withActorClass* `child', withActorClass* `newparent' } -> `()' #} + + +-- | Puts self above below. +-- +-- Both actors must have the same parent. +-- +-- This function is the equivalent of 'containerRaiseChild'. +-- +{# fun unsafe actor_raise as ^ + `(ActorClass self, ActorClass below)' => { withActorClass* `self', withActorClass* `below' } -> `()' #} + +-- | Puts self below above. +-- +-- Both actors must have the same parent. +-- +-- This function is the equivalent of 'containerLowerChild'. +-- +{# fun unsafe actor_lower as ^ + `(ActorClass self, ActorClass below)' => { withActorClass* `self', withActorClass* `below' } -> `()' #} + +-- | Raises self to the top. +-- +-- This function calls 'actorRaise' internally. +-- +{# fun unsafe actor_raise_top as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `()' #} + +-- | Lowers self to the bottom. +-- +-- This function calls 'actorLower' internally. +-- +{# fun unsafe actor_lower_bottom as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `()' #} + + +-- | Retrieves the Stage where an actor is contained. +-- +-- [@actor@] an Actor +-- +-- [@Returns@] +-- +-- the @Just@ stage containing the actor, or @Nothing@. +-- +-- * Since 0.8 +-- +{# fun unsafe actor_get_stage as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `Maybe Stage' maybeNewStage* #} + + +-- | Retrieves the depth of /self/. +-- +-- [@self@] an Actor +-- +-- [@Returns@] the depth of the actor +-- +{# fun unsafe actor_get_depth as ^ + `(ActorClass self)' => { withActorClass* `self'} -> `Float' #} + +-- | Sets the Z coordinate of self to depth. +-- +-- The unit used by depth is dependant on the perspective setup. See +-- also 'stageSetPerspective'. +-- +-- [@self@] an Actor +-- +-- [@depth@] Z co-ord +-- +{# fun unsafe actor_set_depth as ^ + `(ActorClass self)' => { withActorClass* `self', `Float'} -> `()' #} + +-- | Scales an actor with the given factors. The scaling is relative +-- to the scale center and the anchor point. The scale center is +-- unchanged by this function and defaults to 0,0. +-- +-- [@self@] An Actor +-- +-- [@scale_x@] factor to scale actor by horizontally. +-- +-- [@scale_y@] factor to scale actor by vertically. +-- +-- * Since 0.2 +-- +{# fun unsafe actor_set_scale as ^ + `(ActorClass self)' => { withActorClass* `self', `Double', `Double'} -> `()' #} + +-- | Scales an actor with the given factors around the given center +-- point. The center point is specified in pixels relative to the +-- anchor point (usually the top left corner of the actor). +-- +-- [@self@] An Actor +-- +-- [@scale_x@] factor to scale actor by horizontally. +-- +-- [@scale_y@] factor to scale actor by vertically. +-- +-- [@center_x@] X coordinate of the center of the scale. +-- +-- [@center_y@] Y coordinate of the center of the scale +-- +-- * Since 1.0 +-- +{# fun unsafe actor_set_scale_full as ^ + `(ActorClass self)' => { withActorClass* `self', `Double', `Double', `Float', `Float' } -> `()' #} + +-- | Scales an actor with the given factors around the given center +-- point. The center point is specified as one of the compass +-- directions in 'Gravity'. For example, setting it to north will +-- cause the top of the actor to remain unchanged and the rest of the +-- actor to expand left, right and downwards. +-- +-- [@self@] An Actor +-- +-- [@scale_x@] factor to scale actor by horizontally. +-- +-- [@scale_y@] factor to scale actor by vertically. +-- +-- [@gravity@] the location of the scale center expressed as a compass direction. +-- +-- * Since 1.0 +-- +{# fun unsafe actor_set_scale_with_gravity as ^ + `(ActorClass self)' => { withActorClass* `self', `Double', `Double', cFromEnum `Gravity'} -> `()' #} + +-- | Retrieves an actors scale factors. +-- +-- * Since 0.2 +-- +{# fun unsafe actor_get_scale as ^ + `(ActorClass self)' => { withActorClass* `self', + alloca- `Double' peekFloatConv*, + alloca- `Double' peekFloatConv* } -> `()' #} + + +-- | Retrieves the scale center coordinate in pixels relative to the top +-- left corner of the actor. If the scale center was specified using a +-- 'Gravity' this will calculate the pixel offset using the +-- current size of the actor. +-- +-- [@self@] an Actor +-- +-- [@Returns@] (center_x, center_y) +-- +-- * Since 0.2 +-- +{# fun unsafe actor_get_scale_center as ^ + `(ActorClass self)' => { withActorClass* `self', + alloca- `Double' peekFloatConv*, + alloca- `Double' peekFloatConv* } -> `()' #} + +-- | Retrieves the scale center as a compass direction. If the scale +-- center was specified in pixels or units this will return +-- 'GravityNone'. +-- +-- [@self@] An Actor +-- +-- [@Returns@] the scale gravity +-- +-- * Since 1.0 +-- +{# fun unsafe actor_get_scale_gravity as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `Gravity' cToEnum #} + +-- | Checks whether the actor is scaled in either dimension. +-- +-- [@self@] an Actor +-- +-- [@Returns@] @True@ if the actor is scaled. +-- +-- * Since 0.6 +-- +{# fun unsafe actor_is_scaled as ^ + `(ActorClass self)' => { withActorClass* `self'} -> `Bool' #} + +-- | Transforms point in coordinates relative to the actor into +-- screen-relative coordinates with the current actor transformation +-- (i.e. scale, rotation, etc) +-- +-- [@self@] An Actor +-- +-- [@point@] A point as 'Vertex' +-- +-- [@Returns@] The translated 'Vertex' +-- +-- * Since 0.4 +-- +{# fun unsafe actor_apply_transform_to_point as ^ + `(ActorClass self)' => { withActorClass* `self', + withVertex* `Vertex', + alloca- `Vertex' peek* + } -> `()' #} + + +--CHECKME: unsafe? + +-- | This function translates screen coordinates (x, y) to coordinates +-- relative to the actor. For example, it can be used to translate +-- screen events from global screen coordinates into actor-local +-- coordinates. +-- +-- The conversion can fail, notably if the transform stack results in +-- the actor being projected on the screen as a mere line. +-- +-- The conversion should not be expected to be pixel-perfect due to +-- the nature of the operation. In general the error grows when the +-- skewing of the actor rectangle on screen increases. +-- +-- Note: This function is fairly computationally intensive. +-- +-- Note: This function only works when the allocation is up-to-date, +-- i.e. inside of paint() +-- +-- [@self@] An Actor +-- +-- [@x@] x screen coordinate of the point to unproject. +-- +-- [@y@] y screen coordinate of the point to unproject. +-- +-- [@Returns@] (@True@ if conversion was successful, unprojected x +-- coordinance, unprojected y coordinance) +-- +-- * Since 0.6 +-- +{# fun unsafe actor_transform_stage_point as ^ + `(ActorClass a)' => { withActorClass* `a', + `Float', + `Float', + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv* } -> + `Bool' #} + + + + +-- | Transforms point in coordinates relative to the actor into +-- ancestor-relative coordinates using the relevant transform stack +-- (i.e. scale, rotation, etc). +-- +-- If ancestor is @Nothing@ the ancestor will be the Stage. In this case, +-- the coordinates returned will be the coordinates on the stage +-- before the projection is applied. This is different from the +-- behaviour of 'actorApplyTransformToPoint'. +-- +-- * Since 0.6 +-- +actorApplyRelativeTransformToPoint :: (ActorClass self, ActorClass ancestor) => + self -- ^ An Actor + -> Maybe ancestor + -> Vertex -- ^ A point as a 'Vertex' + -> IO Vertex -- ^ The translated 'Vertex' +actorApplyRelativeTransformToPoint self ancestor point = + let func = {# call unsafe actor_apply_relative_transform_to_point #} + in withActorClass self $ \selfPtr -> + withVertex point $ \ptPtr -> do + alloca $ \newVertPtr -> + case ancestor of + Prelude.Nothing -> func selfPtr nullPtr ptPtr newVertPtr >> peek newVertPtr + Just ancActor -> withActorClass ancActor $ \ancPtr -> + func selfPtr ancPtr ptPtr newVertPtr >> peek newVertPtr + +{- +{# fun unsafe actor_apply_relative_transform_to_point as ^ + `(ActorClass self, ActorClass ancestor)' => { withActorClass* `self', + withActorClass* `ancestor', + withVertex* `Vertex', + alloca- `Vertex' peek* + } -> `()' #} +-} + + +-- | Gets the absolute position of an actor, in pixels relative to the +-- stage. +-- +-- [@self@] An Actor +-- +-- [@Returns@] (x coordinate, y coordinate) +-- +-- * Since 0.8 +-- +{# fun unsafe actor_get_transformed_position as ^ + `(ActorClass self)' => { withActorClass* `self', + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv* + } -> `()' #} + + +--TODO: Properly format "Note" in doc +-- | Gets the absolute size of an actor in pixels, taking into account +-- the scaling factors. +-- +-- If the actor has a valid allocation, the allocated size will be +-- used. If the actor has not a valid allocation then the preferred +-- size will be transformed and returned. +-- +-- If you want the transformed allocation, see +-- 'actorGetAbsAllocationVertices' instead. +-- +-- * Note +-- +-- When the actor (or one of its ancestors) is rotated around the X or +-- Y axis, it no longer appears as on the stage as a rectangle, but as +-- a generic quadrangle; in that case this function returns the size +-- of the smallest rectangle that encapsulates the entire quad. Please +-- note that in this case no assumptions can be made about the +-- relative position of this envelope to the absolute position of the +-- actor, as returned by 'actorGetTransformedPosition'; if you need +-- this information, you need to use 'actorGetAbsAllocationVertices' +-- to get the coords of the actual quadrangle. +-- +-- [@self@] An Actor +-- +-- [@Returns@] (width, height) +-- +-- * Since 0.8 +-- +{# fun unsafe actor_get_transformed_size as ^ + `(ActorClass self)' => { withActorClass* `self', + alloca- `Double' peekFloatConv*, + alloca- `Double' peekFloatConv* } -> `()' #} + + +-- | Retrieves the absolute opacity of the actor, as it appears on the +-- stage. +-- +-- This function traverses the hierarchy chain and composites the +-- opacity of the actor with that of its parents. +-- +-- This function is intended for subclasses to use in the paint +-- virtual function, to paint themselves with the correct opacity. +-- +-- [@self@] An Actor +-- +-- [@Returns@] The actor opacity value. +-- +-- * Since 0.8 +-- +{# fun unsafe actor_get_paint_opacity as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `Word8' #} + + +-- | Retrieves the 'paint' visibility of an actor recursively checking +-- for non visible parents. +-- +-- This is by definition the same as 'actorIsMapped'. +-- +-- [@self@] An Actor +-- +-- [@Returns@] @True@ if the actor is visibile and will be painted. +-- +-- * Since 0.8.4 +-- +{# fun unsafe actor_get_paint_visibility as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `Bool' #} + + +-- | Calculates the transformed screen coordinates of the four corners +-- of the actor; the returned vertices relate to the 'ActorBox' +-- coordinates as follows: +-- +-- [(x1, y1), (x2, y1), (x1, y2), (x2, y2)] +-- +-- * Since 0.4 +-- +actorGetAbsAllocationVertices :: (ActorClass self) => self -> IO [Vertex] +actorGetAbsAllocationVertices self = let func = {# call unsafe actor_get_abs_allocation_vertices #} + in withActorClass self $ \selfPtr -> + allocaArray 4 $ \vsPtr -> do + func selfPtr vsPtr + peekArray 4 vsPtr + +{- +{# fun unsafe actor_get_transformation_matrix as ^ `(ActorClass self)' => +{ withActorClass* `self', CoglMatrix } -> `()' #} +-} + + +-- | Sets actor as reactive. Reactive actors will receive events. +-- +-- [@actor@] an Actor +-- +-- [@reactive@] whether the actor should be reactive to events +-- +-- * Since 0.6 +-- +{# fun unsafe actor_set_reactive as ^ + `(ActorClass self)' => { withActorClass* `self', `Bool' } -> `()' #} + + +-- | Checks whether actor is marked as reactive. +-- +-- [@actor@] an Actor +-- +-- [@Returns@] @True@ if the actor is reactive +-- +-- * Since 0.6 +-- +{# fun unsafe actor_get_reactive as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `Bool' #} + +{# fun unsafe actor_set_shader as ^ + `(ActorClass self)' => { withActorClass* `self', withMaybeShader* `Maybe Shader' } -> `()' #} + +--CHECKME: Clutter doc doesn't say returns null, but since you can set null, I assume this works +-- | Queries the currently set ClutterShader on self. +-- +-- * Since 0.6 +-- +{# fun unsafe actor_get_shader as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `Maybe Shader' maybeNewShader* #} + +--{# fun unsafe actor_set_shader_param as ^ + + +-- | Sets the value for a named float parameter of the shader applied +-- to actor. +-- +-- [@self@] an Actor +-- +-- [@param@] the name of the parameter +-- +-- [@value@] the value of the parameter +-- +-- * Since 0.8 +-- +{# fun unsafe actor_set_shader_param_float as ^ + `(ActorClass self)' => { withActorClass* `self', `String', `Float' } -> `()' #} + +-- | Sets the value for a named int parameter of the shader applied to +-- actor. +-- +-- [@self@] an Actor +-- +-- [@param@] the name of the parameter +-- +-- [@value@] the value of the parameter +-- +-- * Since 0.8 +-- +{# fun unsafe actor_set_shader_param_int as ^ + `(ActorClass self)' => { withActorClass* `self', `String', `Int' } -> `()' #} + +--CHECKME: unsafe? +-- | Sets the key focus of the 'Stage' including self to this Actor. +-- +-- * Since 1.0 +-- +{# fun unsafe actor_grab_key_focus as ^ + `(ActorClass a)' => { withActorClass* `a' } -> `()' #} + +--register PangoContext as ptr for c2hs to be happy and not need casts +{#pointer *PangoContext as PangoContextPtr foreign -> PangoContext nocode #} +{#pointer *PangoLayout as PangoLayoutPtr foreign -> PangoLayoutRaw nocode #} + +--TODO: I think I figured out the pango stuff in Text +{# fun unsafe actor_get_pango_context as ^ + `(ActorClass a)' => { withActorClass* `a' } -> `PangoContext' newPangoContext* #} +{# fun unsafe actor_create_pango_context as ^ + `(ActorClass a)' => { withActorClass* `a' } -> `PangoContext' newPangoContext* #} + +--CHECKME: This madness with the pango stuff is probably wrong, as well as in Text +--the string business +actorCreatePangoLayout :: (ActorClass self) => self -> String -> IO PangoLayout +actorCreatePangoLayout act str = let func = {# call unsafe actor_create_pango_layout #} + in withActorClass act $ \actPtr -> + withCString str $ \strPtr -> do + pl <- constructNewGObject mkPangoLayoutRaw (func actPtr strPtr) + withPangoLayoutRaw pl $ \plptr -> do + ps <- makeNewPangoString str + psRef <- newIORef ps + return (PangoLayout psRef pl) + + + +-- | Checks whether self is being currently painted by a 'Clone' +-- +-- This function is useful only inside the ::paint virtual function +-- implementations or within handlers for the "paint" signal +-- +-- This function should not be used by applications +-- +-- [@self@] an Actor +-- +-- [@Returns@] @True@ if the Actor is currently being painted by a 'Clone', and @False@ otherwise +-- +-- * Since 1.0 +-- +{# fun unsafe actor_is_in_clone_paint as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `Bool' #} + +-- | Sets an anchor point for self. The anchor point is a point in the +-- coordinate space of an actor to which the actor position within +-- its parent is relative; the default is (0, 0), i.e. the top-left +-- corner of the actor. +-- +-- [@self@] an Actor +-- +-- [@anchor_x@] X coordinate of the anchor point +-- +-- [@anchor_y@] Y coordinate of the anchor point +-- +-- * Since 0.6 +-- +{# fun unsafe actor_set_anchor_point as ^ + `(ActorClass self)' => { withActorClass* `self', `Float', `Float' } -> `()' #} + +-- | Gets the current anchor point of the actor in pixels. +-- +-- [@self@] an Actor +-- +-- [@Returns@] (X coordinate of the anchor point, Y coordinate of the anchor point) +-- +-- * Since 0.6 +-- +{# fun unsafe actor_get_anchor_point as ^ + `(ActorClass self)' => { withActorClass* `self', + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv*} -> `()' #} + + +-- | Sets an anchor point on the actor, based on the given gravity +-- (this is a convenience function wrapping 'actorSetAnchorPoint'). +-- +-- Since version 1.0 the anchor point will be stored as a gravity so +-- that if the actor changes size then the anchor point will move. For +-- example, if you set the anchor point to 'GravitySouthEast' and +-- later double the size of the actor, the anchor point will move to +-- the bottom right. +-- +-- [@self@] an Actor +-- +-- [@gravity@] 'Gravity'. +-- +-- * Since 0.6 +-- +{# fun unsafe actor_set_anchor_point_from_gravity as ^ + `(ActorClass self)' => { withActorClass* `self', cFromEnum `Gravity' } -> `()' #} + +-- | Retrieves the anchor position expressed as a 'Gravity'. If the +-- anchor point was specified using pixels or units this will return +-- 'GravityNone'. +-- +-- [@self@] a Actor +-- +-- [@Returns@] the 'Gravity' used by the anchor point +-- +-- * Since 1.0 +-- +{# fun unsafe actor_get_anchor_point_gravity as ^ + `(ActorClass self)' => { withActorClass* `self' } -> `Gravity' cToEnum #} + +-- | Sets an anchor point for the actor, and adjusts the actor postion +-- so that the relative position of the actor toward its parent +-- remains the same. +-- +-- [@self@] an Actor +-- +-- [@anchor_x@] X coordinate of the anchor point +-- +-- [@anchor_y@] Y coordinate of the anchor point +-- +-- * Since 0.6 +-- +{# fun unsafe actor_move_anchor_point as ^ + `(ActorClass self)' => { withActorClass* `self', `Float', `Float' } -> `()' #} + +-- | Sets an anchor point on the actor based on the given gravity, +-- adjusting the actor postion so that its relative position within +-- its parent remains unchanged. +-- +-- Since version 1.0 the anchor point will be stored as a gravity so +-- that if the actor changes size then the anchor point will move. For +-- example, if you set the anchor point to 'GravitySouthEast' and +-- later double the size of the actor, the anchor point will move to +-- the bottom right. +-- +-- [@self@] an Actor +-- +-- [@gravity@] 'Gravity'. +-- +-- * Since 0.6 +-- +{# fun unsafe actor_move_anchor_point_from_gravity as ^ + `(ActorClass self)' => { withActorClass* `self', cFromEnum `Gravity' } -> `()' #} + + + +--TODO: Check they are pure. Also wouldn't be hard to actually haskellize them +{# fun pure unsafe actor_box_get_x as ^ { withActorBox* `ActorBox' } -> `Float' #} +{# fun pure unsafe actor_box_get_y as ^ { withActorBox* `ActorBox' } -> `Float' #} +{# fun pure unsafe actor_box_get_width as ^ { withActorBox* `ActorBox' } -> `Float' #} +{# fun pure unsafe actor_box_get_height as ^ { withActorBox* `ActorBox' } -> `Float' #} +{# fun pure unsafe actor_box_get_origin as ^ { withActorBox* `ActorBox', + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv* } -> `()' #} +{# fun pure unsafe actor_box_get_size as ^ { withActorBox* `ActorBox', + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv* } -> `()' #} +{# fun pure unsafe actor_box_get_area as ^ { withActorBox* `ActorBox' } -> `Float' #} + +{# fun pure unsafe actor_box_contains as ^ { withActorBox* `ActorBox', + `Float', + `Float' } -> `()' #} + +{# fun pure unsafe actor_box_from_vertices as ^ { withActorBox* `ActorBox', + withArray* `[Vertex]' + } -> `()' #} + + +-- Attributes + +--CHECKME: actorGetAllocationBox right? + +-- | The allocation for the actor, in pixels +-- +-- This is property is read-only, but you might monitor it to know +-- when an actor moves or resizes +-- +-- * Since 0.8 +-- +actorAllocation :: (ActorClass self) => ReadAttr self ActorBox +actorAllocation = readNamedAttr "allocation" actorGetAllocationBox + +-- | The anchor point expressed as a 'Gravity' +-- +-- Default value: 'GravityNone' +-- +-- * Since 1.0 +-- +actorAnchorGravity :: (ActorClass self) => Attr self Gravity +actorAnchorGravity = newNamedAttr "anchor-gravity" actorGetAnchorPointGravity actorSetAnchorPointFromGravity + +-- | The X coordinate of an actor's anchor point, relative to the +-- actor coordinate space, in pixels +-- +-- * Default value: 0 +-- +-- * Since 0.8 +-- +actorAnchorX :: (ActorClass self) => Attr self Float +actorAnchorX = newAttrFromFloatProperty "anchor-x" + + +-- | The Y coordinate of an actor's anchor point, relative to the +-- actor coordinate space, in pixels +-- +-- Default value: 0 +-- +-- * Since 0.8 +-- +actorAnchorY :: (ActorClass self) => Attr self Float +actorAnchorY = newAttrFromFloatProperty "anchor-y" + +-- | The clip region for the actor, in actor-relative coordinates +-- +-- Every part of the actor outside the clip region will not be painted +-- +actorClip :: (ActorClass self) => Attr self Geometry +actorClip = newAttrFromBoxedStorableProperty "clip" CGT.geometry + + +-- | Whether the clip region should track the allocated area of the actor. +-- +-- This property is ignored if a clip area has been explicitly set +-- using 'actorSetClip'. +-- +-- Default value: @False@ +-- +-- * Since 1.0 +-- +actorClipToAllocation :: (ActorClass self) => Attr self Bool +actorClipToAllocation = newAttrFromBoolProperty "clip-to-allocation" + +-- | The position of the actor on the Z axis +-- +-- Default value: 0 +-- +-- * Since 0.6 +-- +actorDepth :: (ActorClass self) => Attr self Float +actorDepth = newNamedAttr "depth" actorGetDepth actorSetDepth + + +-- | This flag controls whether the 'actorFixedX' and 'actorFixedY' +-- properties are used +-- +-- Default value: @False@ +-- +-- * Since 0.8 +-- +actorFixedPositionSet :: (ActorClass self) => Attr self Bool +actorFixedPositionSet = newNamedAttr "fixed-position-set" actorGetFixedPositionSet actorSetFixedPositionSet + + +-- | The fixed X position of the actor in pixels. +-- +-- Writing this property sets 'actorFixedPositionSet' property as +-- well, as a side effect +-- +-- Default value: 0 +-- +-- * Since 0.8 +-- +actorFixedX :: (ActorClass self) => Attr self Float +actorFixedX = newAttrFromFloatProperty "fixed-x" + + +-- | The fixed Y position of the actor in pixels. +-- +-- Writing this property sets the 'actorFixedPositionSet' property as +-- well, as a side effect +-- +-- Default value: 0 +-- +-- * Since 0.8 +-- +actorFixedY :: (ActorClass self) => Attr self Float +actorFixedY = newAttrFromFloatProperty "fixed-y" + + +-- FIXME: Name conflicts with the actual function. +-- | Whether the actor has the "clip" property set or not +-- +-- Default value: @False@ +-- +--actorHasClip :: (ActorClass self) => ReadAttr self Bool +--actorHasClip = readNamedAttr "has-clip" actorHasClip + + +-- | Height of the actor (in pixels). If written, forces the minimum +-- and natural size request of the actor to the given height. If +-- read, returns the allocated height if available, otherwise the +-- height request. +-- +-- Allowed values: >= 0 +-- +-- Default value: 0 +-- +actorHeight :: (ActorClass self) => Attr self Float +actorHeight = newNamedAttr "height" actorGetHeight actorSetHeight + + +-- | Whether the actor is mapped (will be painted when the stage to +-- which it belongs is mapped) +-- +-- Default value: @False@ +-- +-- * Since 1.0 +-- +actorMapped :: (ActorClass self) => ReadAttr self Bool +actorMapped = readNamedAttr "mapped" actorIsMapped + + +-- | A forced minimum height request for the actor, in pixels +-- +-- Writing this property sets the 'actorMinHeightSet' property as +-- well, as a side effect. This property overrides the usual height +-- request of the actor. +-- +-- Allowed values: >= 0 +-- +-- Default value: 0 +-- +-- * Since 0.8 +-- +actorMinHeight :: (ActorClass self) => Attr self Float +actorMinHeight = newAttrFromFloatProperty "min-height" + + +-- | This flag controls whether the 'actorMinHeight' property is used +-- +-- Default value: @False@ +-- +-- Since 0.8 +-- +actorMinHeightSet :: (ActorClass self) => Attr self Bool +actorMinHeightSet = newAttrFromBoolProperty "min-height-set" + + +-- | A forced minimum width request for the actor, in pixels +-- +-- Writing this property sets the 'actorMinWidthSet' property as well, +-- as a side effect. +-- +-- This property overrides the usual width request of the actor. +-- +-- Allowed values: >= 0 +-- +-- Default value: 0 +-- +-- * Since 0.8 +-- +actorMinWidth :: (ActorClass self) => Attr self Float +actorMinWidth = newAttrFromFloatProperty "min-width" + + +-- | This flag controls whether the 'actorMinWidth' property is used +-- +-- * Default value: @False@ +-- +-- * Since 0.8 +-- +actorMinWidthSet :: (ActorClass self) => Attr self Bool +actorMinWidthSet = newAttrFromBoolProperty "min-width" + +-- | The name of the actor +-- +-- Default value: @Nothing@ +-- +-- * Since 0.2 +-- +actorName :: (ActorClass self) => Attr self (Maybe String) +actorName = newNamedAttr "name" actorGetName actorSetName + + +-- | A forced natural height request for the actor, in pixels +-- +-- Writing this property sets the 'actorNaturalHeightSet' property as +-- well, as a side effect. This property overrides the usual height +-- request of the actor +-- +-- Allowed values: >= 0 +-- +-- Default value: 0 +-- +-- * Since 0.8 +-- +actorNaturalHeight :: (ActorClass self) => Attr self Float +actorNaturalHeight = newAttrFromFloatProperty "natural-height" + +-- | This flag controls whether the 'actorNaturalHeight' property is +-- used +-- +-- Default value: @False@ +-- +-- * Since 0.8 +-- +actorNaturalHeightSet :: (ActorClass self) => Attr self Bool +actorNaturalHeightSet = newAttrFromBoolProperty "natural-height-set" + + +-- | A forced natural width request for the actor, in pixels +-- +-- Writing this property sets the 'actorNaturalWidthSet' property as +-- well, as a side effect. This property overrides the usual width +-- request of the actor +-- +-- Allowed values: >= 0 +-- +-- Default value: 0 +-- +-- * Since 0.8 +-- +actorNaturalWidth :: (ActorClass self) => Attr self Float +actorNaturalWidth = newAttrFromFloatProperty "natural-width" + + +-- | This flag controls whether the 'actorNaturalWidth' property is +-- used +-- +-- Default value: @False@ +-- +-- * Since 0.8 +-- +actorNaturalWidthSet :: (ActorClass self) => Attr self Bool +actorNaturalWidthSet = newAttrFromBoolProperty "natural-width-set" + +-- | Opacity of the actor, between 0 (fully transparent) and 255 +-- (fully opaque) +-- +-- Default value: 255 +-- +actorOpacity :: (ActorClass self) => Attr self Word8 +actorOpacity = newNamedAttr "opacity" actorGetOpacity actorSetOpacity + + +-- | Whether the actor is reactive to events or not +-- +-- Only reactive actors will emit event-related signals +-- +-- Default value: @False@ +-- +-- * Since 0.6 +-- +actorReactive :: (ActorClass self) => Attr self Bool +actorReactive = newNamedAttr "reactive" actorGetReactive actorSetReactive + +-- | Whether the actor has been realized +-- +-- Default value: @False@ +-- +-- * Since 1.0 +-- +actorRealized :: (ActorClass self) => ReadAttr self Bool +actorRealized = readNamedAttr "realized" actorIsRealized + +-- | Request mode for the ClutterActor. The request mode determines +-- the type of geometry management used by the actor, either height +-- for width (the default) or width for height. +-- +-- For actors implementing height for width, the parent container +-- should get the preferred width first, and then the preferred +-- height for that width. +-- +-- For actors implementing width for height, the parent container +-- should get the preferred height first, and then the preferred width +-- for that height. +-- +-- For instance: +-- TODO: Example +-- +-- will retrieve the minimum and natural width and height depending on +-- the preferred request mode of the ClutterActor "child". +-- +-- The 'actorGetPreferredSize' function will implement this check for +-- you. +-- +-- Default value: 'RequestHeightForWidth' +-- +-- * Since 0.8 +-- +actorRequestMode :: (ActorClass self) => Attr self RequestMode +actorRequestMode = newAttrFromEnumProperty "realized" CGT.requestmode + +-- | The rotation angle on the X axis +-- +-- Default value: 0 +-- +-- * Since 0.6 +-- +actorRotationAngleX :: (ActorClass self) => Attr self Double +actorRotationAngleX = newAttrFromDoubleProperty "rotation-angle-x" + + +-- | The rotation angle on the Y axis +-- +-- Default value: 0 +-- +-- * Since 0.6 +-- +actorRotationAngleY :: (ActorClass self) => Attr self Double +actorRotationAngleY = newAttrFromDoubleProperty "rotation-angle-y" + + +-- | The rotation angle on the Z axis +-- +-- Default value: 0 +-- +-- * Since 0.6 +-- +actorRotationAngleZ :: (ActorClass self) => Attr self Double +actorRotationAngleZ = newAttrFromDoubleProperty "rotation-angle-z" + + +actorRotationCenterX :: (ActorClass self) => Attr self Vertex +actorRotationCenterX = newAttrFromBoxedStorableProperty "rotation-center-x" CGT.vertex + +actorRotationCenterY :: (ActorClass self) => Attr self Vertex +actorRotationCenterY = newAttrFromBoxedStorableProperty "rotation-center-y" CGT.vertex + +actorRotationCenterZ :: (ActorClass self) => Attr self Vertex +actorRotationCenterZ = newAttrFromBoxedStorableProperty "rotation-center-z" CGT.vertex + + +-- | The rotation center on the Z axis expressed as a 'Gravity'. +-- +-- Default value: 'GravityNone' +-- +-- * Since 1.0 +-- +actorRotationCenterZGravity :: (ActorClass self) => Attr self Gravity +actorRotationCenterZGravity = newAttrFromEnumProperty "rotation-center-z-gravity" CGT.gravity + + +-- | The horizontal center point for scaling +-- +-- Default value: 0 +-- +-- * Since 1.0 +-- +actorScaleCenterX :: (ActorClass self) => Attr self Float +actorScaleCenterX = newAttrFromFloatProperty "scale-center-x" + + +-- | The vertical center point for scaling +-- +-- Default value: 0 +-- +-- * Since 1.0 +-- +actorScaleCenterY :: (ActorClass self) => Attr self Float +actorScaleCenterY = newAttrFromFloatProperty "scale-center-y" + + +-- | The center point for scaling expressed as a 'Gravity' +-- +-- Default value: 'GravityNone' +-- +-- * Since 1.0 +-- +actorScaleGravity :: (ActorClass self) => Attr self Gravity +actorScaleGravity = newAttrFromEnumProperty "scale-gravity" CGT.gravity + + + +-- | The horizontal scale of the actor +-- +-- Allowed values: >= 0 +-- +-- Default value: 1 +-- +-- * Since 0.6 +-- +actorScaleX :: (ActorClass self) => Attr self Double +actorScaleX = newAttrFromDoubleProperty "scale-x" + + + +-- | The vertical scale of the actor +-- +-- Allowed values: >= 0 +-- +-- Default value: 1 +-- +-- * Since 0.6 +-- +actorScaleY :: (ActorClass self) => Attr self Double +actorScaleY = newAttrFromDoubleProperty "scale-y" + + + +-- | If @True@, the actor is automatically shown when parented. +-- +-- Calling 'actorHide' on an actor which has not been parented will +-- set this property to @False@ as a side effect. +-- +-- Default value: @True@ +-- +-- * Since 0.8 +-- +actorShowOnSetParent :: (ActorClass self) => Attr self Bool +actorShowOnSetParent = newAttrFromBoolProperty "show-on-set-parent" + + +-- | Whether the actor is set to be visible or not +-- +-- See also 'actorMapped' +-- +-- Default value: @False@ +-- +actorVisible :: (ActorClass self) => Attr self Bool +actorVisible = newAttrFromBoolProperty "visible" + +actorWidth :: (ActorClass self) => Attr self Float +actorWidth = newNamedAttr "width" actorGetWidth actorSetWidth + + + + + +-- | X coordinate of the actor in pixels. If written, forces a fixed +-- position for the actor. If read, returns the fixed position if +-- any, otherwise the allocation if available, otherwise 0. +-- +-- Default value: 0 +-- +actorX :: (ActorClass self) => Attr self Float +actorX = newNamedAttr "x" actorGetX actorSetX + + +-- | Y coordinate of the actor in pixels. If written, forces a fixed +-- position for the actor. If read, returns the fixed position if +-- any, otherwise the allocation if available, otherwise 0. +-- +-- Default value: 0 +-- +actorY :: (ActorClass self) => Attr self Float +actorY = newNamedAttr "y" actorGetY actorSetY + + +-- Signals + + +--CHECKME + +onAllocationChanged, afterAllocationChanged :: ActorClass a => a + -> (ActorBox -> [AllocationFlags] -> IO ()) + -> IO (ConnectId a) +onAllocationChanged = connect_BOXED_FLAGS__NONE "allocation-changed" peek False +afterAllocationChanged = connect_BOXED_FLAGS__NONE "allocation-changed" peek True + + +-- | The ::'allocationChanged' signal is emitted when the "allocation" +-- property changes. Usually, application code should just use the +-- notifications for the :allocation property but if you want to +-- track the allocation flags as well, for instance to know whether +-- the absolute origin of actor changed, then you might want use +-- this signal instead. +-- +-- [@box@] an 'ActorBox with the new allocation +-- +-- [@flags@] 'AllocationFlags' for the allocation +-- +-- * Since 1.0 +-- +allocationChanged :: ActorClass self => Signal self (ActorBox -> [AllocationFlags] -> IO ()) +allocationChanged = Signal (connect_BOXED_FLAGS__NONE "allocation-changed" peek) + + +onDestroy, afterDestroy :: ActorClass a => a -> IO () -> IO (ConnectId a) +onDestroy = connect_NONE__NONE "destroy" False +afterDestroy = connect_NONE__NONE "destroy" True + +-- | The \"destroy\" signal is emitted when an actor is destroyed, +-- either by direct invocation of 'actorDestroy' or when the 'Group' +-- that contains the actor is destroyed. +-- +-- * Since 0.2 +-- +destroy :: ActorClass self => Signal self (IO ()) +destroy = Signal (connect_NONE__NONE "destroy") + + +onHide, afterHide :: ActorClass a => a -> IO () -> IO (ConnectId a) +onHide = connect_NONE__NONE "hide" False +afterHide = connect_NONE__NONE "hide" True + + +-- | The \"hide\" signal is emitted when an actor is no longer +-- rendered on the stage. +-- +-- * Since 0.2 +-- +hide :: ActorClass self => Signal self (IO ()) +hide = Signal (connect_NONE__NONE "hide") + + +onKeyFocusIn, afterKeyFocusIn :: ActorClass a => a -> IO () -> IO (ConnectId a) +onKeyFocusIn = connect_NONE__NONE "key_focus_in" False +afterKeyFocusIn = connect_NONE__NONE "key_focus_in" True + +-- | The \"key-focus-in\" signal is emitted when actor recieves key focus. +-- +-- * Since 0.6 +-- +keyFocusIn :: ActorClass self => Signal self (IO ()) +keyFocusIn = Signal (connect_NONE__NONE "key_focus_in") + + +onKeyFocusOut, afterKeyFocusOut :: ActorClass a => a -> IO () -> IO (ConnectId a) +onKeyFocusOut = connect_NONE__NONE "key_focus_out" False +afterKeyFocusOut = connect_NONE__NONE "key_focus_out" True + +-- | The \"key-focus-out\" signal is emitted when actor loses key focus. +-- +-- * Since 0.6 +-- +keyFocusOut :: ActorClass self => Signal self (IO ()) +keyFocusOut = Signal (connect_NONE__NONE "key_focus_out") + + +onPaint, afterPaint :: ActorClass a => a -> IO () -> IO (ConnectId a) +onPaint = connect_NONE__NONE "paint" False +afterPaint = connect_NONE__NONE "paint" True + +-- | The \"paint\" signal is emitted each time an actor is being +-- painted. +-- +-- Subclasses of Actor should override the class signal handler and +-- paint themselves in that function. +-- +-- +-- It is possible to connect a handler to the \"paint\" signal in +-- order to set up some custom aspect of a paint. +-- +-- * Since 0.8 +-- +paint :: ActorClass self => Signal self (IO ()) +paint = Signal (connect_NONE__NONE "paint") + + +onParentSet, afterParentSet :: ActorClass a => a -> (Actor -> IO ()) -> IO (ConnectId a) +onParentSet = connect_OBJECT__NONE "parent-set" False +afterParentSet = connect_OBJECT__NONE "parent-set" True + +--CHECKME: Test if this signal works +-- | This signal is emitted when the parent of the actor changes. +-- +-- [@actor@] : +-- +-- the object which received the signal +-- +-- [@old_parent@] @Just@ the previous parent of the actor, or @Nothing@ +-- +-- * Since 0.2 +-- +parentSet :: ActorClass self => Signal self (Maybe self -> IO ()) +parentSet = Signal (connect_MAYBEOBJECT__NONE "parent") + + +onPick, afterPick :: ActorClass a => a -> (Color -> IO ()) -> IO (ConnectId a) +onPick = connect_BOXED__NONE "pick" peek False +afterPick = connect_BOXED__NONE "pick" peek True + + +-- | The ::pick signal is emitted each time an actor is being painted +-- in "pick mode". The pick mode is used to identify the actor +-- during the event handling phase, or by 'stageGetActorAtPos'. The +-- actor should paint its shape using the passed pick_color. +-- +-- Subclasses of ClutterActor should override the class signal handler +-- and paint themselves in that function. +-- +-- It is possible to connect a handler to the ::pick signal in order +-- to set up some custom aspect of a paint in pick mode. +-- +-- [@actor@] the Actor that received the signal +-- +-- [@color@] the 'Color' to be used when picking +-- +-- * Since 1.0 +-- +pick :: ActorClass self => Signal self (Color -> IO ()) +pick = Signal (connect_BOXED__NONE "pick" peek) + + +onQueueRedraw, afterQueueRedraw :: ActorClass a => a -> (Actor -> IO ()) -> IO (ConnectId a) +onQueueRedraw = connect_OBJECT__NONE "queue-redraw" False +afterQueueRedraw = connect_OBJECT__NONE "queue-redraw" True + +queueRedraw :: ActorClass self => Signal self (Color -> IO ()) +queueRedraw = Signal (connect_BOXED__NONE "queue-redraw" peek) + + +onRealize, afterRealize :: ActorClass a => a -> IO () -> IO (ConnectId a) +onRealize = connect_NONE__NONE "realize" False +afterRealize = connect_NONE__NONE "realize" True + + +-- | The \"realize\" signal is emitted each time an actor is being +-- realized. +-- +-- * Since 0.8 +-- +realize :: ActorClass self => Signal self (IO ()) +realize = Signal (connect_NONE__NONE "realize") + +onShow, afterShow :: ActorClass a => a -> IO () -> IO (ConnectId a) +onShow = connect_NONE__NONE "show" False +afterShow = connect_NONE__NONE "show" True + + +-- | The \"show\" signal is emitted when an actor is visible and +-- rendered on the stage. +-- +-- * Since 0.2 +-- +show :: ActorClass self => Signal self (IO ()) +show = Signal (connect_NONE__NONE "show") + +onUnrealize, afterUnrealize :: ActorClass a => a -> IO () -> IO (ConnectId a) +onUnrealize = connect_NONE__NONE "unrealize" False +afterUnrealize = connect_NONE__NONE "unrealize" True + + +-- | The \"unrealize\" signal is emitted each time an actor is being +-- unrealized. +-- +-- * Since 0.8 +-- +unrealize :: ActorClass self => Signal self (IO ()) +unrealize = Signal (connect_NONE__NONE "unrealize") + + +-- Events + +--CHECKME: Types of events + + +-- | The ::button-press-event signal is emitted each time a mouse +-- button is pressed on actor. +-- +-- [@Returns@] @True@ if the event has been handled by the actor, or +-- @False@ to continue the emission. +-- +-- * Since 0.6 +-- +buttonPressEvent :: ActorClass self => Signal self (EventM EButton Bool) +buttonPressEvent = Signal (eventM "button-press-event") + + + +-- | The ::'buttonReleaseEvent' signal is emitted each time a mouse +-- button is released on actor. +-- +-- [@Returns@] @True@ if the event has been handled by the actor, or +-- @False@ to continue the emission. +-- +-- * Since 0.6 +-- +buttonReleaseEvent :: ActorClass self => Signal self (EventM EButton Bool) +buttonReleaseEvent = Signal (eventM "button-release-event") + + +-- | The ::'capturedEvent' signal is emitted when an event is captured +-- by Clutter. This signal will be emitted starting from the +-- top-level container (the 'Stage') to the actor which received the +-- event going down the hierarchy. This signal can be used to +-- intercept every event before the specialized events (like +-- 'Actor'::'buttonPressEvent' or ::'keyReleasedEvent') are emitted. +-- +-- [@Returns@] @True@ if the event has been handled by the actor, or +-- @False@ to continue the emission. +-- +-- * Since 0.6 +-- +capturedEvent :: ActorClass self => Signal self (EventM EAny Bool) +capturedEvent = Signal (eventM "captured-event") + + + +-- | The ::enter-event signal is emitted when the pointer enters the +-- actor +-- +-- [@Returns@] @True@ if the event has been handled by the actor, or +-- @False@ to continue the emission. +-- +-- * Since 0.6 +-- +enterEvent :: ActorClass self => Signal self (EventM EMotion Bool) +enterEvent = Signal (eventM "enter-event") + + +-- | The ::'event' signal is emitted each time an event is received by +-- the actor. This signal will be emitted on every actor, following +-- the hierarchy chain, until it reaches the top-level container +-- (the 'Stage'). +-- +-- [@Returns@] @True@ if the event has been handled by the actor, or +-- @False@ to continue the emission. +-- +-- * Since 0.6 +-- +event :: ActorClass self => Signal self (EventM EAny Bool) +event = Signal (eventM "event") + + +-- | The ::'keyPressEvent' signal is emitted each time a keyboard +-- button is pressed while actor has key focus (see +-- 'stageSetKeyFocus'). +-- +-- [@Returns@] @True@ if the event has been handled by the actor, or +-- @False@ to continue the emission. +-- +-- * Since 0.6 +-- +keyPressEvent :: ActorClass self => Signal self (EventM EKey Bool) +keyPressEvent = Signal (eventM "key-press-event") + + +-- | The ::'keyReleaseEvent' signal is emitted each time a keyboard +-- button is released while actor has key focus (see +-- 'stageSetKeyFocus'). +-- +-- [@Returns@] @True@ if the event has been handled by the actor, or +-- @False@ to continue the emission. +-- +-- * Since 0.6 +-- +keyReleaseEvent :: ActorClass self => Signal self (EventM EKey Bool) +keyReleaseEvent = Signal (eventM "key-release-event") + + + + +-- | The ::'leaveEvent' signal is emitted when the pointer leaves the +-- actor. +-- +-- [@Returns@] @True@ if the event has been handled by the actor, or +-- @False@ to continue the emission. +-- +-- * Since 0.6 +-- +leaveEvent :: ActorClass self => Signal self (EventM EMotion Bool) +leaveEvent = Signal (eventM "leave-event") + + +-- | The ::'motionEvent' signal is emitted each time the mouse pointer +-- is moved over actor. +-- +-- [@Returns@] @True@ if the event has been handled by the actor, or +-- @False@ to continue the emission. +-- +-- * Since 0.6 +-- +motionEvent :: ActorClass self => Signal self (EventM EMotion Bool) +motionEvent = Signal (eventM "motion-event") + + +-- | The ::'scrollEvent' signal is emitted each time the mouse is +-- scrolled on actor +-- +-- [@Returns@] @True@ if the event has been handled by the actor, or +-- @False@ to continue the emission. +-- +-- * Since 0.6 +-- +scrollEvent :: ActorClass self => Signal self (EventM EScroll Bool) +scrollEvent = Signal (eventM "scroll-event") + + diff --git a/Graphics/UI/Clutter/Alpha.chs b/Graphics/UI/Clutter/Alpha.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Alpha.chs @@ -0,0 +1,270 @@ + -- -*-haskell-*- + -- Clutter Alpha + -- + -- Author : Matthew Arsenault + -- + -- Created: 22 Sep 2009 + -- + -- Copyright (C) 2009 Matthew Arsenault + -- + -- 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 3 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. + -- + {-# LANGUAGE ForeignFunctionInterface, TypeSynonymInstances #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | A class for calculating an alpha value as a function of time. +module Graphics.UI.Clutter.Alpha ( +-- * Detail +-- | 'Alpha' is a class for calculating an floating point value +-- dependent only on the position of a 'Timeline'. +-- +-- A 'Alpha' binds a 'Timeline' to a progress function which +-- translates the time T into an adimensional factor alpha. The factor +-- can then be used to drive a 'Behaviour', which will translate the +-- alpha value into something meaningful for a 'Actor'. +-- +-- You should provide a 'Timeline' and bind it to the 'Alpha' instance +-- using 'alphaSetTimeline'. You should also set an \"animation +-- mode\", either by using the ClutterAnimationMode values that +-- Clutter itself provides or by registering custom functions using +-- 'alphaRegisterFunc'. +-- +-- Instead of a 'AnimationMode' you may provide a function returning +-- the alpha value depending on the progress of the timeline, using +-- 'alphaSetFunc'. The alpha function will be executed each time a new +-- frame in the 'Timeline' is reached. +-- +-- Since the alpha function is controlled by the timeline instance, +-- you can pause, stop or resume the 'Alpha' from calling the alpha +-- function by using the appropriate functions of the 'Timeline' +-- object. +-- +-- 'Alpha' is used to \"drive\" a Behaviour instance, and it is +-- internally used by the Animation API. +-- +-- * Figure 3. Easing modes provided by Clutter +-- <> +-- + +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Alpha' +-- @ + +-- * Types + Alpha, + AlphaClass, + AlphaFunc, + +-- * Constructors + alphaNew, + alphaNewFull, + alphaNewWithFunc, +-- * Methods + + alphaSetTimeline, + alphaGetTimeline, + + alphaSetMode, + alphaGetMode, + + alphaGetAlpha, + alphaSetFunc, + +--alphaSetClosure, +--alphaRegisterClosure, + alphaRegisterFunc, + +-- * Attributes + alphaTimeline, + alphaMode, + alphaAlpha + ) where + +{# import Graphics.UI.Clutter.Types #} + +import C2HS +import System.Glib.GObject +import System.Glib.Attributes + + +-- | Creates a new ClutterAlpha instance. You must set a function to +-- compute the alpha value using 'alphaSetFunc' and bind a +-- 'Timeline' object to the 'Alpha' instance using +-- 'alphaSetTimeline'. +-- +-- You should use the newly created 'Alpha' instance inside a 'Behaviour' object. +-- +-- [@Returns@] the newly created empty 'Alpha' instance. +-- +-- * Since 0.2 +-- +{# fun unsafe alpha_new as ^ { } -> `Alpha' newAlpha* #} + + +-- | Creates a new 'Alpha' instance and sets the timeline and animation mode. +-- +-- See also 'alphaSetTimeline' and 'alphaSetMode'. +-- +-- [@timeline@] 'Timeline' timeline +-- +-- [@mode@] animation mode +-- +-- [@Returns@] the newly created 'Αlpha' +-- +-- * Since 1.0 +-- +{# fun unsafe alpha_new_full as ^ + { withTimeline* `Timeline', cFromEnum `AnimationMode' } -> `Alpha' newAlpha* #} + +-- | Creates a new ClutterAlpha instances and sets the timeline and the alpha function. +-- +-- This function will not register func as a global alpha function. +-- +-- See also alphaSetTimeline and 'alphaSetFunc'. +-- +-- * Since 1.0 +-- +alphaNewWithFunc :: Timeline -- ^ a 'Timeline' + -> AlphaFunc -- ^ an 'AlphaFunc' + -> IO Alpha -- ^ The newly created 'Alpha' +alphaNewWithFunc tl af = withTimeline tl $ \tlptr -> do + afptr <- newAlphaFunc af + a <- {# call unsafe alpha_new_with_func #} tlptr afptr (castFunPtrToPtr afptr) destroyFunPtr + newAlpha a + +-- | Binds alpha to timeline. +-- +-- [@alpha@] An 'Alpha' +-- +-- [@timeline@] A 'Timeline' +-- +-- * Since 0.2 +-- +{# fun unsafe alpha_set_timeline as ^ + { withAlpha* `Alpha', withTimeline* `Timeline' } -> `()' #} + +-- | Gets the 'Timeline' bound to alpha. +-- +-- [@alpha@] an 'Alpha' +-- +-- [@timeline@] a 'Timeline' +-- +-- * Since 0.2 +-- +{# fun unsafe alpha_get_timeline as ^ + { withAlpha* `Alpha' } -> `Timeline' newTimeline* #} + +--CHECKME/FIXME: AlphaMode can be something returned from register_func? +--how does enum stuff handle this? + +-- | Sets the progress function of alpha using the symbolic value of +-- mode, as taken by the 'AnimationMode' enumeration or using +-- the value returned by 'alphaRegisterFunc'. +-- +-- [@alpha@] an 'Alpha' +-- +-- [@mode@] an 'AnimationMode' +-- +-- * Since 1.0 +-- +{# fun unsafe alpha_set_mode as ^ + { withAlpha* `Alpha', cFromEnum `AnimationMode' } -> `()' #} + +-- | Retrieves the 'AnimationMode' used by an 'Αlpha'. +-- +-- * Since 0.2 +-- +{# fun unsafe alpha_get_mode as ^ + { withAlpha* `Alpha' } -> `AnimationMode' cToEnum #} + +-- | Query the current alpha value +-- +-- * Since 0.2 +-- +{# fun unsafe alpha_get_alpha as ^ { withAlpha* `Alpha' } -> `Double' #} + + +-- | Sets the 'AlphaFunc' function used to compute the alpha value at +-- each frame of the 'Timeline' bound to alpha. +-- This function will not register func as a global alpha function. +-- +-- * Since 1.0 +-- +alphaSetFunc :: Alpha -> AlphaFunc -> IO () +alphaSetFunc alp af = withAlpha alp $ \alpPtr -> do + afptr <- newAlphaFunc af + {# call unsafe alpha_set_func #} alpPtr afptr (castFunPtrToPtr afptr) destroyFunPtr + +--TODO: some kind of ID Type for this. +--TODO: What is CLUTTER_ANIMATION_LAST here? some kind of macro +-- | Registers a global alpha function and returns its logical id to +-- be used by 'alphaSetMode' or by 'Animation'. +-- +-- The logical id is always greater than CLUTTER_ANIMATION_LAST. +-- +-- * Since 1.0 +-- +alphaRegisterFunc :: AlphaFunc -> IO Word64 +alphaRegisterFunc af = do + afptr <- newAlphaFunc af + ret <- {# call unsafe alpha_register_func #} afptr nullPtr + return (cIntConv ret) + +--pretty sure don't care about gclosure +--{# fun unsafe alpha_set_closure as ^ { withAlpha* `Alpha', `GClosure' } -> `()' #} +--{# fun unsafe alpha_register_closure as ^ { `GClosure' } -> `GULong' #} + + + + +-- | The alpha value as computed by the alpha function. The linear +-- interval is 0.0 to 1.0, but the Alpha allows overshooting by one +-- unit in each direction, so the valid interval is -1.0 to 2.0. +-- Allowed values: [-1,2] +-- +-- Default value: 0 +-- +-- * Since 0.2 +-- +alphaAlpha :: ReadAttr Alpha Double +alphaAlpha = readNamedAttr "alpha" alphaGetAlpha + + +--CHECKME: The custom mode return +-- | The progress function logical id - either a value from the +-- 'AnimationMode' enumeration or a value returned by +-- 'alphaRegisterFunc'. +-- +-- If CLUTTER_CUSTOM_MODE is used then the function set using +-- 'alphaSetFunc' will be +-- used. +-- +-- * Since 1.0 +-- +alphaMode :: Attr Alpha AnimationMode +alphaMode = newNamedAttr "mode" alphaGetMode alphaSetMode + + + +-- | A 'Timeline' instance used to drive the alpha function +-- +-- * Since 0.2 +-- +alphaTimeline :: Attr Alpha Timeline +alphaTimeline = newNamedAttr "timeline" alphaGetTimeline alphaSetTimeline + + diff --git a/Graphics/UI/Clutter/Animatable.chs b/Graphics/UI/Clutter/Animatable.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Animatable.chs @@ -0,0 +1,72 @@ +-- -*-haskell-*- +-- Clutter Animatable +-- +-- Author : Matthew Arsenault +-- +-- Created: 25 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.Animatable ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GInterface' +-- | +----'Animatable' +-- @ + +-- * Types + AnimatableClass, + +-- * Methods + animatableAnimateProperty + ) where + +{# import Graphics.UI.Clutter.Types #} + +import C2HS +import System.Glib.GObject +{- +animatableAnimateProperty :: (AnimatableClass animatable, GValueArgClass val) => + animatable -> + Animation -> + String -> + val -> + val -> + Double -> + val -> + IO (Maybe val) +-} +animatableAnimateProperty = undefined +{- +animatableAnimateProperty animAble anim pName initial final prog = +--CHECKME: unsafe? + let func = {# call unsafe animatable_animate_property #} + in withAnimatableClass animAble $ \animAblePtr -> + withAnimation anim $ \animPtr -> + withCString pName $ \strPtr -> + withGValueArg initial $ \initPtr -> + withGValueArg final $ \finPtr -> + allocaGValue $ \valPtr -> do + res <- func animAblePtr animPtr strPtr initPtr finPtr (cFloatConv prog) valPtr + return $ if res + then Just valPtr + else Prelude.Nothing +-} + diff --git a/Graphics/UI/Clutter/Animation.chs b/Graphics/UI/Clutter/Animation.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Animation.chs @@ -0,0 +1,681 @@ +-- -*-haskell-*- +-- Clutter Animation +-- +-- Author : Matthew Arsenault +-- +-- Created: 20 Sep 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface, + ExistentialQuantification #-} +{-# OPTIONS_HADDOCK prune #-} + +#include +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.Animation ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Animation' +-- @ + +-- * Types + Animation, + AnimationMode(..), + AnimOp(..), + +-- * Constructors + animate, + animateWithAlpha, + animateWithTimeline, + animationNew, + +-- * Methods + animationSetObject, + animationGetObject, + animationSetMode, + animationGetMode, + + animationSetDuration, + animationGetDuration, + + animationSetLoop, + animationGetLoop, + + animationSetTimeline, + animationGetTimeline, + animationSetAlpha, + animationGetAlpha, + animationCompleted, + animationBind, + animationBindInterval, + animationUpdateInterval, + + animationHasProperty, + animationUnbindProperty, +--animationGetInterval, + actorGetAnimation, + actorAnimation, + +-- * Attributes + animationObject, + animationMode, + animationDuration, + animationLoop, + animationTimeline, + animationAlpha + + +--TODO: Playable class +-- * Signals +--onCompleted, +--afterCompleted, +--completed, +--onStarted, +--afterStarted, +--started + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Signals #} +{# import Graphics.UI.Clutter.StoreValue #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import Prelude +import qualified Prelude as P + +import Control.Monad (liftM, foldM_) + +import System.Glib.GObject +import System.Glib.Attributes +import System.Glib.Properties +import System.Glib.GValue + + + + +-- | Creates a new 'Animation' instance. You should set the GObject to +-- be animated using 'animationSetObject', set the duration with +-- 'animationSetDuration' and the easing mode using +-- 'animationSetMode'. +-- +-- Use 'animationBind' or 'animationBindInterval' to define the +-- properties to be animated. The interval and the animated properties +-- can be updated at runtime. +-- +-- The 'actorAnimate' and relative family of functions provide an easy +-- way to animate an 'Actor' and automatically manage the lifetime of +-- a 'Animation' instance, so you should consider using those +-- functions instead of manually creating an animation. +-- +-- [@Returns@] the newly created 'Animation' +-- +-- * Since 1.0 +-- +animationNew :: (GObjectClass obj) => IO (Animation obj) +animationNew = liftM (mkAnimation (undefined :: obj)) (newAnimationRaw =<< {# call unsafe animation_new #}) + + + +-- | Attaches animation to object. The old animation should not be +-- used after setting a new object. +-- +-- [@animation@] an 'Animation' +-- +-- [@object@] a GObject +-- +-- [@Returns@] The new animation associated with object. +-- +-- * Since 1.0 +-- +animationSetObject :: (GObjectClass obj) => Animation a -> obj -> IO () +animationSetObject anim obj = withAnimation anim $ \animPtr -> + withGObject obj $ \objPtr -> do + {# call unsafe animation_set_object #} animPtr objPtr + + +-- | Retrieves the GObject attached to animation. +-- +-- [@animation@] an Animation +-- +-- [@Returns@] a GObject +-- +-- * Since 1.0 +-- +animationGetObject :: (GObjectClass obj) => Animation obj -> IO obj +animationGetObject anim = withAnimation anim $ \animPtr -> + liftM unsafeCastGObject (newGObject =<< {# call unsafe animation_get_object #} animPtr) + +-- | Sets the animation mode of animation. The animation mode is a +-- logical id, either coming from the ClutterAnimationMode +-- enumeration or the return value of clutter_alpha_register_func(). +-- +-- This function will also set 'alpha' if needed. +-- +-- [@animation@] an 'Animation' +-- +-- [@mode@] an animation mode logical id +-- +-- * Since 1.0 +-- +{# fun unsafe animation_set_mode as ^ + { withAnimation* `Animation a', cFromEnum `AnimationMode' } -> `()' #} + + +-- | Retrieves the animation mode of animation, as set by +-- 'animationSetMode'. +-- +-- [@animation@] an 'Animation' +-- +-- [@Returns@] the mode for the animation +-- +-- * Since 1.0 +-- +{# fun unsafe animation_get_mode as ^ { withAnimation* `Animation a' } -> `AnimationMode' cToEnum #} + + +--CHECKME: Set a gint, get out a guint? +-- | Sets the duration of animation in milliseconds. +-- +-- This function will set "alpha" and "timeline" if needed. +-- +-- [@animation@] an 'Animation' +-- +-- [@msecs@] the duration in milliseconds +-- +-- * Since 1.0 +-- +{# fun unsafe animation_set_duration as ^ { withAnimation* `Animation a', `Int' } -> `()' #} + +-- | Retrieves the duration of animation, in milliseconds. +-- +-- [@animation@] an 'Animation' +-- +-- [@Returns@] the duration of the animation +-- +-- * Since 1.0 +-- +{# fun unsafe animation_get_duration as ^ { withAnimation* `Animation a' } -> `Int' #} + + +-- | Sets the 'Timeline' used by animation. +-- +-- [@animation@] an 'Animation' +-- +-- [@timeline@] @Just@ a 'Timeline', or @Nothing@ to unset the current +-- 'Timeline' +-- +-- * Since 1.0 +-- +{# fun unsafe animation_set_timeline as ^ + { withAnimation* `Animation a', withMaybeTimeline* `Maybe Timeline' } -> `()' #} + + +--CHECKME: Return Null? +-- | Retrieves the 'Timeline' used by animation +-- +-- [@animation@] an 'Animation' +-- +-- [@Returns@] the timeline used by the animation. +-- +-- * Since 1.0 +-- +{# fun unsafe animation_get_timeline as ^ + { withAnimation* `Animation a' } -> `Maybe Timeline' maybeNewTimeline* #} + + +--CHECKME: animation ownership and nothing? +-- | Sets alpha as the 'Alpha' used by animation. +-- +-- If alpha is not @Nothing@, the 'Animation' will take ownership of +-- the 'Alpha' instance. +-- +-- [@animation@] an 'Animation' +-- +-- [@alpha@] @Just@ an 'Alpha', or @Nothing@ to unset the current +-- 'Alpha' +-- +-- * Since 1.0 +-- +{# fun unsafe animation_set_alpha as ^ + { withAnimation* `Animation a', withMaybeAlpha* `Maybe Alpha' } -> `()' #} + +-- | Retrieves the 'Alpha' used by animation. +-- +-- [@animation@] an 'Animation' +-- +-- [@Returns@] the alpha object used by the animation. +-- +-- * Since 1.0 +-- +{# fun unsafe animation_get_alpha as ^ + { withAnimation* `Animation a' } -> `Maybe Alpha' maybeNewAlpha* #} + + +-- | Sets whether animation should loop over itself once finished. +-- +-- A looping 'Animation' will not emit the 'completed' signal when +-- finished. +-- +-- This function will set "alpha" and "timeline" if needed. +-- +-- [@animation@] an 'Animation' +-- +-- [@loop@] @True@ if the animation should loop +-- +-- * Since 1.0 +-- +{# fun unsafe animation_set_loop as ^ { withAnimation* `Animation a', `Bool' } -> `()' #} + +-- | Retrieves whether animation is looping. +-- +-- [@animation@] an 'Animation' +-- +-- [@Returns@] @True@ if the animation is looping +-- +-- * Since 1.0 +-- +{# fun unsafe animation_get_loop as ^ { withAnimation* `Animation a' } -> `Bool' #} + + +--CHECKME: Referencing +-- | Emits the ::'completed' signal on animation +-- +-- [@animation@] an 'Animation' +-- +-- * Since 1.0 +-- +{# fun animation_completed as ^ { withAnimation* `Animation a' } -> `()' #} + + +--FIXME: Use AnimOp +--Says it returns the Animation as a convenience for language bindings. +--This is convenient to me how? +-- | Adds a single property with name property_name to the animation +-- animation. For more information about animations, see 'animate'. +-- +-- This method returns the animation primarily to make chained calls +-- convenient in language bindings. +-- +-- +-- [@animation@] an 'Animation' +-- +-- [@property@] the property to control and it's final value +-- +-- [@Returns@] The animation itself +-- +-- * Since 1.0 +-- +animationBind :: Animation a -> AnimOp b -> IO (Animation a) +animationBind anim (attr :-> val) = let func = {# call unsafe animation_bind #} + str = P.show attr + in withAnimation anim $ \animPtr -> + withCString str $ \strPtr -> + withGenericValue val $ \valPtr -> + liftM (mkAnimation (undefined ::a)) + (newAnimationRaw =<< func animPtr strPtr valPtr) + + +-- | Binds interval to the property_name of the GObject attached to +-- animation. The 'Animation' will take ownership of the passed +-- 'Interval'. For more information about animations, see 'animate'. +-- +-- If you need to update the interval instance use +-- 'animationUpdateProperty' instead. +-- +-- [@animation@] an 'Animation' +-- +-- [@property@] the property to control +-- +-- [@interval@] an 'Interval' +-- +-- [@Returns@] The animation itself +-- +-- * Since 1.0 +-- +animationBindInterval :: (GObjectClass obj) => Animation obj -> Attr obj o -> Interval o -> IO (Animation obj) +animationBindInterval anim attr interval = let func = {# call unsafe animation_bind_interval #} + str = P.show attr + in withAnimation anim $ \animPtr -> + withInterval interval $ \iPtr -> + withCString str $ \strPtr -> + liftM (mkAnimation (undefined :: obj)) (newAnimationRaw =<< func animPtr strPtr iPtr) + + +-- | Changes the interval for property. +-- +-- [@animation@] an 'Animation' +-- +-- [@property@] name of the property +-- +-- [@interval@] a 'Interval' +-- +-- * Since 1.0 +-- +animationUpdateInterval :: Animation a -> Attr a b -> Interval b -> IO () +animationUpdateInterval anim attr interval = let func = {# call unsafe animation_update_interval #} + str = P.show attr + in withAnimation anim $ \animPtr -> + withCString str $ \strPtr -> + withInterval interval $ \iPtr -> + func animPtr strPtr iPtr + + +-- | Checks whether animation is controlling property. +-- +-- [@animation@] an 'Animation' +-- +-- [@property@] the attribute +-- +-- [@Returns@] @True@ if the property is animated by the 'Animation', +-- @False@ otherwise +-- +-- * Since 1.0 +-- +animationHasProperty :: Animation a -> Attr a b -> IO Bool +animationHasProperty anim attr = withAnimation anim $ \animPtr -> + withCString (P.show attr) $ \strPtr -> + liftM cToBool $ {# call unsafe animation_has_property #} animPtr strPtr + +--CHECKME: unsafe? +-- | Removes property from the list of animated properties. +-- +-- [@animation@] an 'Animation' +-- +-- [@property@] the attribute +-- +-- * Since 1.0 +-- +animationUnbindProperty :: Animation a -> Attr a b -> IO () +animationUnbindProperty anim attr = withAnimation anim $ \animPtr -> + withCString (P.show attr) $ \strPtr -> + {# call unsafe animation_unbind_property #} animPtr strPtr + +--The type of the interval should be set when you create it, and +--should be the same as the type of the corresponding attribute, so +--I'm assuming that bad things aren't happening in clutter. This +--needs a good testing. + +-- | Retrieves the 'Interval' associated to property_name inside +-- animation. +-- +-- [@animation@] an 'Animation' +-- +-- [@property@] An attribute +-- +-- [@Returns@] the 'Interval' +-- +-- * Since 1.0 +-- +animationGetInterval :: (GObjectClass a) => Animation a -> Attr a b -> IO (Interval b) +animationGetInterval anim attr = let func = {# call unsafe animation_get_interval #} + str = P.show attr + in withAnimation anim $ \animPtr -> + withCString str $ \strPtr -> + liftM + (mkInterval (undefined :: b)) + (newIntervalRaw =<< func animPtr strPtr) + + +-- | Retrieves the 'Animation' used by actor, if 'animate' has been +-- called on actor. +-- +-- [@actor@] an Actor +-- +-- [@Returns@] @Just@ an 'Animation', or @Nothing@. transfer none. +-- +-- * Since 1.0 +-- +actorGetAnimation :: (ActorClass a) => a -> IO (Maybe (Animation a)) +actorGetAnimation actor = withActorClass actor $ \actorPtr -> do + raw <- {# call unsafe actor_get_animation #} actorPtr + if raw == nullPtr + then return P.Nothing + else newAnimationRaw raw >>= return . Just . mkAnimation (undefined :: a) + + +--onCompleted, afterCompleted :: (GObjectClass a) => Animation a -> IO () -> IO (ConnectId (Animation a)) + +-- | The ::'completed' signal is emitted once the animation has been +-- completed. +-- +-- The animation instance is guaranteed to be valid for the entire +-- duration of the signal emission chain. +-- +-- * Since 1.0 +-- +--completed :: (GObjectClass a) => Signal (Animation a) (IO ()) + +--onStarted, afterStarted :: (GObjectClass a) => Animation a -> IO () -> IO (ConnectId (Animation a)) + + +-- | The ::started signal is emitted once the animation has been +-- started +-- +-- * Since 1.0 +-- +--started :: (GObjectClass a) => Signal (Animation a) (IO ()) + +-- CHECKME? allow WriteAttr? Also, Animatable class? Not all +--attributes animatable. Especially the convenient ones I added like +--position and size +--TODO: Rename to be more general, since other stuff uses it too +--data AnimOp o = forall a b. ReadWriteAttr o a b :-> b +data AnimOp o = forall a b. (GenericValueClass b) => ReadWriteAttr o a b :-> b + +infixr 0 :-> + +--TODO: Rename these +toListAnim :: (ActorClass o) => [AnimOp o] -> ([String], [GenericValue]) +toListAnim = foldr step ([], []) + where step (attr :-> val) (strs, vals) = (show attr:strs, toGenericValue val:vals) + + + +-- | Animates the given list of attributes of actor between the +-- current value for each property and a new final value. The +-- animation has a definite duration and a speed given by the mode. +-- +-- +-- * Warning +-- +-- Unlike clutter_actor_animate(), this function will not allow you to +-- specify "signal::" names and callbacks. +-- +-- [@actor@] an Actor +-- +-- [@mode@] an animation mode logical id +-- +-- [@duration@] duration of the animation, in milliseconds +-- +-- [@anim ops@] A list of attributes associated with their final +-- values. +-- +-- * Since 1.0 +-- +animate :: (ActorClass actor) => actor -> AnimationMode -> Int -> [AnimOp actor] -> IO (Animation actor) +animate _ _ _ [] = error "Need arguments to animate" +animate actor mode duration us = + let (names, gvals) = toListAnim us + animatev = {# call actor_animatev #} + cmode = cFromEnum mode + cdur = cIntConv duration + in + withMany withCString names $ \cstrs -> + withArrayLen cstrs $ \len strptr -> + withActorClass actor $ \actptr -> + withArray gvals $ \gvPtr -> do + ret <- animatev actptr cmode cdur (cIntConv len) strptr gvPtr + foldM_ unsetOneGVal gvPtr gvals + raw <- newAnimationRaw ret + return (mkAnimation (undefined :: actor) raw) + + + +-- | Animates the given list of properties of actor between the +-- current value for each property and a new final value. The +-- animation has a definite behaviour given by the passed alpha. +-- +-- See 'animate' for further details. +-- +-- This function is useful if you want to use an existing 'Alpha' to animate actor. +-- +-- * Warning +-- +-- Unlike clutter_actor_animate_with_alpha(), this function will not +-- allow you to specify "signal::" names and callbacks. +-- +-- [@actor@] an Actor +-- +-- [@alpha@] an Alpha +-- +-- [@anim ops@] A list of attributes associated with their final +-- values. +-- +-- * Since 1.0 +-- +animateWithAlpha :: (ActorClass actor) => actor -> Alpha -> [AnimOp actor] -> IO (Animation actor) +animateWithAlpha _ _ [] = error "Need arguments to animate with alpha" +animateWithAlpha actor alpha us = + let (names, gvals) = toListAnim us + animatev = {# call actor_animate_with_alphav #} + in + withMany withCString names $ \cstrs -> + withArrayLen cstrs $ \len strptr -> + withActorClass actor $ \actptr -> + withAlpha alpha $ \alphptr -> + withArray gvals $ \gvPtr -> do + ret <- animatev actptr alphptr (cIntConv len) strptr gvPtr + foldM_ unsetOneGVal gvPtr gvals + raw <- newAnimationRaw ret + return (mkAnimation (undefined :: actor) raw) + + +-- | Animates the given list of properties of actor between the +-- current value for each property and a new final value. The +-- animation has a definite duration given by timeline and a speed +-- given by the mode. +-- +-- See 'animate for further details. +-- +-- This function is useful if you want to use an existing timeline to +-- animate actor. +-- +-- [@actor@] an Actor +-- +-- [@mode@] an animation mode logical id +-- +-- [@timeline@] a 'Timeline' +-- +-- [@anim ops@] A list of attributes associated with their final +-- values. +-- +-- * Since 1.0 +-- +animateWithTimeline :: (ActorClass actor) => + actor + -> AnimationMode + -> Timeline + -> [AnimOp actor] + -> IO (Animation actor) +animateWithTimeline _ _ _ [] = error "Need arguments to animate with timeline" +animateWithTimeline actor mode tml us = + let (names, gvals) = toListAnim us + animatev = {# call actor_animate_with_timelinev #} + cmode = cFromEnum mode + in + withMany withCString names $ \cstrs -> + withArrayLen cstrs $ \len strptr -> + withActorClass actor $ \actptr -> + withTimeline tml $ \tmlptr -> + withArray gvals $ \gvPtr -> do + ret <- animatev actptr cmode tmlptr (cIntConv len) strptr gvPtr + foldM_ unsetOneGVal gvPtr gvals + raw <- newAnimationRaw ret + return (mkAnimation (undefined :: actor) raw) + + +-- | the alpha object used by the animation. +-- +-- * Since 1.0 +-- +animationAlpha :: Attr (Animation a) (Maybe Alpha) +animationAlpha = newNamedAttr "alpha" animationGetAlpha animationSetAlpha + + +-- | The duration of the animation, expressed in milliseconds. +-- +-- Default value: 0 +-- +-- * Since 1.0 +-- +animationDuration :: Attr (Animation a) Int +animationDuration = newNamedAttr "duration" animationGetDuration animationSetDuration + + +-- | Whether the animation should loop. +-- +-- Default value: @False@ +-- +-- * Since 1.0 +-- +animationLoop :: Attr (Animation a) Bool +animationLoop = newNamedAttr "loop" animationGetLoop animationSetLoop + + +-- | The animation mode, either a value from 'AnimationMode' or a +-- value returned by clutter_alpha_register_func(). The default +-- value is 'Linear'. +-- +-- * Since 1.0 +-- +animationMode :: Attr (Animation a) AnimationMode +animationMode = newAttr animationGetMode animationSetMode + +-- | Retrieves the 'Animation' used by actor, if 'animate' has been +-- called on actor. +actorAnimation :: (ActorClass actor) => ReadAttr actor (Maybe (Animation actor)) +actorAnimation = readAttr actorGetAnimation + +-- | Object to which the animation applies. +-- +animationObject :: (GObjectClass a) => Attr (Animation a) a +animationObject = newNamedAttr "object" animationGetObject animationSetObject + + +-- | The ClutterTimeline used by the animation. +-- +-- * Since 1.0 +-- +animationTimeline :: Attr (Animation a) (Maybe Timeline) +animationTimeline = newNamedAttr "timeline" animationGetTimeline animationSetTimeline + + +instance (GObjectClass a) => Playable (Animation a) where + started = Signal (connect_NONE__NONE "started") + onStarted = connect_NONE__NONE "started" False + afterStarted = connect_NONE__NONE "started" True + completed = Signal (connect_NONE__NONE "completed") + onCompleted = connect_NONE__NONE "completed" False + afterCompleted = connect_NONE__NONE "completed" True + paused = Signal (connect_NONE__NONE "paused") + onPaused = connect_NONE__NONE "paused" False + afterPaused = connect_NONE__NONE "paused" True + + diff --git a/Graphics/UI/Clutter/Behaviour.chs b/Graphics/UI/Clutter/Behaviour.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Behaviour.chs @@ -0,0 +1,291 @@ +-- -*-haskell-*- +-- Clutter Behaviour +-- +-- Author : Matthew Arsenault +-- +-- Created: 2 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | Class for providing behaviours to actors +module Graphics.UI.Clutter.Behaviour ( +-- * Description + +-- | 'Behaviour' is the base class for implementing behaviours. A +-- behaviour is a controller object for Actors; you can use a +-- behaviour to control one or more properties of an actor (such as +-- its opacity, or its position). A 'Behaviour' is driven by an +-- "alpha function" stored inside a 'Alpha' object; an alpha +-- function is a function depending solely on time. The alpha +-- function computes a value which is then applied to the properties +-- of the actors driven by a behaviour. +-- +-- Clutter provides some pre-defined behaviours, like +-- 'BehaviourPath', which controls the position of a set of actors +-- making them "walk" along a set of nodes; 'BehaviourOpacity', +-- which controls the opacity of a set of actors; 'BehaviourScale', +-- which controls the width and height of a set of actors. +-- +-- To visualize the effects of different alpha functions on a +-- 'Behaviour' implementation it is possible to take the +-- 'BehaviourPath' as an example: +-- +-- * Figure 4. Effects of alpha functions on a path +-- <> +-- +-- The actors position between the path's end points directly +-- correlates to the ClutterAlpha's current alpha value driving the +-- behaviour. With the ClutterAlpha's function set to 'AlphaRampInc' +-- the actor will follow the path at a constant velocity, but when +-- changing to 'AlphaSineInc' the actor initially accelerates before +-- quickly decelerating. +-- +-- In order to implement a new behaviour you should subclass +-- 'Behaviour' and override the "alpha_notify" virtual function; +-- inside the overridden function you should obtain the alpha value +-- from the 'Alpha' instance bound to the behaviour and apply it +-- to the desiderd property (or properties) of every actor controlled +-- by the behaviour. +-- +-- 'Behaviour' is available since Clutter 0.2 +-- + +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Behaviour' +-- | +----'BehaviourDepth' +-- | +----'BehaviourEllipse' +-- | +----'BehaviourOpacity' +-- | +----'BehaviourPath' +-- | +----'BehaviourRotate' +-- | +----'BehaviourScale' +-- @ + +-- * Types + Behaviour, + BehaviourClass, + BehaviourForeachFunc, + +-- * Methods + behaviourApply, + behaviourRemove, + behaviourRemoveAll, + behaviourIsApplied, + behaviourActorsForeach, + behaviourGetActors, --Set actors?? + behaviourGetNActors, + behaviourGetNthActor, + behaviourGetAlpha, + behaviourSetAlpha, + +-- * Attributes + behaviourAlpha, + +-- * Signals + onApplied, + afterApplied, + applied, + onRemoved, + afterRemoved, + removed + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Signals #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import System.Glib.Attributes + +-- | Applies behave to actor. This function adds a reference on the actor. +-- +-- [@behave@] a Behaviour +-- +-- [@actor@] an Actor +-- +-- * Since 0.2 +-- +{# fun unsafe behaviour_apply as ^ `(BehaviourClass behave, ActorClass actor)' => + { withBehaviourClass* `behave', withActorClass* `actor' } -> `()' #} + + +-- | Removes actor from the list of Actors to which behave +-- applies. This function removes a reference on the actor. +-- +-- [@behave@] a Behaviour +-- +-- [@actor@] an Actor +-- +-- * Since 0.2 +-- +{# fun unsafe behaviour_remove as ^ `(BehaviourClass behave, ActorClass actor)' => + { withBehaviourClass* `behave', withActorClass* `actor' } -> `()' #} + + +-- | Removes every actor from the list that behave holds. +-- +-- [@behave@] a Behaviour +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_remove_all as ^ `(BehaviourClass behave)' => + { withBehaviourClass* `behave' } -> `()' #} + + +-- | Check if behave applied to actor. +-- +-- [@behave@] a Behaviour +-- +-- [@actor@] an Actor +-- +-- [@Returns@] @True@ if actor has behaviour. @False@ otherwise. +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_is_applied as ^ `(BehaviourClass behave, ActorClass actor)' => + { withBehaviourClass* `behave', withActorClass* `actor' } -> `Bool' #} + + +-- | Calls func for every actor driven by behave. +-- +-- [@behave@] a Behaviour +-- +-- [@func@] a function called for each actor +-- +-- * Since 0.2 +-- +behaviourActorsForeach :: (BehaviourClass behave) => behave -> BehaviourForeachFunc -> IO () +behaviourActorsForeach b func = withBehaviourClass b $ \bptr -> do + funcPtr <- newBehaviourForeachFunc func + {# call unsafe behaviour_actors_foreach #} bptr funcPtr nullPtr + freeHaskellFunPtr funcPtr + --CHECKME: unsafe? + +--TODO: We could make a rw attribute even though clutter doesn't do that. +-- | Retrieves all the actors to which behave applies. It is not +-- recommended for derived classes to use this in there alpha notify +-- method but use behaviourActorsForeach as it avoids alot of +-- needless allocations. +-- +-- [@behave@] a Behaviour +-- +-- [@Returns@] a list of actors to which the behaviour applies. +-- +-- * Since 0.2 +-- +{# fun unsafe behaviour_get_actors as ^ + `(BehaviourClass behave)' => { withBehaviourClass* `behave' } -> `[Actor]' newActorList* #} + +-- | Gets an actor the behaviour was applied to referenced by index +-- num. +-- +-- [@behave@] a Behaviour +-- +-- [@index@] the index of an actor to which this behaviour is applied. +-- +-- [@Returns@] an @Just@ an Actor, or @Nothing@ if index is invalid. +-- +-- * Since 0.2 +-- +{# fun unsafe behaviour_get_nth_actor as ^ + `(BehaviourClass behave)' => { withBehaviourClass* `behave', `Int' } -> `Maybe Actor' maybeNewActor* #} + +-- | Gets the number of actors this behaviour is applied too. +-- +-- [@behave@] a Behaviour +-- +-- [@Returns@] The number of applied actors +-- +-- * Since 0.2 +-- +{# fun unsafe behaviour_get_n_actors as ^ + `(BehaviourClass behave)' => { withBehaviourClass* `behave' } -> `Int' #} + +-- | Retrieves the 'Alpha' object bound to behave. +-- +-- [@behave@] a 'Behaviour' +-- +-- [@Returns@] @Just@ The Alpha or @Nothing@ +-- +-- * Since 0.2 +-- +{# fun unsafe behaviour_get_alpha as ^ + `(BehaviourClass behave)' => { withBehaviourClass* `behave' } -> `Maybe Alpha' maybeNewAlpha* #} + +-- | Binds alpha to a Behaviour. The 'Alpha' object is what makes a +-- behaviour work: for each tick of the timeline used by 'Alpha' a +-- new value of the alpha parameter is computed by the alpha +-- function; the value should be used by the 'Behaviour' to update +-- one or more properties of the actors to which the behaviour +-- applies. +-- +-- | If alpha is not @Nothing@, the Behaviour will take ownership of +-- the 'Alpha' instance. +-- +-- [@behave@] a Behaviour +-- +-- [@alpha@] @Just@ an Alpha or @Nothing@ to unset a previously set α +-- +-- * Since 0.2 +-- +{# fun unsafe behaviour_set_alpha as ^ + `(BehaviourClass behave)' => { withBehaviourClass* `behave', withMaybeAlpha* `Maybe Alpha' } -> `()' #} + + + +-- | The 'Α' object used to drive this behaviour. An 'Alpha' object +-- binds a 'Timeline' and a function which computes a value (the +-- "alpha") depending on the time. Each time the alpha value changes +-- the alpha-notify virtual function is called. +-- +-- * Since 0.2 +-- +behaviourAlpha :: (BehaviourClass self) => Attr self (Maybe Alpha) +behaviourAlpha = newNamedAttr "alpha" behaviourGetAlpha behaviourSetAlpha + +onApplied, afterApplied :: (BehaviourClass behave) => behave -> (Actor -> IO ()) -> IO (ConnectId behave) +onApplied = connect_OBJECT__NONE "applied" False +afterApplied = connect_OBJECT__NONE "applied" True + + +-- | The ::apply signal is emitted each time the behaviour is applied to an actor. +-- +-- [@actor@] the actor the behaviour was applied to. +-- +-- * Since 0.4 +-- +applied :: (BehaviourClass behave) => Signal behave (Actor ->IO ()) +applied = Signal (connect_OBJECT__NONE "applied") + + +onRemoved, afterRemoved :: (BehaviourClass behave) => behave -> (Actor -> IO ()) -> IO (ConnectId behave) +onRemoved = connect_OBJECT__NONE "removed" False +afterRemoved = connect_OBJECT__NONE "removed" True + + +-- | The ::removed signal is emitted each time a behaviour is not +-- applied to an actor anymore. +-- +-- [@actor@] the removed actor +-- +removed :: (BehaviourClass behave) => Signal behave (Actor ->IO ()) +removed = Signal (connect_OBJECT__NONE "removed") + diff --git a/Graphics/UI/Clutter/BehaviourDepth.chs b/Graphics/UI/Clutter/BehaviourDepth.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/BehaviourDepth.chs @@ -0,0 +1,104 @@ +-- -*-haskell-*- +-- Clutter BehaviourDepth +-- +-- Author : Matthew Arsenault +-- +-- Created: 3 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | BehaviourDepth — A behaviour controlling the Z position +module Graphics.UI.Clutter.BehaviourDepth ( +-- * Description +-- | 'BehaviourDepth' is a simple 'Behaviour' controlling the depth of a +-- set of actors between a start and end depth. +-- +-- 'BehaviourDepth' is available since Clutter 0.4. + +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Behaviour' +-- | +----'BehaviourDepth' +-- | +-- @ + +-- * Types + BehaviourDepth, + BehaviourDepthClass, + +-- * Constructors + behaviourDepthNew, + +-- * Methods + behaviourDepthSetBounds, + behaviourDepthGetBounds + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS + +-- | Creates a new 'BehaviourDepth' which can be used to control +-- the 'Actor':depth property of a set of Actors. +-- +-- [@alpha@] @Just@ an Alpha or @Nothing@ +-- +-- [@depth_start@] initial value of the depth +-- +-- [@depth_end@] final value of the depth +-- +-- [@Returns@] the newly created behaviour +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_depth_new as ^ + { withMaybeAlpha* `Maybe Alpha', `Int', `Int' } -> `BehaviourDepth' newBehaviourDepth* #} + + +-- | Sets the boundaries of the behaviour. +-- +-- [@behaviour@] a 'BehaviourDepth' +-- +-- [@depth_start@] initial value of the depth +-- +-- [@depth_end@] final value of the depth +-- +-- * Since 0.6 +-- +{# fun unsafe behaviour_depth_set_bounds as ^ + { withBehaviourDepth* `BehaviourDepth', `Int', `Int' } -> `()' #} + + +-- | Gets the boundaries of the behaviour +-- +-- [@behaviour@] a 'BehaviourDepth' +-- +-- [@Returns@] (depth_start, depth_end) +-- +-- * Since 0.6 +-- +{# fun unsafe behaviour_depth_get_bounds as ^ + { withBehaviourDepth* `BehaviourDepth', + alloca- `Int' peekIntConv*, + alloca- `Int' peekIntConv* + } -> `()' #} + diff --git a/Graphics/UI/Clutter/BehaviourEllipse.chs b/Graphics/UI/Clutter/BehaviourEllipse.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/BehaviourEllipse.chs @@ -0,0 +1,431 @@ +-- -*-haskell-*- +-- Clutter BehaviourEllipse +-- +-- Author : Matthew Arsenault +-- +-- Created: 3 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.BehaviourEllipse ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Behaviour' +-- | +----BehaviourEllipse +-- | +-- @ + +-- * Types + BehaviourEllipse, + BehaviourEllipseClass, + +-- * Constructors + behaviourEllipseNew, + +-- * Methods + behaviourEllipseSetCenter, + behaviourEllipseGetCenter, + + behaviourEllipseSetAngleStart, + behaviourEllipseGetAngleStart, + behaviourEllipseSetAngleEnd, + behaviourEllipseGetAngleEnd, + + behaviourEllipseSetAngleTilt, + behaviourEllipseGetAngleTilt, + + behaviourEllipseSetHeight, + behaviourEllipseGetHeight, + + behaviourEllipseSetWidth, + behaviourEllipseGetWidth, + + behaviourEllipseSetTilt, + behaviourEllipseGetTilt, + behaviourEllipseSetDirection, + behaviourEllipseGetDirection, + +-- * Attributes + behaviourEllipseAngleEnd, + behaviourEllipseAngleStart, + behaviourEllipseAngleTiltX, + behaviourEllipseAngleTiltY, + behaviourEllipseAngleTiltZ, + behaviourEllipseCenter, + behaviourEllipseDirection, + behaviourEllipseHeight, + behaviourEllipseWidth + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import System.Glib.Attributes +import System.Glib.Properties + +-- | Creates a behaviour that drives actors along an elliptical path +-- with given center, width and height; the movement starts at start +-- degrees (with 0 corresponding to 12 o'clock) and ends at end +-- degrees. Angles greated than 360 degrees get clamped to the +-- canonical interval <0, 360); if start is equal to end, the +-- behaviour will rotate by exacly 360 degrees. +-- +-- [@alpha@] @Just@ an 'Alpha', or @Nothing@ +-- +-- [@x@] x coordinates of the center +-- +-- [@y@] y coordinates of the center +-- +-- [@width@] width of the ellipse +-- +-- [@height@] height of the ellipse +-- +-- [@direction@] 'RotateDirection' of rotation +-- +-- [@start@] angle in degrees at which movement starts, between 0 and 360 +-- +-- [@end@] angle in degrees at which movement ends, between 0 and 360 +-- +-- [@Returns@] the newly created 'BehaviourEllipse' +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_ellipse_new as ^ + { withMaybeAlpha* `Maybe Alpha', + `Int', + `Int', + `Int', + `Int', + cFromEnum `RotateDirection', + `Double', + `Double' + } -> `BehaviourEllipse' newBehaviourEllipse* #} + +-- | Sets the center of the elliptical path to the point represented by knot. +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@x@] x coordinate of the center +-- +-- [@y@] y coordinate of the center +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_ellipse_set_center as ^ + { withBehaviourEllipse* `BehaviourEllipse', `Int', `Int' } -> `()' #} + + +-- | Gets the center of the elliptical path path. +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@Returns@] (X coordinate of the center, Y coordinate of the center) +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_ellipse_get_center as ^ + { withBehaviourEllipse* `BehaviourEllipse', + alloca- `Int' peekIntConv*, + alloca- `Int' peekIntConv* } -> `()' #} + + +-- | Sets the angle at which movement starts; angles \>= 360 degress +-- get clamped to the canonical interval <0, 360). +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@angle_start@] angle at which movement starts in degrees, between 0 and 360. +-- +-- * Since 0.6 +-- +{# fun unsafe behaviour_ellipse_set_angle_start as ^ + { withBehaviourEllipse* `BehaviourEllipse', `Double' } -> `()' #} + +-- | Gets the angle at which movements starts. +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@Returns@] angle in degrees +-- +-- * Since 0.6 +{# fun unsafe behaviour_ellipse_get_angle_start as ^ + { withBehaviourEllipse* `BehaviourEllipse' } -> `Double' #} + +-- | Sets the angle at which movement ends; angles \>= 360 degress get +-- clamped to the canonical interval <0, 360). +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@angle_end@] angle at which movement ends in degrees, between 0 and 360. +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_ellipse_set_angle_end as ^ + { withBehaviourEllipse* `BehaviourEllipse', `Double' } -> `()' #} + +-- | Gets the at which movements ends. +-- +-- [@self@] a 'BehaviourEllipse +-- +-- [@Returns@] angle in degrees +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_ellipse_get_angle_end as ^ + { withBehaviourEllipse* `BehaviourEllipse' } -> `Double' #} + +-- | Sets the angle at which the ellipse should be tilted around it's +-- center. +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@axis@] a 'RotateAxis' +-- +-- [@angle_tilt@] tilt of the elipse around the center in the given axis in degrees. +-- +-- * Since 0.4 +{# fun unsafe behaviour_ellipse_set_angle_tilt as ^ + { withBehaviourEllipse* `BehaviourEllipse', cFromEnum `RotateAxis', `Double' } -> `()' #} + +-- | Gets the tilt of the ellipse around the center in the given axis. +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@axis@] a 'RotateAxis' +-- +-- [@Returns@] angle in degrees. +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_ellipse_get_angle_tilt as ^ + { withBehaviourEllipse* `BehaviourEllipse', cFromEnum `RotateAxis' } -> `Double' #} + +-- | Sets the height of the elliptical path. +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@height@] height of the ellipse +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_ellipse_set_height as ^ + { withBehaviourEllipse* `BehaviourEllipse', `Int' } -> `()' #} + +-- | Gets the height of the elliptical path. +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@Returns@] the height of the path +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_ellipse_get_height as ^ + { withBehaviourEllipse* `BehaviourEllipse' } -> `Int' #} + + +-- | Sets the width of the elliptical path. +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@width@] width of the ellipse +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_ellipse_set_width as ^ + { withBehaviourEllipse* `BehaviourEllipse', `Int' } -> `()' #} + +-- | Gets the width of the elliptical path. +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@Returns@] the width of the path +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_ellipse_get_width as ^ + { withBehaviourEllipse* `BehaviourEllipse' } -> `Int' #} + + +-- | Sets the angles at which the ellipse should be tilted around it's +-- center. +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@angle_tilt_x@] tilt of the ellipse around the center in X axis in +-- degrees. +-- +-- [@angle_tilt_y@] tilt of the ellipse around the center in Y axis in +-- degrees. +-- +-- [@angle_tilt_z@] tilt of the ellipse around the center in Z axis in degrees. +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_ellipse_set_tilt as ^ + { withBehaviourEllipse* `BehaviourEllipse', + `Double', + `Double', + `Double' } -> `()' #} + + +-- | Gets the tilt of the ellipse around the center in Y axis. +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@Returns@] (tilt angle on the X axis, tilt angle on the Y axis, +-- tilt angle on the Z axis) +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_ellipse_get_tilt as ^ + { withBehaviourEllipse* `BehaviourEllipse', + alloca- `Double' peekFloatConv* , + alloca- `Double' peekFloatConv*, + alloca- `Double' peekFloatConv* + } -> `()' #} + + +-- | Sets the rotation direction used by the ellipse behaviour. +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@direction@] the rotation direction +-- +-- * Since 0.4 +{# fun unsafe behaviour_ellipse_set_direction as ^ + { withBehaviourEllipse* `BehaviourEllipse', cFromEnum `RotateDirection' } -> `()' #} + +-- | Retrieves the 'RotateDirection' used by the ellipse behaviour. +-- +-- [@self@] a 'BehaviourEllipse' +-- +-- [@Returns@] the rotation direction +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_ellipse_get_direction as ^ + { withBehaviourEllipse* `BehaviourEllipse' } -> `RotateDirection' cToEnum #} + +-- Attributes + + +-- | The final angle to where the rotation should end. +-- +-- Allowed values: [0,360] +-- +-- Default value: 0 +-- +-- * Since 0.4 +-- +behaviourEllipseAngleEnd :: Attr BehaviourEllipse Double +behaviourEllipseAngleEnd = newNamedAttr "angle-end" behaviourEllipseGetAngleEnd behaviourEllipseSetAngleEnd + + +-- | The initial angle from where the rotation should start. +-- +-- Allowed values: [0,360] +-- +-- Default value: 0 +-- +-- * Since 0.4 +-- +behaviourEllipseAngleStart :: Attr BehaviourEllipse Double +behaviourEllipseAngleStart = newNamedAttr "angle-start" behaviourEllipseGetAngleStart behaviourEllipseSetAngleStart + + +-- | The tilt angle for the rotation around center in X axis +-- +-- Allowed values: [0,360] +-- +-- Default value: 360 +-- +-- * Since 0.4 +-- +behaviourEllipseAngleTiltX :: Attr BehaviourEllipse Double +behaviourEllipseAngleTiltX = newAttrFromDoubleProperty "angle-tilt-x" + + +-- | The tilt angle for the rotation around center in Y axis +-- +-- Allowed values: [0,360] +-- +-- Default value: 360 +-- +-- * Since 0.4 +-- +behaviourEllipseAngleTiltY :: Attr BehaviourEllipse Double +behaviourEllipseAngleTiltY = newAttrFromDoubleProperty "angle-tilt-y" + + +-- | The tilt angle for the rotation on the Z axis +-- +-- Allowed values: [0,360] +-- +-- Default value: 360 +-- +-- * Since 0.4 +-- +behaviourEllipseAngleTiltZ :: Attr BehaviourEllipse Double +behaviourEllipseAngleTiltZ = newAttrFromDoubleProperty "angle-tilt-z" + +-- | The center of the ellipse. +-- +-- * Since 0.4 +-- +behaviourEllipseCenter :: Attr BehaviourEllipse Knot +behaviourEllipseCenter = newNamedAttr "center" behaviourEllipseGetCenter (uncurry . behaviourEllipseSetCenter) + + + +-- | The direction of the rotation. +-- +-- Default value: 'RotateCw' +-- +-- * Since 0.4 +-- +behaviourEllipseDirection :: Attr BehaviourEllipse RotateDirection +behaviourEllipseDirection = newNamedAttr "direction" behaviourEllipseGetDirection behaviourEllipseSetDirection + + +-- | Height of the ellipse, in pixels +-- +-- Allowed values: >= 0 +-- +-- Default value: 50 +-- +-- * Since 0.4 +-- +behaviourEllipseHeight :: Attr BehaviourEllipse Int +behaviourEllipseHeight = newNamedAttr "height" behaviourEllipseGetHeight behaviourEllipseSetHeight + +-- | Width of the ellipse, in pixels +-- +-- Allowed values: >= 0 +-- +-- Default value: 100 +-- +-- * Since 0.4 +-- +behaviourEllipseWidth :: Attr BehaviourEllipse Int +behaviourEllipseWidth = newNamedAttr "width" behaviourEllipseGetWidth behaviourEllipseSetWidth + + diff --git a/Graphics/UI/Clutter/BehaviourOpacity.chs b/Graphics/UI/Clutter/BehaviourOpacity.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/BehaviourOpacity.chs @@ -0,0 +1,131 @@ +-- -*-haskell-*- +-- Clutter BehaviourOpacity +-- +-- Author : Matthew Arsenault +-- +-- Created: 3 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface, TypeSynonymInstances #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.BehaviourOpacity ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Behaviour' +-- | +----'BehaviourOpacity' +-- | +-- @ + +-- * Types + BehaviourOpacity, + BehaviourOpacityClass, + +-- * Constructors + behaviourOpacityNew, + +-- * Methods + behaviourOpacitySetBounds, + behaviourOpacityGetBounds, + +-- * Attributes + behaviourOpacityOpacityEnd, + behaviourOpacityOpacityStart + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import System.Glib.Attributes +import System.Glib.Properties + +-- | Creates a new 'BehaviourOpacity' object, driven by alpha which +-- controls the opacity property of every actor, making it change in +-- the interval between opacity_start and opacity_end. +-- +-- [@alpha@] @Just@ an 'Alpha' or @Nothing@ +-- +-- [@opacity_start@] minimum level of opacity +-- +-- [@opacity_end@] maximum level of opacity +-- +-- [@Returns@] the newly created 'BehaviourOpacity' +-- +-- * Since 0.2 +-- +{# fun unsafe behaviour_opacity_new as ^ + { withMaybeAlpha* `Maybe Alpha', `Word8', `Word8'} -> `BehaviourOpacity' newBehaviourOpacity* #} + + +-- | Sets the initial and final levels of the opacity applied by +-- behaviour on each actor it controls. +-- +-- [@behaviour@] a 'BehaviourOpacity' +-- +-- [@opacity_start@] minimum level of opacity +-- +-- [@opacity_end@] maximum level of opacity +-- +-- * Since 0.6 +-- +{# fun unsafe behaviour_opacity_set_bounds as ^ + { withBehaviourOpacity* `BehaviourOpacity', `Word8', `Word8'} -> `()' #} + +-- | Gets the initial and final levels of the opacity applied by +-- behaviour on each actor it controls. +-- +-- [@behaviour@] a 'BehaviourOpacity' +-- +-- [@Returns@] (minimum level of opacity, maximum level of opacity) +-- +-- * Since 0.6 +-- +{# fun unsafe behaviour_opacity_get_bounds as ^ + { withBehaviourOpacity* `BehaviourOpacity', + alloca- `Word8' peekIntConv*, + alloca- `Word8' peekIntConv*} -> `()' #} + + + + +-- | Final opacity level of the behaviour. +-- +-- Allowed values: <= 255 +-- +-- Default value: 0 +-- +-- * Since 0.2 +-- +behaviourOpacityOpacityEnd :: Attr BehaviourOpacity Word +behaviourOpacityOpacityEnd = clutterNewAttrFromUIntProperty "opacity-end" + + + +-- | Initial opacity level of the behaviour. +-- +-- Allowed values: <= 255 +-- +-- Default value: 0 +-- +-- * Since 0.2 +-- +behaviourOpacityOpacityStart :: Attr BehaviourOpacity Word +behaviourOpacityOpacityStart = clutterNewAttrFromUIntProperty "opacity-start" + diff --git a/Graphics/UI/Clutter/BehaviourPath.chs b/Graphics/UI/Clutter/BehaviourPath.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/BehaviourPath.chs @@ -0,0 +1,108 @@ +-- -*-haskell-*- +-- Clutter BehaviourPath +-- +-- Author : Matthew Arsenault +-- +-- Created: 13 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface, TypeSynonymInstances #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.BehaviourPath ( +-- | +-- @ +-- | 'GObject' +-- | +----'Behaviour' +-- | +----'BehaviourPath' +-- | +-- @ + +-- * Types + BehaviourPath, + BehaviourPathClass, + Knot, + +-- * Constructors + behaviourPathNew, + behaviourPathNewWithDescription, + behaviourPathNewWithKnots, + +-- * Methods + + behaviourPathSetPath, + behaviourPathGetPath, + +-- * Attributes + behaviourPathPath, + +-- * Signals + onKnotReached, + afterKnotReached, + knotReached + +--knotCopy, --not needed +--knotFree, +--knotEqual + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Signals #} + +import C2HS +import System.Glib.Attributes + +{# fun unsafe behaviour_path_new as ^ + { withAlpha* `Alpha', withPath* `Path' } -> `BehaviourPath' newBehaviourPath* #} +{# fun unsafe behaviour_path_new_with_description as ^ + { withAlpha* `Alpha', `String' } -> `BehaviourPath' newBehaviourPath* #} + +--CHECKME: Again, why the casting from Ptr Knot to Ptr () +behaviourPathNewWithKnots :: Alpha -> [Knot] -> IO BehaviourPath +behaviourPathNewWithKnots alp knots = let func = {# call unsafe behaviour_path_new_with_knots #} + in withAlpha alp $ \aptr -> + withArrayLen knots $ \len knotptr -> + newBehaviourPath =<< func aptr (castPtr knotptr) (cIntConv len) + + +{# fun unsafe behaviour_path_set_path as ^ + { withBehaviourPath* `BehaviourPath', withPath* `Path'} -> `()' #} +{# fun unsafe behaviour_path_get_path as ^ + { withBehaviourPath* `BehaviourPath' } -> `Path' newPath* #} + +-- Attributes + +behaviourPathPath :: Attr BehaviourPath Path +behaviourPathPath = newNamedAttr "path" behaviourPathGetPath behaviourPathSetPath + + +onKnotReached, afterKnotReached :: BehaviourPath -> (Word -> IO ()) -> IO (ConnectId BehaviourPath) +onKnotReached = connect_WORD__NONE "knot_reached" False +afterKnotReached = connect_WORD__NONE "knot_reached" True + + +-- | This signal is emitted each time a node defined inside the path +-- is reached. +-- +-- [@knot_num@] the index of the 'PathKnot' reached +-- +-- * Since 0.2 +-- +knotReached :: Signal BehaviourPath (Word -> IO ()) +knotReached = Signal (connect_WORD__NONE "knot_reached") + + diff --git a/Graphics/UI/Clutter/BehaviourRotate.chs b/Graphics/UI/Clutter/BehaviourRotate.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/BehaviourRotate.chs @@ -0,0 +1,298 @@ +-- -*-haskell-*- +-- Clutter BehaviourRotate +-- +-- Author : Matthew Arsenault +-- +-- Created: 3 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + + +-- | BehaviourRotate — A behaviour controlling rotation +module Graphics.UI.Clutter.BehaviourRotate ( +-- * Description +-- | A 'BehaviourRotate' rotate actors between a starting and ending +-- angle on a given axis. +-- +-- 'BehaviourRotate' is available since version 0.4. +-- + +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Behaviour' +-- | +----'BehaviourRotate' +-- | +-- @ + +-- * Types + BehaviourRotate, + BehaviourRotateClass, + RotateAxis(..), + RotateDirection(..), + +-- * Constructors + behaviourRotateNew, + +-- * Methods + behaviourRotateSetAxis, + behaviourRotateGetAxis, + + behaviourRotateSetDirection, + behaviourRotateGetDirection, + + behaviourRotateSetBounds, + behaviourRotateGetBounds, + + behaviourRotateSetCenter, + behaviourRotateGetCenter, + +-- * Attributes + behaviourRotateAngleEnd, + behaviourRotateAngleStart, + behaviourRotateAxis, + behaviourRotateCenterX, + behaviourRotateCenterY, + behaviourRotateCenterZ, + behaviourRotateDirection + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import System.Glib.Attributes +import System.Glib.Properties + + +-- | Creates a new 'BehaviourRotate'. This behaviour will rotate +-- actors bound to it on axis, following direction, between +-- angle_start and angle_end. Angles >= 360 degrees will be clamped +-- to the canonical interval <0, 360), if angle_start == angle_end, +-- the behaviour will carry out a single rotation of 360 degrees. +-- +-- [@alpha@] @Just@ an 'Alpha', or @Nothing@ +-- +-- [@axis@] the rotation axis +-- +-- [@direction@] the rotation direction +-- +-- [@angle_start@] the starting angle in degrees, between 0 and 360. +-- +-- [@angle_end@] the final angle in degrees, between 0 and 360. +-- +-- [@Returns@] the newly created 'BehaviourRotate'. +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_rotate_new as ^ + { withMaybeAlpha* `Maybe Alpha', + cFromEnum `RotateAxis', + cFromEnum `RotateDirection', + `Double', + `Double' } -> + `BehaviourRotate' newBehaviourRotate* #} + + +-- | Sets the axis used by the rotate behaviour. +-- +-- [@rotate@] a 'BehaviourRotate' +-- +-- [@axis@] a 'RotateAxis' +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_rotate_set_axis as ^ + { withBehaviourRotate* `BehaviourRotate', cFromEnum `RotateAxis'} -> `()' #} + +-- | Retrieves the 'RotateAxis' used by the rotate behaviour. +-- +-- [@rotate@] a 'BehaviourRotate' +-- +-- [@Returns@] the rotation axis +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_rotate_get_axis as ^ + { withBehaviourRotate* `BehaviourRotate' } -> `RotateAxis' cToEnum #} + + +-- | Sets the rotation direction used by the rotate behaviour. +-- +-- [@rotate@] a 'BehaviourRotate' +-- +-- [@direction@] the rotation direction +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_rotate_set_direction as ^ + { withBehaviourRotate* `BehaviourRotate', cFromEnum `RotateDirection'} -> `()' #} + +-- | Retrieves the 'RotateDirection' used by the rotate behaviour. +-- +-- [@rotate@] a 'BehaviourRotate' +-- +-- [@Returns@] the rotation direction +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_rotate_get_direction as ^ + { withBehaviourRotate* `BehaviourRotate' } -> `RotateDirection' cToEnum #} + +-- | Sets the initial and final angles of a rotation behaviour; angles +-- \>= 360 degrees get clamped to the canonical interval <0, 360). +-- +-- [@rotate@] a 'BehaviourRotate' +-- +-- [@angle_start@] initial angle in degrees, between 0 and 360. +-- +-- [@angle_end@] final angle in degrees, between 0 and 360. +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_rotate_set_bounds as ^ + { withBehaviourRotate* `BehaviourRotate', `Double', `Double'} -> `()' #} + + +-- | Retrieves the rotation boundaries of the rotate behaviour. +-- +-- [@rotate@] a 'BehaviourRotate' +-- +-- [@Returns@] (angle_start, angle_end) +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_rotate_get_bounds as ^ + { withBehaviourRotate* `BehaviourRotate', + alloca- `Double' peekFloatConv*, + alloca- `Double' peekFloatConv* } -> `()' #} + + +-- | Sets the center of rotation. The coordinates are relative to the +-- plane normal to the rotation axis set with +-- 'behaviourRotateSetAxis'. +-- +-- [@rotate@] a 'BehaviourRotate' +-- +-- [@x@] X axis center of rotation +-- +-- [@y@] Y axis center of rotation +-- +-- [@z@] Z axis center of rotation +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_rotate_set_center as ^ + { withBehaviourRotate* `BehaviourRotate', `Int', `Int', `Int'} -> `()' #} + +-- | Retrieves the center of rotation set using +-- 'behaviourRotateSetCenter'. +-- +-- [@rotate@] a 'BehaviourRotate' +-- +-- [@Returns@] (X center of rotation, Y center of rotation, Z center of rotation) +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_rotate_get_center as ^ + { withBehaviourRotate* `BehaviourRotate', + alloca- `Int' peekIntConv*, + alloca- `Int' peekIntConv*, + alloca- `Int' peekIntConv* } -> `()' #} + + + +-- | The final angle to where the rotation should end. +-- +-- Allowed values: [0,360] +-- +-- Default value: 0 +-- +-- * Since 0.4 +-- +behaviourRotateAngleEnd :: Attr BehaviourRotate Double +behaviourRotateAngleEnd = newAttrFromDoubleProperty "angle-end" + + +-- | The initial angle from whence the rotation should start. +-- +-- Allowed values: [0,360] +-- +-- Default value: 0 +-- +-- * Since 0.4 +-- +behaviourRotateAngleStart :: Attr BehaviourRotate Double +behaviourRotateAngleStart = newAttrFromDoubleProperty "angle-start" + + +-- | The axis of rotation. +-- +-- Default value: 'ZAxis' +-- +-- * Since 0.4 +-- +behaviourRotateAxis :: Attr BehaviourRotate RotateAxis +behaviourRotateAxis = newNamedAttr "axis" behaviourRotateGetAxis behaviourRotateSetAxis + +-- | The x center of rotation. +-- +-- Allowed values: >= -2147483647 +-- +-- Default value: 0 +-- +-- * Since 0.4 +-- +behaviourRotateCenterX :: Attr BehaviourRotate Int +behaviourRotateCenterX = newAttrFromIntProperty "center-x" + + +-- | The y center of rotation. +-- +-- Allowed values: >= -2147483647 +-- +-- Default value: 0 +-- +-- * Since 0.4 +-- +behaviourRotateCenterY :: Attr BehaviourRotate Int +behaviourRotateCenterY = newAttrFromIntProperty "center-y" + + +-- | The z center of rotation. +-- +-- Allowed values: >= -2147483647 +-- +-- Default value: 0 +-- +-- * Since 0.4 +-- +behaviourRotateCenterZ :: Attr BehaviourRotate Int +behaviourRotateCenterZ = newAttrFromIntProperty "center-z" + +-- | The direction of the rotation. +-- +-- Default value: 'RotateCw' +-- +-- * Since 0.4 +-- +behaviourRotateDirection :: Attr BehaviourRotate RotateDirection +behaviourRotateDirection = newNamedAttr "direction" behaviourRotateGetDirection behaviourRotateSetDirection + diff --git a/Graphics/UI/Clutter/BehaviourScale.chs b/Graphics/UI/Clutter/BehaviourScale.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/BehaviourScale.chs @@ -0,0 +1,171 @@ +-- -*-haskell-*- +-- Clutter BehaviourScale +-- +-- Author : Matthew Arsenault +-- +-- Created: 2 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | BehaviourScale — A behaviour controlling scale +module Graphics.UI.Clutter.BehaviourScale ( +-- * Description +-- | A 'BehaviourScale' interpolates actors size between two values. + +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Behaviour' +-- | +----'BehaviourScale' +-- | +-- @ + +-- * Types + BehaviourScale, + BehaviourScaleClass, + +-- * Constructors + behaviourScaleNew, + +-- * Methods + behaviourScaleSetBounds, + behaviourScaleGetBounds, + +-- * Attributes + behaviourScaleXScaleEnd, + behaviourScaleXScaleStart, + behaviourScaleYScaleEnd, + behaviourScaleYScaleStart + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import Control.Monad (liftM) +import System.Glib.Attributes +import System.Glib.Properties + + +-- | Creates a new 'BehaviourScale' instance. +-- +-- [@alpha@] an 'Alpha' +-- +-- [@x_scale_start@] initial scale factor on the X axis +-- +-- [@y_scale_start@] initial scale factor on the Y axis +-- +-- [@x_scale_end@] final scale factor on the X axis +-- +-- [@y_scale_end@] final scale factor on the Y axis +-- +-- [@Returns@] the newly created 'BehaviourScale' +-- +-- * Since 0.2 +-- +{# fun unsafe behaviour_scale_new as ^ + { withAlpha* `Alpha', `Double', `Double', `Double', `Double'} -> + `BehaviourScale' newBehaviourScale* #} + + +-- | Sets the bounds used by scale behaviour. +-- +-- [@scale@] a 'BehaviourScale' +-- +-- [@x_scale_start@] initial scale factor on the X axis +-- +-- [@y_scale_start@] initial scale factor on the Y axis +-- +-- [@x_scale_end@] final scale factor on the X axis +-- +-- [@y_scale_end@] final scale factor on the Y axis +-- +-- * Since 0.6 +-- +{# fun unsafe behaviour_scale_set_bounds as ^ + { withBehaviourScale* `BehaviourScale', `Double', `Double', `Double', `Double'} -> `()' #} + +-- | Retrieves the bounds used by scale behaviour. +-- +-- [@scale@] a 'BehaviourScale' +-- +-- [@Returns@] (initial scale factor on the X axis, +-- initial scale factor on the Y axis, +-- final scale factor on the X axis, +-- final scale factor on the Y axis) +-- +-- * Since 0.4 +-- +{# fun unsafe behaviour_scale_get_bounds as ^ + { withBehaviourScale* `BehaviourScale', + alloca- `Double' peekFloatConv*, + alloca- `Double' peekFloatConv*, + alloca- `Double' peekFloatConv*, + alloca- `Double' peekFloatConv*} -> `()' #} + + + +-- | The final scaling factor on the X axis for the actors. +-- +-- Allowed values: >= 0 +-- +-- Default value: 1 +-- +-- * Since 0.6 +-- +behaviourScaleXScaleEnd :: Attr BehaviourScale Double +behaviourScaleXScaleEnd = newAttrFromDoubleProperty "x-scale-end" + + +-- | The initial scaling factor on the X axis for the actors. +-- +-- Allowed values: >= 0 +-- +-- Default value: 1 +-- +-- * Since 0.6 +-- +behaviourScaleXScaleStart :: Attr BehaviourScale Double +behaviourScaleXScaleStart = newAttrFromDoubleProperty "x-scale-start" + + +-- | The final scaling factor on the Y axis for the actors. +-- +-- Allowed values: >= 0 +-- +-- Default value: 1 +-- +-- * Since 0.6 +-- +behaviourScaleYScaleEnd :: Attr BehaviourScale Double +behaviourScaleYScaleEnd = newAttrFromDoubleProperty "y-scale-end" + + +-- | The initial scaling factor on the Y axis for the actors. +-- +-- Allowed values: >= 0 +-- +-- Default value: 1 +-- +-- * Since 0.6 +-- +behaviourScaleYScaleStart :: Attr BehaviourScale Double +behaviourScaleYScaleStart = newAttrFromDoubleProperty "y-scale-start" + diff --git a/Graphics/UI/Clutter/BindingPool.chs b/Graphics/UI/Clutter/BindingPool.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/BindingPool.chs @@ -0,0 +1,269 @@ +-- -*-haskell-*- +-- Clutter BindingPool +-- +-- Author : Matthew Arsenault +-- +-- Created: 11 Sep 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | Key Bindings — Pool for key bindings +module Graphics.UI.Clutter.BindingPool ( +-- * Description + +-- | BindingPool is a data structure holding a +-- set of key bindings. Each key binding associates a key symbol +-- (eventually with modifiers) to an action. A callback function is +-- associated to each action. +-- +-- For a given key symbol and modifier mask combination there can be +-- only one action; for each action there can be only one +-- callback. There can be multiple actions with the same name, and the +-- same callback can be used to handle multiple key bindings. +-- +-- Actors requiring key bindings should create a new +-- 'BindingPool' inside their class initialization function and +-- then install actions like this: +-- +-- TODO: Replace C example +{- +-- @ +-- static void +-- foo_class_init (FooClass *klass) +-- { +-- ClutterBindingPool *binding_pool; +-- +-- binding_pool = clutter_binding_pool_get_for_class (klass); +-- +-- clutter_binding_pool_install_action (binding_pool, "move-up", +-- CLUTTER_Up, 0, +-- G_CALLBACK (foo_action_move_up), +-- NULL, NULL); +-- clutter_binding_pool_install_action (binding_pool, "move-up", +-- CLUTTER_KP_Up, 0, +-- G_CALLBACK (foo_action_move_up), +-- NULL, NULL); +-- } +-- The callback has a signature of: +-- +-- gboolean (* callback) (GObject *instance, +-- const gchar *action_name, +-- guint key_val, +-- ClutterModifierType modifiers, +-- gpointer user_data); +-- +-- The actor should then override the \"key-press-event\" and use +-- 'bindingPoolActivate' to match a 'KeyEvent' +-- structure to one of the actions: +-- +-- ClutterBindingPool *pool; +-- +-- /* retrieve the binding pool for the type of the actor */ +-- pool = clutter_binding_pool_find (G_OBJECT_TYPE_NAME (actor)); +-- +-- /* activate any callback matching the key symbol and modifiers +-- * mask of the key event. the returned value can be directly +-- * used to signal that the actor has handled the event. +-- */ +-- return clutter_binding_pool_activate (pool, G_OBJECT (actor), +-- key_event->keyval, +-- key_event->modifier_state); +-- +-- @ +-} +-- The 'bindingPoolActivate' function will return @False@ if no action +-- for the given key binding was found, if the action was blocked +-- (using 'bindingPoolBlockAction') or if the key binding handler +-- returned @False@. +-- +-- 'BindingPool' is available since Clutter 1.0 +-- + +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'BindingPool' +-- @ + +-- * Types + BindingPool, +--BindingActionFunc, + +-- * Constructors + bindingPoolNew, + +-- * Methods +--bindingPoolGetForClass, + bindingPoolFind, + bindingPoolInstallAction, +--bindingPoolInstallClosure, + bindingPoolOverrideAction, +--bindingPoolOverrideClosure, + bindingPoolFindAction, + bindingPoolRemoveAction, + bindingPoolBlockAction, + bindingPoolUnblockAction, + bindingPoolActivate + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import System.Glib.GObject +import System.Glib.FFI + + +type KeyVal = Word + +--TODO: Private, don't document +maybeBindingPool = maybeNullNew newBindingPool + + +-- | Creates a new 'BindingPool' that can be used to store key +-- bindings for an actor. The name must be a unique identifier for +-- the binding pool, so that 'bindingPoolFind' will be able to +-- return the correct binding pool. +-- +-- [@name@] the name of the binding pool +-- +-- [@Returns@] the newly created binding pool with the given name. +-- +-- * Since 1.0 +-- +{# fun unsafe binding_pool_new as ^ { `String' } -> `BindingPool' newBindingPool* #} + +--I don't understand this function. Looks dirty though. +--{# fun unsafe binding_pool_get_for_class as ^ {} -> `BindingPool' newBindingPool* #} + + + +{# fun unsafe binding_pool_find as ^ { `String' } -> `Maybe BindingPool' maybeBindingPool* #} + +bindingPoolInstallAction :: BindingPool -> String -> KeyVal -> [ModifierType] -> GCallback -> IO () +bindingPoolInstallAction bp name keyval modif gCB = withBindingPool bp $ \bpPtr -> + withCString name $ \namePtr -> + --CHECKME: unsafe? Most likely safe, callback + let func = {# call binding_pool_install_action #} + mod = cFromModFlags modif + kc = cIntConv keyval + in do + gcbPtr <- newGCallback gCB + func bpPtr namePtr kc mod gcbPtr (castFunPtrToPtr gcbPtr) destroyFunPtr + + +bindingPoolOverrideAction :: BindingPool -> KeyVal -> [ModifierType] -> GCallback -> IO () +bindingPoolOverrideAction bp keyval modif gCB = withBindingPool bp $ \bpPtr -> + --CHECKME: unsafe? Most likely safe, callback + let func = {# call binding_pool_override_action #} + mod = cFromModFlags modif + kc = cIntConv keyval + in do + gcbPtr <- newGCallback gCB + func bpPtr kc mod gcbPtr (castFunPtrToPtr gcbPtr) destroyFunPtr + +{# fun unsafe binding_pool_find_action as ^ + { withBindingPool* `BindingPool', cIntConv `KeyVal', cFromModFlags `[ModifierType]' } -> `Maybe String' maybeString* #} + + +--FIXME: make list of modifiers, cFromFlags won't work since Flags instance won't work for ModifierType +-- | Removes the action matching the given key_val, modifiers pair, if +-- any exists. +-- +-- [@pool@] a 'BindingPool' +-- +-- [@key_val@] a key symbol +-- +-- [@modifiers@] a list of modifiers +-- +-- * Since 1.0 +-- + +{# fun unsafe binding_pool_remove_action as ^ + { withBindingPool* `BindingPool', cIntConv `KeyVal', cFromModFlags `[ModifierType]' } -> `()' #} + +-- | Blocks all the actions with name action_name inside pool. +-- +-- [@pool@] a 'BindingPool' +-- +-- [@action_name@] an action name +-- +-- * Since 1.0 +-- +{# fun unsafe binding_pool_block_action as ^ + { withBindingPool* `BindingPool', `String' } -> `()' #} + + +-- | Unblocks all the actions with name action_name inside pool. +-- +-- Unblocking an action does not cause the callback bound to it to be +-- invoked in case 'bindingPoolActivate' was called on an +-- action previously blocked with 'bindingPoolBlockAction'. +-- +-- [@pool@] a 'BindingPool' +-- +-- [@action_name@] an action name +-- +-- * Since 1.0 +-- +{# fun unsafe binding_pool_unblock_action as ^ + { withBindingPool* `BindingPool', `String' } -> `()' #} + + +-- | Activates the callback associated to the action that is bound to the key_val and modifiers pair. +-- +-- The callback has the following signature: +-- +-- @ +-- void (* callback) (GObject *gobject, +-- const gchar *action_name, +-- guint key_val, +-- ClutterModifierType modifiers, +-- gpointer user_data); +-- @ +-- +-- Where the GObject instance is gobject and the user data is the one +-- passed when installing the action with +-- 'bindingPoolInstallAction'. +-- +-- If the action bound to the key_val, modifiers pair has been blocked +-- using 'bindingPoolBlockAction', the callback will not be +-- invoked, and this function will return @False@. +-- +-- [@pool@] a 'BindingPool' +-- +-- [@key_val@] the key symbol +-- +-- [@modifiers@] bitmask for the modifiers +-- +-- [@gobject@] a 'GObject' +-- +-- [@Returns@] @True@ if an action was found and was activated +-- +-- * Since 1.0 +-- + +{# fun unsafe binding_pool_activate as ^ `(GObjectClass gobject)' => + { withBindingPool* `BindingPool', + cIntConv `KeyVal', + cFromModFlags `[ModifierType]', + withGObject* `gobject' } -> `Bool' #} + + diff --git a/Graphics/UI/Clutter/CairoTexture.chs b/Graphics/UI/Clutter/CairoTexture.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/CairoTexture.chs @@ -0,0 +1,222 @@ +-- -*-haskell-*- +-- Clutter Cairo Texture +-- +-- Author : Matthew Arsenault +-- +-- Created: 2 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | CairoTexture — Texture with Cairo integration +module Graphics.UI.Clutter.CairoTexture ( +-- * Description +-- | 'CairoTexture' is a 'Texture' that displays the contents of a +-- Cairo context. The 'CairoTexture' actor will create a Cairo image +-- surface which will then be uploaded to a GL texture when needed. +-- +-- 'CairoTexture' will provide a 'Cairo' context by using the +-- 'cairoTextureCreate' and 'cairoTextureCreateRegion' functions; you +-- can use the Cairo API to draw on the context. +-- +-- As soon as the context is destroyed, the contents of the surface +-- will be uploaded into the 'CairoTexture' actor: +-- +-- Although a new 'Cairo' is created each time you call +-- 'cairoTextureCreate' or 'cairoTextureCreateRegion', it uses the +-- same 'Surface' each time. You can call 'cairoTextureClear' to erase +-- the contents between calls. +-- +-- * Warning +-- +-- Note that you should never use the code above inside the "paint" +-- or "pick" virtual functions or signal handlers because it will +-- lead to performance degradation. +-- +-- * Note +-- +-- Since 'CairoTexture' uses a Cairo image surface internally all +-- the drawing operations will be performed in software and not using +-- hardware acceleration. This can lead to performance degradation if +-- the contents of the texture change frequently. +-- +-- 'CairoTexture' is available since Clutter 1.0. +-- + +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Actor' +-- | +----'Texture' +-- | +----'CairoTexture' +-- @ + +-- * Types + CairoTexture, + CairoTextureClass, + +-- * Constructors + cairoTextureNew, + +-- * Methods + cairoTextureSetSurfaceSize, + cairoTextureGetSurfaceSize, + + cairoTextureCreate, + + cairoTextureCreateRegion, + cairoTextureClear, + + cairoSetSourceColor, + +-- * Attributes + cairoTextureSurfaceHeight, + cairoTextureSurfaceWidth + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import System.Glib.Attributes +import System.Glib.Properties +import Graphics.Rendering.Cairo.Types (Cairo) + +--TODO: CairoTextureClass + +-- stop c2hs complaining about Ptr () not being Ptr Cairo +{# pointer *cairo_t as CairoPtr foreign -> Cairo nocode #} + +-- | Creates a new 'CairoTexture' actor, with a surface of width by +-- height pixels. +-- +-- [@width@] the width of the surface +-- +-- [@height@] the height of the surface +-- +-- [@Returns@] the newly created 'CairoTexture' actor +-- +-- * Since 1.0 +-- +{# fun unsafe cairo_texture_new as ^ { `Int', `Int' } -> `CairoTexture' newCairoTexture* #} + + +-- | Resizes the Cairo surface used by self to width and height. +-- +-- [@self@] a 'CairoTexture' +-- +-- [@width@] the new width of the surface +-- +-- [@height@] the new height of the surface +-- +-- * Since 1.0 +-- +{# fun unsafe cairo_texture_set_surface_size as ^ + { withCairoTexture* `CairoTexture', `Int', `Int' } -> `()' #} + +-- | Retrieves the surface width and height for self. +-- +-- [@self@] a 'CairoTexture' +-- +-- [@Returns@] (Surface width, Surface height) +-- +-- * Since 1.0 +-- +{# fun unsafe cairo_texture_get_surface_size as ^ + { withCairoTexture* `CairoTexture', alloca- `Int' peekIntConv*, alloca- `Int' peekIntConv* } -> `()' #} + + + +--CHECKME: the cairo_destroy to upload the contents? +-- | Creates a new Cairo context for the cairo texture. It is similar +-- to using 'cairoTextureCreateRegion' with x_offset and y_offset of +-- 0, width equal to the cairo texture surface width and height +-- equal to the cairo texture surface height. +-- +-- * Warning +-- +-- Do not call this function within the paint virtual function or from +-- a callback to the "paint" signal. +-- +-- [@self@] a 'CairoTexture' +-- +-- [@Returns@] a newly created Cairo context. Use cairo_destroy() to +-- upload the contents of the context when done drawing +-- +-- * Since 1.0 +-- +{# fun unsafe cairo_texture_create as ^ + { withCairoTexture* `CairoTexture' } -> `Cairo' newCairo #} + + +-- | Creates a new Cairo context that will updat the region defined by +-- x_offset, y_offset, width and height. +-- +-- * Warning +-- +-- Do not call this function within the paint virtual function or from +-- a callback to the "paint" signal. +-- +-- [@self@] a 'CairoTexture' +-- +-- [@x_offset@] offset of the region on the X axis +-- +-- [@y_offset@] offset of the region on the Y axis +-- +-- [@width@] width of the region, or -1 for the full surface width +-- +-- [@height@] height of the region, or -1 for the full surface height +-- +-- [@Returns@] a newly created Cairo context. Use cairo_destroy() to +-- upload the contents of the context when done drawing +-- +-- * Since 1.0 +-- +{# fun unsafe cairo_texture_create_region as ^ + { withCairoTexture* `CairoTexture', `Int', `Int', `Int', `Int' } -> `Cairo' newCairo #} + +-- | Clears self's internal drawing surface, so that the next upload +-- will replace the previous contents of the 'CairoTexture' rather +-- than adding to it. +-- +-- [@self@] a 'CairoTexture' +-- +-- * Since 1.0 +-- +{# fun unsafe cairo_texture_clear as ^ { withCairoTexture* `CairoTexture' } -> `()' #} + +-- | Utility function for setting the source color of cr using a +-- 'Color'. +-- +-- [@cr@] a Cairo context +-- +-- [@color@] a 'Color' +-- +-- * Since 1.0 +-- +{# fun unsafe cairo_set_source_color as ^ + { withCairo `Cairo', withColor* `Color' } -> `()' #} + + +cairoTextureSurfaceHeight :: (CairoTextureClass self) => Attr self Word +cairoTextureSurfaceHeight = clutterNewAttrFromUIntProperty "surface-height" + +cairoTextureSurfaceWidth :: (CairoTextureClass self) => Attr self Word +cairoTextureSurfaceWidth = clutterNewAttrFromUIntProperty "surface-width" + diff --git a/Graphics/UI/Clutter/ChildMeta.chs b/Graphics/UI/Clutter/ChildMeta.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/ChildMeta.chs @@ -0,0 +1,65 @@ +-- -*-haskell-*- +-- Clutter ChildMeta +-- +-- Author : Matthew Arsenault +-- +-- Created: 2 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.ChildMeta ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Actor' +-- | 'GObject' +-- | +----'ChildMeta' +-- @ +-- + +-- * Types + ChildMeta, + + childMetaGetContainer +--childMetaContainer, +--childMetaGetActor, +--childMetaActor + ) where + +{# import Graphics.UI.Clutter.Types #} + +--import System.Glib.Attributes + +childMetaGetContainer = undefined + +{- +--TODO: not use this, since it's just a simple struct + +{# fun unsafe child_meta_get_container as ^ { withChildMeta* `ChildMeta' } -> `Container' newContainer* #} +childMetaContainer :: (ChildMetaClass cm) => ReadAttr cm Container +childMetaContainer = readAttr childMetaGetContainer + + +{# fun unsafe child_meta_get_actor as ^ { withChildMeta* `ChildMeta' } -> `Actor' newActor* #} +childMetaActor :: (ChildMetaClass cm) => ReadAttr cm Actor +childMetaActor = readAttr childMetaGetActor + +-} + diff --git a/Graphics/UI/Clutter/Clone.chs b/Graphics/UI/Clutter/Clone.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Clone.chs @@ -0,0 +1,123 @@ +-- -*-haskell-*- +-- Clutter Clone +-- +-- Author : Matthew Arsenault +-- +-- Created: 2 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | ClutterClone — An actor that displays a clone of a source actor +module Graphics.UI.Clutter.Clone ( +-- * Description +-- +-- | 'Clone' is an Actor which draws with the paint function of +-- another actor, scaled to fit its own allocation. +-- +-- 'Clone' can be used to efficiently clone any other actor. +-- +-- * Note +-- +-- This is different from 'textureNewFromActor' which requires support +-- for FBOs in the underlying GL implementation. +-- +-- 'Clone' is available since Clutter 1.0 +-- + +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Actor' +-- | +----'Clone' +-- @ +-- + +-- * Types + Clone, + +-- * Constructors + cloneNew, +-- * Methods + cloneSetSource, + cloneGetSource, +-- * Attributes + cloneSource + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import qualified Graphics.UI.Clutter.GTypes #} as CGT +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import Control.Monad (liftM) +import System.Glib.Attributes +import System.Glib.Properties + + +-- | Creates a new 'Actor' which clones 'source' +-- +-- [@source@] @Just@ an Actor, or @Nothing@ +-- +-- [@Returns@] the newly created 'Clone' +-- +-- * Since 1.0 +-- +cloneNew :: (ActorClass a) => Maybe a -> IO (Clone a) +cloneNew actor = withMaybeActorClass actor $ \actorPtr -> + liftM (mkClone (undefined::a)) + (newCloneRaw =<< {# call unsafe clone_new #} actorPtr) + + + + +-- | Sets source as the source actor to be cloned by clone. +-- +-- [@clone@] a 'Clone' +-- +-- [@source@] @Just@ an Actor, or @Nothing@ +-- +-- * Since 1.0 +-- +{# fun unsafe clone_set_source as ^ `(ActorClass a)' => + { withClone* `Clone a', withMaybeActorClass* `Maybe a' } -> `()' #} + +-- | Retrieves the source 'Actor' being cloned by clone +-- +-- [@clone@] a 'Clone' +-- +-- [@Returns@] the actor source for the clone. +-- +-- * Since 1.0 +-- +cloneGetSource :: (ActorClass a) => Clone a -> IO (Maybe a) +cloneGetSource clone = withClone clone $ \clonePtr -> + liftM (liftM unsafeCastActor) + (maybeNewActor =<< {# call unsafe clone_get_source #} clonePtr) + + + +-- | This property specifies the source actor being cloned. +-- +-- * Since 1.0 +-- +cloneSource :: (ActorClass a) => Attr (Clone a) (Maybe a) +cloneSource = newNamedAttr "source" cloneGetSource cloneSetSource + + diff --git a/Graphics/UI/Clutter/Color.chs b/Graphics/UI/Clutter/Color.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Color.chs @@ -0,0 +1,225 @@ +-- -*-haskell-*- +-- Clutter Color +-- +-- Author : Matthew Arsenault +-- +-- Created: 4 Sep 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | Colors — Color management and manipulation. +module Graphics.UI.Clutter.Color ( +-- * Types + Color(..), + +-- * Description +-- | 'Color' is a simple type for representing colors in Clutter. +-- +-- A 'Color is expressed as a group of 4 alues ranging from zero to +-- 255, one for each color channel plus one for the alpha. +-- + colorFromString, + colorToString, + + colorFromHls, + colorToHls, + colorFromPixel, + colorToPixel, + colorAdd, + colorSubtract, + colorLighten, + colorDarken, + colorShade + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import Data.Word + + + +-- | Parses a string definition of a color, filling the red, green, +-- blue and alpha channels of color. If alpha is not specified it +-- will be set full opaque. +-- +-- The color may be defined by any of the formats understood by +-- Pango.colorFromString; these include literal color names, like Red +-- or DarkSlateGray, or hexadecimal specifications like #3050b2 or +-- #333. +-- +-- * Since 1.0 +-- +colorFromString :: String -- ^ a string specifiying a color (named color or RRGGBBAA) + -> Maybe Color -- ^ @Just@ a color, or @Nothing@ if parsing failed +colorFromString name = unsafePerformIO $ withCString name $ \cstr -> + alloca $ \colptr -> + if cToBool ({# call pure unsafe color_from_string #} colptr cstr) + then peek colptr >>= return . Just + else return Prelude.Nothing + + +-- | Returns a textual specification of color in the hexadecimal form +-- #rrggbbaa, where r, g, b and a are hex digits representing the +-- red, green, blue and alpha components respectively. +-- +-- [@color@] a 'Color' +-- +-- [@Returns@] a text string describing the color +-- +-- * Since 0.2 +-- +{# fun pure unsafe color_to_string as ^ { withColor* `Color' } -> `String' peekNFreeString* #} + + +-- | Converts a color expressed in HLS (hue, luminance and saturation) +-- values into a 'Color'. +-- +-- [@hue@] hue value, in the 0 .. 360 range +-- +-- [@luminance@] luminance value, in the 0 .. 1 range +-- +-- [@saturation@] saturation value, in the 0 .. 1 range +-- +-- [@Returns@] a 'Color' +-- +{# fun pure unsafe color_from_hls as ^ + { alloca- `Color' peek*, `Float', `Float', `Float' } -> `()' #} + + + + +-- | Converts color to the HLS format. +-- +-- The hue value is in the 0 .. 360 range. The luminance and +-- saturation values are in the 0 .. 1 range. +-- +-- [@color@] a 'Color' +-- +-- [@Returns@] (hue, luminance, saturation) +-- +{# fun pure unsafe color_to_hls as ^ + { withColor*`Color', + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv* } -> `()' #} + + + +-- | Converts pixel from the packed representation of a four 8 bit +-- channel color to a 'Color'. +-- +-- [@pixel@] a 32 bit packed integer containing a color +-- +-- [@Returns@] a 'Color' +-- +{# fun pure unsafe color_from_pixel as ^ { alloca- `Color' peek*, `Word32' } -> `()' #} + + +-- | Converts color into a packed 32 bit integer, containing all the +-- four 8 bit channels used by 'Color'. +-- +-- [@color@] a 'Color' +-- +-- [@Returns@] a packed color +-- +{# fun pure unsafe color_to_pixel as ^ { withColor* `Color' } -> `Word32' #} + +clamp low high x | x > high = high + | x < low = low + | otherwise = x + +-- | Adds a to b and saves the resulting color inside result. +-- +-- The alpha channel of result is set as as the maximum value between +-- the alpha channels of a and b. +-- +-- [@a@] a 'Color' +-- +-- [@b@] a 'Color' +-- +-- [@Returns@] Result +-- +colorAdd (Color ra ga ba aa) (Color rb gb bb ab) = let lim = clamp 0 255 + r = lim (ra + rb) + g = lim (ga + gb) + b = lim (ba + bb) + in Color r g b (max aa ab) +--There's no point in marshalling all this stuff just for this +--{# fun pure unsafe color_add as ^ +-- { withColor* `Color', withColor* `Color', alloca- `Color' peek* } -> `()' #} + +-- | Subtracts b from a +-- +-- This function assumes that the components of a are greater than the +-- components of b; the result is, otherwise, undefined. +-- +-- The alpha channel of result is set as the minimum value between the +-- alpha channels of a and b. +-- +-- [@a@] a 'Color' +-- +-- [@b@] a 'Color' +-- +-- [@Returns@] Result +-- +colorSubtract (Color ra ga ba aa) (Color rb gb bb ab) = let lim = clamp 0 255 + r = lim (ra - rb) + g = lim (ga - gb) + b = lim (ba - bb) + in Color r g b (min aa ab) + +--{# fun pure unsafe color_subtract as ^ +-- { withColor* `Color', withColor* `Color', alloca- `Color' peek* } -> `()' #} + + +-- | Lightens color by a fixed amount +-- +-- [@color@] a 'Color' +-- +-- [@Returns@] the lighter color +-- +{# fun pure unsafe color_lighten as ^ + { withColor* `Color', alloca- `Color' peek* } -> `()' #} + + +-- | Darkens color by a fixed amount, and saves the changed color in result. +-- +-- [@color@] a 'Color' +-- +-- [@Returns@] the darker color. +-- +{# fun pure unsafe color_darken as ^ + { withColor* `Color', alloca- `Color' peek* } -> `()' #} + + +-- | Shades color by factor and saves the modified color into result. +-- +-- [@color@] a 'Color' +-- +-- [@factor@] the shade factor to apply +-- +-- [@result@] the shaded color +-- +{# fun pure unsafe color_shade as ^ + { withColor* `Color', `Double', alloca- `Color' peek* } -> `()' #} + +-- TODO: ClutterParamSpecColor stuff + diff --git a/Graphics/UI/Clutter/Container.chs b/Graphics/UI/Clutter/Container.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Container.chs @@ -0,0 +1,189 @@ +-- -*-haskell-*- +-- Clutter Container +-- +-- Author : Matthew Arsenault +-- +-- Created: 12 Sep 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_HADDOCK prune #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +--TODO: Property list of children? + +-- | ClutterContainer — An interface for implementing container actors +module Graphics.UI.Clutter.Container ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GInterface' +-- | +----'Container' +-- @ + +-- * Methods + containerAddActor, +--containerAddList + containerRemoveActor, +--containerRemoveList, + containerGetChildren, + + containerForeach, + containerForeachWithInternals, + containerFindChildByName, + containerRaiseChild, + containerLowerChild, + containerSortDepthOrder, +--containerClassFindChildProperty, +--containerClassListChildProperties, +--containerChildGetProperty, + containerChildSet, +--containerChildGet, + containerGetChildMeta + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Animation #} +{# import Graphics.UI.Clutter.StoreValue #} + +import C2HS +import Prelude +import qualified Prelude as P +import System.Glib.GObject +import Control.Monad (forM_) + +--CHECKME: unsafe +-- | Adds an Actor to container. This function will emit the "actor-added" signal. +-- The actor should be parented to container. You cannot add a 'Actor' to more +-- than one 'Container'. +{# fun unsafe container_add_actor as ^ + `(ContainerClass container, ActorClass actor)' => + { withContainerClass* `container', withActorClass* `actor' } -> `()' #} +--TODO: add/removeList as var args function, to allow multiple types of the actor class in the list + +--TODO: Does this doc make sense? +-- | Removes actor from container. The +-- actor should be unparented When the actor has been removed, the +-- "actor-removed" signal is emitted by container. +{# fun unsafe container_remove_actor as ^ + `(ContainerClass container, ActorClass actor)' => + { withContainerClass* `container', withActorClass* `actor' } -> `()' #} + +-- | Retrieves all the children of container. +{# fun unsafe container_get_children as ^ + `(ContainerClass container)' => { withContainerClass* `container' } -> `[Actor]' newActorList* #} + +-- | Calls callback for each child of container that was added by the +-- application (with 'containerAddActor'). Does not iterate +-- over "internal" children that are part of the container's own +-- implementation, if any. +containerForeach :: (ContainerClass c) => c -> Callback -> IO () +containerForeach c func = withContainerClass c $ \cptr -> do + funcPtr <- newCallback func + {# call container_foreach #} cptr funcPtr nullPtr + freeHaskellFunPtr funcPtr + --CHECKME: unsafe? + +-- | Calls callback for each child of container, including "internal" +-- children built in to the container itself that were never added by +-- the application. +containerForeachWithInternals :: (ContainerClass c) => c -> Callback -> IO () +containerForeachWithInternals c func = withContainerClass c $ \cptr -> do + funcPtr <- newCallback func + {# call container_foreach #} cptr funcPtr nullPtr + freeHaskellFunPtr funcPtr + --CHECKME: unsafe? + + +-- | Finds a child actor of a container by its name. Search recurses into any child container. +{# fun unsafe container_find_child_by_name as ^ + `(ContainerClass container)' => { withContainerClass* `container', `String' } -> `Actor' newActor* #} + +-- | Raises actor to sibling level, in the depth ordering. +{# fun unsafe container_raise_child as ^ + `(ContainerClass container, ActorClass actor, ActorClass sibling)' => + { withContainerClass* `container', + withActorClass* `actor', + withActorClass* `sibling' } -> `()' #} + +-- | Lowers actor to sibling level, in the depth ordering. +{# fun unsafe container_lower_child as ^ + `(ContainerClass container, ActorClass actor, ActorClass sibling)' => + { withContainerClass* `container', + withActorClass* `actor', + withActorClass* `sibling' } -> `()' #} + +-- | Sorts a container's children using their depth. This function should not be normally used by applications. +{# fun unsafe container_sort_depth_order as ^ + `(ContainerClass container)' => { withContainerClass* `container' } -> `()' #} +{- +We don't care about GParamSpec stuff +{# fun unsafe container_class_find_child_property as ^ + `(GObjectClass gobj)' => { withGObjectClass* `gobj', `String' } -> `GParamSpec' #} + +{# fun unsafe container_class_list_child_properties as ^ + `(GObjectClass gobj)' => { withGObjectClass* `gobj', `Word' } -> `[GParamSpec]' #} +-} +-- + + + + +-- | Retrieves the 'ChildMeta' which contains the data about the +-- container specific state for actor. +{# fun unsafe container_get_child_meta as ^ + `(ContainerClass container)' => + { withContainerClass* `container', + withActor* `Actor' } -> + `ChildMeta' newChildMeta* #} + +--CHECKME: unsafe? +--CHECKME: What are "container specific properties" and does this make sense? +-- | Sets container specific properties on the child of a container. +-- +-- [@container@] a Container +-- +-- [@actor@] an Actor that is a child of container. +-- +-- [@attributes@] List of attributes and their values to be set +-- +-- * Since 0.8 +-- +containerChildSet :: (ContainerClass container, ActorClass child) => container + -> child + -> [AnimOp child] + -> IO () +containerChildSet ctr chld ops = let func = {# call unsafe container_child_set_property #} + in withContainerClass ctr $ \ctrPtr -> + withActorClass chld $ \chldPtr -> + forM_ ops $ \(attr :-> val) -> + withCString (P.show attr) $ \strPtr -> + withGenericValue val $ \valPtr -> + func ctrPtr chldPtr strPtr valPtr + +{- +--getting gvalues out is problematic +containerChildGet :: (ContainerClass container, ActorClass child, GValueClass a) => + container + -> child + -> AnimOp child + -> IO a +containerChildGet ctr chld op = let func = {# call unsafe container_child_get_property #} + in withContainerClass ctr $ \ctrPtr -> + withActorClass chld $ \chldPtr -> +-} + diff --git a/Graphics/UI/Clutter/CustomSignals.chs b/Graphics/UI/Clutter/CustomSignals.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/CustomSignals.chs @@ -0,0 +1,72 @@ +{-# OPTIONS_HADDOCK hide #-} +-- -*-haskell-*- +-- +-- Author : Matthew Arsenault +-- +-- Created: 20 November 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +-- #hide + +--I needed signal handlers with checks for null, but I was too lazy to +--modify the generator. +module Graphics.UI.Clutter.CustomSignals ( + connect_MAYBEOBJECT__NONE, + connect_BOXED_FLAGS__NONE + ) where + +import Control.Monad (liftM) + +import System.Glib.FFI +import System.Glib.Flags +import System.Glib.GError (failOnGError) +import System.Glib.Signals +import System.Glib.GObject + +{#context lib="clutter" prefix="clutter" #} + +connect_MAYBEOBJECT__NONE :: + (GObjectClass a', GObjectClass obj) => SignalName -> + ConnectAfter -> obj -> + (Maybe a' -> IO ()) -> + IO (ConnectId obj) +connect_MAYBEOBJECT__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Ptr GObject -> IO () + action _ obj1 = if obj1 == nullPtr + then failOnGError (user Nothing) + else failOnGError $ + makeNewGObject mkGObject (return obj1) >>= \obj1' -> + user (Just (unsafeCastGObject obj1')) + + + + +--The generator was producing slightly wrong stuff here, but I'm too +--lazy to fix it right now. +connect_BOXED_FLAGS__NONE :: + (Flags b, GObjectClass obj) => SignalName -> + (Ptr a' -> IO a) -> + ConnectAfter -> obj -> + (a -> [b] -> IO ()) -> + IO (ConnectId obj) +connect_BOXED_FLAGS__NONE signal boxedPre1 after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Ptr () -> Int -> IO () + action _ box1 flags2 = + failOnGError $ + boxedPre1 (castPtr box1) >>= \box1' -> + user box1' (toFlags flags2) + + diff --git a/Graphics/UI/Clutter/Event.chs b/Graphics/UI/Clutter/Event.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Event.chs @@ -0,0 +1,449 @@ +-- -*-haskell-*- +-- ClutterEvent +-- +-- Author : Matthew Arsenault +-- +-- Created: 19 Sep 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_HADDOCK prune #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +--TODO: Note the low level stuff ignored here +--TODO: This is in need of a lot of testing +--TODO: Make stuff here more consistent with itself, +--struct using vs. functions. Don't need to do silly struct things. + +module Graphics.UI.Clutter.Event ( +-- * Types + ModifierType(..), + ScrollDirection(..), + InputDeviceType(..), + EventType(..), + EventFlags(..), + StageState(..), + InputDevice, + DeviceID, + Timestamp, + +-- * Event monad, and type tags + EventM, + + EAny, + EButton, + EKey, + EMotion, + EScroll, + EStageState, + ECrossing, + + +-- * Accessor functions for event information + eventCoordinates, + eventState, + eventTime, + eventSource, + eventStage, + eventFlags, + + eventButton, + eventClickCount, + eventKeySymbol, + eventKeyCode, + eventKeyUnicode, + + eventRelated, + eventScrollDirection, + + keysymToUnicode, + + eventDevice, + eventDeviceId, + eventDeviceType, + +-- * Misc + eventPut, + getCurrentEventTime, + eventsPending, + + getInputDeviceForId, + inputDeviceGetDeviceId, + inputDeviceGetDeviceType, + + tryEvent, + stopEvent, + + eventM --should be private + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Signals #} +{# import Graphics.UI.Clutter.Utility #} + +--FIXME: Conflict with EventType Nothing +import Prelude hiding (Nothing, catch) +import qualified Prelude as P + +import C2HS +import System.Glib.Signals +import System.Glib.Flags +import Control.Monad (liftM) +import Control.Monad.Trans (liftIO) +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Data.List (isPrefixOf) +import Control.Exception (Handler(..), + PatternMatchFail(..), + catches, + throw) +import System.IO.Error (isUserError, ioeGetErrorString) + +--TODO: Move keyval + +--Taken almost straight from Gtk. Should I try something else? + +-- | A monad providing access to data in an event. +-- +type EventM t a = ReaderT (Ptr t) IO a + +-- | A tag for events that do not carry any event-specific information. +data EAny = EAny + +-- | A tag for /Button/ events. +data EButton = EButton + +-- | A tag for /key/ events. +data EKey = EKey + +-- | A tag for /Motion/ events. +data EMotion = EMotion + +-- | A tag for /Scroll/ events. +data EScroll = EScroll + +-- | A tag for /StageState/ events. +data EStageState = EStageState + +-- | A tag for /Crossing/ events. +data ECrossing = ECrossing + + +--Clutter seems to not have the event mask stuff +eventM :: ActorClass a => SignalName -> + ConnectAfter -> a -> (EventM t Bool) -> IO (ConnectId a) +eventM name after obj fun = connect_PTR__BOOL name after obj (runReaderT fun) + + +-- | Execute an event handler and assume it handled the event unless it +-- threw a pattern match exception. +--TODO: Support Old GHC exceptions here? +--Other exceptions? Why does gdk use pattern? +tryEvent :: EventM any () -> EventM any Bool +tryEvent act = do + ptr <- ask + liftIO $ (runReaderT (act >> return True) ptr) + `catches` [ Handler (\ (PatternMatchFail _) -> return False), + Handler (\ e -> if isUserError e && "Pattern" `isPrefixOf` ioeGetErrorString e + then return False + else throw e) ] + + +-- | Explicitly stop the handling of an event. This function should only be +-- called inside a handler that is wrapped with 'tryEvent'. (It merely +-- throws a bogus pattern matching error which 'tryEvent' interprets as if +-- the handler does not handle the event.) +stopEvent :: EventM any () +stopEvent = + liftIO $ throw (PatternMatchFail "EventM.stopEvent called explicitly") + + +class HasCoordinates a +instance HasCoordinates EButton +instance HasCoordinates EMotion +instance HasCoordinates EScroll +instance HasCoordinates ECrossing + +class HasModifierType a +instance HasModifierType EButton +instance HasModifierType EKey +instance HasModifierType EMotion +instance HasModifierType EScroll + + +--FIXME: Evil casting + +-- | Retrieves the 'EventFlags' of event +-- +-- the event flags +-- +-- * Since 1.0 +-- +eventFlags :: EventM t [EventFlags] +eventFlags = ask >>= \ptr -> + liftIO $ liftM cToFlags ({# call unsafe event_get_flags #} (castPtr ptr)) + + +-- | Retrieves the source 'Stage' the event originated for, or +-- @Nothing@ if the event has no stage. +-- +-- * Since 0.8 +-- +eventStage :: EventM t (Maybe Stage) +eventStage = ask >>= \ptr -> + liftIO $ maybeNewStage . castPtr =<< {# call unsafe event_get_stage #} (castPtr ptr) + + + +-- | Retrieves the source 'Actor' the event originated from, or +-- @Nothing@ if the event has no source. +-- +-- * Since 0.6 +-- +eventSource :: EventM t (Maybe Actor) +eventSource = ask >>= \ptr -> + liftIO $ maybeNewActor =<< {# call unsafe event_get_source #} (castPtr ptr) + + + +-- | Retrieves the related actor of a crossing event. +-- +-- @Just@ the related 'Actor', or @Nothing@. transfer none. +-- * Since 1.0 +-- +eventRelated :: EventM ECrossing (Maybe Actor) +eventRelated = ask >>= \ptr -> + liftIO $ maybeNewActor =<< {# call unsafe event_get_related #} (castPtr ptr) + + + +-- | Retrieve the @(x,y)@ coordinates of the mouse. +eventCoordinates :: HasCoordinates t => EventM t (Float, Float) +eventCoordinates = ask >>= \ptr -> + liftIO $ alloca $ \xptr -> + alloca $ \yptr -> do + {# call unsafe event_get_coords #} (castPtr ptr) xptr yptr + x <- peekFloatConv xptr + y <- peekFloatConv yptr + return (x,y) + +-- | The time of the event, or CLUTTER_CURRENT_TIME +-- +-- * Since 0.4 +-- +eventTime :: EventM t Timestamp +eventTime = ask >>= \ptr -> + liftIO $ liftM fromIntegral ({# call unsafe event_get_time #} (castPtr ptr)) + + +-- | Retrieves the modifier state of the event. +-- +-- the modifier state parameters, or [] +-- +-- * Since 0.4 +-- +eventState :: HasModifierType t => EventM t [ModifierType] +eventState = do + ptr <- ask + liftIO $ + liftM (toModFlags . cIntConv) $ {# call unsafe event_get_state #} (castPtr ptr) + + +-- | Retrieves the button number of event +-- +-- the button number +-- +-- * Since 1.0 +-- +eventButton :: EventM EButton Word32 +eventButton = ask >>= \ptr -> + liftIO $ liftM cIntConv ({# call unsafe event_get_button #} (castPtr ptr)) + + + +-- | Retrieves the number of clicks of event +-- +-- the click count +-- +-- * Since 1.0 +-- +eventClickCount :: EventM EButton Word +eventClickCount = ask >>= \ptr -> + liftIO $ liftM cIntConv ({# call unsafe event_get_click_count #} (castPtr ptr)) + + + +-- | Retrieves the key symbol of event +-- +-- the key symbol representing the key +-- +-- * Since 1.0 +-- +eventKeySymbol :: EventM EKey Word +eventKeySymbol = ask >>= \ptr -> + liftIO $ liftM cIntConv ({# call unsafe event_get_key_symbol #} (castPtr ptr)) + + + +-- | Retrieves the keycode of the key that caused event +-- +-- The keycode representing the key +-- +-- * Since 1.0 +-- +eventKeyCode :: EventM EKey Word16 +eventKeyCode = ask >>= \ptr -> + liftIO $ liftM cIntConv ({# get ClutterKeyEvent->hardware_keycode #} ptr) + + +-- | Retrieves the unicode value for the key that caused keyev. +-- +-- The unicode value representing the key +-- +eventKeyUnicode :: EventM EKey Word32 +eventKeyUnicode = ask >>= \ptr -> + liftIO $ liftM cIntConv ({# get ClutterKeyEvent->unicode_value #} ptr) + + + +-- | Retrieves the direction of the scrolling of event +-- +-- the scrolling direction +-- +-- * Since 1.0 +-- +eventScrollDirection :: EventM EScroll ScrollDirection +eventScrollDirection = ask >>= \ptr -> + liftIO $ liftM cToEnum ({# get ClutterScrollEvent->direction #} ptr) + + +--TODO: Should this happen automatically? unicode char? +{# fun unsafe keysym_to_unicode as ^ { cIntConv `Word' } -> `Word' cIntConv #} + + + +-- | Retrieves the 'InputDevice' from its id. +-- +-- [@id@] a device id +-- +-- [@Returns@] @Just@ an 'InputDevice', or @Nothing@. transfer none. +-- +-- * Since 0.8 +-- +getInputDeviceForId :: DeviceID -> IO (Maybe InputDevice) +getInputDeviceForId did = let cdid = cIntConv did + in do + dev <- {# call unsafe get_input_device_for_id #} cdid + return $ if dev == nullPtr + then P.Nothing + else Just (castPtr dev) + + +-- | Retrieves the unique identifier of device +-- +-- [@device@] an 'InputDevice' +-- +-- [@Returns@] the identifier of the device +-- +-- * Since 1.0 +-- +{# fun unsafe input_device_get_device_id as ^ { castPtr `InputDevice' } -> `DeviceID' cIntConv #} + + +-- | Retrieves the type of device +-- +-- [@device@] an 'InputDevice' +-- +-- [@Returns@] the type of the device +-- +-- * Since 1.0 +-- +{# fun unsafe input_device_get_device_type as ^ { castPtr `InputDevice' } -> `InputDeviceType' cToEnum #} + + +eventDevice :: EventM t (Maybe InputDevice) +eventDevice = ask >>= \ptr -> + liftIO $ do + device <- {# call unsafe event_get_device #} (castPtr ptr) + return $ if device == nullPtr + then P.Nothing + else Just (castPtr device) + + +data InputDeviceStruct = InputDeviceStruct + +{# pointer *ClutterInputDevice as InputDevice -> InputDeviceStruct #} + + +-- | Retrieves the events device id if set. +-- +-- @Just@ A unique identifier for the device or @Nothing@ if the event +-- has no specific device set. +-- +eventDeviceId :: EventM any (Maybe DeviceID) +eventDeviceId = ask >>= \ptr -> + liftIO $ do + did <- liftM cIntConv $ {# call unsafe event_get_device_id #} (castPtr ptr) + return $ if did == (-1) + then P.Nothing + else Just did + + +-- | Retrieves the type of the device for event +-- +-- the 'InputDeviceType' for the device, if any is set +-- +-- * Since 1.0 +-- +eventDeviceType :: EventM any InputDeviceType +eventDeviceType = ask >>= \ptr -> + liftIO $ liftM cToEnum $ {# call unsafe event_get_device_type #} (castPtr ptr) + + +-- | Retrieves the timestamp of the last event, if there is an event +-- or if the event has a timestamp. +-- +-- [@Returns@] the event timestamp, or CLUTTER_CURRENT_TIME +-- +-- * Since 1.0 +-- +{# fun unsafe get_current_event_time as ^ { } -> `Timestamp' cIntConv #} + + + +-- | Checks if events are pending in the event queue. +-- +-- [@Returns@] @True@ if there are pending events, @False@ otherwise. +-- +-- * Since 0.4 +-- +{# fun unsafe events_pending as ^ { } -> `Bool' #} + + +--CHECKME: Bad? +-- | Puts a copy of the event on the back of the event queue. The +-- event will have the 'EventFlagSynthetic' flag set. If the source +-- is set event signals will be emitted for this source and +-- capture/bubbling for its ancestors. If the source is not set it +-- will be generated by picking or use the actor that currently has +-- keyboard focus +-- +-- * Since 0.6 +-- +eventPut :: EventM any () +eventPut = ask >>= \ptr -> liftIO $ + {# call unsafe event_put #} (castPtr ptr) + diff --git a/Graphics/UI/Clutter/GTypes.chs b/Graphics/UI/Clutter/GTypes.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/GTypes.chs @@ -0,0 +1,137 @@ +-- -*-haskell-*- +-- GTypes for Clutter +-- +-- Author : Matthew Arsenault +-- +-- Created: 21 Nov 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | All GTypes defined in Clutter headers +module Graphics.UI.Clutter.GTypes ( + actor, + actorbox, + alpha, + animation, + animatable, + backend, + behaviour, + behaviourellipse, + behaviourdepth, + behaviouropacity, + behaviourpath, + behaviourrotate, + behaviourscale, + bindingpool, + cairotexture, + childmeta, + clone, + color, + container, + event, + fog, + geometry, + gravity, + group, + interval, + knot, + listmodel, + media, + model, + modeliter, + paramcolor, + paramunits, + path, + pathnode, + perspective, + rectangle, + requestmode, + score, + script, + scriptable, + shader, + shaderfloat, + shaderint, + shadermatrix, + stage, + stagemanager, + text, + texture, + timeline, + units, + vertex + + ) where + +import C2HS +import System.Glib.GType + +{# fun pure unsafe actor_get_type as actor { } -> `GType' cToEnum #} +{# fun pure unsafe actor_box_get_type as actorbox { } -> `GType' cToEnum #} +{# fun pure unsafe alpha_get_type as alpha { } -> `GType' cToEnum #} +{# fun pure unsafe animation_get_type as animation { } -> `GType' cToEnum #} +{# fun pure unsafe animatable_get_type as animatable { } -> `GType' cToEnum #} +{# fun pure unsafe backend_get_type as backend { } -> `GType' cToEnum #} +{# fun pure unsafe behaviour_get_type as behaviour { } -> `GType' cToEnum #} +{# fun pure unsafe behaviour_ellipse_get_type as behaviourellipse { } -> `GType' cToEnum #} +{# fun pure unsafe behaviour_depth_get_type as behaviourdepth { } -> `GType' cToEnum #} +{# fun pure unsafe behaviour_opacity_get_type as behaviouropacity { } -> `GType' cToEnum #} +{# fun pure unsafe behaviour_path_get_type as behaviourpath { } -> `GType' cToEnum #} +{# fun pure unsafe behaviour_rotate_get_type as behaviourrotate { } -> `GType' cToEnum #} +{# fun pure unsafe behaviour_scale_get_type as behaviourscale { } -> `GType' cToEnum #} +{# fun pure unsafe binding_pool_get_type as bindingpool { } -> `GType' cToEnum #} +{# fun pure unsafe cairo_texture_get_type as cairotexture { } -> `GType' cToEnum #} +{# fun pure unsafe child_meta_get_type as childmeta { } -> `GType' cToEnum #} +{# fun pure unsafe clone_get_type as clone { } -> `GType' cToEnum #} +{# fun pure unsafe color_get_type as color { } -> `GType' cToEnum #} +{# fun pure unsafe container_get_type as container { } -> `GType' cToEnum #} +{# fun pure unsafe event_get_type as event { } -> `GType' cToEnum #} +{# fun pure unsafe fog_get_type as fog { } -> `GType' cToEnum #} +{# fun pure unsafe geometry_get_type as geometry { } -> `GType' cToEnum #} +{# fun pure unsafe gravity_get_type as gravity { } -> `GType' cToEnum #} +{# fun pure unsafe group_get_type as group { } -> `GType' cToEnum #} +{# fun pure unsafe interval_get_type as interval { } -> `GType' cToEnum #} +{# fun pure unsafe knot_get_type as knot { } -> `GType' cToEnum #} +{# fun pure unsafe list_model_get_type as listmodel { } -> `GType' cToEnum #} +{# fun pure unsafe media_get_type as media { } -> `GType' cToEnum #} +{# fun pure unsafe model_get_type as model { } -> `GType' cToEnum #} +{# fun pure unsafe model_iter_get_type as modeliter { } -> `GType' cToEnum #} +{# fun pure unsafe param_color_get_type as paramcolor { } -> `GType' cToEnum #} +{# fun pure unsafe param_units_get_type as paramunits { } -> `GType' cToEnum #} +{# fun pure unsafe path_get_type as path { } -> `GType' cToEnum #} +{# fun pure unsafe path_node_get_type as pathnode { } -> `GType' cToEnum #} +{# fun pure unsafe perspective_get_type as perspective { } -> `GType' cToEnum #} +{# fun pure unsafe rectangle_get_type as rectangle { } -> `GType' cToEnum #} +{# fun pure unsafe request_mode_get_type as requestmode { } -> `GType' cToEnum #} +{# fun pure unsafe score_get_type as score { } -> `GType' cToEnum #} +{# fun pure unsafe script_get_type as script { } -> `GType' cToEnum #} +{# fun pure unsafe scriptable_get_type as scriptable { } -> `GType' cToEnum #} +{# fun pure unsafe shader_get_type as shader { } -> `GType' cToEnum #} +{# fun pure unsafe shader_float_get_type as shaderfloat { } -> `GType' cToEnum #} +{# fun pure unsafe shader_int_get_type as shaderint { } -> `GType' cToEnum #} +{# fun pure unsafe shader_matrix_get_type as shadermatrix { } -> `GType' cToEnum #} +{# fun pure unsafe stage_get_type as stage { } -> `GType' cToEnum #} +{# fun pure unsafe stage_manager_get_type as stagemanager { } -> `GType' cToEnum #} +{# fun pure unsafe text_get_type as text { } -> `GType' cToEnum #} +{# fun pure unsafe texture_get_type as texture { } -> `GType' cToEnum #} +{# fun pure unsafe timeline_get_type as timeline { } -> `GType' cToEnum #} +{# fun pure unsafe units_get_type as units { } -> `GType' cToEnum #} +{# fun pure unsafe vertex_get_type as vertex { } -> `GType' cToEnum #} + diff --git a/Graphics/UI/Clutter/General.chs b/Graphics/UI/Clutter/General.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/General.chs @@ -0,0 +1,330 @@ +-- -*-haskell-*- +-- Clutter General +-- +-- Author : Matthew Arsenault +-- +-- Created: 11 Sep 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.General ( + +-- * Types + InitError(..), + FontFlags(..), + +-- * General functions + clutterInit, + clutterMain, + mainQuit, + mainLevel, + + getDebugEnabled, + getShowFps, + getTimestamp, + + getActorByGid, + + setDefaultFrameRate, + getDefaultFrameRate, + setMotionEventsEnabled, + getMotionEventsEnabled, + clearGlyphCache, + setFontFlags, + getFontFlags, + getFontMap, + + getKeyboardGrab, + getPointerGrab, + grabKeyboard, + grabPointer, + ungrabKeyboard, + ungrabPointer, + grabPointerForDevice, + ungrabPointerForDevice, +--doEvent + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import System.Glib.GObject +import Graphics.UI.Gtk.Pango.Types +import Graphics.UI.Gtk.Types (FontMap, mkFontMap) +import System.Glib.UTFString +import System.Environment (getProgName, getArgs) +import Control.Monad (liftM, when) + + +-- | Starts the Clutter mainloop. +{# fun main as clutterMain { } -> `()' #} + +-- | Terminates the Clutter mainloop. +{# fun main_quit as ^ { } -> `()' #} + +-- | Retrieves the depth of the Clutter mainloop. +-- +-- [@Returns@] The level of the mainloop. +-- +{# fun main_level as ^ { } -> `Int' #} + + +--just make it go for now. I think some issues with it +--out args? do they matter? also how to use out marshallers correctly +clutterInit :: IO InitError +clutterInit = do + prog <- getProgName + args <- getArgs + let allArgs = (prog:args) + withMany withUTFString allArgs $ \addrs -> + withArrayLen addrs $ \argc argv -> + with argv $ \argvp -> + with argc $ \argcp -> do + res <- liftM cToEnum $ {# call unsafe init #} (castPtr argcp) (castPtr argvp) + when (res /= InitSuccess) $ error ("Cannot initialize Clutter." ++ show res) + return res + + +-- | Check if clutter has debugging turned on. +-- +-- [@Returns@] @True@ if debugging is turned on, @False@ otherwise. +-- +{# fun unsafe get_debug_enabled as ^ { } -> `Bool' #} + +-- | Returns whether Clutter should print out the frames per second on +-- the console. You can enable this setting either using the +-- CLUTTER_SHOW_FPS environment variable or passing the +-- --clutter-show-fps command line argument. * +-- +-- [@Returns@] @True@ if Clutter should show the FPS. +-- +-- * Since 0.4 +-- +{# fun unsafe get_show_fps as ^ { } -> `Bool' #} + +-- | Returns the approximate number of microseconds passed since +-- clutter was intialised. +-- +-- [@Returns@] Number of microseconds since 'clutterInit' was called. +-- +{# fun unsafe get_timestamp as ^ { } -> `Timestamp' cIntConv #} + +-- | Retrieves the ClutterActor with id. +-- +-- [@id@] a ClutterActor ID. +-- +-- [@Returns@] @Just@ an Actor or @Nothing@ +-- +-- * Since 0.6 +-- +{# fun unsafe get_actor_by_gid as ^ { cIntConv `GID' } -> `Maybe Actor' maybeNewActor* #} + +-- | Sets the default frame rate. This frame rate will be used to +-- limit the number of frames drawn if Clutter is not able to +-- synchronize with the vertical refresh rate of the display. When +-- synchronization is possible, this value is ignored. +-- +-- [@frames_per_sec@] the new default frame rate +-- +-- * Since 0.6 +-- +{# fun unsafe set_default_frame_rate as ^ { cIntConv `Word' } -> `()' #} + +-- | Retrieves the default frame rate. See 'setDefaultFrameRate'. +-- +-- [@Returns@] the default frame rate +-- +-- * Since 0.6 +-- +{# fun unsafe get_default_frame_rate as ^ { } -> `Word' cIntConv #} + +-- | Sets whether per-actor motion events should be enabled or not +-- (the default is to enable them). +-- +-- If enable is @False@ the following events will not work: +-- +-- 'Actor'::'motionEvent', unless on the 'Stage' +-- +-- 'Actor'::'enterEvent' +-- +-- 'Actor'::'leaveEvent' +-- +-- [@enable@] @True@ to enable per-actor motion events +-- +-- * Since 0.6 +-- +{# fun unsafe set_motion_events_enabled as ^ { `Bool' } -> `()' #} + + +-- | Gets whether the per-actor motion events are enabled. +-- +-- [@Returns@] @True@ if the motion events are enabled +-- +-- * Since 0.6 +-- +{# fun unsafe get_motion_events_enabled as ^ { } -> `Bool' #} + +-- | Clears the internal cache of glyphs used by the Pango +-- renderer. This will free up some memory and GL texture +-- resources. The cache will be automatically refilled as more text +-- is drawn. +-- +-- * Since 0.8 +-- +{# fun unsafe clear_glyph_cache as ^ { } -> `()' #} + +-- | Sets the font quality options for subsequent text rendering +-- operations. +-- +-- Using mipmapped textures will improve the quality for scaled down +-- text but will use more texture memory. +-- +-- Enabling hinting improves text quality for static text but may +-- introduce some artifacts if the text is animated. +-- +-- [@flags@] The new flags +-- +-- * Since 1.0 +-- +{# fun unsafe set_font_flags as ^ { cFromFlags `[FontFlags]' } -> `()' #} + +-- | Gets the current font flags for rendering text. See 'setFontFlags'. +-- +-- [@Returns@] The font flags +-- +-- * Since 1.0 +-- +{# fun unsafe get_font_flags as ^ { } -> `[FontFlags]' cToFlags #} + +{# pointer *PangoFontMap as FontMapPtr foreign -> FontMap nocode #} + +-- | Retrieves the PangoFontMap instance used by Clutter. You can use +-- the global font map object with the COGL Pango API. +-- +-- * Since 1.0 +-- +getFontMap :: IO FontMap +getFontMap = makeNewGObject mkFontMap $ {# call unsafe get_font_map #} + +--TODO: What about threads and timeouts etc. + + + +-- | Queries the current keyboard grab of clutter. +-- +-- [@Returns@] @Just@ the actor currently holding the keyboard grab, +-- or @Nothing@ if there is no grab.. transfer none. +-- +-- * Since 0.6 +-- +{# fun unsafe get_keyboard_grab as ^ { } -> `Maybe Actor' maybeNewActor* #} + + +-- | Queries the current pointer grab of clutter. +-- +-- [@Returns@] @Just@ the actor currently holding the pointer grab, or +-- @Nothing@ if there is no grab. +-- +-- * Since 0.6 +-- +{# fun unsafe get_pointer_grab as ^ { } -> `Maybe Actor' maybeNewActor* #} + + +-- | Grabs keyboard events, after the grab is done keyboard events +-- ('keyPressEvent' and 'keyReleaseEvent') are delivered to this +-- actor directly. The source set in the event will be the actor +-- that would have received the event if the keyboard grab was not +-- in effect. +-- +-- Like pointer grabs, keyboard grabs should only be used as a last +-- resource. +-- +-- See also 'stageSetKeyFocus' and 'actorGrabKeyFocus' to perform a +-- \"soft\" key grab and assign key focus to a specific actor. +-- +-- [@actor@] an Actor +-- +-- * Since 0.6 +-- +{# fun unsafe grab_keyboard as ^ { withActor* `Actor' } -> `()' #} + + + + +-- | Grabs pointer events, after the grab is done all pointer related +-- events (press, motion, release, enter, leave and scroll) are +-- delivered to this actor directly without passing through both +-- capture and bubble phases of the event delivery chain. The source +-- set in the event will be the actor that would have received the +-- event if the pointer grab was not in effect. +-- +-- * Note +-- +-- Grabs completely override the entire event delivery chain done by +-- Clutter. Pointer grabs should only be used as a last resource; +-- using the 'capturedEvent' signal should always be the preferred way +-- to intercept event delivery to reactive actors. +-- +-- If you wish to grab all the pointer events for a specific input +-- device, you should use 'grabPointerForDevice'. +-- +-- [@actor@] an Actor +-- +-- * Since 0.6 +-- +{# fun unsafe grab_pointer as ^ { withActor* `Actor' } -> `()' #} + +-- | Removes an existing grab of the keyboard. +-- +-- * Since 0.6 +-- +{# fun unsafe ungrab_keyboard as ^ { } -> `()' #} + + +-- | Removes an existing grab of the pointer. +-- +-- * Since 0.6 +-- +{# fun unsafe ungrab_pointer as ^ { } -> `()' #} + +-- | Grabs all the pointer events coming from the device id for actor. +-- +-- If id is -1 then this function is equivalent to 'grabPointer'. +-- +-- [@actor@] an Actor +-- +-- [@id@] a device id, or -1 +-- +-- * Since 0.8 +-- +{# fun unsafe grab_pointer_for_device as ^ { withActor* `Actor', `Int' } -> `()' #} + + +-- | Removes an existing grab of the pointer events for device id. +-- +-- [@id@] a device id +-- +-- * Since 0.8 +-- +{# fun unsafe ungrab_pointer_for_device as ^ { `Int' } -> `()' #} + +--{# fun unsafe clutter_do_event { withEvent* `Event' } -> `()' #} + diff --git a/Graphics/UI/Clutter/Group.chs b/Graphics/UI/Clutter/Group.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Group.chs @@ -0,0 +1,100 @@ +-- -*-haskell-*- +-- Clutter Group +-- +-- Author : Matthew Arsenault +-- +-- Created: 12 Sep 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | Group — Actor class containing multiple children. actors. +module Graphics.UI.Clutter.Group ( +-- * Description + +-- | A 'Group' is an Actor which contains multiple child actors +-- positioned relative to the ClutterGroup position. Other +-- operations such as scaling, rotating and clipping of the group +-- will apply to the child actors. +-- +-- A 'Group'\'s size is defined by the size and position of its +-- children. Resize requests via the Actor API will be ignored. +-- + +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Actor' +-- | +----'Group' +-- | +----'Stage' +-- @ + +-- * Types + Group, + GroupClass, + +-- * Constructors + groupNew, + +-- * Methods + groupRemoveAll, + groupGetNChildren, + groupGetNthChild + ) where + +{# import Graphics.UI.Clutter.Types #} + +import C2HS + + +-- | Create a new 'Group'. +-- +-- [@Returns@] the newly created 'Group' actor +-- +{# fun unsafe group_new as ^ { } -> `Group' newGroup* #} + + +-- | Removes all children actors from the 'Group'. +-- +-- [@group@] A 'Group' +-- +{# fun unsafe group_remove_all as ^ { withGroup* `Group' } -> `()' #} + +-- | Gets the number of actors held in the group. +-- +-- [@self@] A 'Group' +-- +-- [@Returns@] The number of child actors held in the group. +-- +-- * Since 0.2 +-- +{# fun unsafe group_get_n_children as ^ { withGroup* `Group' } -> `Int' #} + +-- | Gets a groups child held at index in stack. +-- +-- [@self@] A 'Group' +-- +-- [@index@] the position of the requested actor. +-- +-- [@Returns@] transfer none. transfer none. +-- +-- * Since 0.2 +-- +{# fun unsafe group_get_nth_child as ^ { withGroup* `Group', `Int' } -> `Actor' newActor* #} + diff --git a/Graphics/UI/Clutter/Interval.chs b/Graphics/UI/Clutter/Interval.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Interval.chs @@ -0,0 +1,134 @@ +-- -*-haskell-*- +-- Clutter Interval +-- +-- Author : Matthew Arsenault +-- +-- Created: 2 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface, + ScopedTypeVariables #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.Interval ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Interval' +-- @ + +-- * Types + Interval, +--ProgressFunc, + +-- * Constructors + intervalNew, + intervalClone, + +-- * Methods + +--intervalGetValueType, + intervalSetInitialValue, + intervalGetInitialValue, + +--intervalPeekInitalValue, + intervalSetFinalValue, + intervalGetFinalValue, + +--intervalPeekFinalValue, +--intervalSetInterval, +--intervalGetInterval, + + intervalComputeValue, +--intervalValidate, +--intervalRegisterProgressFunc + +-- * Attributes +--intervalInitialValue, +--intervalFinalValue, +--intervalInterval, +) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.StoreValue #} + +import C2HS +import Control.Monad (liftM) +import Prelude +import qualified Prelude as P + +import System.Glib.GValue + +intervalNew :: (GenericValueClass a) => a -> a -> IO (Interval a) +intervalNew initial final = let func = {# call unsafe interval_new_with_values #} + in withGenericValue initial $ \iniPtr -> + withGenericValue final $ \finPtr -> do + gtype <- genericValuePtrGetType iniPtr -- a little silly to gtype this way, also cast + interval <- newIntervalRaw =<< func gtype iniPtr finPtr + return (mkInterval (undefined :: a) interval) + + +intervalClone :: Interval a -> IO (Interval a) +intervalClone interval = withInterval interval $ \intervalPtr -> + liftM (mkInterval (undefined :: a)) + (newIntervalRaw =<< {# call unsafe interval_clone #} intervalPtr) + +intervalSetInitialValue :: (GenericValueClass a) => Interval a -> a -> IO () +intervalSetInitialValue interval val = withInterval interval $ \intervalPtr -> + withGenericValue val $ \valPtr -> + {# call unsafe interval_set_initial_value #} intervalPtr valPtr + +intervalSetFinalValue :: (GenericValueClass a) => Interval a -> a -> IO () +intervalSetFinalValue interval val = withInterval interval $ \intervalPtr -> + withGenericValue val $ \valPtr -> + {# call unsafe interval_set_initial_value #} intervalPtr valPtr + + +--TODO: Cleanup +intervalGetInitialValue :: (GenericValueClass a) => Interval a -> IO a +intervalGetInitialValue interval = withInterval interval $ \intervalPtr -> do + gtype <- liftM cToEnum $ {# call unsafe interval_get_value_type #} intervalPtr + (generic, _) <- allocaTypedGValue gtype $ \gvPtr -> + {# call unsafe interval_get_initial_value #} intervalPtr gvPtr + return (unsafeExtractGenericValue generic) + +intervalGetFinalValue :: (GenericValueClass a) => Interval a -> IO a +intervalGetFinalValue interval = withInterval interval $ \intervalPtr -> do + gtype <- liftM cToEnum $ {# call unsafe interval_get_value_type #} intervalPtr + (generic, _) <- allocaTypedGValue gtype $ \gvPtr -> + {# call unsafe interval_get_final_value #} intervalPtr gvPtr + return (unsafeExtractGenericValue generic) + + + + +intervalComputeValue :: (GenericValueClass a) => Interval a -> Double -> IO (Maybe a) +intervalComputeValue interval factor = let func = {# call unsafe interval_compute_value #} + in withInterval interval $ \intervalPtr -> do + gtype <- liftM cToEnum $ {# call unsafe interval_get_value_type #} intervalPtr + (generic, ret) <- allocaTypedGValue gtype $ \gvPtr -> do + liftM cToBool (func intervalPtr (cFloatConv factor) gvPtr) + return $ if ret + then Just (unsafeExtractGenericValue generic) + else P.Nothing + + +--intervalRegisterProgressFunc :: (GenericValueClass a) => GType -> a -> a -> Double -> IO (Maybe a) + + + diff --git a/Graphics/UI/Clutter/ListModel.chs b/Graphics/UI/Clutter/ListModel.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/ListModel.chs @@ -0,0 +1,57 @@ +-- -*-haskell-*- +-- Clutter ListModel +-- +-- Author : Matthew Arsenault +-- +-- Created: 31 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + + +-- | ListModel — List model implementation +module Graphics.UI.Clutter.ListModel ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Model' +-- | +----'ListModel' +-- @ + +-- * Types + ListModel, + ListModelClass, + +-- * Constructors + listModelNew + ) where + +{# import Graphics.UI.Clutter.Types #} + +import C2HS +import System.Glib.GType + +listModelNew :: [(GType, String)] -> IO ListModel +listModelNew lst = let (types, names) = unzip lst + in withMany withCString names $ \cstrs -> + withArrayLen cstrs $ \len namesPtr -> + withArray types $ \typesPtr -> + newListModel =<< {# call unsafe list_model_newv #} (cIntConv len) typesPtr namesPtr + + diff --git a/Graphics/UI/Clutter/Media.chs b/Graphics/UI/Clutter/Media.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Media.chs @@ -0,0 +1,273 @@ +-- -*-haskell-*- +-- Clutter Media +-- +-- Author : Matthew Arsenault +-- +-- Created: 2 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + + +-- | Media — An interface for controlling playback of media data +module Graphics.UI.Clutter.Media ( +-- * Description +-- | 'Media' is an interface for controlling playback of media +-- sources. +-- +-- Clutter core does not provide an implementation of this interface, +-- but other integration libraries like Clutter-GStreamer implement it +-- to offer a uniform API for applications. +-- +-- 'Media' is available since Clutter 0.2 +-- + +-- * Class Hierarchy +-- | +-- @ +-- | 'GInterface' +-- | +----'Media' +-- @ + +-- * Types + Media, + MediaClass, + +-- * Methods + mediaSetUri, + mediaGetUri, + mediaSetPlaying, + mediaGetPlaying, + mediaSetProgress, + mediaGetProgress, + mediaSetAudioVolume, + mediaGetAudioVolume, + mediaGetCanSeek, + mediaGetBufferFill, + mediaGetDuration, + mediaSetFilename, + +-- * Attributes + mediaAudioVolume, + mediaBufferFill, + mediaCanSeek, + mediaDuration, + mediaPlaying, + mediaProgress, + mediaUri, + +-- * Signals + onEos, + afterEos, + eos, + onError, + afterError, + error + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} +{# import Graphics.UI.Clutter.Signals #} + +import Prelude hiding (error) +import C2HS +import System.Glib.GError +import System.Glib.Attributes + + +-- | Sets the URI of media to uri. +-- +-- [@media@] a Media +-- +-- [@uri@] the URI of the media stream +-- +-- * Since 0.2 +-- +{# fun unsafe media_set_uri as ^ `(MediaClass m)' => { withMediaClass* `m', `String' } -> `()' #} + +-- | Retrieves the URI from media. +-- +-- [@media@] a Media +-- +-- [@Returns@] the URI of the media stream +-- +-- * Since 0.2 +-- +{# fun unsafe media_get_uri as ^ + `(MediaClass m)' => { withMediaClass* `m' } -> `String' peekNFreeString* #} + + +-- | Starts or stops playing of media. +-- +-- [@media@] a Media +-- +-- [@playing@] @True@ to start playing +-- +-- * Since 0.2 +-- +{# fun unsafe media_set_playing as ^ `(MediaClass m)' => { withMediaClass* `m', `Bool' } -> `()' #} + +-- | Retrieves the playing status of media. +-- +-- [@media@] A Media object +-- +-- [@Returns@] @True@ if playing, @False@ if stopped. +-- +-- * Since 0.2 +-- +{# fun unsafe media_get_playing as ^ `(MediaClass m)' => { withMediaClass* `m' } -> `Bool' #} + +-- | Sets the playback progress of media. The progress is a normalized +-- value between 0.0 (begin) and 1.0 (end). +-- +-- [@media@] a Media +-- +-- [@progress@] the progress of the playback, between 0.0 and 1.0 +-- +-- * Since 1.0 +-- +{# fun unsafe media_set_progress as ^ + `(MediaClass m)' => { withMediaClass* `m', `Double' } -> `()' #} + +-- | Retrieves the playback progress of media. +-- +-- [@media@] a Media +-- +-- [@Returns@] the playback progress, between 0.0 and 1.0 +-- +-- * Since 1.0 +-- +{# fun unsafe media_get_progress as ^ + `(MediaClass m)' => { withMediaClass* `m' } -> `Double' #} + + +-- | Sets the playback volume of media to volume. +-- +-- [@media@] a Media +-- +-- [@volume@] the volume as a double between 0.0 and 1.0 +-- +-- * Since 1.0 +-- +{# fun unsafe media_set_audio_volume as ^ + `(MediaClass m)' => { withMediaClass* `m', `Double' } -> `()' #} + +-- | Retrieves the playback volume of media. +-- +-- [@media@] a Media +-- +-- [@Returns@] The playback volume between 0.0 and 1.0 +-- +-- * Since 1.0 +{# fun unsafe media_get_audio_volume as ^ + `(MediaClass m)' => { withMediaClass* `m' } -> `Double' #} + +-- | Retrieves whether media is seekable or not. +-- +-- [@media@] a Media +-- +-- [@Returns@] @True@ if media can seek, @False@ otherwise. +-- +-- * Since 0.2 +-- +{# fun unsafe media_get_can_seek as ^ `(MediaClass m)' => { withMediaClass* `m' } -> `Bool' #} + + +-- | Retrieves the amount of the stream that is buffered. +-- +-- [@media@] a Media +-- +-- [@Returns@] the fill level, between 0.0 and 1.0 +-- +-- * Since 1.0 +-- +{# fun unsafe media_get_buffer_fill as ^ + `(MediaClass m)' => { withMediaClass* `m' } -> `Double' #} + +-- | Retrieves the duration of the media stream that media represents. +-- +-- [@media@] a Media +-- +-- [@Returns@] the duration of the media stream, in seconds +-- +-- * Since 0.2 +-- +{# fun unsafe media_get_duration as ^ + `(MediaClass m)' => { withMediaClass* `m' } -> `Double' #} + +-- | Sets the source of media using a file path. +-- +-- [@media@] a Media +-- +-- [@filename@] A filename +-- +-- * Since 0.2 +-- +{# fun unsafe media_set_filename as ^ + `(MediaClass m)' => { withMediaClass* `m', `String' } -> `()' #} + + +-- attributes + +mediaAudioVolume :: (MediaClass media) => Attr media Double +mediaAudioVolume = newNamedAttr "audio-volume" mediaGetAudioVolume mediaSetAudioVolume + +mediaBufferFill :: (MediaClass media) => ReadAttr media Double +mediaBufferFill = readNamedAttr "buffer-fill" mediaGetBufferFill + +mediaCanSeek :: (MediaClass media) => ReadAttr media Bool +mediaCanSeek = readAttr mediaGetCanSeek + +mediaDuration :: (MediaClass media) => ReadAttr media Double +mediaDuration = readNamedAttr "duration" mediaGetDuration + +mediaPlaying :: (MediaClass media) => Attr media Bool +mediaPlaying = newNamedAttr "playing" mediaGetPlaying mediaSetPlaying + +mediaProgress :: (MediaClass media) => Attr media Double +mediaProgress = newNamedAttr "progress" mediaGetProgress mediaSetProgress + +mediaUri :: (MediaClass media) => Attr media String +mediaUri = newNamedAttr "uri" mediaGetUri mediaSetUri + + +-- signals + +onEos, afterEos :: (MediaClass media) => media -> IO () -> IO (ConnectId media) +onEos = connect_NONE__NONE "eos" False +afterEos = connect_NONE__NONE "eos" True + +-- | The ::eos signal is emitted each time the media stream ends. +-- +eos :: (MediaClass media) => Signal media (IO ()) +eos = Signal (connect_NONE__NONE "eos") + +--CHECKME:checky +onError, afterError :: Timeline -> (GError -> IO ()) -> IO (ConnectId Timeline) +onError = connect_BOXED__NONE "error" peek False +afterError = connect_BOXED__NONE "error" peek True + +-- | The ::error signal is emitted each time an error occurred. +-- +-- [@error@] : the GError +-- +-- * Since 0.2 +-- +error :: Signal Timeline (GError -> IO ()) +error = Signal (connect_BOXED__NONE "error" peek) + diff --git a/Graphics/UI/Clutter/Model.chs b/Graphics/UI/Clutter/Model.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Model.chs @@ -0,0 +1,204 @@ +-- -*-haskell-*- +-- Clutter Model +-- +-- Author : Matthew Arsenault +-- +-- Created: 6 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +--TODO: Make it like models in gtk2hs + +module Graphics.UI.Clutter.Model ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Model' +-- | +----'ListModel' +-- @ + +-- * Types + Model, + ModelClass, + ModelForeachFunc, + +-- * Methods + +--modelSetNames, +--modelSetTypes, + + modelGetColumnName, + modelGetColumnType, + modelGetNColumns, + modelGetNRows, +--modelAppend, +--modelPrepend, +--modelInsert, +--modelInsertValue, + modelRemove, + modelForeach, + modelSetSortingColumn, + modelGetSortingColumn, +--modelSetSort, + modelResort, +--modelSetFilter, + modelGetFilterSet, + modelFilterIter, + modelFilterRow, + modelGetFirstIter, + modelGetLastIter, + modelGetIterAtRow, +-- * Attributes + modelFilterSet, + +--TODO: Signals +-- * Signals + onFilterChanged, + afterFilterChanged, + filterChanged, + onRowAdded, + afterRowAdded, + rowAdded, + onRowRemoved, + afterRowRemoved, + rowRemoved, + onSortChanged, + afterSortChanged, + sortChanged + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Signals #} + +import C2HS +import System.Glib.Attributes +import System.Glib.Properties +import System.Glib.GType +import Data.Word + +{# fun unsafe model_get_column_name as ^ + `(ModelClass model)' => { withModelClass* `model', cIntConv `Word' } -> `String' #} + +{# fun unsafe model_get_column_type as ^ + `(ModelClass model)' => { withModelClass* `model', cIntConv `Word' } -> `GType' cToEnum #} + +{# fun unsafe model_get_n_columns as ^ + `(ModelClass model)' => { withModelClass* `model' } -> `Word' cIntConv #} + +{# fun unsafe model_get_n_rows as ^ + `(ModelClass model)' => { withModelClass* `model' } -> `Word' cIntConv #} + + +{# fun unsafe model_get_sorting_column as ^ + `(ModelClass model)' => { withModelClass* `model' } -> `Word' cIntConv #} +{# fun unsafe model_set_sorting_column as ^ + `(ModelClass model)' => { withModelClass* `model', cIntConv `Word' } -> `()' #} + + +--CHECKME: unsafe? +{# fun unsafe model_remove as ^ + `(ModelClass model)' => { withModelClass* `model', cIntConv `Word' } -> `()' #} + + +modelForeach :: (ModelClass b) => b -> ModelForeachFunc -> IO () +modelForeach b func = withModelClass b $ \mptr -> do + funcPtr <- newModelForeachFunc func + {# call unsafe model_foreach #} mptr funcPtr nullPtr + freeHaskellFunPtr funcPtr + --CHECKME: unsafe? + + +{# fun unsafe model_resort as ^ + `(ModelClass model)' => { withModelClass* `model' } -> `()' #} + +{- +TODO: need the mkModelFilterFunc part +modelSetFilter :: (ModelClass model) => model -> ModelFilterFunc +modelSetFilter model filterFunc = withModelClass model $ \mdlPtr -> do + fFuncPtr <- mkModelFilterFunc + gdestroy <- mkFunPtrDestroyNotify fFuncPtr + --CHECKME: unsafe? + {# call unsafe model_set_filter #} mdpPtr fFuncPtr nullPtr gdestroy +-} + +{# fun unsafe model_get_filter_set as ^ + `(ModelClass model)' => { withModelClass* `model' } -> `Bool' #} + +{# fun unsafe model_filter_iter as ^ + `(ModelClass model)' => { withModelClass* `model', withModelIter* `ModelIter' } -> `Bool' #} + +{# fun unsafe model_filter_row as ^ + `(ModelClass model)' => { withModelClass* `model', cIntConv `Word' } -> `Bool' #} + +{# fun unsafe model_get_first_iter as ^ + `(ModelClass model)' => { withModelClass* `model' } -> `ModelIter' newModelIter* #} +{# fun unsafe model_get_last_iter as ^ + `(ModelClass model)' => { withModelClass* `model' } -> `ModelIter' newModelIter* #} +{# fun unsafe model_get_iter_at_row as ^ + `(ModelClass model)' => { withModelClass* `model', cIntConv `Word' } -> `ModelIter' newModelIter* #} + + +-- Attributes + +modelFilterSet :: (ModelClass self) => ReadAttr self Bool +modelFilterSet = readAttrFromBoolProperty "filter-set" + + +-- Signals + +onFilterChanged, afterFilterChanged :: Model -> IO () -> IO (ConnectId Model) +onFilterChanged = connect_NONE__NONE "filter-changed" False +afterFilterChanged = connect_NONE__NONE "filter-changed" True + +filterChanged :: Signal Model (IO ()) +filterChanged = Signal (connect_NONE__NONE "filter-changed") + + +onRowAdded, afterRowAdded :: Model -> (ModelIter -> IO ()) -> IO (ConnectId Model) +onRowAdded = connect_OBJECT__NONE "row-added" False +afterRowAdded = connect_OBJECT__NONE "row-added" True + +rowAdded :: Signal Model (ModelIter ->IO ()) +rowAdded = Signal (connect_OBJECT__NONE "row-added") + + +onRowChanged, afterRowChanged :: Model -> (ModelIter -> IO ()) -> IO (ConnectId Model) +onRowChanged = connect_OBJECT__NONE "row-changed" False +afterRowChanged = connect_OBJECT__NONE "row-changed" True + +rowChanged :: Signal Model (ModelIter ->IO ()) +rowChanged = Signal (connect_OBJECT__NONE "row-changed") + + +onRowRemoved, afterRowRemoved :: Model -> (ModelIter -> IO ()) -> IO (ConnectId Model) +onRowRemoved = connect_OBJECT__NONE "row-removed" False +afterRowRemoved = connect_OBJECT__NONE "row-removed" True + +rowRemoved :: Signal Model (ModelIter ->IO ()) +rowRemoved = Signal (connect_OBJECT__NONE "row-removed") + + +onSortChanged, afterSortChanged :: Model -> IO () -> IO (ConnectId Model) +onSortChanged = connect_NONE__NONE "sort-changed" False +afterSortChanged = connect_NONE__NONE "sort-changed" True + +sortChanged :: Signal Model (ModelIter ->IO ()) +sortChanged = Signal (connect_OBJECT__NONE "sort-changed") + diff --git a/Graphics/UI/Clutter/ModelIter.chs b/Graphics/UI/Clutter/ModelIter.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/ModelIter.chs @@ -0,0 +1,96 @@ +-- -*-haskell-*- +-- Clutter ModelIter +-- +-- Author : Matthew Arsenault +-- +-- Created: 24 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.ModelIter ( +-- * ModelIter + ModelIter, + ModelIterClass, + +-- * Methods + modelIterCopy, +--modelIterGet, +--modelIterGetValue, +--modelIterSet, +--modelIterSetValue, + modelIterIsFirst, + modelIterIsLast, + modelIterNext, + modelIterPrev, + modelIterGetModel, + modelIterGetRow, + +-- * Attributes + modelIterModel, + modelIterRow + ) where + +{# import Graphics.UI.Clutter.Types #} + +import C2HS +import Control.Monad (liftM) +import System.Glib.Attributes +import System.Glib.Properties +import System.Glib.GType +import qualified System.Glib.GTypeConstants as GType + +{# fun unsafe model_iter_copy as ^ { withModelIter* `ModelIter' } -> `ModelIter' newModelIter* #} + + +{# fun unsafe model_iter_is_first as ^ { withModelIter* `ModelIter' } -> `Bool' #} +{# fun unsafe model_iter_is_last as ^ { withModelIter* `ModelIter' } -> `Bool' #} + +{# fun unsafe model_iter_next as ^ { withModelIter* `ModelIter' } -> `ModelIter' newModelIter* #} + +{# fun unsafe model_iter_prev as ^ { withModelIter* `ModelIter' } -> `ModelIter' newModelIter* #} + +{# fun unsafe model_iter_get_model as ^ { withModelIter* `ModelIter' } -> `Model' newModel* #} + + +{# fun unsafe model_iter_get_row as ^ { withModelIter* `ModelIter' } -> `Word' cIntConv #} + + +-- Attributes + +-- CHECKME: Makes sense to be read only, and no set +--function (but get function), but clutter doc says Read/Write next to +--it + +-- | The row number to which this iter points to. +-- +-- Default value: 0 +-- +-- * Since 0.6 +-- +modelIterRow :: ReadAttr ModelIter Word +modelIterRow = readNamedAttr "row" modelIterGetRow + + +-- | A reference to the 'Model' that this iter belongs to. +-- +-- * Since 0.6 +-- +modelIterModel :: ReadAttr ModelIter Model +modelIterModel = readNamedAttr "model" modelIterGetModel + diff --git a/Graphics/UI/Clutter/Path.chs b/Graphics/UI/Clutter/Path.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Path.chs @@ -0,0 +1,475 @@ +-- -*-haskell-*- +-- Clutter Path +-- +-- Author : Matthew Arsenault +-- +-- Created: 2 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | Path — An object describing a path with straight lines and Bezier curves. +module Graphics.UI.Clutter.Path ( +-- * Detail +-- | A 'Path' contains a description of a path +-- consisting of straight lines and bezier curves. This can be used in +-- a 'BehaviourPath' to animate an actor moving along the path. +-- +-- The path consists of a series of nodes. Each node is one of the following four types: +-- +-- 'PathMoveTo' +-- +-- Changes the position of the path to the given pair of +-- coordinates. This is usually used as the first node of a path to +-- mark the start position. If it is used in the middle of a path then +-- the path will be disjoint and the actor will appear to jump to the +-- new position when animated. +-- +-- 'PathLineTo' +-- +-- Creates a straight line from the previous point to the given point. +-- +-- 'PathCurveTo' +-- +-- Creates a bezier curve. The end of the last node is used as the +-- first control point and the three subsequent coordinates given in +-- the node as used as the other three. +-- +-- 'PathClose' +-- +-- Creates a straight line from the last node to the last +-- pathMoveTo node. This can be used to close a path so that +-- it will appear as a loop when animated. +-- +-- The first three types have the corresponding relative versions +-- 'PathRelMoveTo', 'PathRelLineTo' and +-- 'PathRelCurveTo'. These are exactly the same except the +-- coordinates are given relative to the previous node instead of as +-- direct screen positions. +-- +-- You can build a path using the node adding functions such as +-- 'pathAddLineTo'. Alternatively the path can be described +-- in a string using a subset of the SVG path syntax. See +-- 'pathAddString' for details. +-- +-- * Path is available since Clutter 1.0 + +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Path' +-- @ + +-- * Types + Path, + PathClass, + PathNode, + PathCallback, + PathNodeType(..), + +-- * Constructors + pathNew, + pathNewWithDescription, + +-- * Methods + pathAddMoveTo, + pathAddRelMoveTo, + pathAddLineTo, + pathAddRelLineTo, + pathAddCurveTo, + pathAddRelCurveTo, + pathAddClose, + pathAddString, + pathAddNode, + pathAddCairoPath, + pathGetNNodes, + pathGetNode, + pathGetNodes, + pathForeach, + pathInsertNode, + pathRemoveNode, + pathReplaceNode, + pathGetDescription, + pathSetDescription, + + pathToCairoPath, + pathClear, + pathGetPosition, + pathGetLength, +-- * Attributes + pathDescription, + pathLength + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import System.Glib.Attributes +import System.Glib.Properties +import Control.Monad (liftM2) +import Graphics.Rendering.Cairo.Types (Cairo) +import qualified Graphics.Rendering.Cairo.Types as Cairo + +-- | Creates a new 'Path' instance with no nodes. +{# fun unsafe path_new as ^ { } -> `Path' newPath* #} + +-- | Creates a new 'Path' instance with the nodes described in +-- desc. See 'pathAddString' for details of the format of +-- the string. +-- +-- [@description@] A string describing the path. +-- +-- [@Returns@] The newly created 'Path'. +-- +-- * Since 1.0 +{# fun unsafe path_new_with_description as ^ { `String' } -> `Path' newPath* #} + +-- | Adds a 'PathMoveTo' type node to the path. This is usually used as +-- the first node in a path. It can also be used in the middle of +-- the path to cause the actor to jump to the new coordinate. +-- +-- [@path@] a 'Path' +-- +-- [@x@] the x coordinate +-- +-- [@y@] the y coordinate +-- +-- * Since 1.0 +{# fun unsafe path_add_move_to as ^ { withPath* `Path', `Int', `Int' } -> `()' #} + +-- | Same as 'pathAddMoveTo' except the coordinates are relative to the previous node. +-- +-- [@path@] a 'Path' +-- +-- [@x@] the x coordinate +-- +-- [@y@] the y coordinate +-- +-- * Since 1.0 +{# fun unsafe path_add_rel_move_to as ^ { withPath* `Path', `Int', `Int' } -> `()' #} + +-- | Adds a PathLineTo type node to the path. This causes the actor to +-- move to the new coordinates in a straight line. +-- +-- [@path@] a Path +-- +-- [@x@] the x coordinate +-- +-- [@y@] the y coordinate +-- +-- * Since 1.0 +{# fun unsafe path_add_line_to as ^ { withPath* `Path', `Int', `Int' } -> `()' #} + + +-- | Same as 'pathAddLineTo' except the coordinates are relative to the previous node. +-- +-- [@path@] a 'Path' +-- +-- [@x@] the x coordinate +-- +-- [@y@] the y coordinate +-- +-- * Since 1.0 +{# fun unsafe path_add_rel_line_to as ^ { withPath* `Path', `Int', `Int' } -> `()' #} + +-- | Adds a PathCurveTo type node to the path. This causes +-- the actor to follow a Bezier from the last node to (x_3, y_3) +-- using (x_1, y_1) and (x_2,y_2) as control points. +-- +-- [@path@] a 'Path' +-- +-- [@x_1@] the x coordinate of the first control point +-- +-- [@y_1@] the y coordinate of the first control point +-- +-- [@x_2@] the x coordinate of the second control point +-- +-- [@y_2@] the y coordinate of the second control point +-- +-- [@x_3@] the x coordinate of the third control point +-- +-- [@y_3@] the y coordinate of the third control point +-- +-- * Since 1.0 +{# fun unsafe path_add_curve_to as ^ { withPath* `Path', `Int', `Int', `Int', `Int', `Int', `Int' } -> `()' #} + + +-- | Same as 'pathAddCurveTo' except the coordinates are +-- relative to the previous node. +-- +-- [@path@]: a 'Path' +-- +-- [@x_1@] the x coordinate of the first control point +-- +-- [@y_1@] the y coordinate of the first control point +-- +-- [@x_2@] the x coordinate of the second control point +-- +-- [@y_2@] the y coordinate of the second control point +-- +-- [@x_3@] the x coordinate of the third control point +-- +-- [@y_3@] the y coordinate of the third control point +-- +-- * Since: 1.0 +{# fun unsafe path_add_rel_curve_to as ^ { withPath* `Path', `Int', `Int', `Int', `Int', `Int', `Int' } -> `()' #} + + +-- | Adds a 'PathClose' type node to the path. This creates a +-- straight line from the last node to the last 'PathMoveTo' +-- type node. +-- +-- [@path@] a 'Path' +-- +-- * Since: 1.0 +-- +{# fun unsafe path_add_close as ^ { withPath* `Path' } -> `()' #} + +-- | Adds new nodes to the end of the path as described by a @String@. The +-- format is a subset of the SVG path format. Each node is represented +-- by a letter and is followed by zero, one or three pairs of +-- coordinates. The coordinates can be separated by spaces or a +-- comma. The types are: +-- +-- [@M@] Adds a 'PathMoveTo' node. Takes one pair of coordinates. +-- +-- [@L@] Adds a 'PathLineTo' node. Takes one pair of coordinates. +-- +-- [@C@] Adds a 'PathCurveTo' node. Takes three pairs of coordinates. +-- +-- [@z@] Adds a 'PathClose' node. No coordinates are needed. +-- +-- The M, L and C commands can also be specified in lower case which +-- means the coordinates are relative to the previous node. +-- +-- For example, to move an actor in a 100 by 100 pixel square centered +-- on the point 300,300 you could use the following path: +-- +-- @ M 250,350 l 0 -100 L 350,250 l 0 100 z @ +-- +-- If the path description isn't valid @False@ will be returned and no nodes will be added. +-- +-- [@path@] a 'Path' +-- +-- [@str@] a string describing the new nodes +-- +-- [@Returns@] @True@ is the path description was valid or @False@ otherwise. +-- +-- * Since 1.0 +-- +{# fun unsafe path_add_string as ^ { withPath* `Path', `String' } -> `Bool' #} + + + +-- | Adds a node to the end of the path. +-- +-- [@path@] a 'Path' +-- +-- [@node@] a 'PathNode' +-- +-- * Since 1.0 +{# fun unsafe path_add_node as ^ { withPath* `Path', withPathNode* `PathNode' } -> `()' #} + +-- | Add the nodes of the Cairo path to the end of path +-- +-- [@path@] a Path +-- +-- [@cairopath@] a 'CairoPath' +-- +-- * Since 1.0 +-- +{# fun unsafe path_add_cairo_path as ^ { withPath* `Path', withCairoPath `Cairo.Path' } -> `()' #} + +-- | Retrieves the number of nodes in the path. +-- +-- [@path@] A 'Path' +-- +-- [@Returns@] The number of nodes +-- +-- * Since 1.0 +-- +{# fun unsafe path_get_n_nodes as ^ { withPath* `Path' } -> `Word' cIntConv #} + +-- | Retrieves the node of the path indexed by index. +-- +-- [@path@] a 'Path' +-- +-- [@index@] the node number to retrieve +-- +-- [@Returns@] The node at the location +-- +-- * Since 1.0 +-- +{# fun unsafe path_get_node as ^ { withPath* `Path', `Int', alloca- `PathNode' peek* } -> `()' #} + +-- | Returns a list of 'PathNodes'. +-- +-- [@path@] a 'Path' +-- +-- [@Returns@] a list of 'PathNode's in the path +-- +-- * Since 1.0 +-- +{# fun unsafe path_get_nodes as ^ { withPath* `Path' } -> `[PathNode]' newPathNodes* #} + +-- | Calls a function for each node of the path +-- +-- [@path@] a 'Path' +-- +-- [@callback@] the function to call with each node +-- +-- * Since 1.0 +-- +pathForeach :: Path -> PathCallback -> IO () +pathForeach path cpcb = withPath path $ \pathPtr -> do + funcPtr <- newPathCallback cpcb + --CHECKME: unsafe? + {# call unsafe path_foreach #} pathPtr funcPtr nullPtr + freeHaskellFunPtr funcPtr + +-- | Inserts node into the path before the node at the given +-- offset. If index is negative it will append the node to the end +-- of the path. +-- +-- [@path@] a 'Path' +-- +-- [@index@] offset of where to insert the node +-- +-- [@node@] the node to insert +-- +-- * Since 1.0 +-- +{# fun unsafe path_insert_node as ^ { withPath* `Path', `Int', withPathNode* `PathNode' } -> `()' #} + +-- | Removes the node at the given offset from the path. +-- +-- [@path@] a 'Path' +-- +-- [@index@] index of the node to remove +-- +-- * Since 1.0 +-- +{# fun unsafe path_remove_node as ^ { withPath* `Path', cIntConv `Word' } -> `()' #} + +-- | Replaces the node at a given offset index with node. +-- +-- [@path@] a 'Path' +-- +-- [@index@] index to the existing node +-- +-- [@node@] the replacement node +-- +-- *Since 1.0 +-- +{# fun unsafe path_replace_node as ^ { withPath* `Path', cIntConv `Word', withPathNode* `PathNode' } -> `()' #} + + +-- | Returns a string describing the path in the same format as used by 'pathAddString' +-- +-- [@path@] a 'Path' +-- +-- [@Returns@] a string description of the path +-- +-- * Since 1.0 +-- +{# fun unsafe path_get_description as ^ { withPath* `Path' } -> `String' peekNFreeString* #} + +-- | Replaces all of the nodes in the path with nodes described by +-- str. See 'pathAddString' for details of the format. +-- If the string is invalid then @False@ is returned and the path is unaltered. +-- +-- [@path@] a 'Path' +-- +-- [@str@] a string describing the path +-- +-- [@Returns@] @True@ if the path was valid, @False@ otherwise +-- +-- * Since 1.0 +-- +{# fun unsafe path_set_description as ^ { withPath* `Path', `String' } -> `Bool' #} + +-- | Add the nodes of the ClutterPath to the path in the Cairo context. +-- +-- [@path@] a 'Path' +-- +-- [@cairo@] a Cairo context +-- +-- * Since 1.0 +-- +{# fun unsafe path_to_cairo_path as ^ { withPath* `Path', withCairo `Cairo' } -> `()' #} + +-- | Removes all nodes from the path. +-- +-- [@path@] a 'Path' +-- +-- * Since 1.0 +-- +{# fun unsafe path_clear as ^ { withPath* `Path' } -> `()' #} + +--CHECKME: Do you want to get the position out? or is it just storage? +--CHECKME: Maybe not use type Knot = (Int, Int) +--CHECKME: is this what I want to return? + +-- | The value in progress represents a position along the path where +-- 0.0 is the beginning and 1.0 is the end of the path. An +-- interpolated position is then stored in position. +-- +-- [@path@] a 'Path' +-- +-- [@progress@] a position along the path as a fraction of its length +-- +-- [@position@] location to store the position +-- +-- [@Returns@] index of the node used to calculate the position. +-- +-- * Since 1.0 +-- +pathGetPosition :: Path -> Double -> IO (Word, Knot) +pathGetPosition path progress = withPath path $ \pathptr -> + alloca $ \kptr -> do + ret <- ({# call unsafe path_get_position #} pathptr (cFloatConv progress) (castPtr kptr)) + val <- peek kptr + return (cIntConv ret, val) + +-- | Retrieves an approximation of the total length of the path. +-- +-- [@path@] a 'Path' +-- +-- [@Returns@] the length of the path +-- +-- * Since 1.0 +-- +{# fun unsafe path_get_length as ^ { withPath* `Path' } -> `Word' cIntConv #} + + +-- | SVG-style description of the path. +-- +-- Default value: \"\" +-- +pathDescription :: Attr Path String +pathDescription = newAttrFromStringProperty "description" + +-- | An approximation of the total length of the path. +-- +-- Default value: 0 +-- +pathLength :: ReadAttr Path Word +pathLength = readNamedAttr "length" pathGetLength + diff --git a/Graphics/UI/Clutter/Rectangle.chs b/Graphics/UI/Clutter/Rectangle.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Rectangle.chs @@ -0,0 +1,149 @@ +-- -*-haskell-*- +-- Clutter Rectangle +-- +-- Author : Matthew Arsenault +-- +-- Created: 11 Sep 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | 'Rectangle' — An actor that displays a simple rectangle. +module Graphics.UI.Clutter.Rectangle ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Actor' +-- | +----'Rectangle' +-- @ + +-- * Types + Rectangle, + RectangleClass, + +-- * Constructors + rectangleNew, + rectangleNewWithColor, + +-- * Methods + rectangleGetColor, + rectangleSetColor, + + rectangleGetBorderColor, + rectangleSetBorderColor, + rectangleGetBorderWidth, + rectangleSetBorderWidth, + +-- * Attributes + rectangleColor, + rectangleBorderColor, + rectangleBorderWidth, + rectangleHasBorder + ) where + +{# import Graphics.UI.Clutter.Types #} + +import C2HS +import Control.Monad (liftM) +import System.Glib.Properties +import System.Glib.Attributes + + +-- | Creates a new actor with a rectangular shape. +{# fun unsafe rectangle_new as ^ { } -> `Rectangle' newRectangle* #} + +-- | Creates a new actor with a rectangular shape and of the given /color/ +{# fun unsafe rectangle_new_with_color as ^ { withColor* `Color'} -> `Rectangle' newRectangle* #} + +-- | Retrieves the color of rectangle +{# fun unsafe rectangle_get_color as ^ { withRectangle* `Rectangle', alloca- `Color' peek* } -> `()' #} +-- | Sets the color of a rectangle +{# fun unsafe rectangle_set_color as ^ { withRectangle* `Rectangle', withColor* `Color' } -> `()' #} + +-- | Gets the color of the border used by rectangle +-- +-- [@rectangle@] a 'Rectangle' +-- +-- [@color@] The color of the rectangle's border +-- +-- * Since 0.2 +--- +{# fun unsafe rectangle_get_border_color as ^ { withRectangle* `Rectangle', alloca- `Color' peek* } -> `()' #} + + +-- | Sets the color of the border used by rectangle using color +-- +-- [@rectangle@] a 'Rectangle' +-- +-- [@color@] the color of the border +-- +{# fun unsafe rectangle_set_border_color as ^ { withRectangle* `Rectangle', withColor* `Color'} -> `()' #} + +-- | Gets the width (in pixels) of the border used by rectangle +-- +-- [@rectangle@] a 'Rectangle' +-- +-- [@Returns@] the border's width +-- +-- * Since 0.2 +-- +{# fun unsafe rectangle_get_border_width as ^ { withRectangle* `Rectangle' } -> `Word' cIntConv #} + +-- | Sets the width (in pixel) of the border used by rectangle. A width of 0 will unset the border +-- +-- [@rectangle@] a 'Rectangle' +-- +-- [@width@] the width of the border +-- +-- * Since 0.2 +-- +{# fun unsafe rectangle_set_border_width as ^ { withRectangle* `Rectangle', cIntConv `Word' } -> `()' #} + +-- | The color of the rectangle. +-- +-- * Since 0.2 +-- +rectangleColor :: Attr Rectangle Color +rectangleColor = newNamedAttr "color" rectangleGetColor rectangleSetColor + +-- | The color of the border of the rectangle. +rectangleBorderColor :: Attr Rectangle Color +rectangleBorderColor = newNamedAttr "border-color" rectangleGetBorderColor rectangleSetBorderColor + +-- | The width of the border of the rectangle, in pixels. +-- +-- Default value: 0 +-- +-- * Since 0.2 +-- +rectangleBorderWidth :: Attr Rectangle Word +rectangleBorderWidth = newNamedAttr "border-width" rectangleGetBorderWidth rectangleSetBorderWidth + +--CHECKME: One random property without special function in clutter? + + +-- | Whether the 'Rectangle' should be displayed with a border. +-- +-- Default value: @False@ +-- +-- * Since 0.2 +-- +rectangleHasBorder :: Attr Rectangle Bool +rectangleHasBorder = newAttrFromBoolProperty "has-border" + diff --git a/Graphics/UI/Clutter/Score.chs b/Graphics/UI/Clutter/Score.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Score.chs @@ -0,0 +1,361 @@ +-- -*-haskell-*- +-- Clutter Score +-- +-- Author : Matthew Arsenault +-- +-- Created: 9 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | Score - Controller for multiple timelines +module Graphics.UI.Clutter.Score ( +-- * Description +-- | 'Score' is a base class for sequencing multiple timelines in +-- order. Using 'Score' it is possible to start multiple timelines at +-- the same time or launch multiple timelines when a particular +-- timeline has emitted the 'Timeline'::completed signal. +-- +-- Each time a 'Timeline' is started and completed, a signal will be +-- emitted. +-- +-- For example, this code will start two 'Timeline's after a third +-- timeline terminates: +-- +-- @ +-- do +-- timeline1 \<\- timelineNew 1000 +-- timeline2 \<\- timelineNew 500 +-- timeline3 \<\- timelineNew 500 +-- score \<\- scoreNew +-- scoreAppend score Nothing timeline1 +-- scoreAppend score \(Just timeline1\) timeline2 +-- scoreAppend score \(Just timeline1\) timeline3 +-- scoreStart score +-- @ +-- +-- New timelines can be appended to the 'Score' using 'scoreAppend' +-- and removed using 'scoreRemove'. +-- +-- Timelines can also be appended to a specific marker on the parent +-- timeline, using 'scoreAppendAtMarker'. +-- +-- The score can be cleared using 'scoreRemoveAll'. +-- +-- The list of timelines can be retrieved using 'scoreListTimelines'. +-- +-- The score state is controlled using 'scoreStart', 'scorePause', +-- 'scoreStop' and 'scoreRewind'. The state can be queried using +-- 'scoreIsPlaying'. +-- +-- Score is available since Clutter 0.6 +-- + +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Score' +-- @ +-- + +-- * Types + Score, + ScoreClass, + +-- * Constructors + scoreNew, + +-- * Methods + scoreSetLoop, + scoreGetLoop, + + scoreAppend, + scoreAppendAtMarker, + + scoreRemove, + scoreRemoveAll, + + scoreGetTimeline, + scoreListTimelines, + + scoreStart, + scorePause, + scoreStop, + scoreIsPlaying, + scoreRewind, + +-- * Attributes + scoreLoop, + +-- * Signals +{- +--FIXME: Export name conflict + onCompleted, + afterCompleted, + completed, + onPaused, + afterPaused, + paused, + onStarted, + afterStarted, + started, +-} + onTimelineCompleted, + afterTimelineCompleted, + timelineCompleted, + onTimelineStarted, + afterTimelineStarted, + timelineStarted + + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Signals #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import Control.Monad (liftM) +import System.Glib.Attributes + + +-- | Creates a new 'Score'. A 'Score' is an object that can hold +-- multiple 'Timelines' in a sequential order. +-- +-- [@Returns@] the newly created 'Score' +-- +-- * Since 0.6 +-- +{# fun unsafe score_new as ^ { } -> `Score' newScore* #} + +-- | Sets whether score should loop. A looping 'Score' will start from +-- its initial state after the ::complete signal has been fired. +-- +-- [@score@] a 'Score' +-- +-- [@loop@] @True@ for enable looping +-- +-- * Since 0.6 +-- +{# fun unsafe score_set_loop as ^ { withScore* `Score', `Bool' } -> `()' #} + +-- | Gets whether score is looping +-- +-- [@score@] a 'Score' +-- +-- [@Returns@] @True@ if the score is looping +-- +-- * Since 0.6 +-- +{# fun unsafe score_get_loop as ^ { withScore* `Score' } -> `Bool' #} + +scoreLoop :: Attr Score Bool +scoreLoop = newNamedAttr "score" scoreGetLoop scoreSetLoop + + +-- | Appends a timeline to another one existing in the score; the +-- newly appended timeline will be started when parent is complete. +-- +-- If parent is @Nothing@, the new 'Timeline' will be started when +-- 'scoreStart' is called. +-- +-- [@score@] a Score +-- +-- [@parent@] a @Just@ a 'Timeline' in the score, or @Nothing@ +-- +-- [@timeline@] a 'Timeline' +-- +-- [@Returns@] the id of the 'Timeline' inside the score, or 0 on +-- failure. The returned id can be used with 'scoreRemove' or +-- 'scoreGetTimeline'. +-- +-- * Since 0.6 +-- +{# fun unsafe score_append as ^ + { withScore* `Score', withMaybeTimeline* `Maybe Timeline', withTimeline* `Timeline' } -> `Word' cIntConv #} + +-- | Appends timeline at the given marker_name on the parent +-- 'Timeline'. +-- +-- If you want to append timeline at the end of parent, use 'scoreAppend'. +-- +-- [@score@] a 'Score' +-- +-- [@parent@] the parent 'Timeline' +-- +-- [@marker_name@] the name of the marker to use +-- +-- [@timeline@] the 'Timeline' to append +-- +-- [@Returns@] the id of the 'Timeline' inside the score, or 0 on +-- failure. The returned id can be used with 'scoreRemove' or +-- 'scoreGetTimeline'. +-- +-- * Since 0.8 +-- +{# fun unsafe score_append_at_marker as ^ + { withScore* `Score', withTimeline* `Timeline', `String', withTimeline* `Timeline' } -> `Word' cIntConv #} + + +-- | Removes the 'Timeline' with the given id inside score. If the +-- timeline has other timelines attached to it, those are removed as +-- well. +-- +-- [@score@] a 'Score' +-- +-- [@id@] the id of the timeline to remove +-- +-- * Since 0.6 +-- +{# fun unsafe score_remove as ^ { withScore* `Score', cIntConv `Word' } -> `()' #} + +-- | Removes all the timelines inside score. +-- +-- [@score@] a 'Score' +-- +-- * Since 0.6 +-- +{# fun unsafe score_remove_all as ^ { withScore* `Score' } -> `()' #} + +-- | Retrieves the 'Timeline' for id inside score. +-- +-- [@score@] a 'Score' +-- +-- [@id@] the id of the timeline +-- +-- [@Returns@] the 'Timeline' +-- +-- * Since 0.6 +-- +{# fun unsafe score_get_timeline as ^ + { withScore* `Score', cIntConv `Word' } -> `Timeline' newTimeline* #} + + +-- | Retrieves a list of all the 'Timeline's managed by score. +-- +-- [@score@] a 'Score' +-- +-- [@Returns@] the list of 'Timeline's in the 'Score' +-- +-- * Since 0.6 +-- +{# fun unsafe score_list_timelines as ^ + { withScore* `Score'} -> `[Timeline]' newTimelineList* #} + +-- | Starts the score. +-- +-- * Since 0.6 +-- +{# fun score_start as ^ { withScore* `Score' } -> `()' #} + +-- | Pauses a playing score score. +-- +-- * Since 0.6 +-- +{# fun score_pause as ^ { withScore* `Score' } -> `()' #} + +-- | Stops and rewinds a playing 'Score' instance. +-- +-- * Since 0.6 +-- +{# fun score_stop as ^ { withScore* `Score' } -> `()' #} + +-- | Query state of a 'Score' instance. +-- +-- [@score@] A 'Score' +-- +-- [@Returns@] @True@ if score is currently playing +-- +-- * Since 0.6 +-- +{# fun unsafe score_is_playing as ^ { withScore* `Score' } -> `Bool' #} + + +-- | Rewinds a 'Score' to its initial state. +-- +-- * Since 0.6 +-- +{# fun unsafe score_rewind as ^ { withScore* `Score' } -> `()' #} + + +--onCompleted, afterCompleted :: Score -> IO () -> IO (ConnectId Score) + + +-- | The ::completed signal is emitted each time a 'Score' terminates. +-- +-- * Since 0.6 +-- + +-- onPaused, afterPaused :: Score -> IO () -> IO (ConnectId Score) + + +-- | The ::paused signal is emitted each time a 'Score' is paused. +-- +-- * Since 0.6 +-- +-- paused :: Signal Score (IO ()) + + + +-- onStarted, afterStarted :: Score -> IO () -> IO (ConnectId Score) + + +instance Playable Score where + started = Signal (connect_NONE__NONE "started") + onStarted = connect_NONE__NONE "started" False + afterStarted = connect_NONE__NONE "started" True + completed = Signal (connect_NONE__NONE "completed") + onCompleted = connect_NONE__NONE "completed" False + afterCompleted = connect_NONE__NONE "completed" True + paused = Signal (connect_NONE__NONE "paused") + onPaused = connect_NONE__NONE "paused" False + afterPaused = connect_NONE__NONE "paused" True + + +onTimelineCompleted, afterTimelineCompleted :: Score -> (Timeline -> IO ()) -> IO (ConnectId Score) +onTimelineCompleted = connect_OBJECT__NONE "timeline-completed" False +afterTimelineCompleted = connect_OBJECT__NONE "timeline-completed" True + + +-- | The ::timeline-completed signal is emitted each time a timeline +-- inside a 'Score' terminates. +-- +-- [@timeline@] the completed timeline +-- +-- * Since 0.6 +-- +timelineCompleted :: Signal Score (Timeline -> IO ()) +timelineCompleted = Signal (connect_OBJECT__NONE "timeline-completed") + + +onTimelineStarted, afterTimelineStarted :: Score -> (Timeline -> IO ()) -> IO (ConnectId Score) +onTimelineStarted = connect_OBJECT__NONE "timeline-started" False +afterTimelineStarted = connect_OBJECT__NONE "timeline-started" True + + +-- | The ::timeline-started signal is emitted each time a new timeline +-- inside a 'Score' starts playing. +-- +-- [@timeline@] the current timeline +-- +-- * Since 0.6 +-- +timelineStarted :: Signal Score (Timeline -> IO ()) +timelineStarted = Signal (connect_OBJECT__NONE "timeline-started") + + diff --git a/Graphics/UI/Clutter/Script.chs b/Graphics/UI/Clutter/Script.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Script.chs @@ -0,0 +1,126 @@ +-- -*-haskell-*- +-- Clutter Script +-- +-- Author : Matthew Arsenault +-- +-- Created: 6 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.Script ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Script' +-- @ + +-- * Types + Script, + ScriptError(..), + + +-- * Constructors + scriptNew, + +-- * Methods + +--scriptLoadFromData, +--scriptLoadFromFile, +--scriptAddSearchPaths, + scriptLookupFilename, +--scriptGetObject, +--scriptGetObjects, +--scriptUnmergeObjects, + scriptEnsureObjects, +--scriptListObjects, + scriptConnectSignals, +--scriptConnectSignalsFull, +--scriptGetTypeFromName, + getScriptId, + +-- * Attributes + scriptFilename, + scriptFilenameSet + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import Control.Monad (liftM) +import System.Glib.GObject +import System.Glib.GType +import System.Glib.GTypeConstants +import System.Glib.Attributes +import System.Glib.Properties + +{# fun unsafe script_new as ^ { } -> `Script' newScript* #} + +{# fun unsafe script_lookup_filename as ^ { withScript* `Script', `String' } -> `String' peekNFreeString* #} + +{# fun unsafe script_unmerge_objects as ^ { withScript* `Script', cIntConv `Word' } -> `()' #} +{# fun unsafe script_ensure_objects as ^ { withScript* `Script' } -> `()' #} + + +--CHECKME: unsafe probably wrong +scriptConnectSignals :: Script -> IO () +scriptConnectSignals script = withScript script $ \p -> + {# call unsafe script_connect_signals #} p nullPtr + +{- +scriptConnectSignalsFull :: Script -> ScriptConnectFunc -> IO () +scriptConnectSignals script func = withScript $ \p -> do + funcPtr <- mkScriptConnectFunc func + {# call unsafe script_connect_signals #} p funcPtr nullPtr + freeHaskellFunPtr funcPtr +-} + + +{# fun unsafe script_get_type_from_name as ^ + { withScript* `Script', `String' } -> `GType' cFromEnum #} + +{# fun unsafe get_script_id as ^ + `(GObjectClass gobject)' => { withGObject* `gobject' } -> `String' #} + + + +-- | The path of the currently parsed file. If 'scriptFilenameSet' is +-- @False@ then the value of this property is undefined. +-- +-- Default value: @Nothing@ +-- +-- * Since 0.6 +-- +scriptFilename :: ReadAttr Script (Maybe String) +scriptFilename = readAttrFromMaybeStringProperty "filename" + + +-- | Whether the 'scriptFilename' property is set. If this property is +-- @True@ then the currently parsed data comes from a file, and the +-- file name is stored inside the 'Script':filename property. +-- +-- Default value: @False@ +-- +-- * Since 0.6 +-- +scriptFilenameSet :: ReadAttr Script Bool +scriptFilenameSet = readAttrFromBoolProperty "filename-set" + + diff --git a/Graphics/UI/Clutter/Scriptable.chs b/Graphics/UI/Clutter/Scriptable.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Scriptable.chs @@ -0,0 +1,57 @@ +-- -*-haskell-*- +-- Clutter Scriptable +-- +-- Author : Matthew Arsenault +-- +-- Created: 9 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.Scriptable ( +-- | +-- @ +-- | 'GInterface' +-- | +----'Scriptable' +-- @ + +-- * Types + ScriptableClass, + +-- * Methods + scriptableSetId, + scriptableGetId, + +--scriptableParseCustomNode, +--scriptableSetCustomProperty + +-- * Attributes + scriptableId + ) where + +{# import Graphics.UI.Clutter.Types #} + +import C2HS +import System.Glib.Attributes + +{# fun unsafe scriptable_get_id as ^ `(ScriptableClass o)' => { withScriptableClass* `o'} -> `String' #} +{# fun unsafe scriptable_set_id as ^ `(ScriptableClass o)' => { withScriptableClass* `o', `String'} -> `()' #} +scriptableId :: (ScriptableClass self) => Attr self String +scriptableId = newAttr scriptableGetId scriptableSetId + + diff --git a/Graphics/UI/Clutter/Shader.chs b/Graphics/UI/Clutter/Shader.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Shader.chs @@ -0,0 +1,292 @@ +-- -*-haskell-*- +-- Clutter Shader +-- +-- Author : Matthew Arsenault +-- +-- Created: 6 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | Shader — Programmable pipeline abstraction +module Graphics.UI.Clutter.Shader ( +-- * Description +-- | 'Shader' is an object providing an abstraction over the OpenGL +-- programmable pipeline. By using ClutterShaders is possible to +-- override the drawing pipeline by using small programs also known as +-- "shaders". +-- +-- ClutterShader is available since Clutter 0.6 +-- +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Shader' +-- @ + +-- * Types + Shader, + ShaderClass, + ShaderError(..), + +-- * Constructors + shaderNew, + +-- * Methods + shaderSetVertexSource, + shaderGetVertexSource, + + shaderSetFragmentSource, + shaderGetFragmentSource, + + shaderCompile, + shaderRelease, + + shaderIsCompiled, + + shaderSetIsEnabled, + shaderGetIsEnabled, + +--shaderSetUniform, +--shaderGetCoglProgram, +--shaderGetCoglFragmentShader, +--shaderGetCoglVertexShader, + +--valueHoldsShaderFloat, + +--valueSetShaderFloat, +--valueGetShaderFloat, +--valueShaderFloat, + +--valueHoldsShaderInt, +--valueSetShaderInt, +--valueGetShaderInt, +--valueShaderInt, + +--valueHoldsShaderMatrix, +--valueSetShaderMatrix, +--valueGetShaderMatrix, +--valueShaderMatrix + +-- * Attributes + shaderCompiled, + shaderEnabled, + shaderFragmentSource, + shaderVertexSource + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import Control.Monad (liftM) +import System.Glib.Attributes +import System.Glib.Properties +import System.Glib.GError + + +-- | Create a new 'Shader' instance. +-- +-- [@Returns@] a new Shader. +-- +-- * Since 0.6 +-- +{# fun unsafe shader_new as ^ { } -> `Shader' newShader* #} + + +-- | Sets the GLSL source code to be used by a 'Shader' for the vertex +-- program. +-- +-- [@shader@] a 'Shader' +-- +-- [@data@] GLSL source code. +-- +-- * Since 0.6 +-- +shaderSetVertexSource :: Shader -> String -> IO () +shaderSetVertexSource shader str= let func = {# call unsafe shader_set_vertex_source #} + in withShader shader $ \shdPtr -> + withCStringLen str $ \(strPtr, len) -> + func shdPtr strPtr (cIntConv len) + +-- | Query the current GLSL vertex source set on shader. +-- +-- [@shader@] a 'Shader' +-- +-- [@Returns@] @Just@ the source of the vertex shader for this +-- 'Shader' object or @Nothing@. +-- +-- * Since 0.6 +-- +{# fun unsafe shader_get_vertex_source as ^ { withShader* `Shader' } -> `Maybe String' maybeString* #} + + +-- | Query the current GLSL fragment source set on shader. +-- +-- [@shader@] a 'Shader' +-- +-- [@Returns@] the source of the fragment shader for this 'Shader' +-- object or NULL. The returned string is owned by the shader object +-- and should never be modified or freed +-- +-- * Since 0.6 +-- +shaderSetFragmentSource :: Shader -> String -> IO () +shaderSetFragmentSource shader str= let func = {# call unsafe shader_set_fragment_source #} + in withShader shader $ \shdPtr -> + withCStringLen str $ \(strPtr, len) -> + func shdPtr strPtr (cIntConv len) + +-- | Query the current GLSL fragment source set on shader. +-- +-- [@shader@] a 'Shader' +-- +-- [@Returns@] @Just@ the source of the fragment shader for this +-- 'Shader' object or @Nothing@. +-- +-- * Since 0.6 +-- +{# fun unsafe shader_get_fragment_source as ^ { withShader* `Shader' } -> `Maybe String' maybeString* #} + +--TODO: Fix this description of GError +-- | Compiles and links GLSL sources set for vertex and fragment +-- shaders for a 'Shader'. If the compilation fails a GError +-- exception will be thrown containing the errors from the compiler, +-- if any. +-- +-- [@shader@] a 'Shader' +-- +-- [@Returns@] returns @True@ if the shader was succesfully compiled. +-- +-- * Since 0.8 +-- +shaderCompile :: Shader -> IO Bool +shaderCompile shader = withShader shader $ \sPtr -> + propagateGError $ \gerrorPtr -> + liftM cToBool $ {# call unsafe shader_compile #} sPtr gerrorPtr + + +-- | Frees up any GL context resources held by the shader. +-- +-- [@shader@] a 'Shader' +-- +-- * Since 0.6 +-- +{# fun unsafe shader_release as ^ { withShader* `Shader' } -> `()' #} + +-- | Checks whether shader is is currently compiled, linked and bound +-- to the GL context. +-- +-- [@shader@] a 'Shader' +-- +-- [@Returns@] @True@ if the shader is compiled, linked and ready for +-- use. +-- +-- * Since 0.8 +-- +{# fun unsafe shader_is_compiled as ^ { withShader* `Shader' } -> `Bool' #} + + +-- | Enables a shader. This function will attempt to compile and link +-- the shader, if it isn't already. +-- +-- When enabled is @False@ the default state of the GL pipeline will +-- be used instead. +-- +-- [@shader@] a 'Shader' +-- +-- [@enabled@] The new state of the shader. +-- +-- * Since 0.6 +-- +{# fun unsafe shader_set_is_enabled as ^ { withShader* `Shader', `Bool' } -> `()' #} + +-- | Checks whether shader is enabled. +-- +-- [@shader@] a 'Shader' +-- +-- [@Returns@] @True@ if the shader is enabled. +-- +-- * Since 0.6 +-- +{# fun unsafe shader_get_is_enabled as ^ { withShader* `Shader' } -> `Bool' #} + +--TODO: GValue +--{# fun unsafe shader_set_uniform as ^ { withShader* `Shader', `String', } -> `()' #} + +--{# fun unsafe shader_get_cogl_program as ^ { withShader* `Shader' } -> `CoglHandle' #} + +--{# fun unsafe shader_get_cogl_fragment_shader as ^ { withShader* `Shader' } -> `CoglHandle' #} + +--{# fun unsafe shader_get_cogl_vertex_shader as ^ { withShader* `Shader' } -> `CoglHandle' #} + +--{# fun unsafe value_set_shader_float as ^ +--{# fun unsafe value_get_shader_float as ^ + +--{# fun unsafe value_set_shader_int as ^ +--{# fun unsafe value_get_shader_int as ^ + +--{# fun unsafe value_set_shader_matrix as ^ +--{# fun unsafe value_get_shader_matrix as ^ + + + +-- | Whether the shader is compiled and linked, ready for use in the +-- GL context. +-- +-- Default value: @False@ +-- +-- * Since 0.8 +-- +shaderCompiled :: ReadAttr Shader Bool +shaderCompiled = readAttrFromBoolProperty "compiled" + + +-- | Whether the shader is currently used in the GL rendering +-- pipeline. +-- +-- Default value: @False@ +-- +-- * Since 0.6 +-- +shaderEnabled :: Attr Shader Bool +shaderEnabled = newAttrFromBoolProperty "enabled" + + +-- | GLSL source code for the fragment shader part of the shader +-- program. +-- +-- Default value: @Nothing@ +-- +-- * Since 0.6 +-- +shaderFragmentSource :: Attr Shader (Maybe String) +shaderFragmentSource = newAttrFromMaybeStringProperty "fragment-source" + +-- | GLSL source code for the vertex shader part of the shader +-- program, if any +-- +-- Default value: @Nothing@ +-- +-- * Since 0.6 +-- +shaderVertexSource :: Attr Shader (Maybe String) +shaderVertexSource = newAttrFromMaybeStringProperty "vertex-source" + + diff --git a/Graphics/UI/Clutter/Signals.chs b/Graphics/UI/Clutter/Signals.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Signals.chs @@ -0,0 +1,274 @@ +{-# OPTIONS_HADDOCK hide #-} +-- -*-haskell-*- +-- -------------------- automatically generated file - do not edit ------------ +-- Callback installers for the GIMP Toolkit (GTK) Binding for Haskell +-- +-- Author : Axel Simon +-- +-- Created: 19 September 2009 +-- +-- Copyright (C) 2000-2005 Axel Simon +-- +-- 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 3 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. +-- +-- #hide + +-- These functions are used to connect signals to widgets. They are auto- +-- matically created through HookGenerator.hs which takes a list of possible +-- function signatures that are included in the GTK sources (gtkmarshal.list). +-- +-- The object system in the second version of GTK is based on GObject from +-- GLIB. This base class is rather primitive in that it only implements +-- ref and unref methods (and others that are not interesting to us). If +-- the marshall list mentions OBJECT it refers to an instance of this +-- GObject which is automatically wrapped with a ref and unref call. +-- Structures which are not derived from GObject have to be passed as +-- BOXED which gives the signal connect function a possiblity to do the +-- conversion into a proper ForeignPtr type. In special cases the signal +-- connect function use a PTR type which will then be mangled in the +-- user function directly. The latter is needed if a signal delivers a +-- pointer to a string and its length in a separate integer. +-- +module Graphics.UI.Clutter.Signals ( + module System.Glib.Signals, + + connect_PTR__BOOL, + connect_ENUM__BOOL, + connect_NONE__BOOL, + connect_PTR__INT, + connect_BOOL__NONE, + connect_INT__NONE, + connect_WORD__NONE, + connect_NONE__NONE, + connect_OBJECT__NONE, + connect_PTR__NONE, + connect_BOXED__NONE, + connect_PTR_ENUM__NONE, + connect_CHAR_INT__NONE, + connect_STRING_INT__NONE, + connect_STRING_WORD__NONE, + connect_INT_INT__NONE, + + ) where + +import Control.Monad (liftM) + +import System.Glib.FFI +import System.Glib.UTFString (peekUTFString) +import System.Glib.GError (failOnGError) +import System.Glib.Signals +import System.Glib.GObject + +{#context lib="clutter" prefix="clutter" #} + + +-- Here are the generators that turn a Haskell function into +-- a C function pointer. The fist Argument is always the widget, +-- the last one is the user g_pointer. Both are ignored. + + +connect_PTR__BOOL :: + GObjectClass obj => SignalName -> + ConnectAfter -> obj -> + (Ptr a -> IO Bool) -> + IO (ConnectId obj) +connect_PTR__BOOL signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Ptr () -> IO Bool + action _ ptr1 = + failOnGError $ + user (castPtr ptr1) + +connect_ENUM__BOOL :: + (Enum a, GObjectClass obj) => SignalName -> + ConnectAfter -> obj -> + (a -> IO Bool) -> + IO (ConnectId obj) +connect_ENUM__BOOL signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Int -> IO Bool + action _ enum1 = + failOnGError $ + user (toEnum enum1) + +connect_NONE__BOOL :: + GObjectClass obj => SignalName -> + ConnectAfter -> obj -> + (IO Bool) -> + IO (ConnectId obj) +connect_NONE__BOOL signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> IO Bool + action _ = + failOnGError $ + user + +connect_PTR__INT :: + GObjectClass obj => SignalName -> + ConnectAfter -> obj -> + (Ptr a -> IO Int) -> + IO (ConnectId obj) +connect_PTR__INT signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Ptr () -> IO Int + action _ ptr1 = + failOnGError $ + user (castPtr ptr1) + +connect_BOOL__NONE :: + GObjectClass obj => SignalName -> + ConnectAfter -> obj -> + (Bool -> IO ()) -> + IO (ConnectId obj) +connect_BOOL__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Bool -> IO () + action _ bool1 = + failOnGError $ + user bool1 + +connect_INT__NONE :: + GObjectClass obj => SignalName -> + ConnectAfter -> obj -> + (Int -> IO ()) -> + IO (ConnectId obj) +connect_INT__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Int -> IO () + action _ int1 = + failOnGError $ + user int1 + +connect_WORD__NONE :: + GObjectClass obj => SignalName -> + ConnectAfter -> obj -> + (Word -> IO ()) -> + IO (ConnectId obj) +connect_WORD__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Word -> IO () + action _ int1 = + failOnGError $ + user int1 + +connect_NONE__NONE :: + GObjectClass obj => SignalName -> + ConnectAfter -> obj -> + (IO ()) -> + IO (ConnectId obj) +connect_NONE__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> IO () + action _ = + failOnGError $ + user + +connect_OBJECT__NONE :: + (GObjectClass a', GObjectClass obj) => SignalName -> + ConnectAfter -> obj -> + (a' -> IO ()) -> + IO (ConnectId obj) +connect_OBJECT__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Ptr GObject -> IO () + action _ obj1 = + failOnGError $ + makeNewGObject mkGObject (return obj1) >>= \obj1' -> + user (unsafeCastGObject obj1') + +connect_PTR__NONE :: + GObjectClass obj => SignalName -> + ConnectAfter -> obj -> + (Ptr a -> IO ()) -> + IO (ConnectId obj) +connect_PTR__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Ptr () -> IO () + action _ ptr1 = + failOnGError $ + user (castPtr ptr1) + +connect_BOXED__NONE :: + GObjectClass obj => SignalName -> + (Ptr a' -> IO a) -> + ConnectAfter -> obj -> + (a -> IO ()) -> + IO (ConnectId obj) +connect_BOXED__NONE signal boxedPre1 after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Ptr () -> IO () + action _ box1 = + failOnGError $ + boxedPre1 (castPtr box1) >>= \box1' -> + user box1' + +connect_PTR_ENUM__NONE :: + (Enum b, GObjectClass obj) => SignalName -> + ConnectAfter -> obj -> + (Ptr a -> b -> IO ()) -> + IO (ConnectId obj) +connect_PTR_ENUM__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Ptr () -> Int -> IO () + action _ ptr1 enum2 = + failOnGError $ + user (castPtr ptr1) (toEnum enum2) + +connect_CHAR_INT__NONE :: + GObjectClass obj => SignalName -> + ConnectAfter -> obj -> + (Char -> Int -> IO ()) -> + IO (ConnectId obj) +connect_CHAR_INT__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Char -> Int -> IO () + action _ char1 int2 = + failOnGError $ + user char1 int2 + +connect_STRING_INT__NONE :: + GObjectClass obj => SignalName -> + ConnectAfter -> obj -> + (String -> Int -> IO ()) -> + IO (ConnectId obj) +connect_STRING_INT__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> CString -> Int -> IO () + action _ str1 int2 = + failOnGError $ + peekUTFString str1 >>= \str1' -> + user str1' int2 + +connect_STRING_WORD__NONE :: + GObjectClass obj => SignalName -> + ConnectAfter -> obj -> + (String -> Word -> IO ()) -> + IO (ConnectId obj) +connect_STRING_WORD__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> CString -> Word -> IO () + action _ str1 int2 = + failOnGError $ + peekUTFString str1 >>= \str1' -> + user str1' int2 + +connect_INT_INT__NONE :: + GObjectClass obj => SignalName -> + ConnectAfter -> obj -> + (Int -> Int -> IO ()) -> + IO (ConnectId obj) +connect_INT_INT__NONE signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Int -> Int -> IO () + action _ int1 int2 = + failOnGError $ + user int1 int2 + diff --git a/Graphics/UI/Clutter/Stage.chs b/Graphics/UI/Clutter/Stage.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Stage.chs @@ -0,0 +1,529 @@ +-- -*-haskell-*- +-- Clutter Stage +-- +-- Author : Matthew Arsenault +-- +-- Created: 11 Sep 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include +#include + +{# context lib="clutter" prefix="clutter" #} + +--FIXME: remove reference to freeing stuff +-- | 'Stage' — Top level visual element to which actors are placed. +module Graphics.UI.Clutter.Stage ( +-- * Detail +-- | ClutterStage is a top level 'window' on which child actors are placed and manipulated. +-- +-- Clutter creates a default stage upon initialization, which can be +-- retrieved using 'stageGetDefault'. Clutter always +-- provides the default stage, unless the backend is unable to create +-- one. The stage returned by 'stageGetDefault' is +-- guaranteed to always be the same. +-- +-- Backends might provide support for multiple stages. The support for +-- this feature can be checked at run-time using the +-- 'clutterFeatureAvailable' function and the +-- CLUTTER_FEATURE_STAGE_MULTIPLE flag. If the backend used supports +-- multiple stages, new 'Stage' instances can be created using +-- 'stageNew'. These stages must be managed by the developer +-- using 'actorDestroy', which will take care of destroying +-- all the actors contained inside them. +-- +-- 'Stage' is a proxy actor, wrapping the backend-specific +-- implementation of the windowing system. It is possible to subclass +-- 'Stage', as long as every overridden virtual function chains up +-- to the parent class corresponding function. + +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Actor' +-- | +----'Group' +-- | +----'Stage' +-- @ + +-- * Types + Stage, + StageClass, + Perspective(..), + Fog(..), + PickMode(..), + +-- * Constructors + stageGetDefault, + stageNew, + + -- * Methods, + stageIsDefault, + + stageSetColor, + stageGetColor, + + stageSetFullscreen, + stageGetFullscreen, + + stageShowCursor, + stageHideCursor, + + stageGetActorAtPos, + + stageEnsureCurrent, + stageEnsureViewport, + + stageEnsureRedraw, + stageQueueRedraw, + +--stageEvent, + stageSetKeyFocus, + stageGetKeyFocus, +--stageKeyFocus, +--stageReadPixels, + + stageSetThrottleMotionEvents, + stageGetThrottleMotionEvents, + + stageSetPerspective, + stageGetPerspective, + + stageSetTitle, + stageGetTitle, + + stageSetUserResizable, + stageGetUserResizable, + + stageSetUseFog, + stageGetUseFog, + + stageSetFog, + stageGetFog, + +-- * Attributes + stageColor, + stageCursorVisible, + stageFog, + stageFullscreenSet, + stageOffscreen, + stagePerspective, + stageTitle, + stageUseFog, + stageUserResizable, + +-- * Signals +--FIXME: Export conflicts with Text's signals and probably other signals + onActivate, + afterActivate, + activate, + + onDeactivate, + afterDeactivate, + deactivate, + + onFullscreen, + afterFullscreen, + fullscreen, + + onUnfullscreen, + afterUnfullscreen, + unfullscreen + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Actor #} +{# import Graphics.UI.Clutter.Signals #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import Control.Monad (liftM) +import System.Glib.Attributes +import System.Glib.Properties +import System.Glib.FFI (maybeNull) + +-- | Returns the main stage. The default 'Stage' is a singleton, so +-- the stage will be created the first time this function is called +-- (typically, inside 'clutterInit'); all the subsequent calls to +-- 'stageGetDefault' will return the same instance. +-- Clutter guarantess the existence of the default stage. +{# fun unsafe stage_get_default as ^ { } -> `Stage' newStage* #} + +-- | Creates a new, non-default stage. A non-default stage is a new +-- top-level actor which can be used as another container. It works +-- exactly like the default stage, but while 'stageGetDefault' will +-- always return the same instance, you will have to keep any +-- 'Stage' returned by 'stageNew'. +-- +-- The ability to support multiple stages depends on the current +-- backend. Use 'clutterFeatureAvailable' and +-- CLUTTER_FEATURE_STAGE_MULTIPLE to check at runtime whether a +-- backend supports multiple stages. +-- +-- [@Returns@] @Just@ a new stage, or @Nothing@ if the default +-- backend does not support multiple stages. Use 'actorDestroy' to +-- programmatically close the returned stage. +-- +{# fun unsafe stage_new as ^ { } -> `Maybe Stage' maybeNewStage* #} + +-- | Checks if stage is the default stage, or an instance created using +-- 'stageNew' but internally using the same implementation. +-- +{# fun unsafe stage_is_default as ^ `(StageClass stage)' => + { withStageClass* `stage' } -> `Bool' #} + +-- | Sets the stage color. +{# fun unsafe stage_set_color as ^ `(StageClass stage)' => + { withStageClass* `stage', withColor* `Color' } -> `()' #} + +-- | Retrieves the stage color. +{# fun unsafe stage_get_color as ^ `(StageClass stage)' => + { withStageClass* `stage', alloca- `Color' peek*} -> `()' #} + + +-- | Asks to place the stage window in the fullscreen or unfullscreen +-- states. +-- +-- ( Note that you shouldn't assume the window is definitely full screen +-- afterward, because other entities (e.g. the user or window manager) +-- could unfullscreen it again, and not all window managers honor +-- requests to fullscreen windows. +-- +-- If you want to receive notification of the fullscreen state you should +-- either use the "fullscreen" and "unfullscreen" signals, or use the +-- notify signal for the "fullscreen-set" property +{# fun unsafe stage_set_fullscreen as ^ `(StageClass stage)' => + { withStageClass* `stage', `Bool'} -> `()' #} +-- | Retrieves whether the stage is full screen or not +{# fun unsafe stage_get_fullscreen as ^ `(StageClass stage)' => + { withStageClass* `stage' } -> `Bool' #} + + +-- | Shows the cursor on the stage window +{# fun unsafe stage_show_cursor as ^ `(StageClass stage)' => { withStageClass* `stage' } -> `()' #} +-- | Makes the cursor invisible on the stage window +{# fun unsafe stage_hide_cursor as ^ `(StageClass stage)' => { withStageClass* `stage' } -> `()' #} + +--CHECKME: Should I even include non-application functions? + +-- | Checks the scene at the coordinates x and y and returns a pointer to the 'Actor' at those coordinates. +-- +-- By using pick_mode it is possible to control which actors will be painted and thus available. +{# fun unsafe stage_get_actor_at_pos as ^ `(StageClass stage)' => + { withStageClass* `stage', cFromEnum `PickMode', `Int', `Int'} -> `Actor' newActor* #} + +-- | This function essentially makes sure the right GL context is +-- current for the passed stage. It is not intended to be used by +-- applications. +{# fun unsafe stage_ensure_current as ^ `(StageClass stage)' => { withStageClass* `stage' } -> `()' #} + +-- | Ensures that the GL viewport is updated with the current stage +-- window size. +-- +-- This function will queue a redraw of stage. +-- +-- This function should not be called by applications; it is used when +-- embedding a ClutterStage into a toolkit with another windowing +-- system, like GTK+. +{# fun unsafe stage_ensure_viewport as ^ `(StageClass stage)' => { withStageClass* `stage' } -> `()' #} + +-- | Ensures that stage is redrawn +-- +-- This function should not be called by applications: it is used when +-- embedding a 'Stage' into a toolkit with another windowing +-- system, like GTK+. +{# fun unsafe stage_ensure_redraw as ^ `(StageClass stage)' => { withStageClass* `stage' } -> `()' #} + +-- | Queues a redraw for the passed stage. +-- +-- Note +-- +-- Applications should call 'actorQueueRedraw' and not this function. +-- Note +-- +-- This function is just a wrapper for 'actorQueueRedraw' and should probably go away. +{# fun unsafe stage_queue_redraw as ^ `(StageClass stage)' => { withStageClass* `stage' } -> `()' #} + +--CHECKME this might fall under the category of low level event stuff we're not dealing with +--{# fun unsafe stage_event as ^ `(StageClass stage)' => { withStageClass* `stage', withEvent* `Event' } -> `Bool' #} + + +-- | Sets the key focus on actor. An actor with key focus will receive +-- all the key events. If actor is @Nothing@, the stage will receive +-- focus. +-- +-- [@stage@] the 'Stage' +-- +-- [@actor@] @Just@ the actor to set key focus to, or @Nothing@ +-- +-- * Since 0.6 +-- +{# fun unsafe stage_set_key_focus as ^ `(StageClass stage, ActorClass actor)' => + { withStageClass* `stage', withMaybeActorClass* `Maybe actor' } -> `()' #} + +-- | Retrieves the actor that is currently under key focus. +-- +-- [@stage@] the 'Stage' +-- +-- [@Returns@] the actor with key focus, or the stage. transfer none. +-- +-- * Since 0.6 +-- +{# fun unsafe stage_get_key_focus as ^ `(StageClass stage)' => { withStageClass* `stage' } -> `Actor' newActor* #} + +--TODO: Same problem as other places, setting and getting ActorClass is unhappy +--stageKeyFocus :: (StageClass stage, ActorClass actor) => Attr stage actor +--stageKeyFocus = newAttr stageGetKeyFocus stageSetKeyFocus + +--TODO: all those types, namely guchar* out = what? +--Returns some kind of image buffer, what do I do with it? +--{# fun unsafe stage_read_pixels as ^ `(StageClass stage)' => { withStageClass* `stage', `Int', `Int', `Int', `Int' } -> `Ptr ()' #} +--Why is this scattered around in many places in gtk2hs? +foreign import ccall unsafe "&g_free" + finalizerGFree :: FinalizerPtr a + + +stageReadPixels :: (StageClass stage) => + stage + -> Int + -> Int + -> Int + -> Int + -> IO (Maybe (RGBData Int Word8)) +stageReadPixels stage x y w h = let cx = cIntConv x + cy = cIntConv y + cw = cIntConv w + ch = cIntConv h + in withStageClass stage $ \stgPtr -> do + sizeW <- if w == -1 + then liftM floor (actorGetWidth stage) + else return w + sizeH <- if h == -1 + then liftM floor (actorGetHeight stage) + else return h + let size = sizeW * sizeH * 4 + ptr <- {# call unsafe stage_read_pixels #} stgPtr cx cy cw ch + if ptr == nullPtr + then return Prelude.Nothing + else newForeignPtr finalizerGFree ptr >>= \fptr -> + return $ Just (mkRGBData (castForeignPtr fptr) True size) + + +-- | Sets whether motion events received between redraws should be +-- throttled or not. If motion events are throttled, those events +-- received by the windowing system between redraws will be compressed +-- so that only the last event will be propagated to the stage and its +-- actors. This function should only be used if you want to have all +-- the motion events delivered to your application code. +{# fun unsafe stage_set_throttle_motion_events as ^ `(StageClass stage)' => + { withStageClass* `stage', `Bool' } -> `()' #} + +-- | Retrieves the value set with 'stageSetThrottleMotionEvents' +{# fun unsafe stage_get_throttle_motion_events as ^ `(StageClass stage)' => + { withStageClass* `stage' } -> `Bool' #} + + +-- | Retrieves the stage perspective. +{# fun unsafe stage_get_perspective as ^ `(StageClass stage)' => + { withStageClass* `stage', alloca- `Perspective' peek* } -> `()' #} +-- | Sets the stage perspective. +{# fun unsafe stage_set_perspective as ^ `(StageClass stage)' => + { withStageClass* `stage', withPerspective* `Perspective'} -> `()' #} + + + +--TODO: Unicode??? +-- | Sets the stage title. +{# fun unsafe stage_set_title as ^ `(StageClass stage)' => + { withStageClass* `stage', withMaybeString* `Maybe String' } -> `()' #} +-- | Gets the stage title. +{# fun unsafe stage_get_title as ^ `(StageClass stage)' => + { withStageClass* `stage' } -> `Maybe String' maybeString* #} + +-- | Sets if the stage is resizable by user interaction (e.g. via window manager controls) +{# fun unsafe stage_set_user_resizable as ^ `(StageClass stage)' => + { withStageClass* `stage', `Bool' } -> `()' #} +-- | Retrieves the value set with 'stageSetUserResizable'. +{# fun unsafe stage_get_user_resizable as ^ `(StageClass stage)' => + { withStageClass* `stage' } -> `Bool' #} + + +-- | Sets whether the depth cueing effect on the stage should be enabled or not. +-- +-- Depth cueing is a 3D effect that makes actors farther away from +-- the viewing point less opaque, by fading them with the stage +-- color. +-- +-- The parameters of the GL fog used can be changed using the 'stageSetFog' function. +{# fun unsafe stage_set_use_fog as ^ `(StageClass stage)' => + { withStageClass* `stage', `Bool' } -> `()' #} + +-- | Gets whether the depth cueing effect is enabled on stage. +{# fun unsafe stage_get_use_fog as ^ `(StageClass stage)' => { withStageClass* `stage' } -> `Bool' #} + + +-- | Sets the fog (also known as "depth cueing") settings for the stage. +-- +-- A 'Stage' will only use a linear fog progression, which depends +-- solely on the distance from the viewer. The cogl_set_fog() function in +-- COGL exposes more of the underlying implementation, and allows +-- changing the for progression function. It can be directly used by +-- disabling the "use-fog" property and connecting a signal handler to +-- the "paint" signal on the stage, like: +-- TODO: The equivalent example +-- +-- Note: The fogging functions only work correctly when the visible +-- actors use unmultiplied alpha colors. By default Cogl will premultiply +-- textures and cogl_set_source_color will premultiply colors, so unless +-- you explicitly load your textures requesting an unmultiplied +-- internal_format and use cogl_material_set_color you can only use +-- fogging with fully opaque actors. +-- +-- We can look to improve this in the future when we can depend on +-- fragment shaders. +{# fun unsafe stage_set_fog as ^ `(StageClass stage)' => + { withStageClass* `stage', withFog* `Fog' } -> `()' #} + +-- | Retrieves the current depth cueing settings from the stage. +{# fun unsafe stage_get_fog as ^ `(StageClass stage)' => + { withStageClass* `stage', alloca- `Fog' peek* } -> `()' #} + + +-- Attributes + + +-- | The color of the main stage. +stageColor :: (StageClass stage) => Attr stage Color +stageColor = newNamedAttr "color" stageGetColor stageSetColor + + +-- | Whether the mouse pointer should be visible +-- +-- Default value: @True@ +-- +stageCursorVisible :: (StageClass stage) => Attr stage Bool +stageCursorVisible = newAttrFromBoolProperty "cursor-visible" + + +-- | Whether the main stage is fullscreen. +-- +-- Default value: @False@ +-- +stageFullscreenSet :: (StageClass stage) => ReadAttr stage Bool +stageFullscreenSet = readAttrFromBoolProperty "fullscreen-set" + +-- | Whether the stage should be rendered in an offscreen buffer. +-- +-- * Warning +-- +-- Not every backend supports redirecting the stage to an offscreen +-- buffer. This property might not work and it might be deprecated at +-- any later date. +-- +-- Default value: @False@ +-- +stageOffscreen :: (StageClass stage) => Attr stage Bool +stageOffscreen = newAttrFromBoolProperty "offscreen" + + +-- | The parameters used for the perspective projection from 3D +-- coordinates to 2D +-- +-- * Since 0.8.2 +-- +stagePerspective :: (StageClass stage) => Attr stage Perspective +stagePerspective = newNamedAttr "perspective" stageGetPerspective stageSetPerspective + + +-- | The stage's title - usually displayed in stage windows title +-- decorations. +-- +-- Default value: @Nothing@ +-- +-- * Since 0.4 +-- +stageTitle :: (StageClass stage) => Attr stage (Maybe String) +stageTitle = newNamedAttr "title" stageGetTitle stageSetTitle + + +-- | Whether the stage is resizable via user interaction. +-- +-- Default value: @False@ +-- +-- * Since 0.4 +-- +stageUserResizable :: (StageClass stage) => Attr stage Bool +stageUserResizable = newNamedAttr "user-resizable" stageGetUserResizable stageSetUserResizable + + +-- | Whether the stage should use a linear GL "fog" in creating the +-- depth-cueing effect, to enhance the perception of depth by fading +-- actors farther from the viewpoint. +-- +-- Default value: @False@ +-- +-- * Since 0.6 +-- +stageUseFog :: (StageClass stage) => Attr stage Bool +stageUseFog = newNamedAttr "use-fog" stageGetUseFog stageSetUseFog + + +-- | The settings for the GL "fog", used only if "use-fog" is set to +-- @True@ +-- +-- * Since 1.0 +-- +stageFog :: (StageClass stage) => Attr stage Fog +stageFog = newNamedAttr "fog" stageGetFog stageSetFog + + +-- Signals + +--See note in Types of Activatable +-- | The 'activate' signal is emitted when the stage receives key focus from the underlying window system. +instance Activatable Stage where + onActivate = connect_NONE__NONE "activate" False + afterActivate = connect_NONE__NONE "activate" True + activate = Signal (connect_NONE__NONE "activate") + +onDeactivate, afterDeactivate :: (StageClass stage) => stage -> IO () -> IO (ConnectId stage) +onDeactivate = connect_NONE__NONE "deactivate" False +afterDeactivate = connect_NONE__NONE "deactivate" True + +-- | The 'deactivate' signal is emitted when the stage loses key focus +-- from the underlying window system. +deactivate :: (StageClass stage) => Signal stage (IO ()) +deactivate = Signal (connect_NONE__NONE "deactivate") + + +onFullscreen, afterFullscreen :: (StageClass stage) => stage -> IO () -> IO (ConnectId stage) +onFullscreen = connect_NONE__NONE "fullscreen" False +afterFullscreen = connect_NONE__NONE "fullscreen" True + +-- | The 'fullscreen' signal is emitted when the stage is made fullscreen. +fullscreen :: (StageClass stage) => Signal stage (IO ()) +fullscreen = Signal (connect_NONE__NONE "fullscreen") + + +onUnfullscreen, afterUnfullscreen :: (StageClass stage) => stage -> IO () -> IO (ConnectId stage) +onUnfullscreen = connect_NONE__NONE "unfullscreen" False +afterUnfullscreen = connect_NONE__NONE "unfullscreen" True + +-- | The 'unfullscreen' signal is emitted when the stage leaves a fullscreen state. +unfullscreen :: (StageClass stage) => Signal stage (IO ()) +unfullscreen = Signal (connect_NONE__NONE "unfullscreen") + + diff --git a/Graphics/UI/Clutter/StoreValue.chs b/Graphics/UI/Clutter/StoreValue.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/StoreValue.chs @@ -0,0 +1,396 @@ +-- -*-haskell-*- +-- GIMP Toolkit (GTK) StoreValue GenericValue +-- modified for use in Clutter +-- +-- Author : Axel Simon +-- +-- Created: 23 May 2001 +-- Modified for Clutter: 25 Oct 2009 +-- +-- Copyright (c) 1999..2002 Axel Simon +-- Copyright (c) 2009 Matthew Arsenault +-- +-- 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 : arsenm2@rpi.edu +-- Stability : experimental +-- Portability : portable (depends on GHC) +-- + +{-# LANGUAGE ForeignFunctionInterface, + MultiParamTypeClasses, + UndecidableInstances, + ScopedTypeVariables, + FlexibleInstances, + FunctionalDependencies, + EmptyDataDecls #-} -- If this is on next line, GHC panic + +#include +#include + +{# context lib="clutter" prefix="clutter" #} + +--FIXME: Overall this is very messy + +--FIXME: Too much duplication, and unnecessary incompatability between +--2 different representations of GValue + +--StoreValue in Gtk2hs was missing some pieces for color (which also +--must be different than boxed) that wouldn't make sense to put there, +--such as GV's for color. +-- + +module Graphics.UI.Clutter.StoreValue ( + AnimType(..), + GenericValue(..), + GenericValuePtr, + valueSetGenericValue, + valueGetGenericValue, + GenericValueClass(..), + withGenericValue, + unsetGValue, + unsetOneGVal, + genericValuePtrGetType, + allocaTypedGValue + ) where + +import C2HS +import Control.Monad (liftM) + +--TODO: New exceptions +import Control.OldException (throw, Exception(AssertionFailed)) + +import Control.Exception (bracket) + +{# import Graphics.UI.Clutter.Types #} +{# import qualified Graphics.UI.Clutter.GTypes #} as CGT + +import System.Glib.FFI +import System.Glib.Flags +import System.Glib.GValue +import System.Glib.GValueTypes +import qualified System.Glib.GTypeConstants as GType +import System.Glib.Types +import System.Glib.GType + +-- | A union with information about the currently stored type. +-- +-- * Internally used by "Graphics.UI.Clutter.Animation". + +{# pointer *GValue as GenericValuePtr -> GenericValue #} + +-- most of this is duplicated in gtk2hs, and should be fixed + +genericValuePtrGetType :: GenericValuePtr -> IO GType +genericValuePtrGetType gvPtr = {# get GValue->g_type #} gvPtr + +--GenericValue is a wrapper around haskell types that can be put in a gvalue +--GValue is the actual C type. GenericValues get put into GValues +--This is mostly the same as in gtk2hs, but with clutter types included + +--CHECKME: Types for char, uchar. Do we want them to actually be Int8, Word8? +data GenericValue = GVuint Word + | GVint Int + | GVuchar Word8 + | GVchar Int8 + | GVboolean Bool + | GVenum Int + | GVflags Int + --- | GVpointer (Ptr ()) + | GVfloat Float + | GVdouble Double + | GVstring (Maybe String) + | GVobject GObject + | GVcolor Color + --- | GVunits Units + --- | GVboxed (Ptr ()) + +-- This is an enumeration of all GTypes that can be used in an Animation +-- It's also probably wrong. + +data AnimType = ATinvalid + | ATuint + | ATint + | ATuchar + | ATchar + | ATbool + | ATenum + | ATflags +-- | ATpointer + | ATfloat + | ATdouble + | ATstring + | ATobject + | ATcolor +-- | ATboxed + + +--workaround for some kind of c2hs limitation, TODO: Find a better solution +instance Enum AnimType where + fromEnum ATinvalid = fromEnum GType.invalid + fromEnum ATuint = fromEnum GType.uint + fromEnum ATint = fromEnum GType.int + fromEnum ATuchar = fromEnum GType.uchar + fromEnum ATchar = fromEnum GType.char + fromEnum ATbool = fromEnum GType.bool + fromEnum ATenum = fromEnum GType.enum + fromEnum ATflags = fromEnum GType.flags +--fromEnum ATpointer = fromEnum GType.pointer + fromEnum ATfloat = fromEnum GType.float + fromEnum ATdouble = fromEnum GType.double + fromEnum ATstring = fromEnum GType.string + fromEnum ATobject = fromEnum GType.object + fromEnum ATcolor = fromEnum CGT.color +--fromEnum ATboxed = fromEnum GType.boxed + + toEnum x | x == fromEnum GType.invalid = ATinvalid + | x == fromEnum GType.uint = ATuint + | x == fromEnum GType.int = ATint + | x == fromEnum GType.uchar = ATuchar + | x == fromEnum GType.char = ATchar + | x == fromEnum GType.bool = ATbool + | x == fromEnum GType.enum = ATenum + | x == fromEnum GType.flags = ATflags + --- | x == fromEnum GType.pointer = ATpointer + | x == fromEnum GType.float = ATfloat + | x == fromEnum GType.double = ATdouble + | x == fromEnum GType.string = ATstring + | x == fromEnum GType.object = ATobject + | x == fromEnum CGT.color = ATcolor + --- | x == fromEnum GType.boxed = ATboxed + | otherwise = error "StoreValue.toEnum(AnimType): no dynamic types allowed." + + +valueSetGenericValue :: GValue -> GenericValue -> IO () +valueSetGenericValue gvalue (GVuint x) = do valueInit gvalue GType.uint + valueSetUInt gvalue x +valueSetGenericValue gvalue (GVint x) = do valueInit gvalue GType.int + valueSetInt gvalue x +valueSetGenericValue gvalue (GVuchar x) = do valueInit gvalue GType.uchar + valueSetUChar gvalue x +valueSetGenericValue gvalue (GVchar x) = do valueInit gvalue GType.char + valueSetChar gvalue (cToEnum x) +valueSetGenericValue gvalue (GVboolean x) = do valueInit gvalue GType.bool + valueSetBool gvalue x +valueSetGenericValue gvalue (GVenum x) = do valueInit gvalue GType.enum + valueSetUInt gvalue (fromIntegral x) +valueSetGenericValue gvalue (GVflags x) = do valueInit gvalue GType.flags + valueSetUInt gvalue (fromIntegral x) +--valueSetGenericValue gvalue (GVpointer x) = valueSetPointer gvalue x +valueSetGenericValue gvalue (GVfloat x) = do valueInit gvalue GType.float + valueSetFloat gvalue x +valueSetGenericValue gvalue (GVdouble x) = do valueInit gvalue GType.double + valueSetDouble gvalue x +valueSetGenericValue gvalue (GVstring x) = do valueInit gvalue GType.string + valueSetMaybeString gvalue x +valueSetGenericValue gvalue (GVobject x) = do valueInit gvalue GType.object + valueSetGObject gvalue x +valueSetGenericValue gvalue (GVcolor x) = do valueInit gvalue CGT.color + valueSetColor gvalue x +--valueSetGenericValue gvalue (GVboxed x) = valueSetPointer gvalue x + +--valueSetGenericValue gvalue (GVenum x) = do valueInit gvalue GType.enum +-- valueSetUInt gvalue (fromIntegral x) + + +-- TMenum -> liftM (GVenum . fromIntegral) $ valueGetUInt gvalue + + +valueGetGenericValue :: GValue -> IO GenericValue +valueGetGenericValue gvalue = do + gtype <- valueGetType gvalue + case cToEnum gtype of + ATinvalid -> throw $ AssertionFailed "valueGetGenericValue: invalid or unavailable value." + ATuint -> liftM GVuint $ valueGetUInt gvalue + ATint -> liftM GVint $ valueGetInt gvalue + ATuchar -> liftM (GVuchar . cFromEnum) $ valueGetUChar gvalue + ATchar -> liftM (GVchar . cFromEnum) $ valueGetChar gvalue + ATbool -> liftM GVboolean $ valueGetBool gvalue + ATenum -> liftM (GVenum . cToEnum) $ valueGetUInt gvalue + ATflags -> liftM (GVflags . cToEnum) $ valueGetUInt gvalue +-- ATpointer -> liftM GVpointer $ valueGetPointer gvalue + ATfloat -> liftM GVfloat $ valueGetFloat gvalue + ATdouble -> liftM GVdouble $ valueGetDouble gvalue + ATstring -> liftM GVstring $ valueGetMaybeString gvalue + ATobject -> liftM GVobject $ valueGetGObject gvalue + ATcolor -> liftM GVcolor $ valueGetColor gvalue +-- ATboxed -> liftM GVpointer $ valueGetPointer gvalue + + +--for folding along a list +--The list doesn't matter, just gets the length +unsetOneGVal :: Ptr GenericValue -> a -> IO (Ptr GenericValue) +unsetOneGVal i _ = {# call unsafe g_value_unset #} i >> return (advancePtr i 1) + +unsetGValue :: Ptr GenericValue -> IO () +unsetGValue p = {# call unsafe g_value_unset #} p + +--CHECKME: Bad things? +instance Storable GenericValue where + sizeOf _ = {# sizeof GValue #} + alignment _ = alignment (undefined :: GType) + peek p = let gv = GValue (castPtr p) + in valueGetGenericValue gv + poke p ut = let gv = GValue (castPtr p) + in do + {# set GValue->g_type #} p (0 :: GType) --must be initialized to 0 or init will fail + valueSetGenericValue gv ut + + + +--interval get stuff wants initialized type. This is essentially allocaGValue +allocaTypedGValue :: GType -> (GenericValuePtr -> IO a) -> IO (GenericValue, a) +allocaTypedGValue gtype body = + allocaBytes ({# sizeof GType #}+ 2* {# sizeof guint64 #}) $ \gvPtr -> do + {# set GValue->g_type #} gvPtr gtype + ret <- body gvPtr + val <- valueGetGenericValue (GValue (castPtr gvPtr)) + {#call unsafe g_value_unset#} gvPtr + return (val, ret) + + + +mkGValueFromGenericValue :: GenericValue -> IO GenericValuePtr +mkGValueFromGenericValue gv = do cptr <- malloc + poke cptr gv + return cptr + + +freeGValue :: GenericValuePtr -> IO () +freeGValue p = unsetGValue (castPtr p) >> free p + +--get gvalue out: allocaGValue (in body use valueGetGenericValue), then + +withGenericValue :: (GenericValueClass arg) => arg -> (GenericValuePtr -> IO a) -> IO a +withGenericValue gv = bracket (mkGValueFromGenericValue (toGenericValue gv)) freeGValue + + +--This madness is almost straight from Haskell wiki on AdvancedOverlap +-- I only halfway understand it. It should pick the GObjectClass +-- instance for any gobject, and the others for anything else. + + +-- Wrapper type for gvalues you want to use in Clutter with unsafe +-- extraction. This should never be needed directly, and the type for +-- the extraction should be constrained to be the proper type by +-- every function I think that needs this. +class GenericValueClass a where + toGenericValue :: a -> GenericValue + unsafeExtractGenericValue :: GenericValue -> a + +class GenericValueClass' flag a where + toGenericValue' :: flag -> a -> GenericValue + unsafeExtractGenericValue' :: flag -> GenericValue -> a + +instance (GVPred a flag, GenericValueClass' flag a) => GenericValueClass a where + toGenericValue = toGenericValue' (undefined::flag) + unsafeExtractGenericValue = unsafeExtractGenericValue' (undefined::flag) + + +-- overlapping instances are used only for GVPred +class GVPred a flag | a -> flag where {} + +instance GVPred Word RegularGValue +instance GVPred Int RegularGValue +instance GVPred Word8 RegularGValue +instance GVPred Int8 RegularGValue +instance GVPred Bool RegularGValue +--Enum +--Flags +instance GVPred Float RegularGValue +instance GVPred Double RegularGValue +instance GVPred (Maybe String) RegularGValue +instance GVPred Color RegularGValue + +data IsGObject +data RegularGValue + +instance GenericValueClass' RegularGValue Int where + toGenericValue' _ x = GVint x + unsafeExtractGenericValue' _ (GVint x) = x + unsafeExtractGenericValue' _ _ = typeMismatchError + +instance GenericValueClass' RegularGValue Word where + toGenericValue' _ x = GVuint x + unsafeExtractGenericValue' _ (GVuint x) = x + unsafeExtractGenericValue' _ _ = typeMismatchError + +instance GenericValueClass' RegularGValue Word8 where + toGenericValue' _ x = GVuchar x + unsafeExtractGenericValue' _ (GVuchar x) = x + unsafeExtractGenericValue' _ _ = typeMismatchError + +instance GenericValueClass' RegularGValue Int8 where + toGenericValue' _ x = GVchar x + unsafeExtractGenericValue' _ (GVchar x) = x + unsafeExtractGenericValue' _ _ = typeMismatchError + +instance GenericValueClass' RegularGValue Bool where + toGenericValue' _ x = GVboolean x + unsafeExtractGenericValue' _ (GVboolean x) = x + unsafeExtractGenericValue' _ _ = typeMismatchError + +-- TODO: Enum, Flags + {- +instance GenericValueClass' RegularGValue Bool where + toGenericValue' _ x = GVboolean x + unsafeExtractGenericValue' _ (GVboolean x) = x +-} + +instance GenericValueClass' RegularGValue Float where + toGenericValue' _ x = GVfloat x + unsafeExtractGenericValue' _ (GVfloat x) = x + unsafeExtractGenericValue' _ _ = typeMismatchError + +instance GenericValueClass' RegularGValue Double where + toGenericValue' _ x = GVdouble x + unsafeExtractGenericValue' _ (GVdouble x) = x + unsafeExtractGenericValue' _ _ = typeMismatchError + +instance GenericValueClass' RegularGValue (Maybe String) where + toGenericValue' _ x = GVstring x + unsafeExtractGenericValue' _ (GVstring x) = x + unsafeExtractGenericValue' _ _ = typeMismatchError + +instance GenericValueClass' RegularGValue Color where + toGenericValue' _ x = GVcolor x + unsafeExtractGenericValue' _ (GVcolor x) = x + unsafeExtractGenericValue' _ _ = typeMismatchError + +instance (GObjectClass a) => GenericValueClass' IsGObject a where + toGenericValue' _ x = GVobject (toGObject x) + unsafeExtractGenericValue' _ (GVobject x) = unsafeCastGObject x + unsafeExtractGenericValue' _ _ = typeMismatchError + + +--More madness from Haskell wiki. This is the part I really don't +-- understand. "Used only if the other instances don't apply" +--instance TypeCast flag RegularGValue => GVPred a flag + +class TypeCast a b | a -> b, b->a where typeCast :: a -> b +class TypeCast' t a b | t a -> b, t b -> a where typeCast' :: t->a->b +class TypeCast'' t a b | t a -> b, t b -> a where typeCast'' :: t->a->b +instance TypeCast' () a b => TypeCast a b where typeCast x = typeCast' () x +instance TypeCast'' t a b => TypeCast' t a b where typeCast' = typeCast'' +instance TypeCast'' () a a where typeCast'' _ x = x + + +-- for every use of gvalues, the out type should be inferrable from +-- what you pass in, so this should never happen unless clutter is +-- doing horrible things inside +typeMismatchError = error "unsafeExtractGenericValue: Type mismatch" + +{# fun unsafe value_get_color as ^ { withGValue `GValue' } -> `Color' peek* #} +{# fun unsafe value_set_color as ^ { withGValue `GValue', withColor* `Color' } -> `()' #} + + + diff --git a/Graphics/UI/Clutter/Text.chs b/Graphics/UI/Clutter/Text.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Text.chs @@ -0,0 +1,1370 @@ +-- -*-haskell-*- +-- Clutter Text +-- +-- Author : Matthew Arsenault +-- +-- Created: 17 Sep 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include +#include + +{# context lib="clutter" prefix="clutter" #} +{# context lib="pango" prefix="pango" #} + +-- | 'Text' — An actor for displaying and editing text +module Graphics.UI.Clutter.Text ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Actor' +-- | +----'Text' +-- @ + +-- * Types + Text, + TextClass, + + +-- * Constructors + textNew, + textNewFull, + textNewWithText, + +-- * Methods + textGetText, + textSetText, + + textSetMarkup, + + textGetActivatable, + textSetActivatable, + + textSetAttributes, + textGetAttributes, + + textGetColor, + textSetColor, + + textGetEllipsize, + textSetEllipsize, + + textGetFontName, + textSetFontName, + + textSetPasswordChar, + textGetPasswordChar, + + textGetJustify, + textSetJustify, + + textGetLayout, + + textSetLineAlignment, + textGetLineAlignment, + + textGetLineWrap, + textSetLineWrap, + + textSetLineWrapMode, + textGetLineWrapMode, + + textSetMaxLength, + textGetMaxLength, + + textSetSelectable, + textGetSelectable, + + textSetSelection, + textGetSelection, + + textGetSelectionBound, + textSetSelectionBound, + + textSetSingleLineMode, + textGetSingleLineMode, + + textSetUseMarkup, + textGetUseMarkup, + + textSetEditable, + textGetEditable, + + textInsertText, + textInsertUnichar, + + textDeleteChars, + textDeleteText, + + textDeleteSelection, + textGetChars, + + textGetCursorColor, + textSetCursorColor, + + textGetSelectionColor, + textSetSelectionColor, + + textSetCursorPosition, + textGetCursorPosition, + + textSetCursorVisible, + textGetCursorVisible, + + textSetCursorSize, + textGetCursorSize, + + textActivate, + textPositionToCoords, + +#if CLUTTER_CHECK_VERSION(1,2,0) + textSetPreeditString, +#endif + +--TODO: Title for this +-- * Related Types + --TODO: Export more of Pango? + PangoLayout, + LayoutWrapMode(..), + LayoutAlignment(..), + EllipsizeMode(..), + +-- * Attributes + textActivatable, +--textAttributes, + textColor, + textCursorColor, + textCursorColorSet, + textCursorSize, + textCursorVisible, + textEditable, + textEllipsize, + textFontName, + textJustify, + textLineAlignment, + textLineWrap, + textLineWrapMode, + textMaxLength, + textPasswordChar, + textPosition, + textSelectable, + textSelectionBound, + textSelectionColor, + textSelectionColorSet, + textSingleLineMode, + textText, + textUseMarkup, + +-- * Signals + onActivate, + afterActivate, + activate, + onCursorEvent, + afterCursorEvent, + cursorEvent, + onTextChanged, + afterTextChanged, + textChanged + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Utility #} +{# import Graphics.UI.Clutter.Signals #} + +import C2HS +import System.Glib.GObject +import System.Glib.Attributes +import System.Glib.Properties +import System.Glib.UTFString + +import Control.Monad (liftM) +import Data.IORef + +import Graphics.UI.Gtk.Types (PangoLayoutRaw, mkPangoLayoutRaw) +import Graphics.UI.Gtk.Pango.Types +import Graphics.UI.Gtk.Pango.Layout +import Graphics.UI.Gtk.Pango.Attributes +import Graphics.UI.Gtk.Pango.Enums (EllipsizeMode) + +--CHECKME: Is LayoutWrapMode/LayoutAlignment the wrap mode we want? + + +-- | Creates a new 'Text' actor. This actor can be used to display and +-- edit text. +-- +-- [@Returns@] the newly created 'Text' actor +-- +-- * Since 1.0 +-- +{# fun unsafe text_new as ^ { } -> `Text' newText* #} + + + +-- | Creates a new 'Text' actor, using font_name as the font +-- description; text will be used to set the contents of the actor; +-- and color will be used as the color to render text. +-- +-- This function is equivalent to calling 'textNew', +-- 'textSetFontName', 'textSetText' and 'textSetColor'. +-- +-- [@font_name@] a string with a font description +-- +-- [@text@] the contents of the actor +-- +-- [@color@] the color to be used to render text +-- +-- [@Returns@] the newly created 'Text' actor +-- +-- * Since 1.0 +-- +{# fun unsafe text_new_full as ^ { `String', `String', withColor* `Color' } -> `Text' newText* #} + + + +-- | Creates a new 'Text' actor, using font_name as the font +-- description; text will be used to set the contents of the actor. +-- +-- This function is equivalent to calling 'textNew', +-- 'textSetFontName', and 'textSetText'. +-- +-- [@font_name@] a string with a font description +-- +-- [@text@] the contents of the actor +-- +-- [@Returns@] the newly created 'Text' actor +-- +-- * Since 1.0 +-- +{# fun unsafe text_new_with_text as ^ { `String', `String' } -> `Text' newText* #} + + +-- | Sets the contents of a 'Text' actor. +-- +-- [@self@] a 'Text' +-- +-- [@text@] the text to set. +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_text as ^ `(TextClass self)' => { withTextClass* `self', `String' } -> `()' #} + +{# fun unsafe text_get_text as ^ `(TextClass self)' => { withTextClass* `self' } -> `String' #} + + +-- | Sets markup as the contents of a 'Text'. +-- +-- This is a convenience function for setting a string containing +-- Pango markup, and it is logically equivalent to: +-- +-- +-- > textSetUseMarkup aTextActor True +-- > textSetText aTextActor markup +-- +-- [@self@] a Text +-- +-- [@markup@] a string containing Pango markup +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_markup as ^ `(TextClass self)' => { withTextClass* `self', `String' } -> `()' #} + + + +-- | Sets whether a 'Text' actor should be activatable. +-- +-- An activatable 'Text' actor will emit the "activate" signal +-- whenever the 'Enter' (or 'Return') key is pressed; if it is not +-- activatable, a new line will be appended to the current content. +-- +-- An activatable 'Text must also be set as editable using +-- 'textSetEditable.' +-- +-- [@self@] a 'Text' +-- +-- [@activatable@] whether the 'Text' actor should be activatable +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_activatable as ^ `(TextClass self)' => { withTextClass* `self', `Bool' } -> `()' #} + + +-- | Retrieves whether a 'Text' is activatable or not. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] @True@ if the actor is activatable +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_activatable as ^ `(TextClass self)' => { withTextClass* `self' } -> `Bool' #} + + +--CHECKME: Something seems unsafe about this, also stupid get text out for correction +--CHECKME: Empty list unset + +-- | Sets the attributes list that are going to be applied to the +-- 'Text' contents. +-- +-- The 'Text' actor will take a reference on the PangoAttrList passed to this function. +-- +-- [@self@] a 'Text' +-- +-- [@attrs@] a list of 'PangoAttribute' +-- +-- * Since 1.0 +-- +textSetAttributes :: (TextClass self) => self -> [PangoAttribute] -> IO () +textSetAttributes txt pattrs = let func = {# call unsafe text_set_attributes #} + in withTextClass txt $ \txtPtr -> do + pStr <- makeNewPangoString =<< textGetText txt + withAttrList pStr pattrs $ \attrPtr -> + func txtPtr attrPtr + +--getting text out seems convoluted and avoidable +--also why [[PA]]? and not [PA]? +-- | Gets the attribute list that was set on the 'Text' actor +-- 'textSetAttributes', if any. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] The 'PangoAttribute' list set on the 'Text' +-- +-- * Since 1.0 +-- +textGetAttributes :: (TextClass self) => self -> IO [[PangoAttribute]] +textGetAttributes text = withTextClass text $ \txtPtr -> do + attrPtr <- {# call unsafe text_get_attributes #} txtPtr + correct <- liftM genUTFOfs (textGetText text) --TODO: silly + fromAttrList correct attrPtr + + +-- | Sets the color of the contents of a 'Text' actor. +-- +-- The overall opacity of the 'Text' actor will be the result of the +-- alpha value of color and the composited opacity of the actor itself +-- on the scenegraph, as returned by 'actorGetPaintOpacity'. +-- +-- [@self@] a 'Text' +-- +-- [@color@] a 'Color' +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_color as ^ `(TextClass self)' => + { withTextClass* `self', withColor* `Color' } -> `()' #} + + +-- | Retrieves the text color as set by 'textSetColor'. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] a 'Color' +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_color as ^ `(TextClass self)' => + { withTextClass* `self', alloca- `Color' peek* } -> `()' #} + + +-- | Sets the mode used to ellipsize (add an ellipsis: "...") to the +-- text if there is not enough space to render the entire contents +-- of a 'Text' actor +-- +-- [@self@] a 'Text' +-- +-- [@mode@] : a 'PangoEllipsizeMode' +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_ellipsize as ^ `(TextClass self)' => + { withTextClass* `self', cFromEnum `EllipsizeMode' } -> `()' #} + + +-- | Returns the ellipsizing position of a 'Text' actor, as set by +-- 'textSetEllipsize'. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] a 'PangoEllipsizeMode' +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_ellipsize as ^ `(TextClass self)' => + { withTextClass* `self' } -> `EllipsizeMode' cToEnum #} + +--CHECKME: Can set nothing, what do you get back? +-- | Sets the font used by a 'Text'. The font_name string must either +-- be @Nothing@, which means that the font name from the default +-- ClutterBackend will be used; or be something that can be parsed +-- by the pango_font_description_from_string() function, like: +-- +-- > textSetFontName text "Sans 10pt" +-- > textSetFontName text "Serif 16px" +-- > textSetFontName text "Helvetica 10" +-- +-- [@self@] a 'Text' +-- +-- [@font_name@] @Just@ a font name, or @Nothing@ to set the default +-- font name +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_font_name as ^ `(TextClass self)' => + { withTextClass* `self', withMaybeString* `Maybe String' } -> `()' #} + + +-- | Retrieves the font name as set by 'textSetFontName'. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] a string containing the font name. The returned string +-- is owned by the 'Text' actor and should not be modified or freed +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_font_name as ^ `(TextClass self)' => + { withTextClass* `self' } -> `Maybe String' maybeString* #} + +--TODO: Do something with unicode stuff +--TODO: Maybe this +-- | Sets the character to use in place of the actual text in a password text actor. +-- +-- If wc is 0 the text will be displayed as it is entered in the ClutterText actor. +-- +-- [@self@] a 'Text' +-- +-- [@wc@] @Just@ a Unicode character, or @Nothing@ to unset the +-- password character +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_password_char as ^ `(TextClass self)' => + {withTextClass* `self', cIntConv `GUnichar' } -> `()' #} + + +-- | Retrieves the character to use in place of the actual text as set +-- by 'textSetPasswordChar'. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] @Just@ a Unicode character or @Nothing@ if the password +-- character is not set +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_password_char as ^ `(TextClass self)' => + { withTextClass* `self' } -> `GUnichar' cIntConv #} + + +-- | Sets whether the text of the 'Text' actor should be justified on +-- both margins. This setting is ignored if Clutter is compiled +-- against Pango < 1.18. +-- +-- [@self@] a 'Text' +-- +-- [@justify@] whether the text should be justified +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_justify as ^ `(TextClass self)' => { withTextClass* `self', `Bool'} -> `()' #} + +-- | Retrieves whether the 'Text' actor should justify its contents on +-- both margins. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] @True@ if the text should be justified +-- +-- * Since 0.6 +-- +{# fun unsafe text_get_justify as ^ `(TextClass self)' => { withTextClass* `self' } -> `Bool' #} + +--FIXME: Pango doc +--CHECKME: I have no idea if this is right or makes sense. +--particularly the getting the text from the layoutraw and putting it +--in PangoLayout, the newGObject followed by the with, and really just +--this whole function needs to be looked at +-- | Retrieves the current PangoLayout used by a 'Text' actor. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] 'PangoLayout' +-- +-- * Since 1.0 +-- +textGetLayout :: (TextClass self) => self -> IO PangoLayout +textGetLayout self = withTextClass self $ \ctextptr -> do + pl <- constructNewGObject mkPangoLayoutRaw $ liftM castPtr $ {# call unsafe text_get_layout #} ctextptr + withPangoLayoutRaw pl $ \plptr -> do + str <- {#call unsafe layout_get_text#} (castPtr plptr) >>= peekUTFString + ps <- makeNewPangoString str + psRef <- newIORef ps + return (PangoLayout psRef pl) + + +-- | Sets the way that the lines of a wrapped label are aligned with +-- respect to each other. This does not affect the overall alignment +-- of the label within its allocated or specified width. +-- +-- To align a 'Text' actor you should add it to a container that +-- supports alignment, or use the anchor point. +-- +-- [@self@] a 'Text' +-- +-- [@alignment@] A 'PangoAlignment' +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_line_alignment as ^ `(TextClass self)' => + { withTextClass* `self', cFromEnum `LayoutAlignment'} -> `()' #} + +-- | Retrieves the alignment of a 'Text', as set by +-- 'textSetLineAlignment'. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] a 'PangoAlignment' +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_line_alignment as ^ `(TextClass self)' => + { withTextClass* `self' } -> `LayoutAlignment' cToEnum #} + + + +-- | Sets whether the contents of a 'Text' actor should wrap, if they +-- don't fit the size assigned to the actor. +-- +-- [@self@] a 'Text' +-- +-- [@line_wrap@] whether the contents should wrap +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_line_wrap as ^ `(TextClass self)' => + { withTextClass* `self', `Bool'} -> `()' #} + +-- | Retrieves the value set using 'textSetLineWrap'. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] @True@ if the 'Text' actor should wrap its contents +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_line_wrap as ^ `(TextClass self)' => + { withTextClass* `self' } -> `Bool' #} + + +--CHECKME: Link to pango doc +-- | If line wrapping is enabled (see 'textSetLineWrap') this function +-- controls how the line wrapping is performed. The default is +-- 'PangoWrapWord' which means wrap on word boundaries. +-- +-- [@self@] a 'Text' +-- +-- [@wrap_mode@] the line wrapping mode +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_line_wrap_mode as ^ `(TextClass self)' => + { withTextClass* `self', cFromEnum `LayoutWrapMode' } -> `()' #} + + +-- | Retrieves the line wrap mode used by the 'Text' actor. +-- +-- See 'textSetLineWrapMode'. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] the wrap mode used by the 'Text' +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_line_wrap_mode as ^ `(TextClass self)' => + { withTextClass* `self' } -> `LayoutWrapMode' cToEnum #} + + +-- | Sets the maximum allowed length of the contents of the actor. If +-- the current contents are longer than the given length, then they +-- will be truncated to fit. +-- +-- [@self@] a 'Text' +-- +-- [@max@] the maximum number of characters allowed in the text actor; 0 to +-- disable or -1 to set the length of the current string * Since 1.0 +-- +{# fun unsafe text_set_max_length as ^ `(TextClass self)' => + { withTextClass* `self', `Int'} -> `()' #} + +-- | Gets the maximum length of text that can be set into a text +-- actor. +-- +-- See 'textSetMaxLength'. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] the maximum number of characters. +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_max_length as ^ `(TextClass self)' => + { withTextClass* `self' } -> `Int' #} + + +-- | Sets whether a 'Text' actor should be selectable. +-- +-- A selectable 'Text' will allow selecting its contents using the +-- pointer or the keyboard. +-- +-- [@self@] a 'Text' +-- +-- [@selectable@] whether the 'Text' actor should be selectable +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_selectable as ^ `(TextClass self)' => + { withTextClass* `self', `Bool'} -> `()' #} + + +-- | Retrieves whether a 'Text' is selectable or not. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] @True@ if the actor is selectable +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_selectable as ^ `(TextClass self)' => + { withTextClass* `self' } -> `Bool' #} + + +-- | Selects the region of text between start_pos and end_pos. +-- +-- This function changes the position of the cursor to match +-- start_pos and the selection bound to match end_pos. +-- +-- [@self@] a 'Text' +-- +-- [@start_pos@] start of the selection, in characters +-- +-- [@end_pos@] end of the selection, in characters +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_selection as ^ `(TextClass self)' => + { withTextClass* `self', cIntConv `GSSize', cIntConv `GSSize' } -> `()' #} + +--CHECKME: Return NULL / make Maybe? +-- | Retrieves the currently selected text. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] a string containing the currently selected text +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_selection as ^ `(TextClass self)' => + { withTextClass* `self' } -> `String' peekNFreeString* #} + + +-- | Sets the other end of the selection, starting from the current cursor position. +-- +-- If selection_bound is -1, the selection unset. +-- +-- [@self@] a 'Text' +-- +-- [@selection_bound@] the position of the end of the selection, in +-- characters +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_selection_bound as ^ `(TextClass self)' => + { withTextClass* `self', `Int' } -> `()' #} + +-- | Retrieves the other end of the selection of a 'Text' actor, in +-- characters from the current cursor position. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] the position of the other end of the selection +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_selection_bound as ^ `(TextClass self)' => { withTextClass* `self' } -> `Int' #} + +--CHECKME: I think these need to be safe +-- | Sets whether a 'Text' actor should be in single line mode or not. +-- +-- A text actor in single line mode will not wrap text and will clip +-- the the visible area to the predefined size. The contents of the +-- text actor will scroll to display the end of the text if its length +-- is bigger than the allocated width. +-- +-- When setting the single line mode the "activatable" property is +-- also set as a side effect. Instead of entering a new line +-- character, the text actor will emit the "activate" signal. +-- +-- [@self@] a 'Text' +-- +-- [@single_line@] whether to enable single line mode +-- +-- * Since 1.0 +-- +{# fun text_set_single_line_mode as ^ `(TextClass self)' => { withTextClass* `self', `Bool' } -> `()' #} + +-- | Retrieves whether the 'Text' actor is in single line mode. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] @True@ if the 'Text' actor is in single line mode +-- +-- * Since 1.0 +-- +{# fun text_get_single_line_mode as ^ `(TextClass self)' => { withTextClass* `self' } -> `Bool' #} + + +-- | Sets whether the contents of the 'Text' actor contains markup in +-- Pango's text markup language. +-- +-- Setting "use-markup" on an editable 'Text' will make the actor +-- discard any markup. +-- +-- [@self@] a 'Text' +-- +-- [@setting@] @True@ if the text should be parsed for markup. +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_use_markup as ^ `(TextClass self)' => { withTextClass* `self', `Bool' } -> `()' #} + +-- | Retrieves whether the contents of the 'Text' actor should be +-- parsed for the Pango text markup. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] @True@ if the contents will be parsed for markup +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_use_markup as ^ `(TextClass self)' => { withTextClass* `self' } -> `Bool' #} + + +-- | Sets whether the 'Text' actor should be editable. +-- +-- An editable 'Text' with key focus set using 'actorGrabKeyFocus' or +-- 'stageTakeKeyFocus' will receive key events and will update its +-- contents accordingly. +-- +-- [@self@] a 'Text' +-- +-- [@editable@] whether the 'Text' should be editable +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_editable as ^ `(TextClass self)' => { withTextClass* `self', `Bool' } -> `()' #} + +-- | Retrieves whether a 'Text' is editable or not. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] @True@ if the actor is editable +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_editable as ^ `(TextClass self)' => { withTextClass* `self' } -> `Bool' #} +--Insertions + + +-- | Inserts text into a 'Text' at the given position. +-- +-- If position is a negative number, the text will be appended at the +-- end of the current contents of the 'Text'. +-- +-- The position is expressed in characters, not in bytes. +-- +-- [@self@] a 'Text' +-- +-- [@text@] the text to be inserted +-- +-- [@position@] the position of the insertion, or -1 +-- +-- * Since 1.0 +-- +{# fun unsafe text_insert_text as ^ `(TextClass self)' => + { withTextClass* `self', `String', cIntConv `GSSize' } -> `()' #} + + +--FIXME: Unicode +-- | Inserts wc at the current cursor position of a 'Text' actor. +-- +-- [@self@] a 'Text' +-- +-- [@wc@] a Unicode character +-- +-- * Since 1.0 +-- +{# fun unsafe text_insert_unichar as ^ `(TextClass self)' => + { withTextClass* `self', cIntConv `GUnichar' } -> `()' #} + +-- | Deletes n_chars inside a 'Text' actor, starting from the current +-- cursor position. +-- +-- [@self@] a 'Text' +-- +-- [@n_chars@] the number of characters to delete +-- +-- * Since 1.0 +-- +{# fun unsafe text_delete_chars as ^ `(TextClass self)' => + { withTextClass* `self', cIntConv `Word' } -> `()' #} + +-- | Deletes the text inside a 'Text' actor between start_pos and +-- end_pos. +-- +-- The starting and ending positions are expressed in characters, not +-- in bytes. +-- +-- [@self@] a 'Text' +-- +-- [@start_pos@] starting position +-- +-- [@end_pos@] ending position +-- +-- * Since 1.0 +-- +{# fun unsafe text_delete_text as ^ `(TextClass self)' => + { withTextClass* `self', cIntConv `GSSize', cIntConv `GSSize' } -> `()' #} + + +--CHECKME: Subclasses it references? +-- | Deletes the currently selected text +-- +-- This function is only useful in subclasses of 'Text' +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] @True@ if text was deleted or if the text actor is +-- empty, and @False@ otherwise +-- +-- * Since 1.0 +-- +{# fun unsafe text_delete_selection as ^ `(TextClass self)' => + { withTextClass* `self' } -> `()' #} + + +--TODO: GSSize +-- | Retrieves the contents of the 'Text' actor between start_pos and +-- end_pos. +-- +-- The positions are specified in characters, not in bytes. +-- +-- [@self@] a 'Text' +-- +-- [@start_pos@] start of text, in characters +-- +-- [@end_pos@] end of text, in characters +-- +-- [@Returns@] a string with the contents of the text actor between +-- the specified positions. +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_chars as ^ `(TextClass self)' => + { withTextClass* `self', cIntConv `GSSize', cIntConv `GSSize' } -> `String' peekNFreeString* #} + + +--CHECKME: This can be set to Nothing, but you can't get Nothing back. +--so with the attribute, make Maybe or not? +-- +-- | Sets the color of the cursor of a 'Text' actor. +-- +-- If color is @Nothing@, the cursor color will be the same as the +-- text color. +-- +-- [@self@] a 'Text' +-- +-- [@color@] the color of the cursor, or @Nothing@ to unset it +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_cursor_color as ^ `(TextClass self)' => + { withTextClass* `self', withMaybeColor* `Maybe Color' } -> `()' #} + + +-- | Retrieves the color of the cursor of a 'Text' actor. +-- +-- [@self@] a 'Text' +-- +-- [@color@] @Just@ a 'Color' +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_cursor_color as ^ `(TextClass self)' => + { withTextClass* `self', alloca- `Maybe Color' maybeNullPeek* } -> `()' #} + +-- | Sets the color of the selection of a 'Text' actor. +-- +-- If color is @Nothing@, the selection color will be the same as the +-- cursor color, or if no cursor color is set either then it will be +-- the same as the text color. +-- +-- [@self@] a 'Text' +-- +-- [@color@] the color of the selection, or @Nothing@ to unset it +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_selection_color as ^ `(TextClass self)' => + { withTextClass* `self', withMaybeColor* `Maybe Color' } -> `()' #} + +-- | Retrieves the color of the selection of a 'Text' actor. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] @Just@ a 'Color' +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_selection_color as ^ `(TextClass self)' => + { withTextClass* `self', alloca- `Maybe Color' maybeNullPeek* } -> `()' #} + +-- | Sets the cursor of a 'Text' actor at position. +-- +-- The position is expressed in characters, not in bytes. +-- +-- [@self@] a 'Text' +-- +-- [@position@] the new cursor position, in characters +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_cursor_position as ^ `(TextClass self)' => { withTextClass* `self', `Int' } -> `()' #} + +-- | Retrieves the cursor position. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] the cursor position, in characters +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_cursor_position as ^ `(TextClass self)' => { withTextClass* `self' } -> `Int' #} + + +-- | Sets whether the cursor of a 'Text' actor should be visible or +-- not. +-- +-- The color of the cursor will be the same as the text color unless +-- 'textSetCursorColor' has been called. +-- +-- The size of the cursor can be set using 'textSetCursorSize'. +-- +-- The position of the cursor can be changed programmatically using +-- 'textSetCursorPosition'. +-- +-- [@self@] a 'Text' +-- +-- [@cursor_visible@] whether the cursor should be visible +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_cursor_visible as ^ `(TextClass self)' => { withTextClass* `self', `Bool' } -> `()' #} + +-- | Retrieves whether the cursor of a 'Text' actor is visible. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] @True@ if the cursor is visible +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_cursor_visible as ^ `(TextClass self)' => { withTextClass* `self' } -> `Bool' #} + + +-- | Sets the size of the cursor of a 'Text'. The cursor will only be +-- visible if the 'textCursorVisible' property is set to @True@. +-- +-- [@self@] a 'Text' +-- +-- [@size@] the size of the cursor, in pixels, or -1 to use the +-- default value +-- +-- * Since 1.0 +-- +{# fun unsafe text_set_cursor_size as ^ `(TextClass self)' => { withTextClass* `self', `Int' } -> `()' #} + + +-- | Retrieves the size of the cursor of a 'Text actor. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] the size of the cursor, in pixels +-- +-- * Since 1.0 +-- +{# fun unsafe text_get_cursor_size as ^ `(TextClass self)' => { withTextClass* `self' } -> `Int' #} + +-- | Emits the "activate" signal, if self has been set as activatable +-- using 'textSetActivatable'. +-- +-- This function can be used to emit the ::activate signal inside a +-- "captured-event" or "key-press-event" signal handlers before the +-- default signal handler for the 'Text' is invoked. +-- +-- [@self@] a 'Text' +-- +-- [@Returns@] @True@ if the ::activate signal has been emitted, and +-- @False@ otherwise +-- +-- * Since 1.0 +-- +{# fun text_activate as ^ `(TextClass self)' => { withTextClass* `self' } -> `Bool' #} + + +--TODO: This return type is messy +-- | Retrieves the coordinates of the given position. +-- +-- [@self@] a 'Text' +-- +-- [@position@] position in characters +-- +-- [@Returns@] (X coordinate, Y coordinate, line_height, @True@ if the conversion was successful) +-- +-- * Since 1.0 +-- +{# fun unsafe text_position_to_coords as ^ `(TextClass self)' => + { withTextClass* `self', + `Int', + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv*, + alloca- `Float' peekFloatConv*} -> `Bool' #} + +#if CLUTTER_CHECK_VERSION(1,2,0) +--CHECKME: I've never used Pango, and not really sure if this is good +--also it seems weird. +textSetPreeditString :: (TextClass self) => self -> String -> [PangoAttribute] -> Word -> IO () +textSetPreeditString text str pattrs cpos = let func = {# call unsafe text_set_preedit_string #} + in withTextClass text $ \txtPtr -> + withUTFString str $ \strPtr -> do + pStr <- makeNewPangoString str + withAttrList pStr pattrs $ \attrPtr -> + func txtPtr strPtr attrPtr (cIntConv cpos) +#endif + + +-- Attributes + + +-- | Toggles whether return invokes the activate signal or not. +-- +-- Default value: @True@ +-- +-- Since 1.0 +-- +textActivatable :: (TextClass self) => Attr self Bool +textActivatable = newNamedAttr "activatable" textGetActivatable textSetActivatable + +-- | A list of 'PangoStyleAttributes' to be applied to the contents of +-- the 'Text' actor. +-- +-- * Since 1.0 +-- +--textAttributes :: (TextClass self) => Attr self [PangoAttribute] +--textAttributes = newNamedAttr "attributes" textGetAttributes textSetAttributes + + +-- | The color used to render the text. +-- +-- * Since 1.0 +-- +textColor :: (TextClass self) => Attr self Color +textColor = newNamedAttr "color" textGetColor textSetColor + + +-- | The color of the cursor. +-- +-- * Since 1.0 +-- +textCursorColor :: (TextClass self) => Attr self (Maybe Color) +textCursorColor = newNamedAttr "cursor-color" textGetCursorColor textSetCursorColor + + +-- | Will be set to @True@ if 'actorCursorColor' has been set. +-- +-- Default value: @False@ +-- +-- * Since 1.0 +-- +textCursorColorSet :: (TextClass self) => ReadAttr self Bool +textCursorColorSet = readAttrFromBoolProperty "cursor-color-set" + + + +-- | The size of the cursor, in pixels. If set to -1 the size used +-- will be the default cursor size of 2 pixels. +-- +-- Allowed values: >= -1 +-- +-- Default value: 2 +-- +-- * Since 1.0 +-- +textCursorSize :: (TextClass self) => Attr self Int +textCursorSize = newNamedAttr "cursor-size" textGetCursorSize textSetCursorSize + + +-- | Whether the input cursor is visible or not, it will only be +-- visible if both 'textCursorVisible' and 'textEditable' are set to +-- @True@. +-- +-- Default value: @True@ +-- +-- * Since 1.0 +-- +textCursorVisible :: (TextClass self) => Attr self Bool +textCursorVisible = newNamedAttr "cursor-visible" textGetCursorVisible textSetCursorVisible + + +-- | Whether key events delivered to the actor causes editing. +-- +-- Default value: @True@ +-- +-- * Since 1.0 +-- +textEditable :: (TextClass self) => Attr self Bool +textEditable = newNamedAttr "editable" textGetEditable textSetEditable + + +-- | The preferred place to ellipsize the contents of the 'Text' actor +-- +-- Default value: 'PangoEllipsizeNone' +-- +-- * Since 1.0 +-- +textEllipsize :: (TextClass self) => Attr self EllipsizeMode +textEllipsize = newAttr textGetEllipsize textSetEllipsize + +-- | The font to be used by the ClutterText, as a string that can be +-- parsed by 'Pango.Font.fontDescriptionFromString'. +-- +-- Default value: @Nothing@ +-- +-- * Since 1.0 +-- +textFontName :: (TextClass self) => Attr self (Maybe String) +textFontName = newNamedAttr "font-name" textGetFontName textSetFontName + + +-- | Whether the contents of the 'Text' should be justified on both +-- margins. +-- +-- Default value: @False@ +-- +-- * Since 1.0 +-- +textJustify :: (TextClass self) => Attr self Bool +textJustify = newNamedAttr "justify" textGetJustify textSetJustify + +-- | The preferred alignment for the text. This property controls the +-- alignment of multi-line paragraphs. +-- +-- Default value: 'PangoAlignLeft' +-- +-- * Since 1.0 +-- +textLineAlignment :: (TextClass self) => Attr self LayoutAlignment +textLineAlignment = newNamedAttr "line-alignment" textGetLineAlignment textSetLineAlignment + + +-- | Whether to wrap the lines of 'textText' if the contents exceed +-- the available allocation. The wrapping strategy is controlled by +-- the 'textLineWrapMode' attribute. +-- +-- Default value: @False@ +-- +textLineWrap :: (TextClass self) => Attr self Bool +textLineWrap = newNamedAttr "line-wrap" textGetLineWrap textSetLineWrap + + +-- | If 'textLineWrap' is set to @True@, this property will control +-- how the text is wrapped. +-- +-- Default value: 'PangoWrapWord' +-- +-- * Since 1.0 +-- +textLineWrapMode :: (TextClass self) => Attr self LayoutWrapMode +textLineWrapMode = newNamedAttr "line-wrap-mode" textGetLineWrapMode textSetLineWrapMode + + +-- | The maximum length of the contents of the 'Text' actor. +-- +-- * Allowed values: >= -1 +-- +-- Default value: 0 +-- +-- * Since 1.0 +-- +textMaxLength :: (TextClass self) => Attr self Int +textMaxLength = newNamedAttr "max-length" textGetMaxLength textSetMaxLength + + + +-- | If non-zero, the character that should be used in place of the +-- actual text in a password text actor. +-- +-- Default value: 0 +-- +-- * Since 1.0 +-- +textPasswordChar :: (TextClass self) => Attr self GUnichar +textPasswordChar = newNamedAttr "password-char" textGetPasswordChar textSetPasswordChar + +-- | The current input cursor position. -1 is taken to be the end of +-- the text +-- +-- Allowed values: >= -1 +-- +-- Default value: -1 +-- +-- * Since 1.0 +-- +textPosition :: (TextClass self) => Attr self Int +textPosition = newNamedAttr "position" textGetCursorPosition textSetCursorPosition + + +-- | Whether it is possible to select text, either using the pointer +-- or the keyboard. +-- +-- Default value: @True@ +-- +-- * Since 1.0 +-- +textSelectable :: (TextClass self) => Attr self Bool +textSelectable = newNamedAttr "selectable" textGetSelectable textSetSelectable + + +-- | The current input cursor position. -1 is taken to be the end of +-- the text +-- +-- Allowed values: >= -1 +-- +-- Default value: -1 +-- +-- * Since 1.0 +-- +textSelectionBound :: (TextClass self) => Attr self Int +textSelectionBound = newNamedAttr "selection-bound" textGetSelectionBound textSetSelectionBound + + +-- | The color of the selection. +-- +-- * Since 1.0 +-- +textSelectionColor :: (TextClass self) => Attr self (Maybe Color) +textSelectionColor = newNamedAttr "selection-color" textGetSelectionColor textSetSelectionColor + + +-- | Will be set to @True@ if 'textSelectionColor' has been set. +-- +-- Default value: @False@ +-- +-- * Since 1.0 +-- +textSelectionColorSet :: (TextClass self) => ReadAttr self Bool +textSelectionColorSet = readAttrFromBoolProperty "selection-color-set" + + + +-- | Whether the 'Text' actor should be in single line mode or not. A +-- single line 'Text' actor will only contain a single line of text, +-- scrolling it in case its length is bigger than the allocated +-- size. +-- +-- Setting this property will also set the 'textActivatable' property +-- as a side-effect. +-- +-- Default value: @False@ +-- +-- * Since 1.0 +-- +textSingleLineMode :: (TextClass self) => Attr self Bool +textSingleLineMode = newNamedAttr "single-line-mode" textGetSingleLineMode textSetSingleLineMode + + +-- | The text to render inside the actor. +-- +-- Default value: \"\" +-- +-- * Since 1.0 +-- +textText :: (TextClass self) => Attr self String +textText = newNamedAttr "text" textGetText textSetText + + +-- | Whether the text includes Pango markup. See +-- 'Pango.Layout.layoutSetMarkup' in the Pango documentation. +-- +-- Default value: @False@ +-- +-- * Since 1.0 +-- +textUseMarkup :: (TextClass self) => Attr self Bool +textUseMarkup = newNamedAttr "use-markup" textGetUseMarkup textSetUseMarkup + + +-- Signals + + +--See note in Types of Activatable +instance Activatable Text where + onActivate = connect_NONE__NONE "activate" False + afterActivate = connect_NONE__NONE "activate" True + activate = Signal (connect_NONE__NONE "activate") + +--CHECKME: Do I work? +onCursorEvent, afterCursorEvent :: Text -> (Geometry -> IO ()) -> IO (ConnectId Text) +onCursorEvent = connect_BOXED__NONE "cursor-event" peek False +afterCursorEvent = connect_BOXED__NONE "cursor-event" peek True + + +-- | The ::'cursorEvent' signal is emitted whenever the cursor +-- position changes inside a 'Text' actor. Inside geometry it is +-- stored the current position and size of the cursor, relative to +-- the actor itself. +-- +-- * Since 1.0 +-- +cursorEvent :: Signal Text (Geometry -> IO ()) +cursorEvent = Signal (connect_BOXED__NONE "cursor-event" peek) + + +onTextChanged, afterTextChanged :: Text -> IO () -> IO (ConnectId Text) +onTextChanged = connect_NONE__NONE "text-changed" False +afterTextChanged = connect_NONE__NONE "text-changed" True + + +-- | The ::'textChanged' signal is emitted after actor's text changes +-- +-- * Since 1.0 +-- +textChanged :: Signal Text (IO ()) +textChanged = Signal (connect_NONE__NONE "text-changed") + + + diff --git a/Graphics/UI/Clutter/Texture.chs b/Graphics/UI/Clutter/Texture.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Texture.chs @@ -0,0 +1,647 @@ +-- -*-haskell-*- +-- Clutter Texture +-- +-- Author : Matthew Arsenault +-- +-- Created: 3 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.Texture ( +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Actor' +-- | +----'Texture' +-- | +----'CairoTexture' +-- @ +-- + +-- * Types + Texture, + TextureClass, + TextureFlags(..), + TextureQuality(..), + +-- * Constructors + textureNew, + textureNewFromFile, + textureNewFromActor, + +-- * Methods + textureSetFromFile, + textureSetFromRgbData, --TODO: RGB??? vs. Rgb +--textureSetFromYuvData, +--textureSetAreaFromRgbData, + textureGetBaseSize, + +--textureGetPixelFormat, + textureGetMaxTileWaste, + + textureGetFilterQuality, + textureSetFilterQuality, + +--textureGetCoglTexture, +--textureSetCoglTexture, + +--textureSetCoglMaterial, +--textureGetCoglMaterial, + + textureGetSyncSize, + textureSetSyncSize, + + textureGetRepeat, + textureSetRepeat, + + textureSetKeepAspectRatio, + textureGetKeepAspectRatio, + + textureGetLoadAsync, + textureSetLoadAsync, + + textureGetLoadDataAsync, + textureSetLoadDataAsync, + +-- * Attributes +--textureCoglMaterial, +--textureCoglTexture, + textureDisableSlicing, + textureFilename, + textureFilterQuality, + textureKeepAspectRatio, + textureLoadAsync, + textureLoadDataAsync, +--texturePixelFormat, + textureRepeatX, + textureRepeatY, + textureSyncSize, + textureTileWaste, + +-- * Signals + onLoadFinished, + afterLoadFinished, + loadFinished, + + onPixbufChange, + afterPixbufChange, + pixbufChange, + + onSizeChange, + afterSizeChange, + sizeChange + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Signals #} +{# import Graphics.UI.Clutter.Utility #} + +import Data.Array.Base (getBounds) + +import C2HS +import Control.Monad (liftM) +import System.Glib.Attributes +import System.Glib.Properties +import System.Glib.GError +import System.Glib.FFI + + +-- | Creates a new empty 'Texture' object. +-- +-- [@Returns@] A newly created 'Texture' object. +-- +{# fun unsafe texture_new as ^ { } -> `Texture' newTexture* #} + + +-- | Creates a new 'Texture' actor to display the image contained a +-- file. If the image failed to load then a GError exception is +-- thrown. +-- +-- [@filename@] The name of an image file to load. +-- +-- [@Returns@] A newly created 'Texture' +-- +-- * Since 0.8 +-- +textureNewFromFile :: String -> IO Texture +textureNewFromFile filename = let func = {# call unsafe texture_new_from_file #} + in newTexture =<< (propagateGError $ \gerrorPtr -> + withCString filename $ \cstr -> do + func cstr gerrorPtr) + + + +-- | Creates a new 'Texture' object with its source a prexisting actor +-- (and associated children). The textures content will contain +-- 'live' redirected output of the actors scene. +-- +-- Note this function is intented as a utility call for uniformly +-- applying shaders to groups and other potential visual effects. It +-- requires that the CLUTTER_FEATURE_OFFSCREEN feature is supported by +-- the current backend and the target system. +-- +-- Some tips on usage: +-- +-- * The source actor must be made visible (i.e by calling 'actorShow'). +-- +-- * The source actor must have a parent in order for it to be +-- allocated a size from the layouting mechanism. If the source +-- actor does not have a parent when this function is called then +-- the 'Texture' will adopt it and allocate it at its preferred +-- size. Using this you can clone an actor that is otherwise not +-- displayed. Because of this feature if you do intend to display +-- the source actor then you must make sure that the actor is +-- parented before calling 'textureNewFromActor' or that you +-- unparent it before adding it to a container. +-- +-- * When getting the image for the clone texture, Clutter will +-- attempt to render the source actor exactly as it would appear if +-- it was rendered on screen. The source actor's parent +-- transformations are taken into account. Therefore if your source +-- actor is rotated along the X or Y axes so that it has some depth, +-- the texture will appear differently depending on the on-screen +-- location of the source actor. While painting the source actor, +-- Clutter will set up a temporary asymmetric perspective matrix as +-- the projection matrix so that the source actor will be projected +-- as if a small section of the screen was being viewed. Before +-- version 0.8.2, an orthogonal identity projection was used which +-- meant that the source actor would be clipped if any part of it +-- was not on the zero Z-plane. +-- +-- * Avoid reparenting the source with the created texture. +-- +-- * A group can be padded with a transparent rectangle as to provide +-- a border to contents for shader output (blurring text for +-- example). +-- +-- The texture will automatically resize to contain a further +-- transformed source. However, this involves overhead and can be +-- avoided by placing the source actor in a bounding group sized +-- large enough to contain any child tranformations. +-- +-- * Uploading pixel data to the texture (e.g by using +-- 'textureSetFromFile') will destroy the offscreen texture data and +-- end redirection. +-- +-- * 'coglTextureGetData' with the handle returned by +-- 'textureGetCoglTexture' can be used to read the offscreen texture +-- pixels into a pixbuf. +-- +-- [@actor@] A source Actor +-- +-- [@Returns@] @Just@ A newly created 'Texture' object, or @Nothing@ on failure. +-- +-- * Since 0.6 +-- +{# fun unsafe texture_new_from_actor as ^ + `(ActorClass a)' => { withActorClass* `a'} -> `Maybe Texture' maybeNewTexture* #} + + +--FIXME: Better description of gerror exception +-- | Sets the ClutterTexture image data from an image file. In case of +-- failure, @False@ is returned and a GError exception is thrown. +-- +-- If "load-async" is set to @True@, this function will return as soon +-- as possible, and the actual image loading from disk will be +-- performed asynchronously. "size-change" will be emitten when the +-- size of the texture is available and "load-finished" will be +-- emitted when the image has been loaded or if an error occurred. +-- +-- [@texture@] A 'Texture' +-- +-- [@filename@] The filename of the image in GLib file name encoding +-- +-- [@Returns@] @True@ if the image was successfully loaded and set +-- +-- * Since 0.8 +-- +textureSetFromFile :: (TextureClass self) => self -> String -> IO Bool +textureSetFromFile txt fname = let func = {# call texture_set_from_file #} + in liftM cToBool $ propagateGError $ \gerrorPtr -> + withTextureClass txt $ \txtptr -> + withCString fname $ \cstr -> + func txtptr cstr (castPtr gerrorPtr) + + + + +--CHECKME: Generalized RGBData +--CHECKME: Rgb or RGB? +--FIXME: Proper rowstride +textureSetFromRgbData :: (TextureClass self) => self -> + RGBData Int Word8 -> + [TextureFlags] -> + IO Bool +textureSetFromRgbData txt dat flags = + let func = {# call texture_set_from_rgb_data #} + hasA = rgbDataHasAlpha dat + bpp = if hasA then 4 else 3 + datPtr = rgbDataData dat + in withTextureClass txt $ \txtptr -> + propagateGError $ \gerrorPtr -> do + (w, h) <- getBounds dat + putStrLn $ "W: " ++ Prelude.show w ++ " H: " ++ Prelude.show h + let rowstride = w * 4 -- FIXME + liftM cToBool $ withForeignPtr datPtr $ \fPtr -> + func txtptr + (castPtr fPtr) + (cFromBool hasA) + (cIntConv w) + (cIntConv h) + (cIntConv rowstride) + (cIntConv bpp) + (cFromFlags flags) + (castPtr gerrorPtr) + +{- +texture_set_from_yuv_data +texture_set_area_from_rgb_data +-} + + +-- | Gets the size in pixels of the untransformed underlying image +-- +-- [@texture@] a 'Texture' +-- +-- [@Returns@] (width, height) +-- +{# fun unsafe texture_get_base_size as ^ `(TextureClass self)' => + { withTextureClass* `self', + alloca- `Int' peekIntConv*, + alloca- `Int' peekIntConv* } -> `()' #} + +{- TODO: Requires cogl +{# fun unsafe texture_get_pixel_format as ^ + { withTexture* `Texture' } -> `CoglPixelFormat' cToEnum #} +-} + +--CHECKME: Wrap the -1 thing somehow? +-- | Gets the maximum waste that will be used when creating a texture +-- or -1 if slicing is disabled. +-- +-- [@texture@] A 'Texture' +-- +-- [@Returns@] The maximum waste or -1 if the texture waste is +-- unlimited. +-- +-- * Since 0.8 +-- +{# fun unsafe texture_get_max_tile_waste as ^ `(TextureClass self)' => + { withTextureClass* `self' } -> `Int' #} + +-- | Gets the filter quality used when scaling a texture. +-- +-- [@texture@] A 'Texture +-- +-- [@Returns @] The filter quality value. +-- +-- * Since 0.8 +-- +{# fun unsafe texture_get_filter_quality as ^ `(TextureClass self)' => + { withTextureClass* `self' } -> `TextureQuality' cToEnum #} + +-- | Sets the filter quality when scaling a texture. The quality is an +-- enumeration currently the following values are supported: +-- 'TextureQualityLow' which is fast but only uses nearest neighbour +-- interpolation. 'TextureQualityMedium' which is computationally a +-- bit more expensive (bilinear interpolation), and +-- 'TextureQualityHigh' which uses extra texture memory resources to +-- improve scaled down rendering as well (by using mipmaps). The +-- default value is 'TextureQualityMedium'. +-- +-- [@texture@] a 'Texture' +-- +-- [@filter_quality@] new filter quality value +-- +-- * Since 0.8 +-- +{# fun unsafe texture_set_filter_quality as ^ `(TextureClass self)' => + { withTextureClass* `self', cFromEnum `TextureQuality' } -> `()' #} + +{- +{# fun unsafe texture_get_cogl_texture as ^ `(TextureClass self)' => + { withTexture* `Texture' } -> `CoglTexture' newCoglTexture #} +{# fun unsafe texture_set_cogl_texture as ^ `(TextureClass self)' => + { withTexture* `Texture', withCoglTexture `CoglTexture' } -> `()' #} +{# fun unsafe texture_get_cogl_material as ^ `(TextureClass self)' => + { withTexture* `Texture' } -> `CoglMaterial' newCoglMaterial #} +{# fun unsafe texture_set_cogl_material as ^ `(TextureClass self)' => + { withTexture* `Texture', withCoglMaterial `CoglMaterial' } -> `()' #} +-} + + +-- | Retrieves the value set with 'textureGetSyncSize' +-- +-- [@texture@] a 'Texture' +-- +-- [@Returns@] @True@ if the 'Texture' should have the same preferred +-- size of the underlying image data +-- +-- * Since 1.0 +-- +{# fun unsafe texture_get_sync_size as ^ `(TextureClass self)' => { withTextureClass* `self' } -> `Bool' #} + +-- | Sets whether texture should have the same preferred size as the +-- underlying image data. +-- +-- [@texture@] a 'Texture' +-- +-- [@sync_size@] @True@ if the texture should have the same size of +-- the underlying image data +-- +-- * Since 1.0 +-- +{# fun unsafe texture_set_sync_size as ^ `(TextureClass self)' => + { withTextureClass* `self', `Bool' } -> `()' #} + + +-- | Retrieves the horizontal and vertical repeat values set using +-- 'textureSetRepeat' +-- +-- [@texture@] a 'Texture' +-- +-- [@Returns@] (horizontal (x) repeat, vertical (y) repeat) +-- +-- * Since 1.0 +-- +{# fun unsafe texture_get_repeat as ^ `(TextureClass self)' => + { withTextureClass* `self', alloca- `Bool' peekBool*, alloca- `Bool' peekBool* } -> `()' #} + +-- | Sets whether the texture should repeat horizontally or vertically +-- when the actor size is bigger than the image size +-- +-- [@texture@] a 'Texture' +-- +-- [@repeat_x@] @True@ if the texture should repeat horizontally +-- +-- [@repeat_y@] @True@ if the texture should repeat vertically +-- +-- * Since 1.0 +-- +{# fun unsafe texture_set_repeat as ^ `(TextureClass self)' => + { withTextureClass* `self', `Bool', `Bool' } -> `()' #} + +-- | Retrieves the value set using 'textureGetKeepAspectRatio' +-- +-- [@texture@] a 'Texture' +-- +-- [@Returns@] @True@ if the 'Texture' should maintain the aspect +-- ratio of the underlying image +-- +-- * Since 1.0 +-- +{# fun unsafe texture_get_keep_aspect_ratio as ^ `(TextureClass self)' => + { withTextureClass* `self' } -> `Bool' #} + +-- | Sets whether texture should have a preferred size maintaining the +-- aspect ratio of the underlying image +-- +-- [@texture@] a 'Texture' +-- +-- [@keep_aspect@] @True@ to maintain aspect ratio +-- +-- * Since 1.0 +-- +{# fun unsafe texture_set_keep_aspect_ratio as ^ `(TextureClass self)' => + { withTextureClass* `self', `Bool'} -> `()' #} + + +-- | Retrieves the value set using 'textureSetLoadAsync' +-- +-- [@texture@] a 'Texture' +-- +-- [@Returns@] @True@ if the 'Texture' should load the data from disk +-- asynchronously +-- +-- * Since 1.0 +-- +{# fun unsafe texture_get_load_async as ^ `(TextureClass self)' => + { withTextureClass* `self' } -> `Bool' #} + +-- | Sets whether texture should use a worker thread to load the data +-- from disk asynchronously. Setting load_async to @True@ will make +-- 'textureSetFromFile' return immediately. +-- +-- See the 'textureLoadAsync' property documentation, and +-- 'textureSetLoadDataAsync'. +-- +-- [@texture@] a 'Texture' +-- +-- [@load_async@] @True@ if the texture should asynchronously load +-- data from a filename +-- +-- * Since 1.0 +-- +{# fun unsafe texture_set_load_async as ^ `(TextureClass self)' => + { withTextureClass* `self', `Bool'} -> `()' #} + + +-- | Retrieves the value set by 'textureSetLoadDataAsync' +-- +-- [@texture@] a 'Texture' +-- +-- [@Returns@] @True@ if the 'Texture' should load the image data from +-- a file asynchronously +-- +-- * Since 1.0 +-- +{# fun unsafe texture_get_load_data_async as ^ `(TextureClass self)' => + { withTextureClass* `self' } -> `Bool' #} + +-- | Sets whether texture should use a worker thread to load the data +-- from disk asynchronously. Setting load_async to @True@ will make +-- 'textureSetFromFile' block until the 'Texture' has determined the +-- width and height of the image data. +-- +-- See the "load-async" property documentation, and +-- 'textureSetLoadAsync'. +-- +-- [@texture@] a 'Texture' +-- +-- [@load_async@] @True@ if the texture should asynchronously load +-- data from a filename +-- +-- * Since 1.0 +-- +{# fun unsafe texture_set_load_data_async as ^ `(TextureClass self)' => + { withTextureClass* `self', `Bool'} -> `()' #} + + +-- attributes + +-- | The underlying COGL material handle used to draw this actor. +--textureCoglMaterial :: (TextureClass self) => Attr self CoglMaterial +--textureCoglMaterial = newAttr textureGetCoglMaterial textureSetCoglMaterial + +-- | The underlying COGL texture handle used to draw this actor. +--textureCoglTexture :: (TextureClass self) => Attr self CoglTexture +--textureCoglTexture = newAttr textureGetCoglTexture textureSetCoglTexture + +-- | Force the underlying texture to be singlularand not made of of +-- smaller space saving inidivual textures. +-- +-- Default value: @False@ +-- +textureDisableSlicing :: (TextureClass self) => Attr self Bool +textureDisableSlicing = newAttrFromBoolProperty "disable-slicing" + +-- | The full path of the file containing the texture. +-- +-- Default value: @Nothing@ +-- +textureFilename :: (TextureClass self) => WriteAttr self (Maybe String) +textureFilename = writeAttrFromMaybeStringProperty "filename" + +-- | Rendering quality used when drawing the texture. +-- +-- Default value: 'TextureQualityMedium' +-- +textureFilterQuality :: (TextureClass self) => Attr self TextureQuality +textureFilterQuality = newNamedAttr "filter-quality" textureGetFilterQuality textureSetFilterQuality + +-- | Keep the aspect ratio of the texture when requesting the +-- preferred width or height. +-- +-- Default value: @False@ +-- +textureKeepAspectRatio :: (TextureClass self) => Attr self Bool +textureKeepAspectRatio = newNamedAttr "keep-aspect-ratio" textureGetKeepAspectRatio textureSetKeepAspectRatio + +--CHECKME: Threading stuff +-- | Tries to load a texture from a filename by using a local thread +-- to perform the read operations. The initially created texture has +-- dimensions 0x0 when the true size becomes available the +-- "size-change" signal is emitted and when the image has completed +-- loading the "load-finished" signal is emitted. +-- +-- Threading is only enabled if g_thread_init() has been called prior +-- to clutter_init(), otherwise 'Texture' will use the main loop to +-- load the image. +-- +-- The upload of the texture data on the GL pipeline is not +-- asynchronous, as it must be performed from within the same thread +-- that called clutter_main(). +-- +-- Default value: @False@ +-- +-- * Since 1.0 +-- +textureLoadAsync :: (TextureClass self) => Attr self Bool +textureLoadAsync = newNamedAttr "load-async" textureGetLoadAsync textureSetLoadAsync + + +-- | Like 'textureLoadAsync' but loads the width and height +-- synchronously causing some blocking. +-- +-- Default value: @False@ +-- +-- Since 1.0 +-- +textureLoadDataAsync :: (TextureClass self) => Attr self Bool +textureLoadDataAsync = newAttr textureGetLoadDataAsync textureSetLoadDataAsync + +-- | CoglPixelFormat to use. +-- +-- Default value: CoglPixelFormatRgba8888 +-- +--textureCoglPixelFormat :: (TextureClass self) => Attr self CoglPixelFormat +--textureCoglPixelFormat = newAttr textureGetCoglPixelFormat textureSetCoglPixelFormat + + +-- | Repeat underlying pixbuf rather than scale in x direction. +-- +-- Default value: @False@ +-- +textureRepeatX :: (TextureClass self) => Attr self Bool +textureRepeatX = newAttrFromBoolProperty "repeat-x" + +-- | Repeat underlying pixbuf rather than scale in y direction. +-- +-- Default value: @False@ +-- +textureRepeatY :: (TextureClass self) => Attr self Bool +textureRepeatY = newAttrFromBoolProperty "repeat-y" + +-- | Auto sync size of actor to underlying pixbuf dimensions. +-- +-- Default value: @True@ +-- +textureSyncSize :: (TextureClass self) => Attr self Bool +textureSyncSize = newNamedAttr "sync-size" textureGetSyncSize textureSetSyncSize + +--CHECKME: +-- | Maximum waste area of a sliced texture. +-- +-- Allowed values: >= -1 +-- +-- Default value: 127 +-- +textureTileWaste :: (TextureClass self) => ReadAttr self Int +textureTileWaste = readNamedAttr "tile-waste" textureGetMaxTileWaste + +-- signals + +--CHECKME: Exception in handler? + +onLoadFinished, afterLoadFinished :: Texture -> (Maybe GError -> IO ()) -> IO (ConnectId Texture) +onLoadFinished = connect_BOXED__NONE "load-finished" maybeNullPeek False +afterLoadFinished = connect_BOXED__NONE "load-finished" maybeNullPeek True + + + +-- | The ::'loadFinished' signal is emitted when a texture load has +-- completed. If there was an error during loading, error will be set, +-- otherwise it will be @Nothing@ +-- +-- [@error@] A set error, or @Nothing@ +-- +-- * Since 1.0 +-- +loadFinished :: (TextureClass self) => Signal self (GError -> IO ()) +loadFinished = Signal (connect_BOXED__NONE "load-finished" peek) + + +onPixbufChange, afterPixbufChange :: Texture -> IO () -> IO (ConnectId Texture) +onPixbufChange = connect_NONE__NONE "pixbuf-change" False +afterPixbufChange = connect_NONE__NONE "pixbuf-change" True + +-- | The ::pixbuf-change signal is emitted each time the pixbuf used +-- by texture changes. +-- +pixbufChange :: (TextureClass self) => Signal self (IO ()) +pixbufChange = Signal (connect_NONE__NONE "pixbuf-change") + + +onSizeChange, afterSizeChange :: Texture -> (Int -> Int -> IO ()) -> IO (ConnectId Texture) +onSizeChange = connect_INT_INT__NONE "size-change" False +afterSizeChange = connect_INT_INT__NONE "size-change" True + + +-- | The ::size-change signal is emitted each time the size of the +-- pixbuf used by texture changes. The new size is given as argument +-- to the callback. +-- +-- [@width@] the width of the new texture +-- +-- [@height@] the height of the new texture +-- +sizeChange :: (TextureClass self) => Signal self (Int -> Int -> IO ()) +sizeChange = Signal (connect_INT_INT__NONE "size-change") + + diff --git a/Graphics/UI/Clutter/Timeline.chs b/Graphics/UI/Clutter/Timeline.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Timeline.chs @@ -0,0 +1,513 @@ +-- -*-haskell-*- +-- Clutter Timeline +-- +-- Author : Matthew Arsenault +-- +-- Created: 21 Sep 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | Timeline — A class for time-based events +module Graphics.UI.Clutter.Timeline ( +-- * Description +-- | 'Timeline' is a base class for managing time based events such as animations. +-- + +-- * Class Hierarchy +-- | +-- @ +-- | 'GObject' +-- | +----'Timeline' +-- @ + +-- * Types + Timeline, + TimelineClass, + TimelineDirection(..), + +-- * Constructors + + timelineNew, + timelineClone, + +-- * Methods + + timelineSetDuration, + timelineGetDuration, + + timelineSetLoop, + timelineGetLoop, + + timelineSetDelay, + timelineGetDelay, + + timelineSetDirection, + timelineGetDirection, + + timelineStart, + timelinePause, + timelineStop, + timelineRewind, + timelineSkip, + timelineAdvance, + timelineGetElapsedTime, + timelineGetDelta, + timelineGetProgress, + timelineIsPlaying, + + timelineAddMarkerAtTime, + timelineHasMarker, + timelineListMarkers, + timelineRemoveMarker, + timelineAdvanceToMarker, + +-- * Attributes + timelineDuration, + timelineLoop, + timelineDelay, + timelineDirection, + +-- * Signals + onCompleted, + afterCompleted, + completed, + + onMarkerReached, + afterMarkerReached, + markerReached, + + onNewFrame, + afterNewFrame, + newFrame, + + onPaused, + afterPaused, + paused, + + onStarted, + afterStarted, + started + ) where + +{# import Graphics.UI.Clutter.Types #} +{# import Graphics.UI.Clutter.Signals #} +{# import Graphics.UI.Clutter.Utility #} + +import C2HS +import Control.Monad (liftM) +import System.Glib.GObject +import System.Glib.Attributes +import System.Glib.Properties +import System.Glib.Signals + + +-- | Creates a new 'Timeline' with a duration of msecs. +-- +-- [@msecs@] Duration of the timeline in milliseconds +-- +-- [@Returns@] the newly created 'Timeline' instance +-- +-- * Since 0.6 +-- +{# fun unsafe timeline_new as ^ { cIntConv `Word' } -> `Timeline' newTimeline* #} + +-- | Create a new 'Timeline' instance which has property values +-- matching that of supplied timeline. The cloned timeline will not +-- be started and will not be positioned to the current position of +-- timeline: you will have to start it with 'timelineStart'. +-- +-- [@timeline@] 'Timeline' to duplicate. +-- +-- [@Returns@] a new 'Timeline', cloned from timeline +-- +-- * Since 0.4 +-- +{# fun unsafe timeline_clone as ^ { withTimeline* `Timeline'} -> `Timeline' newTimeline* #} + +-- | Sets the duration of the timeline, in milliseconds. The speed of +-- the timeline depends on the ClutterTimeline:fps setting. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@msecs@] duration of the timeline in milliseconds +-- +-- * Since 0.6 +-- +{# fun unsafe timeline_set_duration as ^ { withTimeline* `Timeline', cIntConv `Word' } -> `()' #} + +-- | Retrieves the duration of a 'Timeline' in milliseconds. See +-- 'timelineSetDuration'. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@Returns@] the duration of the timeline, in milliseconds. +-- +-- * Since 0.6 +-- +{# fun unsafe timeline_get_duration as ^ { withTimeline* `Timeline' } -> `Word' cIntConv #} + + +-- | Sets whether timeline should loop. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@loop@] @True@ for enable looping +-- +{# fun unsafe timeline_set_loop as ^ { withTimeline* `Timeline', `Bool' } -> `()' #} + + +-- | Gets whether timeline is looping +-- +-- [@timeline@] a 'Timeline' +-- +-- [@Returns@] @True@ if the timeline is looping +-- +{# fun unsafe timeline_get_loop as ^ { withTimeline* `Timeline' } -> `Bool' #} + +-- | Sets the delay, in milliseconds, before timeline should start. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@msecs@] delay in milliseconds +-- +-- * Since 0.4 +-- +{# fun unsafe timeline_set_delay as ^ { withTimeline* `Timeline', cIntConv `Word' } -> `()' #} + +-- | Retrieves the delay set using 'timelineSetDelay'. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@Returns@] the delay in milliseconds. +-- +-- * Since 0.4 +-- +{# fun unsafe timeline_get_delay as ^ { withTimeline* `Timeline' } -> `Word' cIntConv #} + +-- | Sets the direction of timeline, either TimelineForward or +-- TimelineBackward. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@direction@] the direction of the timeline +-- +-- * Since 0.6 +-- +{# fun unsafe timeline_set_direction as ^ + { withTimeline* `Timeline', cFromEnum `TimelineDirection' } -> `()' #} + +-- | Retrieves the direction of the timeline set with +-- 'TimelineSetDirection'. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@Returns@] the direction of the timeline +-- +-- * Since 0.6 +-- +{# fun unsafe timeline_get_direction as ^ + { withTimeline* `Timeline' } -> `TimelineDirection' cToEnum #} + +-- | Starts the 'Timeline' playing. +{# fun timeline_start as ^ { withTimeline* `Timeline' } -> `()' #} + +-- | Pauses the 'Timeline' on current frame +{# fun timeline_pause as ^ { withTimeline* `Timeline' } -> `()' #} + +-- | Stops the 'Timeline' and moves to frame 0 +{# fun timeline_stop as ^ { withTimeline* `Timeline' } -> `()' #} + +-- | Rewinds ClutterTimeline to the first frame if its direction is +-- TimelineForward and the last frame if it is TimelineBackward. +{# fun timeline_rewind as ^ { withTimeline* `Timeline' } -> `()' #} + +-- | Advance timeline by the requested time in milliseconds +-- +-- [@timeline@] A 'Timeline' +-- +-- [@msecs@] Amount of time to skip +-- +{# fun timeline_skip as ^ { withTimeline* `Timeline', cIntConv `Word' } -> `()' #} + +--CHECKME: Since it's skipping the given time, but does it skip others? mark unsafe or not? +-- | Advance timeline to the requested point. The point is given as a +-- time in milliseconds since the timeline started. +-- +-- * Note +-- +-- The timeline will not emit the "new-frame" signal for the given +-- time. The first ::new-frame signal after the call to +-- 'timelineAdvance' will be emit the skipped markers. +-- +-- [@timeline@] A 'Timeline' +-- +-- [@msecs@] Time to advance to +-- +{# fun unsafe timeline_advance as ^ { withTimeline* `Timeline', cIntConv `Word' } -> `()' #} + + +-- | Request the current time position of the timeline. +-- +-- [@timeline@] A 'Timeline' +-- +-- [@Returns@] current elapsed time in milliseconds. +-- +{# fun unsafe timeline_get_elapsed_time as ^ { withTimeline* `Timeline' } -> `Word' cIntConv #} + + +--TODO: Links to all the signals in the doc +-- | Retrieves the amount of time elapsed since the last 'Timeline'::new-frame signal. +-- +-- This function is only useful inside handlers for the ::new-frame +-- signal, and its behaviour is undefined if the timeline is not +-- playing. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@Returns@] the amount of time in milliseconds elapsed since the last frame +-- +-- * Since 0.6 +-- +{# fun unsafe timeline_get_delta as ^ { withTimeline* `Timeline' } -> `Word' cIntConv #} + + +-- | The position of the timeline in a [0, 1] interval. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@Returns@] the position of the timeline. +-- +-- * Since 0.6 +-- +{# fun unsafe timeline_get_progress as ^ { withTimeline* `Timeline' } -> `Double' #} + +-- | Queries state of a 'Timeline'. +-- +-- [@timeline@] A 'Timeline' +-- +-- [@Returns@] @True@ if timeline is currently playing +-- +{# fun unsafe timeline_is_playing as ^ { withTimeline* `Timeline' } -> `Bool' #} + +-- | Adds a named marker that will be hit when the timeline has been +-- running for msecs milliseconds. Markers are unique string +-- identifiers for a given time. Once timeline reaches msecs, it +-- will emit a ::marker-reached signal for each marker attached to +-- that time. +-- +-- A marker can be removed with 'timelineRemoveMarker'. The timeline +-- can be advanced to a marker using 'timelineAdvanceToMarker'. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@marker_name@] the unique name for this marker +-- +-- [@msecs@] position of the marker in milliseconds +-- +-- * Since 0.8 +-- +{# fun unsafe timeline_add_marker_at_time as ^ + { withTimeline* `Timeline', `String', cIntConv `Word' } -> `()' #} + + +-- | Checks whether timeline has a marker set with the given name. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@marker_name@] the name of the marker +-- +-- [@Returns@] @True@ if the marker was found +-- +-- * Since 0.8 +-- +{# fun unsafe timeline_has_marker as ^ { withTimeline* `Timeline', `String' } -> `Bool' #} + +--CHECKME: Does the returned gchar** need to be freed from this? +--CHECME: Unicode? +--TODO: Maybe better way to get char** out + +-- | Retrieves the list of markers at time msecs. If frame_num is a +-- negative integer, all the markers attached to timeline will be +-- returned. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@msecs@] the time to check, or -1 +-- +-- [@Returns@] A list of markers returned +-- +-- * Since 0.8 +-- +timelineListMarkers :: Timeline -> Int -> IO [String] +timelineListMarkers tml time = withTimeline tml $ \tmlptr -> + alloca $ \intptr -> do + strArrayPtr <- {# call unsafe timeline_list_markers #} tmlptr (cIntConv time) intptr + num <- peek intptr + strPtrList <- peekArray (cIntConv num) strArrayPtr + mapM peekNFreeString strPtrList + +-- | Removes marker_name, if found, from timeline. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@marker_name@] the name of the marker to remove +-- +-- * Since 0.8 +-- +{# fun unsafe timeline_remove_marker as ^ { withTimeline* `Timeline', `String' } -> `()' #} + +-- | Advances timeline to the time of the given marker_name. +-- +-- * Note +-- +-- Like 'timelineAdvance', this function will not emit the "new-frame" +-- for the time where marker_name is set, nor it will emit +-- "marker-reached" for marker_name. +-- +-- [@timeline@] a 'Timeline' +-- +-- [@marker_name@] the name of the marker +-- +-- * Since 0.8 +-- +{# fun unsafe timeline_advance_to_marker as ^ { withTimeline* `Timeline', `String' } -> `()' #} + + +-- | Duration of the timeline in milliseconds, depending on the +-- 'Timeline':fps value. +-- +-- Default value: 1000 +-- +-- * Since 0.6 +-- +timelineDuration :: Attr Timeline Word +timelineDuration = newNamedAttr "duration" timelineGetDuration timelineSetDuration + + +-- | Whether the timeline should automatically rewind and restart. +-- +-- Default value: @False@ +-- +timelineLoop :: Attr Timeline Bool +timelineLoop = newNamedAttr "loop" timelineGetLoop timelineSetLoop + + +-- | A delay, in milliseconds, that should be observed by the timeline +-- before actually starting. +-- +-- Default value: 0 +-- +-- * Since 0.4 +-- +timelineDelay :: Attr Timeline Word +timelineDelay = newNamedAttr "delay" timelineGetDelay timelineSetDelay + + +-- | The direction of the timeline, either TimelineForward +-- or TimelineBackward. +-- +-- Default value: TimelineForward +-- +-- * Since 0.6 +-- +timelineDirection :: Attr Timeline TimelineDirection +timelineDirection = newNamedAttr "direction" timelineGetDirection timelineSetDirection + + + +--TODO: Check these + +--onCompleted, afterCompleted :: Timeline -> IO () -> IO (ConnectId Timeline) + +-- | The ::completed signal is emitted when the timeline reaches the +-- number of frames specified by the 'Timeline':num-frames +-- property. +--completed :: Signal Timeline (IO ()) + +onMarkerReached, afterMarkerReached :: Timeline -> (String -> Word -> IO ()) -> IO (ConnectId Timeline) +onMarkerReached = connect_STRING_WORD__NONE "marker-reached" False +afterMarkerReached = connect_STRING_WORD__NONE "marker-reached" True + +--TODO: Code part of this doc +-- | The ::marker-reached signal is emitted each time a timeline +-- reaches a marker set with 'timelineAddMarkerAtTime'. This signal +-- is detailed with the name of the marker as well, so it is +-- possible to connect a callback to the ::marker-reached signal for +-- a specific marker with: +-- +-- TODO: The example +-- +-- In the example, the first callback will be invoked for both the +-- \"foo\" and \"bar\" marker, while the second and third callbacks +-- will be invoked for the \"foo\" or \"bar\" markers, respectively. +-- +-- [@timeline@] the 'Timeline' which received the signal +-- +-- [@marker_name@] the name of the marker reached +-- +-- [@msecs@] the elapsed time +-- +-- * Since 0.8 +-- +markerReached :: Signal Timeline (String -> Word -> IO ()) +markerReached = Signal (connect_STRING_WORD__NONE "marker-reached") + +onNewFrame, afterNewFrame :: Timeline -> (Int -> IO ()) -> IO (ConnectId Timeline) +onNewFrame = connect_INT__NONE "new-frame" False +afterNewFrame = connect_INT__NONE "new-frame" True + + +-- | The ::new-frame signal is emitted for each timeline running +-- timeline before a new frame is drawn to give animations a chance +-- to update the scene. +-- +-- [@timeline@] the timeline which received the signal +-- +-- [@msecs@] the elapsed time between 0 and duration +-- +newFrame :: Signal Timeline (Int -> IO ()) +newFrame = Signal (connect_INT__NONE "new-frame") + + +instance Playable Timeline where + started = Signal (connect_NONE__NONE "started") + onStarted = connect_NONE__NONE "started" False + afterStarted = connect_NONE__NONE "started" True + completed = Signal (connect_NONE__NONE "completed") + onCompleted = connect_NONE__NONE "completed" False + afterCompleted = connect_NONE__NONE "completed" True + paused = Signal (connect_NONE__NONE "paused") + onPaused = connect_NONE__NONE "paused" False + afterPaused = connect_NONE__NONE "paused" True + + +-- | The ::paused signal is emitted when 'timelinePause' is invoked. +-- paused :: Signal Timeline (IO ()) + + +-- onStarted, afterStarted :: Timeline -> IO () -> IO (ConnectId Timeline) + + + +-- | The ::started signal is emitted when the timeline starts its +-- run. This might be as soon as 'timelineStart' is invoked or after +-- the delay set in the 'Timeline':delay property has expired. +--started :: Signal Timeline (IO ()) + + diff --git a/Graphics/UI/Clutter/Types.chs b/Graphics/UI/Clutter/Types.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Types.chs @@ -0,0 +1,1516 @@ +-- -*-haskell-*- +-- Clutter Types +-- +-- Author : Matthew Arsenault +-- +-- Created: 5 Sep 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- + +{-# LANGUAGE ForeignFunctionInterface, + TypeSynonymInstances, + MultiParamTypeClasses, + ScopedTypeVariables, + FlexibleInstances #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +--CHECKME: gtk2hs change broke everything. I need to double check what +--they are doing to get the referencing right, but I just want it to +--compile right now. + +module Graphics.UI.Clutter.Types ( + withGObject, + newGObject, + withGValue, + constrGObject, + makeNewActor, + --TODO: Exports need organizing and stuff + + GSSize, + GUnichar, + Word, + GID, + Timestamp, + DeviceID, + + Color(..), + ColorPtr, + withColor, + + Actor, + ActorClass, + withActor, + withActorClass, + toActor, + newActor, + newActorList, + + Rectangle, + RectangleClass, + toRectangle, + withRectangle, + newRectangle, + + Text, + TextClass, + toText, + withText, + withTextClass, + newText, + + Stage, + StageClass, + withStage, + withStageClass, + newStage, + + Container, + ContainerClass, + toContainer, + withContainer, + withContainerClass, + + Perspective(..), + PerspectivePtr, + withPerspective, + PickMode(..), + Gravity(..), + RequestMode(..), + ActorFlags(..), + AllocationFlags(..), + RotateAxis(..), + + InitError(..), + + Event, + + EventType(..), + EventFlags(..), + ModifierType(..), + StageState(..), + ScrollDirection(..), + + Animation, + AnimationRaw, + AnimationRawClass, + toAnimation, + withAnimation, + mkAnimation, + newAnimationRaw, + getAnimationRaw, + + Timeline, + TimelineClass, + withTimeline, + newTimeline, + newTimelineList, + + Alpha, + AlphaClass, + withAlpha, + newAlpha, + + AnimationMode(..), + + TimelineDirection(..), + + Interval, + IntervalRaw, + mkInterval, + withInterval, + newIntervalRaw, + + Fog(..), + FogPtr, + withFog, + + CairoTexture, + CairoTextureClass, + withCairoTexture, + newCairoTexture, + + Media, + MediaClass, + withMedia, + withMediaClass, + + ChildMeta, + ChildMetaClass, + newChildMeta, + + Clone, + CloneRaw, + mkClone, + newCloneRaw, + withClone, + + BehaviourClass, + Behaviour, + withBehaviour, + withBehaviourClass, + newBehaviour, + BehaviourForeachFunc, + CBehaviourForeachFunc, + newBehaviourForeachFunc, + BehaviourScaleClass, + BehaviourScale, + withBehaviourScale, + newBehaviourScale, + BehaviourDepthClass, + BehaviourDepth, + withBehaviourDepth, + newBehaviourDepth, + BehaviourEllipseClass, + BehaviourEllipse, + withBehaviourEllipse, + newBehaviourEllipse, + BehaviourOpacityClass, + BehaviourOpacity, + withBehaviourOpacity, + newBehaviourOpacity, + BehaviourRotateClass, + BehaviourRotate, + withBehaviourRotate, + newBehaviourRotate, + BehaviourPathClass, + BehaviourPath, + withBehaviourPath, + newBehaviourPath, + + PathClass, + Path, + withPath, + newPath, + + Group, + GroupClass, + newGroup, + withGroup, + + AlphaFunc, + newAlphaFunc, + + RotateDirection(..), + TextureQuality(..), + Texture, + TextureClass, + newTexture, + withTexture, + withTextureClass, + + TextureFlags(..), + + Shader, + ShaderClass, + withShader, + newShader, + + ShaderError(..), + + Model, + ModelClass, + withModel, + withModelClass, + newModel, + + ModelIter, + ModelIterClass, + withModelIter, + newModelIter, + + ListModel, + ListModelClass, + withListModel, + newListModel, + + Script, + ScriptClass, + withScript, + newScript, + + PathNodeType(..), + PathNode, + PathNodePtr, + Knot, + withPathNode, + newPathNodes, + PathCallback, + CPathCallback, + newPathCallback, + + Score, + ScoreClass, + withScore, + newScore, + + UnitType(..), + + ScriptableClass, + Scriptable, + withScriptableClass, + + BindingPool, + newBindingPool, + withBindingPool, + + InputDeviceType(..), + + GCallback, + CGCallback, + newGCallback, + + Geometry, + GeometryPtr, + withGeometry, + + Vertex, + VertexPtr, + withVertex, + vertexX, + vertexY, + vertexZ, + + ActorBox, + actorBoxX1, + actorBoxY1, + actorBoxX2, + actorBoxY2, + ActorBoxPtr, + withActorBox, + + --Units, + --unUnits + ScriptError(..), + FontFlags(..), + + Animatable, + AnimatableClass, + withAnimatable, + withAnimatableClass, + + Callback, + CCallback, + newCallback, + + ModelForeachFunc, + CModelForeachFunc, + newModelForeachFunc, + + RGBData, + mkRGBData, + rgbDataHasAlpha, + rgbDataData, + + Activatable(..), + Playable(..) + + ) where + +--FIXME: Conflict with EventType Nothing +import Prelude hiding (Nothing) +import Data.Word + +--RGBData stuff +import Data.Ix +-- internal module of GHC +import Data.Array.Base ( MArray, newArray, newArray_, unsafeRead, unsafeWrite, + getBounds, + getNumElements + ) + +import C2HS hiding (newForeignPtr) +import System.Glib.GObject +import System.Glib.Signals +import System.Glib.GValue (GValue(GValue)) +import System.Glib.GList +import System.Glib.Flags +import System.Glib.FFI +import Control.Monad (when, liftM2, join) +import Control.Exception (bracket) + + +-- gtk2hs changed mkGObject to be a tuple (GObject, objectUnref) +--TODO: Move this +constrGObject = fst mkGObject + +--also why the flipped newForeignPtr there? +--from foreign.concurrent or something, and also flipped in System.Glib.FFI + + +--The name makeNewActor is unfortunate since Path technically isn't an +-- actor but has a floating reference + + +-- Get rid of the floating +-- reference to get a normal reference clutter actors and gtk widgets +-- have floating references + + -- This is a convenience function to generate a new actor. (not to +-- be confused with 'newActor'. It adds the finalizer with the method +-- described under objectSink. It is basically the same thing as +-- 'makeNewObject' for GtkWidgets, since clutter actors are nearly the +-- same. The only difference is the class constraint, since Actors, etc. +-- shouldn't be Gtk's Object. +-- +-- * The constr argument is the contructor of the specific object. +-- +makeNewActor :: GObjectClass obj => + (ForeignPtr obj -> obj, FinalizerPtr obj) -> IO (Ptr obj) -> IO obj +makeNewActor (constr, objectUnref) generator = do + objPtr <- generator + when (objPtr == nullPtr) (fail "makeNewActorObject: object is NULL") + objectRefSink objPtr + obj <- newForeignPtr objPtr objectUnref + return $! constr obj + +withGObject::GObjectClass o => o -> (Ptr () -> IO b) -> IO b +withGObject obj act = (withForeignPtr . unGObject . toGObject) obj $ \ptr -> act (castPtr ptr) + +newGObject a = makeNewGObject (constrGObject, objectUnref) $ return (castPtr a) + +--TODO: Make this castPtr go away +withGValue (GValue gval) = castPtr gval + +--this doesn't seem to work since GObjectClass is not here +--I'm not sure if I can work around this. Oh well, I don't think it's that important +-- {# pointer *GObject newtype nocode #} +-- {# class GObjectClass GObject #} + +--TODO: Make this go away. +type GSSize = {# type gssize #} +type GUnichar = {# type gunichar #} + +-- *** Misc + +{# enum ClutterInitError as InitError {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterPickMode as PickMode {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterAllocationFlags as AllocationFlags {underscoreToCase} deriving (Show, Eq, Bounded) #} +{# enum ClutterGravity as Gravity {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterActorFlags as ActorFlags {underscoreToCase} deriving (Show, Eq, Bounded) #} +{# enum ClutterRequestMode as RequestMode {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterRotateAxis as RotateAxis {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterEventType as EventType {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterEventFlags as EventFlags {underscoreToCase} deriving (Show, Eq, Bounded) #} +{# enum ClutterModifierType as ModifierType {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterStageState as StageState {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterScrollDirection as ScrollDirection {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterTimelineDirection as TimelineDirection {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterAnimationMode as AnimationMode {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterRotateDirection as RotateDirection {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterTextureQuality as TextureQuality {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterTextureFlags as TextureFlags {underscoreToCase} deriving (Show, Eq, Bounded) #} +{# enum ClutterShaderError as ShaderError {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterPathNodeType as PathNodeType {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterUnitType as UnitType {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterInputDeviceType as InputDeviceType {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterScriptError as ScriptError {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterFontFlags as FontFlags {underscoreToCase} deriving (Show, Eq, Bounded) #} + +instance Flags EventFlags +instance Flags ActorFlags +instance Flags TextureFlags +instance Flags AllocationFlags +instance Flags FontFlags + + +type GID = Word32 +type Timestamp = Word +type DeviceID = Int + +--CHECKME: I'm not sure how to deal with this opaque type +-- {# pointer *ClutterUnits as Units newtype #} + +-- unUnits (Units ptr) = ptr + +-- *** Color + +{# pointer *ClutterColor as ColorPtr -> Color #} + +data Color = Color { red :: Word8, + green :: Word8, + blue :: Word8, + alpha :: Word8 + } deriving (Eq, Show) + +instance Storable Color where + sizeOf _ = {# sizeof ClutterColor #} + alignment _ = alignment (undefined :: Word8) + peek p = do + red <- {# get ClutterColor->red #} p + blue <- {# get ClutterColor->blue #} p + green <- {# get ClutterColor->green #} p + alpha <- {# get ClutterColor->alpha #} p + return $ Color (cIntConv red) (cIntConv green) (cIntConv blue) (cIntConv alpha) + + poke p (Color r g b a) = do + {# set ClutterColor->red #} p (cIntConv r) --FIXME: cIntConv is wrong? + {# set ClutterColor->green #} p (cIntConv g) + {# set ClutterColor->blue #} p (cIntConv b) + {# set ClutterColor->alpha #} p (cIntConv a) + +--This seems not right. But it seems to work. +mkColor :: Color -> IO ColorPtr +mkColor col = do cptr <- (malloc :: IO ColorPtr) + poke cptr col + return cptr + +withColor :: Color -> (ColorPtr -> IO a) -> IO a +withColor col = bracket (mkColor col) free + +-- *** Actor + +{# pointer *ClutterActor as Actor foreign newtype #} + +class GObjectClass o => ActorClass o +toActor::ActorClass o => o -> Actor +toActor = unsafeCastGObject . toGObject + +withActorClass::ActorClass o => o -> (Ptr Actor -> IO b) -> IO b +withActorClass o = (withActor . toActor) o + +newActor :: (ActorClass actor) => Ptr actor -> IO Actor +newActor a = makeNewActor (Actor, objectUnref) $ return (castPtr a) + +--TODO: this should also go somewhere else?? +--CHECKME: Does this actually work? +newActorList :: GSList -> IO [Actor] +newActorList gsl = (fromGSList gsl :: IO [Ptr Actor]) >>= mapM newActor + +instance ActorClass Actor +instance ScriptableClass Actor +instance GObjectClass Actor where + toGObject (Actor a) = constrGObject (castForeignPtr a) + unsafeCastGObject (GObject o) = Actor (castForeignPtr o) + +-- *** Rectangle + +{# pointer *ClutterRectangle as Rectangle foreign newtype #} + +class GObjectClass o => RectangleClass o +toRectangle::RectangleClass o => o -> Rectangle +toRectangle = unsafeCastGObject . toGObject + +newRectangle :: Ptr Actor -> IO Rectangle +newRectangle a = makeNewActor (Rectangle, objectUnref) $ return (castPtr a) + +instance RectangleClass Rectangle +instance ActorClass Rectangle +instance GObjectClass Rectangle where + toGObject (Rectangle r) = constrGObject (castForeignPtr r) + unsafeCastGObject (GObject o) = Rectangle (castForeignPtr o) + +-- *** Text + +{# pointer *ClutterText as Text foreign newtype #} + +class GObjectClass o => TextClass o +toText::TextClass o => o -> Text +toText = unsafeCastGObject . toGObject + +newText :: Ptr Actor -> IO Text +newText a = makeNewActor (Text, objectUnref) $ return (castPtr a) + +withTextClass::TextClass o => o -> (Ptr Text -> IO b) -> IO b +withTextClass o = (withText . toText) o + + +instance TextClass Text +instance ActorClass Text +instance ScriptableClass Text +instance GObjectClass Text where + toGObject (Text a) = constrGObject (castForeignPtr a) + unsafeCastGObject (GObject o) = Text (castForeignPtr o) + +-- *** Group + +{#pointer *ClutterGroup as Group foreign newtype #} + +class ActorClass o => GroupClass o +toGroup :: GroupClass o => o -> Group +toGroup = unsafeCastGObject . toGObject + +newGroup :: Ptr Actor -> IO Group +newGroup a = makeNewActor (Group, objectUnref) $ return (castPtr a) + +instance GroupClass Group +instance ScriptableClass Group +instance ContainerClass Group +instance ActorClass Group +instance GObjectClass Group where + toGObject (Group g) = constrGObject (castForeignPtr g) + unsafeCastGObject (GObject o) = Group (castForeignPtr o) + +-- *** Container + +{# pointer *ClutterContainer as Container foreign newtype #} + +class GObjectClass o => ContainerClass o +toContainer :: ContainerClass o => o -> Container +toContainer = unsafeCastGObject . toGObject + +withContainerClass::ContainerClass o => o -> (Ptr Container -> IO b) -> IO b +withContainerClass o = (withContainer . toContainer) o + +instance ContainerClass Container +instance GObjectClass Container where + toGObject (Container c) = constrGObject (castForeignPtr c) + unsafeCastGObject (GObject o) = Container (castForeignPtr o) + +-- *** Stage + +{# pointer *ClutterStage as Stage foreign newtype #} + +class GroupClass o => StageClass o +toStage :: StageClass o => o -> Stage +toStage = unsafeCastGObject . toGObject + +withStageClass::StageClass o => o -> (Ptr Stage -> IO b) -> IO b +withStageClass o = (withStage . toStage) o + + +--Actor class? +newStage :: (ActorClass actor) => Ptr actor -> IO Stage +newStage a = makeNewActor (Stage, objectUnref) $ return (castPtr a) + +instance StageClass Stage +instance ContainerClass Stage +instance GroupClass Stage +instance ActorClass Stage +instance ScriptableClass Stage +instance GObjectClass Stage where + toGObject (Stage s) = constrGObject (castForeignPtr s) + unsafeCastGObject (GObject o) = Stage (castForeignPtr o) + +-- *** Perspective + +data Perspective = Perspective { + perspectiveFovy :: !Float, + perspectiveAspect :: !Float, + perspectiveZNear :: !Float, + perspectiveZFar :: !Float + } deriving (Show, Eq) + +{# pointer *ClutterPerspective as PerspectivePtr -> Perspective #} + +instance Storable Perspective where + sizeOf _ = {# sizeof ClutterPerspective #} + alignment _ = alignment (undefined :: CFloat) + peek p = do + fovy <- {# get ClutterPerspective->fovy #} p + aspect <- {# get ClutterPerspective->aspect #} p + z_near <- {# get ClutterPerspective->z_near #} p + z_far <- {# get ClutterPerspective->z_far #} p + return $ Perspective (cFloatConv fovy) (cFloatConv aspect) (cFloatConv z_near) (cFloatConv z_far) + + poke p (Perspective fovy aspect z_near z_far) = do + {# set ClutterPerspective->fovy #} p (cFloatConv fovy) + {# set ClutterPerspective->aspect #} p (cFloatConv aspect) + {# set ClutterPerspective->z_near #} p (cFloatConv z_near) + {# set ClutterPerspective->z_far #} p (cFloatConv z_far) + +--This seems not right. But it seems to work. +mkPerspective :: Perspective -> IO PerspectivePtr +mkPerspective pst = do pptr <- (malloc :: IO PerspectivePtr) + poke pptr pst + return pptr + +withPerspective :: Perspective -> (PerspectivePtr -> IO a) -> IO a +withPerspective pst = bracket (mkPerspective pst) free + +-- *** ClutterEvent + +{# pointer *ClutterEvent as Event foreign newtype #} + +-- *** Animation + +{# pointer *ClutterAnimation as AnimationRaw foreign newtype #} + +data Animation a = Animation a AnimationRaw + +withAnimation (Animation _ raw) = withAnimationRaw raw + +--CHECKME: does animationraw class make sense to have? +class GObjectClass o => AnimationRawClass o +toAnimation :: AnimationRawClass o => o -> AnimationRaw +toAnimation = unsafeCastGObject . toGObject + +mkAnimation :: a -> AnimationRaw -> Animation a +mkAnimation _ raw = Animation (undefined :: a) raw + +--CHECKME: Do I actually need this and does it break things? +getAnimationRaw :: Animation a -> AnimationRaw +getAnimationRaw (Animation _ raw) = raw + +newAnimationRaw:: Ptr AnimationRaw -> IO AnimationRaw +newAnimationRaw a = makeNewGObject (AnimationRaw, objectUnref) $ return (castPtr a) + +instance AnimationRawClass AnimationRaw +instance GObjectClass AnimationRaw where + toGObject (AnimationRaw a) = constrGObject (castForeignPtr a) + unsafeCastGObject (GObject o) = AnimationRaw (castForeignPtr o) + +--CHECKME: +instance (GObjectClass a) => GObjectClass (Animation a) where + toGObject (Animation _ (AnimationRaw p)) = constrGObject (castForeignPtr p) + unsafeCastGObject (GObject o) = Animation (undefined :: a) (AnimationRaw (castForeignPtr o)) + +-- *** Timeline + +--FIXME: DO animations and timelines etc. have floating references or not? +--They don't derive from actor, so I'm going to go with no + +{# pointer *ClutterTimeline as Timeline foreign newtype #} + +class GObjectClass o => TimelineClass o +toTimeline :: TimelineClass o => o -> Timeline +toTimeline = unsafeCastGObject . toGObject + +newTimeline:: Ptr Timeline -> IO Timeline +newTimeline a = makeNewGObject (Timeline, objectUnref) $ return a + +newTimelineList :: GSList -> IO [Timeline] +newTimelineList gsl = (fromGSList gsl :: IO [Ptr Timeline]) >>= mapM newTimeline + +instance TimelineClass Timeline +instance GObjectClass Timeline where + toGObject (Timeline t) = constrGObject (castForeignPtr t) + unsafeCastGObject (GObject o) = Timeline (castForeignPtr o) + +-- *** Score + +{# pointer *ClutterScore as Score foreign newtype #} + +class GObjectClass o => ScoreClass o +toScore::ScoreClass o => o -> Score +toScore = unsafeCastGObject . toGObject + +--CHECKME: doesn't derive from Actor, so using makeNewGObject +newScore :: Ptr Score -> IO Score +newScore a = makeNewGObject (Score, objectUnref) $ return (castPtr a) + +instance ScoreClass Score +instance GObjectClass Score where + toGObject (Score r) = constrGObject (castForeignPtr r) + unsafeCastGObject (GObject o) = Score (castForeignPtr o) + +-- *** Alpha + +{# pointer *ClutterAlpha as Alpha foreign newtype #} + +class GObjectClass o => AlphaClass o +toAlpha :: AlphaClass o => o -> Alpha +toAlpha = unsafeCastGObject . toGObject + +newAlpha:: Ptr Alpha -> IO Alpha +newAlpha a = makeNewGObject (Alpha, objectUnref) $ return a + +instance AlphaClass Alpha +instance GObjectClass Alpha where + toGObject (Alpha a) = constrGObject (castForeignPtr a) + unsafeCastGObject (GObject o) = Alpha (castForeignPtr o) + +-- *** AlphaFunc + +type AlphaFunc = Alpha -> IO Double +type CAlphaFunc = FunPtr (Ptr Alpha -> Ptr () -> IO CDouble) + +newAlphaFunc :: AlphaFunc -> IO CAlphaFunc +newAlphaFunc userfunc = mkAlphaFunc (newAlphaFunc' userfunc) + where + newAlphaFunc' :: (Alpha -> IO Double) -> Ptr Alpha -> IO Double + newAlphaFunc' userfunc aptr = newAlpha aptr >>= userfunc + +foreign import ccall "wrapper" + mkAlphaFunc :: (Ptr Alpha -> IO Double) -> IO CAlphaFunc + +-- *** Interval + +{# pointer *ClutterInterval as IntervalRaw foreign newtype #} + +-- Track the type of the interval with the 1st field +data Interval a = Interval a IntervalRaw + +mkInterval :: a -> IntervalRaw -> Interval a +mkInterval _ raw = Interval (undefined :: a) raw + +withInterval (Interval _ raw) = withIntervalRaw raw + +newIntervalRaw a = makeNewGObject (IntervalRaw, objectUnref) $ return (castPtr a) + +instance GObjectClass IntervalRaw where + toGObject (IntervalRaw i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = IntervalRaw (castForeignPtr o) + +-- *** Fog + +{# pointer *ClutterFog as FogPtr -> Fog #} + +data Fog = Fog { z_near :: Float, + z_far :: Float + } deriving (Eq, Show) + +instance Storable Fog where + sizeOf _ = {# sizeof ClutterFog #} + alignment _ = alignment (undefined :: Float) + peek p = do + znear <- {# get ClutterFog->z_near #} p + zfar <- {# get ClutterFog->z_far #} p + return $ Fog (cFloatConv znear) (cFloatConv zfar) + poke p (Fog zn zf) = do + {# set ClutterFog->z_near #} p (cFloatConv zn) + {# set ClutterFog->z_far #} p (cFloatConv zf) + +--This seems not right. But it seems to work. +mkFog :: Fog -> IO FogPtr +mkFog col = do cptr <- (malloc :: IO FogPtr) + poke cptr col + return cptr + +withFog :: Fog -> (FogPtr -> IO a) -> IO a +withFog col = bracket (mkFog col) free + +-- *** CairoTexture + +{# pointer *ClutterCairoTexture as CairoTexture foreign newtype #} + +class GObjectClass o => CairoTextureClass o +toCairoTexture :: CairoTextureClass o => o -> CairoTexture +toCairoTexture = unsafeCastGObject . toGObject + +newCairoTexture a = makeNewGObject (CairoTexture, objectUnref) $ return (castPtr a) + +instance CairoTextureClass CairoTexture +instance GObjectClass CairoTexture where + toGObject (CairoTexture i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = CairoTexture (castForeignPtr o) + +-- *** Media + +{# pointer *ClutterMedia as Media foreign newtype #} + +withMediaClass::MediaClass o => o -> (Ptr Media -> IO b) -> IO b +withMediaClass o = (withMedia . toMedia) o + +class GObjectClass o => MediaClass o +toMedia :: MediaClass o => o -> Media +toMedia = unsafeCastGObject . toGObject + +newMedia a = makeNewGObject (Media, objectUnref) $ return (castPtr a) + +instance MediaClass Media +instance GObjectClass Media where + toGObject (Media i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = Media (castForeignPtr o) + +-- *** ChildMeta + +{# pointer *ClutterChildMeta as ChildMeta foreign newtype #} + +class GObjectClass o => ChildMetaClass o +toChildMeta :: ChildMetaClass o => o -> Media +toChildMeta = unsafeCastGObject . toGObject + +newChildMeta a = makeNewGObject (ChildMeta, objectUnref) $ return (castPtr a) + +instance ChildMetaClass ChildMeta +instance GObjectClass ChildMeta where + toGObject (ChildMeta i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = ChildMeta (castForeignPtr o) + +-- *** Clone + +{# pointer *ClutterClone as CloneRaw foreign newtype #} + +data Clone a = Clone a CloneRaw + +newCloneRaw a = makeNewActor (CloneRaw, objectUnref) $ return (castPtr a) + +mkClone :: (ActorClass a) => a -> CloneRaw -> Clone a +mkClone _ raw = Clone (undefined :: a) raw + +withClone (Clone _ raw) = withCloneRaw raw + + +class GObjectClass o => CloneRawClass o +toCloneRaw :: CloneRawClass o => o -> CloneRaw +toCloneRaw = unsafeCastGObject . toGObject + + +instance (ActorClass a) => ScriptableClass (Clone a) +instance (ActorClass a) => ActorClass (Clone a) +instance (ActorClass a) => GObjectClass (Clone a) where + toGObject (Clone _ (CloneRaw i)) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = Clone (undefined::a) (CloneRaw (castForeignPtr o)) + +instance GObjectClass CloneRaw where + toGObject (CloneRaw i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = CloneRaw (castForeignPtr o) + + +-- *** Behaviour + +{# pointer *ClutterBehaviour as Behaviour foreign newtype #} + +class GObjectClass o => BehaviourClass o +toBehaviour :: BehaviourClass o => o -> Behaviour +toBehaviour = unsafeCastGObject . toGObject + +withBehaviourClass::BehaviourClass o => o -> (Ptr Behaviour -> IO b) -> IO b +withBehaviourClass o = (withBehaviour . toBehaviour) o + +newBehaviour a = makeNewGObject (Behaviour, objectUnref) $ return (castPtr a) + +instance BehaviourClass Behaviour +instance ScriptableClass Behaviour +instance GObjectClass Behaviour where + toGObject (Behaviour i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = Behaviour (castForeignPtr o) + +-- *** BehaviourForeachFunc +type BehaviourForeachFunc = Behaviour -> Actor -> IO () +type CBehaviourForeachFunc = FunPtr (Ptr Behaviour -> Ptr Actor -> Ptr () -> IO ()) +newBehaviourForeachFunc :: BehaviourForeachFunc -> IO CBehaviourForeachFunc +newBehaviourForeachFunc userfunc = mkBehaviourForeachFunc (newBehaviourForeachFunc' userfunc) + where + newBehaviourForeachFunc' :: BehaviourForeachFunc -> Ptr Behaviour -> Ptr Actor -> IO () + newBehaviourForeachFunc' userfunc bptr aptr = newBehaviour bptr >>= \behave -> + newActor aptr >>= \actor -> + userfunc behave actor + +foreign import ccall "wrapper" + mkBehaviourForeachFunc :: (Ptr Behaviour -> Ptr Actor -> IO ()) -> IO CBehaviourForeachFunc + +-- *** BehaviourScale + +{# pointer *ClutterBehaviourScale as BehaviourScale foreign newtype #} + +class GObjectClass o => BehaviourScaleClass o +toBehaviourScale :: BehaviourScaleClass o => o -> Behaviour +toBehaviourScale = unsafeCastGObject . toGObject + +newBehaviourScale a = makeNewGObject (BehaviourScale, objectUnref) $ return (castPtr a) + +instance BehaviourScaleClass BehaviourScale +instance BehaviourClass BehaviourScale +instance ScriptableClass BehaviourScale +instance GObjectClass BehaviourScale where + toGObject (BehaviourScale i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = BehaviourScale (castForeignPtr o) + +-- *** BehaviourDepth + +{# pointer *ClutterBehaviourDepth as BehaviourDepth foreign newtype #} + +class GObjectClass o => BehaviourDepthClass o +toBehaviourDepth :: BehaviourDepthClass o => o -> BehaviourDepth +toBehaviourDepth = unsafeCastGObject . toGObject + +newBehaviourDepth a = makeNewGObject (BehaviourDepth, objectUnref) $ return (castPtr a) + +instance BehaviourDepthClass BehaviourDepth +instance BehaviourClass BehaviourDepth +instance ScriptableClass BehaviourDepth +instance GObjectClass BehaviourDepth where + toGObject (BehaviourDepth i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = BehaviourDepth (castForeignPtr o) + +-- *** BehaviourEllipse + +{# pointer *ClutterBehaviourEllipse as BehaviourEllipse foreign newtype #} + +class GObjectClass o => BehaviourEllipseClass o +toBehaviourEllipse :: BehaviourEllipseClass o => o -> BehaviourEllipse +toBehaviourEllipse = unsafeCastGObject . toGObject + +newBehaviourEllipse a = makeNewGObject (BehaviourEllipse, objectUnref) $ return (castPtr a) + +instance BehaviourEllipseClass BehaviourEllipse +instance BehaviourClass BehaviourEllipse +instance ScriptableClass BehaviourEllipse +instance GObjectClass BehaviourEllipse where + toGObject (BehaviourEllipse i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = BehaviourEllipse (castForeignPtr o) + +-- *** BehaviourOpacity + +{# pointer *ClutterBehaviourOpacity as BehaviourOpacity foreign newtype #} + +class GObjectClass o => BehaviourOpacityClass o +toBehaviourOpacity :: BehaviourOpacityClass o => o -> BehaviourOpacity +toBehaviourOpacity = unsafeCastGObject . toGObject + +newBehaviourOpacity a = makeNewGObject (BehaviourOpacity, objectUnref) $ return (castPtr a) + +instance BehaviourOpacityClass BehaviourOpacity +instance BehaviourClass BehaviourOpacity +instance ScriptableClass BehaviourOpacity +instance GObjectClass BehaviourOpacity where + toGObject (BehaviourOpacity i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = BehaviourOpacity (castForeignPtr o) + +-- *** BehaviourRotate + +{# pointer *ClutterBehaviourRotate as BehaviourRotate foreign newtype #} + +class GObjectClass o => BehaviourRotateClass o +toBehaviourRotate :: BehaviourRotateClass o => o -> BehaviourRotate +toBehaviourRotate = unsafeCastGObject . toGObject + +newBehaviourRotate a = makeNewGObject (BehaviourRotate, objectUnref) $ return (castPtr a) + +instance BehaviourRotateClass BehaviourRotate +instance BehaviourClass BehaviourRotate +instance ScriptableClass BehaviourRotate +instance GObjectClass BehaviourRotate where + toGObject (BehaviourRotate i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = BehaviourRotate (castForeignPtr o) + + +-- *** BehaviourPath + +{# pointer *ClutterBehaviourPath as BehaviourPath foreign newtype #} + +class GObjectClass o => BehaviourPathClass o +toBehaviourPath :: BehaviourPathClass o => o -> BehaviourPath +toBehaviourPath = unsafeCastGObject . toGObject + +newBehaviourPath a = makeNewGObject (BehaviourPath, objectUnref) $ return (castPtr a) + +instance BehaviourPathClass BehaviourPath +instance BehaviourClass BehaviourPath +instance ScriptableClass BehaviourPath +instance GObjectClass BehaviourPath where + toGObject (BehaviourPath i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = BehaviourPath (castForeignPtr o) + +-- *** Path + +{# pointer *ClutterPath as Path foreign newtype #} + +class GObjectClass o => PathClass o +toPath :: PathClass o => o -> Path +toPath = unsafeCastGObject . toGObject + +--CHECKME: Path has a floating reference, but I don't remember +-- which one you use and I'm really lazy so I'm not going to check now + +newPath a = makeNewActor (Path, objectUnref) $ return (castPtr a) + +instance PathClass Path +instance GObjectClass Path where + toGObject (Path i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = Path (castForeignPtr o) + +-- *** Texture + +{# pointer *ClutterTexture as Texture foreign newtype #} + +class GObjectClass o => TextureClass o +toTexture :: TextureClass o => o -> Texture +toTexture = unsafeCastGObject . toGObject + +newTexture :: Ptr Actor -> IO Texture +newTexture a = makeNewActor (Texture, objectUnref) $ return (castPtr a) + +withTextureClass :: TextureClass o => o -> (Ptr Texture -> IO b) -> IO b +withTextureClass o = (withTexture . toTexture) o + + +instance TextureClass Texture +instance ActorClass Texture +instance ScriptableClass Texture +instance GObjectClass Texture where + toGObject (Texture i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = Texture (castForeignPtr o) + +-- *** Shader + +{# pointer *ClutterShader as Shader foreign newtype #} + +class GObjectClass o => ShaderClass o +toShader :: ShaderClass o => o -> Shader +toShader = unsafeCastGObject . toGObject + +newShader a = makeNewGObject (Shader, objectUnref) $ return (castPtr a) + +instance ShaderClass Shader +instance GObjectClass Shader where + toGObject (Shader i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = Shader (castForeignPtr o) + +-- *** Model + +{# pointer *ClutterModel as Model foreign newtype #} + +class GObjectClass o => ModelClass o +toModel :: ModelClass o => o -> Model +toModel = unsafeCastGObject . toGObject + +withModelClass::ModelClass o => o -> (Ptr Model -> IO b) -> IO b +withModelClass o = (withModel . toModel) o + +newModel a = makeNewGObject (Model, objectUnref) $ return (castPtr a) + +instance ModelClass Model +instance GObjectClass Model where + toGObject (Model i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = Model (castForeignPtr o) + +-- *** ListModel + +{# pointer *ClutterListModel as ListModel foreign newtype #} + +class GObjectClass o => ListModelClass o +toListModel :: ListModelClass o => o -> ListModel +toListModel = unsafeCastGObject . toGObject + +newListModel a = makeNewGObject (ListModel, objectUnref) $ return (castPtr a) + +instance ModelClass ListModel +instance ListModelClass ListModel +instance GObjectClass ListModel where + toGObject (ListModel i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = ListModel (castForeignPtr o) + +-- *** ModelIter + +{# pointer *ClutterModelIter as ModelIter foreign newtype #} + +class GObjectClass o => ModelIterClass o +toModelIter :: ModelIterClass o => o -> ModelIter +toModelIter = unsafeCastGObject . toGObject + +newModelIter a = makeNewGObject (ModelIter, objectUnref) $ return (castPtr a) + +instance ModelIterClass ModelIter +instance GObjectClass ModelIter where + toGObject (ModelIter i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = ModelIter (castForeignPtr o) + +-- *** Script + +{# pointer *ClutterScript as Script foreign newtype #} + +class GObjectClass o => ScriptClass o +toScript :: ScriptClass o => o -> Script +toScript = unsafeCastGObject . toGObject + +withScriptClass::ScriptClass o => o -> (Ptr Script -> IO b) -> IO b +withScriptClass o = (withScript . toScript) o + +newScript a = makeNewActor (Script, objectUnref) $ return (castPtr a) + +instance ScriptClass Script +instance ActorClass Script +instance GObjectClass Script where + toGObject (Script i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = Script (castForeignPtr o) + +-- *** Knot + +type Knot = (Int, Int) + +--TypeSynonymInstance +instance Storable Knot where + sizeOf _ = {# sizeof ClutterKnot #} + alignment _ = alignment (undefined :: Int) + peek p = do + x <- {# get ClutterKnot->x #} p + y <- {# get ClutterKnot->y #} p + return (cIntConv x, cIntConv y) + + poke p (x,y) = do + {# set ClutterKnot->x #} p (cIntConv x) + {# set ClutterKnot->y #} p (cIntConv y) + +-- *** PathNode + +{# pointer *ClutterPathNode as PathNodePtr -> PathNode #} + +data PathNode = PathNode { pathNodeType :: !PathNodeType, + pathNodePoints :: !(Knot, Knot, Knot) + } deriving (Eq, Show) + +instance Storable PathNode where + sizeOf _ = {# sizeof ClutterPathNode #} + alignment _ = alignment (undefined :: Word8) + peek p = do + tp <- {# get ClutterPathNode->type #} p + [p3, p2, p1] <- peekArray 3 (plusPtr p {# sizeof ClutterPathNodeType #}) + --peekArray gets out backwards + return $ PathNode (cToEnum tp) (p1, p2, p3) + + poke p (PathNode tp (p1, p2, p3)) = do + {# set ClutterPathNode->type #} p (cFromEnum tp) + pokeArray (plusPtr p {# sizeof ClutterPathNodeType #}) [p1, p2, p3] + +--This seems not right. But it seems to work. +mkPathNode :: PathNode -> IO PathNodePtr +mkPathNode col = do cptr <- (malloc :: IO PathNodePtr) + poke cptr col + return cptr + +withPathNode :: PathNode -> (PathNodePtr -> IO a) -> IO a +withPathNode col = bracket (mkPathNode col) free + +newPathNodes :: GSList -> IO [PathNode] +newPathNodes gsl = (fromGSList gsl :: IO [PathNodePtr]) >>= mapM peek + +-- *** PathCallback +type PathCallback = PathNode -> IO () +type CPathCallback = FunPtr (PathNodePtr -> Ptr () -> IO ()) +newPathCallback :: PathCallback -> IO CPathCallback +newPathCallback userfunc = mkPathCallback (newPathCallback' userfunc) + where + newPathCallback' :: PathCallback -> PathNodePtr -> IO () + newPathCallback' userfunc pnPtr = peek pnPtr >>= userfunc + +foreign import ccall "wrapper" + mkPathCallback :: (PathNodePtr -> IO ()) -> IO CPathCallback + +-- *** ParamSpecUnits + +{# pointer *ClutterParamSpecUnits as ParamSpecUnitsPtr -> ParamSpecUnits #} + +--TODO: Prefix the names of the fields of this +data ParamSpecUnits = ParamSpecUnits { defaultType :: !UnitType, + defaultValue :: !Float, + minimum :: !Float, + maximum :: !Float + } deriving (Eq, Show) + +--FIXME: Type for alignment +instance Storable ParamSpecUnits where + sizeOf _ = {# sizeof ClutterParamSpecUnits #} + alignment _ = alignment (undefined :: Word64) + peek p = do + dt <- {# get ClutterParamSpecUnits->default_type #} p + dval <- {# get ClutterParamSpecUnits->default_value #} p + min <- {# get ClutterParamSpecUnits->minimum #} p + max <- {# get ClutterParamSpecUnits->maximum #} p + return $ ParamSpecUnits (cToEnum dt) (cFloatConv dval) (cFloatConv min) (cFloatConv max) + poke p (ParamSpecUnits dt dval min max) = do + {# set ClutterParamSpecUnits->default_type #} p (cFromEnum dt) + {# set ClutterParamSpecUnits->default_value #} p (cFloatConv dval) + {# set ClutterParamSpecUnits->minimum #} p (cFloatConv min) + {# set ClutterParamSpecUnits->maximum #} p (cFloatConv max) + +--This seems not right. But it seems to work. +mkParamSpecUnits :: ParamSpecUnits -> IO ParamSpecUnitsPtr +mkParamSpecUnits col = do cptr <- (malloc :: IO ParamSpecUnitsPtr) + poke cptr col + return cptr + +withParamSpecUnits :: ParamSpecUnits -> (ParamSpecUnitsPtr -> IO a) -> IO a +withParamSpecUnits col = bracket (mkParamSpecUnits col) free + +newParamSpecUnits :: GSList -> IO [ParamSpecUnits] +newParamSpecUnits gsl = (fromGSList gsl :: IO [ParamSpecUnitsPtr]) >>= mapM peek + +-- *** Scriptable + +{# pointer *ClutterScriptable as Scriptable foreign newtype #} + +class GObjectClass o => ScriptableClass o +toScriptable :: ScriptableClass o => o -> Scriptable +toScriptable = unsafeCastGObject . toGObject + +withScriptableClass::ScriptableClass o => o -> (Ptr Scriptable -> IO b) -> IO b +withScriptableClass o = (withScriptable . toScriptable) o + +instance ScriptableClass Scriptable +instance GObjectClass Scriptable where + toGObject (Scriptable i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = Scriptable (castForeignPtr o) + +-- *** BindingPool + +{# pointer *ClutterBindingPool as BindingPool foreign newtype #} + +class GObjectClass o => BindingPoolClass o +toBindingPool :: BindingPoolClass o => o -> BindingPool +toBindingPool = unsafeCastGObject . toGObject + +newBindingPool a = makeNewGObject (BindingPool, objectUnref) $ return (castPtr a) + +instance BindingPoolClass BindingPool +instance GObjectClass BindingPool where + toGObject (BindingPool i) = constrGObject (castForeignPtr i) + unsafeCastGObject (GObject o) = BindingPool (castForeignPtr o) + +-- *** GCallback + +type GCallback = IO () +type CGCallback = FunPtr (IO ()) + +foreign import ccall "wrapper" + newGCallback :: IO () -> IO CGCallback + +-- *** Geometry + +data Geometry = Geometry { + geometryX :: !Int, + geometryY :: !Int, + geometryWidth :: !Word, + geometryHeight :: !Word + } deriving (Show, Eq) + +{# pointer *ClutterGeometry as GeometryPtr -> Geometry #} + +instance Storable Geometry where + sizeOf _ = {# sizeof ClutterGeometry #} + alignment _ = alignment (undefined :: Int) + peek p = do + x <- {# get ClutterGeometry->x #} p + y <- {# get ClutterGeometry->y #} p + width <- {# get ClutterGeometry->width #} p + height <- {# get ClutterGeometry->height #} p + return $ Geometry (cIntConv x) (cIntConv y) (cIntConv width) (cIntConv height) + + poke p (Geometry x y width height) = do + {# set ClutterGeometry->x #} p (cIntConv x) + {# set ClutterGeometry->y #} p (cIntConv y) + {# set ClutterGeometry->width #} p (cIntConv width) + {# set ClutterGeometry->height #} p (cIntConv height) + + +mkGeometry :: Geometry -> IO GeometryPtr +mkGeometry pst = do pptr <- (malloc :: IO GeometryPtr) + poke pptr pst + return pptr + +withGeometry :: Geometry -> (GeometryPtr -> IO a) -> IO a +withGeometry pst = bracket (mkGeometry pst) free + +-- *** Vertex + +data Vertex = Vertex { + vertexX :: !Float, + vertexY :: !Float, + vertexZ :: !Float + } deriving (Show, Eq) + +{# pointer *ClutterVertex as VertexPtr -> Vertex #} + +instance Storable Vertex where + sizeOf _ = {# sizeof ClutterVertex #} + alignment _ = alignment (undefined :: Float) + peek p = do + x <- {# get ClutterVertex->x #} p + y <- {# get ClutterVertex->y #} p + z <- {# get ClutterVertex->z #} p + return $ Vertex (cFloatConv x) (cFloatConv y) (cFloatConv z) + + poke p (Vertex x y z) = do + {# set ClutterVertex->x #} p (cFloatConv x) + {# set ClutterVertex->y #} p (cFloatConv y) + {# set ClutterVertex->z #} p (cFloatConv z) + + +mkVertex :: Vertex -> IO VertexPtr +mkVertex pst = do pptr <- (malloc :: IO VertexPtr) + poke pptr pst + return pptr + +withVertex :: Vertex -> (VertexPtr -> IO a) -> IO a +withVertex pst = bracket (mkVertex pst) free + + +-- *** ActorBox + +data ActorBox = ActorBox { + actorBoxX1 :: !Float, + actorBoxY1 :: !Float, + actorBoxX2 :: !Float, + actorBoxY2 :: !Float + } deriving (Show, Eq) + +{# pointer *ClutterActorBox as ActorBoxPtr -> ActorBox #} + +instance Storable ActorBox where + sizeOf _ = {# sizeof ClutterActorBox #} + alignment _ = alignment (undefined :: Float) + peek p = do + x1 <- {# get ClutterActorBox->x1 #} p + y1 <- {# get ClutterActorBox->y1 #} p + x2 <- {# get ClutterActorBox->x2 #} p + y2 <- {# get ClutterActorBox->y2 #} p + return $ ActorBox (cFloatConv x1) (cFloatConv y1) (cFloatConv x2) (cFloatConv y2) + + poke p (ActorBox x1 y1 x2 y2) = do + {# set ClutterActorBox->x1 #} p (cFloatConv x1) + {# set ClutterActorBox->y1 #} p (cFloatConv y1) + {# set ClutterActorBox->x2 #} p (cFloatConv x2) + {# set ClutterActorBox->y2 #} p (cFloatConv y2) + + +--This seems not right. But it seems to work. +mkActorBox :: ActorBox -> IO ActorBoxPtr +mkActorBox pst = do pptr <- (malloc :: IO ActorBoxPtr) + poke pptr pst + return pptr + +withActorBox :: ActorBox -> (ActorBoxPtr -> IO a) -> IO a +withActorBox pst = bracket (mkActorBox pst) free + +-- *** Animatable + +{# pointer *ClutterAnimatable as Animatable foreign newtype #} + +class GObjectClass o => AnimatableClass o +toAnimatable::AnimatableClass o => o -> Animatable +toAnimatable = unsafeCastGObject . toGObject + +withAnimatableClass::AnimatableClass o => o -> (Ptr Animatable -> IO b) -> IO b +withAnimatableClass o = (withAnimatable . toAnimatable) o + +--CHECKME: makeNewActor or makeNewGObject? Is is always some kind of +--actor? does it always have a floating reference or what? +newAnimatable :: (AnimatableClass actor) => Ptr actor -> IO Animatable +newAnimatable a = makeNewGObject (Animatable, objectUnref) $ return (castPtr a) + +instance AnimatableClass Animatable +instance GObjectClass Animatable where + toGObject (Animatable a) = constrGObject (castForeignPtr a) + unsafeCastGObject (GObject o) = Animatable (castForeignPtr o) + +-- *** Callback + +type Callback = Actor -> IO () +type CCallback = FunPtr (Ptr Actor -> Ptr () -> IO ()) + +newCallback :: Callback -> IO CCallback +newCallback userfunc = mkCallback (newCallback' userfunc) + where + newCallback' :: (Actor -> IO ()) -> Ptr Actor -> IO () + newCallback' userfunc aptr = newActor aptr >>= userfunc + +foreign import ccall "wrapper" + mkCallback :: (Ptr Actor -> IO ()) -> IO CCallback + + +-- *** ModelForeachFunc + +type ModelForeachFunc = Model -> ModelIter -> IO Bool +type CModelForeachFunc = FunPtr (Ptr Model -> Ptr ModelIter -> Ptr () -> IO CInt) + +newModelForeachFunc :: ModelForeachFunc -> IO CModelForeachFunc +newModelForeachFunc userfunc = mkModelForeachFunc (newModelForeachFunc' userfunc) + where + newModelForeachFunc' :: ModelForeachFunc -> Ptr Model -> Ptr ModelIter -> IO Bool + newModelForeachFunc' userfunc modPtr miPtr = join $ liftM2 userfunc (newModel modPtr) (newModelIter miPtr) + +foreign import ccall "wrapper" + mkModelForeachFunc :: (Ptr Model -> Ptr ModelIter -> IO Bool) -> IO CModelForeachFunc + +-- *** TimeoutPool + +{# pointer *ClutterTimeoutPool as TimeoutPool foreign newtype #} + + +-- *** RGBData + +--FIXME/CHECKME: Not really sure best way to deal with this +--This is basically PixbufData without the pixbuf. +-- | An array that stored the raw pixel data in RGB Format. +-- +data Ix i => RGBData i e = RGBData {-# UNPACK #-} !(ForeignPtr e) + !Bool + !(i,i) + {-# UNPACK #-} !Int + +rgbDataHasAlpha :: (Storable e, Ix i) => RGBData i e -> Bool +rgbDataHasAlpha (RGBData _ hasA _ _) = hasA + +--FIXME: Bad bad bad +rgbDataData (RGBData ptr _ _ _) = ptr + +mkRGBData :: Storable e => ForeignPtr e -> Bool -> Int -> RGBData Int e +mkRGBData (ptr :: ForeignPtr e) hasA size = + RGBData ptr hasA (0, count) count + where count = fromIntegral (size `div` sizeOf (undefined :: e)) + +--CHECKME: Touching things? +-- | 'RGBData' is a mutable array. +instance Storable e => MArray RGBData e IO where + newArray (l,u) e = error "Clutter.Texture.RGBData.newArray: not implemented" + newArray_ (l,u) = error "Clutter.Texture.RGBData.newArray_: not implemented" + {-# INLINE unsafeRead #-} + unsafeRead (RGBData pixPtr _ _ _) idx = withForeignPtr pixPtr (flip peekElemOff idx) + {-# INLINE unsafeWrite #-} + unsafeWrite (RGBData pixPtr _ _ _) idx elem = withForeignPtr pixPtr (\p -> pokeElemOff p idx elem) + {-# INLINE getBounds #-} + getBounds (RGBData _ _ bd _) = return bd + {-# INLINE getNumElements #-} + getNumElements (RGBData _ _ _ count) = return count + + +-- Since some things have the same signal names, classes for them. Not +-- sure if I want to fix things this way Alternatively, rename things +-- to include the name such as timelineActivate and scoreActivate or +-- whatever +-- +-- CHECKME: There are multiple +-- actors which have the "activate" signal. They all can't be exported +-- from the one Clutter module. I don't really want to require +-- qualified importing of the different modules and such +-- (e.g. Timeline and Score). +-- +-- Also everything deals with the *Class, e.g. StageClass, however you +-- can't instance (StageClass stage) => Activatable stage without +-- undecidable instances which is bad, so I'm just doing instance +-- Activatable Stage. I think this would only be an issue if there was +-- a subclass of Stage (which doesn't exist as far as I know.) If +-- there were one to exist, there would have to be this instance for +-- it (which actually isn't much of a problem, just something to +-- remember if such a class existed). I don't think this is an issue, +-- but I don't know what I'm doing. + + +--FIXME: This is ugly and confusing, and haddock apparently can't +--document instances. Probably don't do this madness with Activatable +--Documentation for Text's activate + +-- | The ::'activate' signal is emitted each time a Text actor is +-- 'activated' by the user, normally by pressing the 'Enter' +-- key. The signal is emitted only if "activatable" is set to +-- @True@. +-- +-- | The ::'activate' signal is emitted when the stage receives key +-- focus from the underlying window system. +-- +-- * Since 0.6 +-- +class Activatable a where + onActivate :: a -> IO () -> IO (ConnectId a) + afterActivate :: a -> IO () -> IO (ConnectId a) + activate :: Signal a (IO ()) + +-- | Class of things that have signals related to starting, pausing +-- etc. +-- +class (GObjectClass a) => Playable a where + started :: Signal a (IO ()) + onStarted :: a -> IO () -> IO (ConnectId a) + afterStarted :: a -> IO () -> IO (ConnectId a) + completed :: Signal a (IO ()) + onCompleted :: a -> IO () -> IO (ConnectId a) + afterCompleted :: a -> IO () -> IO (ConnectId a) + paused :: Signal a (IO ()) + onPaused :: a -> IO () -> IO (ConnectId a) + afterPaused :: a -> IO () -> IO (ConnectId a) + diff --git a/Graphics/UI/Clutter/Units.chs b/Graphics/UI/Clutter/Units.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Units.chs @@ -0,0 +1,52 @@ +-- -*-haskell-*- +-- Clutter Units +-- +-- Author : Matthew Arsenault +-- +-- Created: 9 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + + +-- | Unit conversion — A logical distance unit +module Graphics.UI.Clutter.Units ( + unitsFromMm, + --unitsFromPt, + --unitsFromEm, + --unitsFromEmForFont, + --unitsFromPixels, + --unitsToPixels, + --unitsCopy, --unnecessary + --unitsFree, + --unitsGetUnitType, --do these in record + --unitsGetUnitValue, + --unitsFromString, + --unitsToString --instance for show? + --paramSpecUnits, --TODO: what is this? + --valueSetUnits, + --valueGetUnits + ) where + +{# import Graphics.UI.Clutter.Types #} + +import C2HS +import Control.Monad (liftM) + +unitsFromMm = undefined + diff --git a/Graphics/UI/Clutter/Utilities.chs b/Graphics/UI/Clutter/Utilities.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Utilities.chs @@ -0,0 +1,99 @@ +-- -*-haskell-*- +-- Utilities +-- +-- Author : Matthew Arsenault +-- +-- Created: 1 Nov 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include +#include + +{# context lib="clutter" prefix="clutter" #} +{# context lib="glib" prefix="g" #} + +--CHECKME: Do I want to have the functions that claim to be not for applications? + +module Graphics.UI.Clutter.Utilities ( +-- * Types +--TimeoutPool, + SourceFunc, + HandlerID, + + utilNextP2, +--timeoutPoolNew, +--timeoutPoolAdd, + frameSourceAdd, + frameSourceAddFull + ) where + +{# import Graphics.UI.Clutter.Types #} + +import C2HS +import Control.Monad (liftM) +import System.Glib.MainLoop +import System.Glib.GObject + + +{# fun pure unsafe util_next_p2 as ^ { `Int' } -> `Int' #} + +{- +{# fun unsafe timeout_pool_new as ^ { `Priority' } -> `TimeoutPool' newTimeoutPool #} + +timeoutPoolAdd :: TimeoutPool -> Word -> SourceFunc -> IO HandlerID +timeoutPoolAdd pool fps cb = let func = {# call unsafe timeout_pool_add #} --CHECKME: unsafe? + in withTimeoutPool pool $ \poolPtr -> do + (sf, gdestrnotify) <- makeCallback cb + func poolPtr (cIntConv fps) sf nullPtr gdestrnotify + +{# fun unsafe timeout_pool_remove as ^ { withTimeoutPool `TimeoutPool', cIntConv `Word' } -> `()' #} +-} + +--CHECKME: Um, says a wrapper around frame_source_add_full but doesn't take gdestroynotify? +--leak? +--ALSOCHECKME: unsafe? + + +--this stuff is in gtk2hs but not exported +type SourceFunc = IO Int +type HandlerID = Word + +{# pointer SourceFunc as CSourceFunc #} + +foreign import ccall "wrapper" mkSourceFunc :: SourceFunc -> IO CSourceFunc + +makeCallback :: SourceFunc -> IO (CSourceFunc, DestroyNotify) +makeCallback fun = do + funPtr <- mkSourceFunc fun + return (funPtr, destroyFunPtr) + +frameSourceAdd :: Word -> SourceFunc -> IO HandlerID +frameSourceAdd fps sfFunc = let func = {# call unsafe frame_source_add #} + in do + sf <- mkSourceFunc sfFunc + liftM cIntConv $ func (cIntConv fps) sf nullPtr + +frameSourceAddFull :: Priority -> HandlerID -> SourceFunc -> IO HandlerID +frameSourceAddFull priority fps sfFunc = let func = {# call unsafe frame_source_add_full #} + in do + (sf, gdn) <- makeCallback sfFunc + liftM cIntConv $ func (cIntConv priority) (cIntConv fps) sf (castFunPtrToPtr sf) gdn + + +--TODO: Other stuff here needs cogl + + + diff --git a/Graphics/UI/Clutter/Utility.chs b/Graphics/UI/Clutter/Utility.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/Utility.chs @@ -0,0 +1,226 @@ +-- -*-haskell-*- +-- Stuff used internally +-- +-- Author : Matthew Arsenault +-- +-- Created: 23 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +{# context lib="clutter" prefix="clutter" #} + +module Graphics.UI.Clutter.Utility ( + newPangoContext, + + cFromFlags, + cToFlags, + toModFlags, + cFromModFlags, + +--TODO: Move some of this stuff to types + newCairo, + withCairo, + withCairoPath, + withPangoLayoutRaw, + + peekNFree, + peekNFreeString, + maybeString, + withMaybeString, + maybeNullNew, + maybeNullPeek, + + withMaybeAlpha, + withMaybeText, + withMaybeTimeline, + withMaybeShader, + withMaybeColor, + withMaybeActorClass, + maybeNewActor, + maybeNewStage, + maybeNewAlpha, + maybeNewTimeline, + maybeNewTexture, + maybeNewShader, + + clutterNewAttrFromUIntProperty, + unsafeCastActor + ) where + +{# import Graphics.UI.Clutter.Types #} + +import C2HS +import Data.Maybe (catMaybes) + +import System.Glib.Flags +import System.Glib.Attributes +import System.Glib.Properties +import System.Glib.GValueTypes +import System.Glib.GObject (makeNewGObject, GObjectClass, toGObject, unsafeCastGObject) +import Graphics.Rendering.Cairo.Types (Cairo(..), unCairo) +import qualified Graphics.Rendering.Cairo.Types as Cairo +import qualified System.Glib.GTypeConstants as GType + +import Graphics.UI.Gtk.Types (PangoContext, mkPangoContext, unPangoLayoutRaw) + +--flag functions from gtk2hs with c int conversion + +cToFlags :: (Flags a) => CInt -> [a] +cToFlags = toFlags . cIntConv + +cFromFlags :: (Flags a) => [a] -> CInt +cFromFlags = cIntConv . fromFlags + +{# pointer *cairo_t as CairoPtr foreign -> Cairo nocode #} + +--convenient marshalling not provided by gtk2hs +newCairo :: Ptr Cairo -> Cairo +newCairo = Cairo + +withCairoPath = castPtr . Cairo.unPath +withCairo = castPtr . unCairo + +peekNFree :: (Storable a) => Ptr a -> IO a +peekNFree p = do + ret <- peek p + free p + return ret + +peekNFreeString :: Ptr CChar -> IO String +peekNFreeString p = do + ret <- peekCString p + free p + return ret + + +maybeNewActor :: Ptr Actor -> IO (Maybe Actor) +maybeNewActor = maybeNullNew newActor + +maybeNewStage :: Ptr Actor -> IO (Maybe Stage) +maybeNewStage = maybeNullNew newStage + +maybeNewAlpha :: Ptr Alpha -> IO (Maybe Alpha) +maybeNewAlpha = maybeNullNew newAlpha + +--maybeNewAnimation :: Ptr Animation -> IO (Maybe Animation) +--maybeNewAnimation = maybeNullNew newAnimation + +maybeNewTimeline :: Ptr Timeline -> IO (Maybe Timeline) +maybeNewTimeline = maybeNullNew newTimeline + +maybeNewTexture :: Ptr Actor -> IO (Maybe Texture) +maybeNewTexture = maybeNullNew newTexture + +maybeNewShader :: Ptr Shader -> IO (Maybe Shader) +maybeNewShader = maybeNullNew newShader + + +-- e.g. maybeNewRectangle = maybeNullNew newRectangle +maybeNullNew :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b) +maybeNullNew marshal ptr = do + if ptr == nullPtr + then return Prelude.Nothing + else marshal ptr >>= return . Just + +maybeNullPeek :: (Storable a) => Ptr a -> IO (Maybe a) +maybeNullPeek = maybeNullNew peek + + +maybeString :: Ptr CChar -> IO (Maybe String) +maybeString ptr = do + if ptr == nullPtr + then return Prelude.Nothing + else peekCString ptr >>= return . Just + +withMaybeString :: Maybe String -> (Ptr CChar -> IO a) -> IO a +withMaybeString Prelude.Nothing act = act nullPtr +withMaybeString (Just str) act = withCString str act + +withMaybeAlpha = maybeWith withAlpha +withMaybeText = maybeWith withText +withMaybeTimeline = maybeWith withTimeline +withMaybeShader = maybeWith withShader +withMaybeColor = maybeWith withColor + +withMaybeActorClass :: (ActorClass a) => Maybe a -> (Ptr Actor -> IO b) -> IO b +withMaybeActorClass = maybeWith withActorClass + + +cFromModFlags :: [ModifierType] -> CInt +cFromModFlags = cIntConv . fromModFlags + +--can't just make instance of flags for this, since toModFlags must be different +fromModFlags :: [ModifierType] -> Int +fromModFlags is = cIntConv (orNum 0 is) + where orNum n [] = n + orNum n (i:is) = orNum (n .|. fromEnum i) is + + +--The normal one from gtk2hs does not work here. there is a +--discontinuity in the enum of unused bits and also an internally used +--bit, therefore minBound .. maxBound fails, so do this shitty listing +--of all options +toModFlags :: Int -> [ModifierType] +toModFlags n = catMaybes [ if n .&. fromEnum flag == fromEnum flag + then Just flag + else Prelude.Nothing + | flag <- [ShiftMask, + LockMask, + ControlMask, + Mod1Mask, + Mod2Mask, + Mod3Mask, + Mod4Mask, + Mod5Mask, + Button1Mask, + Button2Mask, + Button3Mask, + Button4Mask, + Button5Mask, + SuperMask, + HyperMask, + MetaMask, + ReleaseMask, + ModifierMask] + ] + + +withPangoLayoutRaw = withForeignPtr . unPangoLayoutRaw + +newPangoContext :: Ptr PangoContext -> IO PangoContext +newPangoContext p = makeNewGObject mkPangoContext (return p) + +--FIXME/WTF: this should be this, but for some reason in this file +--it's getting the old version of makeNewGObject +--newPangoContext p = makeNewGObject (mkPangoContext, objectUnref) (return p) + + +-- gtk2hs uses Int for everything, which doesn't work for opacity at all. +clutterNewAttrFromUIntProperty :: GObjectClass gobj => String -> Attr gobj Word +clutterNewAttrFromUIntProperty propName = + newNamedAttr propName (clutterObjectGetPropertyUInt propName) (clutterObjectSetPropertyUInt propName) + +clutterObjectGetPropertyUInt :: GObjectClass gobj => String -> gobj -> IO Word +clutterObjectGetPropertyUInt = objectGetPropertyInternal GType.uint valueGetUInt + +clutterObjectSetPropertyUInt :: GObjectClass gobj => String -> gobj -> Word -> IO () +clutterObjectSetPropertyUInt = objectSetPropertyInternal GType.uint valueSetUInt + + +unsafeCastActor :: (ActorClass a, ActorClass b) => a -> b +unsafeCastActor = unsafeCastGObject . toGObject + diff --git a/Graphics/UI/Clutter/X11.chs b/Graphics/UI/Clutter/X11.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Clutter/X11.chs @@ -0,0 +1,245 @@ +-- -*-haskell-*- +-- Clutter X11 Specific stuff +-- +-- Author : Matthew Arsenault +-- +-- Created: 25 Oct 2009 +-- +-- Copyright (C) 2009 Matthew Arsenault +-- +-- 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 3 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. +-- +{-# LANGUAGE ForeignFunctionInterface #-} + +#include +#include + +{# context lib="clutter" prefix="clutter" #} + +-- | X11 Specific Support — X11 specific API +module Graphics.UI.Clutter.X11 ( + x11SetDisplay, + x11DisableEventRetrieval, + x11HasEventRetrieval, + x11GetStageFromWindow, +--x11HandleEvent, + x11GetDefaultDisplay, + x11GetDefaultScreen, + x11GetRootWindow, +--x11GetStageVisual, + x11GetStageWindow, + x11SetStageForeign, + x11TrapXErrors, + x11UntrapXErrors, + x11HasCompositeExtension, + x11GetCurrentEventTime, +--x11AddFilter, +--x11RemoveFilter, +--x11GetInputDevices, + x11HasXinput, + x11EnableXinput, +--x11TexturePixmapNew, +--x11TexturePixmapNewWithPixmap, +--x11TexturePixmapNewWithWindow, +--xllTexturePixmapSetPixmap, +--xllTexturePixmapSetWindow, +--x11TexturePixmapSyncWindow, +--x11TexturePixmapUpdateArea, +--x11TexturePixmapSetAutomatic, + X11FilterReturn(..), +--X11FilterFunc, + X11XInputEventTypes(..) +--X11TexturePixmap, +--X11TexturePixmapClass +) where + +{# import Graphics.UI.Clutter.Types #} + +import C2HS +import Graphics.X11 +import Graphics.X11.Xlib.Types (Display(..)) + +{# pointer *Display as DisplayPtr foreign -> Display nocode #} + +unDisplay :: Display -> Ptr Display +unDisplay (Display p) = p + +{# enum ClutterX11FilterReturn as X11FilterReturn {underscoreToCase} deriving (Show, Eq) #} +{# enum ClutterX11XInputEventTypes as X11XInputEventTypes {underscoreToCase} deriving (Show, Eq) #} + +--CHECKME: I have no idea if any of this x stuff works +-- | Sets the display connection Clutter should use; must be called +-- before 'clutterInit', 'clutterInitWithArgs' or other functions +-- pertaining Clutter's initialization process. +-- +-- [@xdpy@] an X display connection. +-- +-- * Since 0.8 +-- +{# fun unsafe x11_set_display as ^ { unDisplay `Display' } -> `()' #} + +-- | Disables retrieval of X events in the main loop. Use to create +-- event-less canvas or in conjunction with +-- 'x11HandleEvent'. +-- +-- This function can only be called before calling 'clutterInit'. +-- +-- * Since 0.8 +-- +{# fun unsafe x11_disable_event_retrieval as ^ { } -> `()' #} + +-- | Queries the X11 backend to check if event collection has been disabled. +-- +-- [@Returns@]: @True@ if event retrival has been disabled. @False@ otherwise. +-- +-- * Since 0.8 +-- +{# fun unsafe x11_has_event_retrieval as ^ { } -> `Bool' #} + + +{# fun unsafe x11_get_stage_from_window as ^ { cIntConv `Window' } -> `Stage' newStage* #} + +--{# fun unsafe x11_handle_event as ^ { unXEvent `XEvent' } -> `X11FilterReturn' #} + +-- | Retrieves the pointer to the default display. +-- +-- [@Returns@] the default display +-- +-- * Since 0.6 +-- +{# fun unsafe x11_get_default_display as ^ { } -> `Display' Display #} + + +-- | Gets the number of the default X Screen object. +-- +-- [@Returns@] the number of the default screen +-- +-- * Since 0.6 +-- +{# fun unsafe x11_get_default_screen as ^ { } -> `Int' #} + + +-- | Retrieves the root window. +-- +-- [@Returns@] the id of the root window +-- +-- * Since 0.6 +-- +{# fun unsafe x11_get_root_window as ^ { } -> `Window' cIntConv #} + +{- +not bound in X11? +-- | Returns the stage XVisualInfo +-- +-- [@stage@] a 'Stage' +-- +-- [@Returns@] The XVisualInfo for the stage. +-- +-- * Since 0.4 +-- +{# fun unsafe x11_get_stage_visual as ^ { withStage* `Stage' } -> `XVisualInfo' #} +-} + +-- | Gets the stages X Window. +-- +-- [@stage@] a 'Stage' +-- +-- [@Returns@] An XID for the stage window. +-- +-- * Since 0.4 +-- +{# fun unsafe x11_get_stage_window as ^ { withStage* `Stage' } -> `Window' cIntConv #} + + + +-- | Target the 'Stage' to use an existing external X Window +-- +-- [@stage@] a 'Stage' +-- +-- [@xwindow@] an existing X Window id +-- +-- [@Returns@] @True@ if foreign window is valid +-- +-- * Since 0.4 +-- +{# fun unsafe x11_set_stage_foreign as ^ { withStage* `Stage', cIntConv `Window' } -> `Bool' #} + + +-- | Traps every X error until 'x11UntrapXErrors' is called. +-- +-- * Since 0.6 +-- +{# fun unsafe x11_trap_x_errors as ^ { } -> `()' #} + +-- | Removes the X error trap and returns the current status. +-- +-- [@Returns@] the trapped error code, or 0 for success +-- +-- * Since 0.4 +-- +{# fun unsafe x11_untrap_x_errors as ^ { } -> `Int' #} + +{# fun unsafe x11_has_composite_extension as ^ { } -> `Bool' #} + +-- | Retrieves the timestamp of the last X11 event processed by +-- Clutter. This might be different from the timestamp returned by +-- 'getCurrentEventTime', as Clutter may synthesize or +-- throttle events. +-- +-- * Since 1.0 +-- + +-- | Retrieves the timestamp of the last X11 event processed by +-- Clutter. This might be different from the timestamp returned by +-- 'getCurrentEventTime', as Clutter may synthesize or throttle +-- events. +-- +-- [@Returns@] a timestamp, in milliseconds +-- +-- * Since 1.0 +-- +{# fun unsafe x11_get_current_event_time as ^ { } -> `Time' cIntConv #} +-- {# fun x11_add_filter +-- {# fun x11_remove_filter + +-- {# fun x11_get_input_devices as ^ { } -> `[X11XInputDevice]' readGSList* #} + +-- | Gets whether Clutter has XInput support. +-- +-- [@Returns@] @True@ if Clutter was compiled with XInput support and XInput support is +-- available at run time. +-- +-- * Since 0.8 +-- +{# fun unsafe x11_has_xinput as ^ { } -> `Bool' #} + +-- | Enables the use of the XInput extension if present on connected +-- XServer and support built into Clutter. XInput allows for +-- multiple pointing devices to be used. This must be called before +-- 'clutterInit'. +-- +-- You should use 'x11HasXinput' to see if support was enabled. +-- +-- * Since 0.8 +-- +{# fun unsafe x11_enable_xinput as ^ { } -> `()' #} + + +-- {# fun x11_texture_pixmap_new +-- {# fun x11_texture_pixmap_new_with_pixmap +-- {# fun x11_texture_pixmap_new_with_window +-- {# fun x11_texture_pixmap_set_pixmap +-- {# fun x11_texture_pixmap_set_window +-- {# fun x11_texture_pixmap_syn_window + +-- {# fun x11_texture_pixmap_update_area +-- {# fun x11_texture_pixmap_set_automatic + diff --git a/INSTALL b/INSTALL new file mode 100644 --- /dev/null +++ b/INSTALL @@ -0,0 +1,42 @@ + Clutterhs Installation Instructions + ------------------------------------ + +Prerequisites +~~~~~~~~~~~~~ + +You need GHC, the Haskell compiler (as far as I know). I've only +tested with 6.10.4. + +You need gtk2hs installed from darcs, and c2hs 0.16.0. + + +Not so simple install procedure +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + # First, install gtk2hs from darcs: + + darcs get --partial http://code.haskell.org/gtk2hs/ + cd gtk2hs + autoreconf + ./configure + make + [ Become root if necessary ] + make install + + # Next, install Clutterhs: + + tar -xzf .tar.gz # unpack the sources + cd # change to the toplevel directory + runghc Setup.hs configure # configure the build system + runghc Setup.hs build # build everything + [ Become root if necessary ] + runghc Setup.hs install # install clutterhs + +Documentation +~~~~~~~~~~~~~ + +Documentation can be built with + + $ runghc Setup.hs haddock + + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,54 @@ +=== Clutterhs README == + +Bindings for the Clutter (http://clutter-project.org/) animation +library for Haskell. + +This currently depends on Gtk2hs from darcs, mostly using the +Glib/GObject bindings. + +git: http://jayne.hortont.com/git/cgit.cgi/clutterhs.git/ + +The closest things to examples are in clutter/demo in the git repo, +the most useful of which is probably ClutterGame. + +This library is currently incomplete. Most of the core parts of +Clutter are bound. Basic actors and animations should all be bound +(however incompletely tested). Documentation is partially complete. It +is mostly copied from the Clutter C documentation, and some parts have +not been Haskellified yet. There's also quite a bit of mess internally +that will be cleaned up eventually. + +If you have any comments, complaints, or suggestions on the API or +anything, feel free to email me (arsenm2@rpi.edu). + +The only major components that are somewhere between entirely unbound +or effectively so are ClutterUnits, ClutterModel related things, and +perhaps ClutterScriptable and Animatable. Also many random lower level +functions, and things involving threads or timeouts are unbound. Also +I haven't started binding COGL yet, but that's also planned. + +I've only tested on Linux, and only partially have the X11 backend +specific stuff bound (which you also can't yet disable, so this is +more or less X11-backend-only for right now). Clutter-gtk is in the source +tree, but pretend it doesn't exist since nothing is actually there +right now. + +As another GObject based GUI library, use should be similar to gtk2hs +in many ways. As a simple example of animations, you do something like + + animate rectangle EaseOutBounce 3000 [ actorX :-> rnd1 * w, + actorY :-> rnd2 * h / 2 + h / 2, + actorRotationAngleZ :-> ang, + actorOpacity :-> 0 ] + +where the last argument to the animate function is a list of +attributes and their ending values in the animation. Any writable +property of the Clutter Actor you are animating should work, paired +with it's ending value with ':->'. The best example currently would be +ClutterGame.hs in the demo folder. Better examples and a tutorial are +planned. + +In general, anything in the Clutter C API that takes a string name of +a property and a Gvalue uses an Attribute. + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/clutterhs.cabal b/clutterhs.cabal new file mode 100644 --- /dev/null +++ b/clutterhs.cabal @@ -0,0 +1,121 @@ +name: clutterhs +version: 0.1 +license: LGPL +license-file: COPYING +stability: alpha +author: Matthew Arsenault +copyright: (c) 2009 Matthew Arsenault +maintainer: arsenm2@rpi.edu +--homepage: http://example.com +category: GUI +synopsis: Bindings to the Clutter animation library +Description: Clutterhs is a binding to the Clutter C library. Clutter + is an open source software library for creating fast, + visually rich, portable and animated graphical user + interfaces. Clutter uses OpenGL for rendering but with + an API which hides the underlying GL complexity from the + developer. The Clutter API is intended to be easy to use, + efficient and flexible. +Build-Type: Simple +Extra-Source-Files: AUTHORS, INSTALL, README +tested-with: GHC == 6.10.4 +Cabal-Version: >= 1.2 +build-depends: base >= 3 && <5, + glib >= 0.10.1, + gtk >= 0.10.1, + array, + c2hs >= 0.16 + + + +Flag Debug + Description: Enable debug support + Default: False + +--Flag X11Support +-- Description: Enable X11 support +-- Default: True + +Library + pkgconfig-depends: glib-2.0, gobject-2.0, clutter-1.0, pango + Build-Tools: c2hs >= 0.16 + Includes: csrc/clutter-macros.h + C-Sources: ./csrc/clutter-macros.c + Install-Includes: ./csrc/clutter-macros.h + Hs-Source-Dirs: . + Extensions: ForeignFunctionInterface, + ExistentialQuantification, + TypeSynonymInstances, + CPP, + FunctionalDependencies, + MultiParamTypeClasses, + OverlappingInstances, + ScopedTypeVariables, + EmptyDataDecls, + UndecidableInstances, + FlexibleInstances + + Build-Depends: base > 3 && < 5, + haskell98, + mtl, + cairo, + X11, + glib >= 0.10.1, + gtk >= 0.10.1, + array + + Other-modules: C2HS +--Utility and Types should not be exposed, but build fails if put in Other-modules field +--X11 and gtk should also be optional + Exposed-modules: Graphics.UI.Clutter.Types, + Graphics.UI.Clutter.Signals, + Graphics.UI.Clutter.Utility, + Graphics.UI.Clutter.GTypes, + Graphics.UI.Clutter.Event, + Graphics.UI.Clutter.StoreValue, + Graphics.UI.Clutter.Animation, + Graphics.UI.Clutter.CustomSignals, + Graphics.UI.Clutter.General, + Graphics.UI.Clutter.Color, + Graphics.UI.Clutter.Actor, + Graphics.UI.Clutter.Rectangle, + Graphics.UI.Clutter.Texture, + Graphics.UI.Clutter.Container, + Graphics.UI.Clutter.Group, + Graphics.UI.Clutter.Text, + Graphics.UI.Clutter.Stage, + Graphics.UI.Clutter.Animatable, + Graphics.UI.Clutter.Timeline, + Graphics.UI.Clutter.Score, + Graphics.UI.Clutter.CairoTexture, + Graphics.UI.Clutter.Alpha, + Graphics.UI.Clutter.Media, + Graphics.UI.Clutter.ChildMeta, + Graphics.UI.Clutter.Clone, + Graphics.UI.Clutter.Behaviour, + Graphics.UI.Clutter.BehaviourScale, + Graphics.UI.Clutter.BehaviourDepth, + Graphics.UI.Clutter.BehaviourEllipse, + Graphics.UI.Clutter.BehaviourOpacity, + Graphics.UI.Clutter.BehaviourRotate, + Graphics.UI.Clutter.BehaviourPath, + Graphics.UI.Clutter.Interval, + Graphics.UI.Clutter.Path, + Graphics.UI.Clutter.Shader, + Graphics.UI.Clutter.Model, + Graphics.UI.Clutter.ListModel, + Graphics.UI.Clutter.ModelIter, + Graphics.UI.Clutter.Script, + Graphics.UI.Clutter.Units, + Graphics.UI.Clutter.Scriptable, + Graphics.UI.Clutter.BindingPool, + Graphics.UI.Clutter.Utilities, + Graphics.UI.Clutter.X11, + Graphics.UI.Clutter + Exposed: True + Include-dirs: ./csrc + if flag(debug) + GHC-options: -W + CC-Options: "-DDEBUG -O0 -g" + CPP-Options: -DDEBUG + diff --git a/csrc/clutter-macros.c b/csrc/clutter-macros.c new file mode 100644 --- /dev/null +++ b/csrc/clutter-macros.c @@ -0,0 +1,24 @@ + +#include +#include + +gboolean actor_is_realized(ClutterActor* actor) +{ + return CLUTTER_ACTOR_IS_REALIZED(actor); +} + +gboolean actor_is_visible(ClutterActor* actor) +{ + return CLUTTER_ACTOR_IS_VISIBLE(actor); +} + +gboolean actor_is_reactive(ClutterActor* actor) +{ + return CLUTTER_ACTOR_IS_REACTIVE(actor); +} + +gboolean actor_is_mapped(ClutterActor* actor) +{ + return CLUTTER_ACTOR_IS_MAPPED(actor); +} + diff --git a/csrc/clutter-macros.h b/csrc/clutter-macros.h new file mode 100644 --- /dev/null +++ b/csrc/clutter-macros.h @@ -0,0 +1,13 @@ +#ifndef CLUTTER_MACROS_H_ +#define CLUTTER_MACROS_H_ +/* CPP macros */ + +#include + +gboolean actor_is_realized(ClutterActor* actor); +gboolean actor_is_visible(ClutterActor* actor); +gboolean actor_is_reactive(ClutterActor* actor); +gboolean actor_is_mapped(ClutterActor* actor); + +#endif +