cairo 0.13.5.0 → 0.13.6.0
raw patch · 7 files changed
+623/−56 lines, 7 filesdep ~base
Dependency ranges changed: base
Files
- Graphics/Rendering/Cairo.hs +335/−10
- Graphics/Rendering/Cairo/Internal/Drawing/Cairo.chs +4/−4
- Graphics/Rendering/Cairo/Internal/Drawing/Paths.chs +168/−1
- Graphics/Rendering/Cairo/Internal/Drawing/Patterns.chs +59/−16
- Graphics/Rendering/Cairo/Types.chs +47/−19
- cairo.cabal +3/−3
- demo/gtk3/Makefile +7/−3
Graphics/Rendering/Cairo.hs view
@@ -127,8 +127,16 @@ , relCurveTo , relLineTo , relMoveTo+ , copyPath+ , copyPathFlat+ , appendPath+ , pathExtents -- ** Patterns+ , createRGBPattern+ , createRGBAPattern+ , createLinearPattern+ , createRadialPattern , withRGBPattern , withRGBAPattern , withPatternForSurface@@ -300,6 +308,9 @@ , HintMetrics(..) , FontOptions , Path+ , PathElement(..)+ , SurfaceType(..)+ , PatternType(..) #if CAIRO_CHECK_VERSION(1,10,0) , RectangleInt(..) , RegionOverlap(..)@@ -310,6 +321,24 @@ , Extend(..) , Filter(..) + -- mesh patterns+#if CAIRO_CHECK_VERSION(1,12,0)+ , createMeshPattern+ , meshPatternAddPatchRGB+ , meshPatternAddPatchRGBA+ , meshPatternBeginPatch+ , meshPatternEndPatch+ , meshPatternMoveTo+ , meshPatternLineTo+ , meshPatternCurveTo+ , meshPatternSetControlPoint+ , meshPatternSetCornerColorRGB+ , meshPatternSetCornerColorRGBA+ , meshPatternGetPatchCount+ , meshPatternGetPath+ , meshPatternGetControlPoint+ , meshPatternGetCornerColorRGBA+#endif ) where import Control.Monad (unless, when)@@ -998,6 +1027,87 @@ relMoveTo = liftRender2 Internal.relMoveTo +-- | Creates a copy of the current path and returns it to the user.+copyPath :: Render Path+copyPath = liftRender0 Internal.copyPath+++-- | Gets a flattened copy of the current path and returns it to the user.+--+-- This function is like copyPath except that any curves in the path will be+-- approximated with piecewise-linear approximations, accurate to within the current tolerance value.+-- That is, any path elements created by curveTo or relCurveTo will be replaced by a series of lineTo elements.+copyPathFlat :: Render Path+copyPathFlat = liftRender0 Internal.copyPathFlat+++-- | Append the path onto the current path.+--+-- The path may be either the return value from copyPath or copyPathFlat or it may be constructed manually.+appendPath :: Path -- ^ the path to append+ -> Render ()+appendPath = liftRender1 Internal.appendPath++++pathExtents :: Render (Double,Double,Double,Double)+pathExtents = liftRender0 Internal.pathExtents+++++-- | +--+createRGBPattern ::+ MonadIO m =>+ Double -- ^ @r@+ -> Double -- ^ @g@+ -> Double -- ^ @b@+ -> m Pattern+createRGBPattern r g b = liftIO$ Internal.patternCreateRGB r g b+++-- | +--+createRGBAPattern ::+ MonadIO m =>+ Double -- ^ @r@+ -> Double -- ^ @g@+ -> Double -- ^ @b@+ -> Double -- ^ @a@+ -> m Pattern+createRGBAPattern r g b a = liftIO$ Internal.patternCreateRGBA r g b a+++-- | +--+createLinearPattern ::+ MonadIO m =>+ Double -- ^ @x1@+ -> Double -- ^ @y1@+ -> Double -- ^ @x2@+ -> Double -- ^ @y2@+ -> m Pattern+createLinearPattern x1 y1 x2 y2 = liftIO$ Internal.patternCreateLinear x1 y1 x2 y2+++-- | +--+createRadialPattern ::+ MonadIO m =>+ Double -- ^ @x1@+ -> Double -- ^ @y1@+ -> Double -- ^ @r1@+ -> Double -- ^ @x2@+ -> Double -- ^ @y2@+ -> Double -- ^ @r2@+ -> m Pattern+createRadialPattern x1 y1 r1 x2 y2 r2 = liftIO$ Internal.patternCreateRadial x1 y1 r1 x2 y2 r2+++++ -- | Creates a new 'Pattern' corresponding to an opaque color. The color -- components are floating point numbers in the range 0 to 1. If the values -- passed in are outside that range, they will be clamped.@@ -1017,7 +1127,8 @@ withRGBPattern r g b f = bracketR (Internal.patternCreateRGB r g b) (\pattern -> do status <- Internal.patternStatus pattern- liftIO $ Internal.patternDestroy pattern+ -- omitted because patternCreateRGB now returns a foreign ptr with patternDestroy as a finalizer+-- liftIO $ Internal.patternDestroy pattern unless (status == StatusSuccess) $ fail =<< Internal.statusToString status) (\pattern -> f pattern)@@ -1042,7 +1153,7 @@ withRGBAPattern r g b a f = bracketR (Internal.patternCreateRGBA r g b a) (\pattern -> do status <- Internal.patternStatus pattern- liftIO $ Internal.patternDestroy pattern+-- liftIO $ Internal.patternDestroy pattern unless (status == StatusSuccess) $ fail =<< Internal.statusToString status) (\pattern -> f pattern)@@ -1056,7 +1167,7 @@ withPatternForSurface surface f = bracketR (Internal.patternCreateForSurface surface) (\pattern -> do status <- Internal.patternStatus pattern- liftIO $ Internal.patternDestroy pattern+-- liftIO $ Internal.patternDestroy pattern unless (status == StatusSuccess) $ fail =<< Internal.statusToString status) (\pattern -> f pattern)@@ -1071,7 +1182,7 @@ context <- ask bracketR (Internal.popGroup context) (\pattern -> do status <- Internal.patternStatus pattern- liftIO $ Internal.patternDestroy pattern+-- liftIO $ Internal.patternDestroy pattern unless (status == StatusSuccess) $ fail =<< Internal.statusToString status) f@@ -1094,14 +1205,14 @@ withLinearPattern x0 y0 x1 y1 f = bracketR (Internal.patternCreateLinear x0 y0 x1 y1) (\pattern -> do status <- Internal.patternStatus pattern- liftIO $ Internal.patternDestroy pattern+-- liftIO $ Internal.patternDestroy pattern unless (status == StatusSuccess) $ fail =<< Internal.statusToString status) (\pattern -> f pattern) -- | Creates a new radial gradient 'Pattern' between the two circles defined by--- @(x0, y0, c0)@ and @(x1, y1, c0)@. Before using the gradient pattern, a--- number of color stops should be defined using 'patternAddColorStopRGB'+-- @(x0, y0, radius0)@ and @(x1, y1, radius0)@. Before using the gradient pattern,+-- a number of color stops should be defined using 'patternAddColorStopRGB' -- or 'patternAddColorStopRGBA'. -- -- * Note: The coordinates here are in pattern space. For a new pattern,@@ -1120,7 +1231,7 @@ withRadialPattern cx0 cy0 radius0 cx1 cy1 radius1 f = bracketR (Internal.patternCreateRadial cx0 cy0 radius0 cx1 cy1 radius1) (\pattern -> do status <- Internal.patternStatus pattern- liftIO $ Internal.patternDestroy pattern+-- liftIO $ Internal.patternDestroy pattern unless (status == StatusSuccess) $ fail =<< Internal.statusToString status) (\pattern -> f pattern)@@ -1204,7 +1315,7 @@ patternSetExtend :: MonadIO m => Pattern -- ^ a 'Pattern'- -> Extend -- ^ an 'Extent'+ -> Extend -- ^ an 'Extend' enum -> m () patternSetExtend p e = liftIO $ Internal.patternSetExtend p e @@ -1221,7 +1332,7 @@ patternSetFilter :: MonadIO m => Pattern -- ^ a 'Pattern'- -> Filter -- ^ a 'Filter'+ -> Filter -- ^ a 'Filter' type -> m () patternSetFilter p f = liftIO $ Internal.patternSetFilter p f @@ -1232,6 +1343,220 @@ Pattern -- ^ a 'Pattern' -> m Filter patternGetFilter p = liftIO $ Internal.patternGetFilter p++++#if CAIRO_CHECK_VERSION(1,12,0)++-- | Create a new mesh pattern.+--+-- Mesh patterns are tensor-product patch meshes (type 7 shadings in PDF).+-- Mesh patterns may also be used to create other types of shadings that are special cases+-- of tensor-product patch meshes such as Coons patch meshes (type 6 shading in PDF) and+-- Gouraud-shaded triangle meshes (type 4 and 5 shadings in PDF).+--+-- Refer to <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-pattern-create-mesh>+-- for a more detailed explanation of their usage, as this library merely provides a wrapper+-- around the underlying C API.+--+createMeshPattern ::+ MonadIO m =>+ m Pattern+createMeshPattern = liftIO$ Internal.patternCreateMesh+++-- | A convenience method that adds a patch to the mesh pattern in a single call.+--+-- It translates the provided path into calls to meshPatternMoveTo, meshPatternLineTo, and+-- meshPatternCurveTo, as appropriate. The control points are set using meshPatternSetControlPoint+-- and the corner colors are set using meshPatternSetCornerColorRGB.+-- The above operations are wrapped in calls to +-- At most the first 4 elements of the provided list will be used.+meshPatternAddPatchRGB ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Path -- ^ a path to use as the boundary of the mesh pattern+ -> [(Double,Double)] -- ^ a list of control points as @(x,y)@ pairs+ -> [(Double,Double,Double)] -- ^ a list of corner colors, each of the form @(r,g,b)@+ -> m Status+meshPatternAddPatchRGB pat elems controlPoints colors = do+ meshPatternBeginPatch pat+ mapM_ (liftIO . Internal.convertPathElement pat) (take 4 elems)+ sequence_ $ zipWith (\(x,y) n -> meshPatternSetControlPoint pat n x y) (take 4 controlPoints) [0..3]+ sequence_ $ zipWith (\(r,g,b) n -> meshPatternSetCornerColorRGB pat n r g b) (take 4 colors) [0..3]+ meshPatternEndPatch pat+ liftIO$ Internal.patternStatus pat+++-- | as 'meshPatternAddPatchRGB', but the colors contain an alpha channel.+--+-- The corner colors are set using meshPatternSetCornerColorRGBA.+meshPatternAddPatchRGBA ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Path -- ^ a path to use as the boundary of the mesh pattern+ -> [(Double,Double)] -- ^ a list of control points as @(x,y)@ pairs+ -> [(Double,Double,Double,Double)] -- ^ a list of corner colors, each of the form @(r,g,b,a)@+ -> m Status+meshPatternAddPatchRGBA pat elems controlPoints colors = do+ meshPatternBeginPatch pat+ mapM_ (liftIO . Internal.convertPathElement pat) (take 4 elems)+ sequence_ $ zipWith (\(x,y) n -> meshPatternSetControlPoint pat n x y) (take 4 controlPoints) [0..3]+ sequence_ $ zipWith (\(r,g,b,a) n -> meshPatternSetCornerColorRGBA pat n r g b a) (take 4 colors) [0..3]+ meshPatternEndPatch pat+ liftIO$ Internal.patternStatus pat+++-- | Begin a patch in a mesh pattern.+--+-- Safer, more convenient methods 'meshPatternAddPatchRGB' and 'meshPatternAddPatchRGBA' are provided+-- to avoid the begin/end idiom of the procedural language.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-begin-patch>+meshPatternBeginPatch ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> m ()+meshPatternBeginPatch p = liftIO$ Internal.meshPatternBeginPatch p++-- | Indicates the end of the current patch in a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-end-patch>+meshPatternEndPatch ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> m ()+meshPatternEndPatch p = liftIO$ Internal.meshPatternEndPatch p+++-- | Define the first point of the current patch in a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-move-to>+meshPatternMoveTo ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Double -- ^ the @x@ coordinate of the point+ -> Double -- ^ the @y@ coordinate of the point+ -> m ()+meshPatternMoveTo p x y = liftIO$ Internal.meshPatternMoveTo p x y+++-- | Adds a line to the current patch from the current point to position @(x,y)@ in pattern-space coordinates.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-line-to>+meshPatternLineTo ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Double -- ^ the @x@ coordinate of the endpoint+ -> Double -- ^ the @y@ coordinate of the endpoint+ -> m ()+meshPatternLineTo p x y = liftIO$ Internal.meshPatternLineTo p x y+++-- | Adds a cubic Bézier spline to the current patch from the current point to position @(x3,y3)@+-- in pattern-space coordinates, using @(x1,y1)@ and @(x2,y2)@ as the control points.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-curve-to>+meshPatternCurveTo ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Double -- ^ @x1@+ -> Double -- ^ @y1@+ -> Double -- ^ @x2@+ -> Double -- ^ @y2@+ -> Double -- ^ @x3@+ -> Double -- ^ @y3@+ -> m ()+meshPatternCurveTo p x1 y1 x2 y2 x3 y3 = liftIO$ Internal.meshPatternCurveTo p x1 y1 x2 y2 x3 y3+++-- | Set an internal control point of the current mesh patch.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-set-control-point>+meshPatternSetControlPoint ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Int -- ^ the number of the control point to modify, from 0 to 3+ -> Double -- ^ the @x@ coordinate of the control point+ -> Double -- ^ the @y@ coordinate of the control point+ -> m ()+meshPatternSetControlPoint p n x y = liftIO$ Internal.meshPatternSetControlPoint p n x y+++-- | Sets the color of a corner of the current patch in a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-set-corner-color-rgb>+meshPatternSetCornerColorRGB ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Int -- ^ the number of the corner to modify, from 0 to 3+ -> Double -- ^ the @r@ component of a color+ -> Double -- ^ the @g@ component of a color+ -> Double -- ^ the @b@ component of a color+ -> m ()+meshPatternSetCornerColorRGB p n r g b = liftIO$ Internal.meshPatternSetCornerColorRGB p n r g b+++-- | Sets the color of a corner of the current patch in a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-set-corner-color-rgba>+meshPatternSetCornerColorRGBA ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to modify+ -> Int -- ^ the number of the corner to modify, from 0 to 3+ -> Double -- ^ the @r@ component of a color+ -> Double -- ^ the @g@ component of a color+ -> Double -- ^ the @b@ component of a color+ -> Double -- ^ the @a@ component of a color+ -> m ()+meshPatternSetCornerColorRGBA p n r g b a = liftIO$ Internal.meshPatternSetCornerColorRGBA p n r g b a+++-- | Gets the number of patches specified in the given mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-get-patch-count>+meshPatternGetPatchCount ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to query+ -> m (Status, Int)+meshPatternGetPatchCount p = liftIO$ Internal.meshPatternGetPatchCount p++-- | Gets path defining a spedified patch from a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-get-path>+meshPatternGetPath ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to query+ -> Int -- ^ the zero-indexed patch number+ -> m Path+meshPatternGetPath p n = liftIO$ Internal.meshPatternGetPath p n++-- | Gets the control point @point_num@ of patch @patch_num@ from a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-get-control-point>+meshPatternGetControlPoint ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to query+ -> Int -- ^ @point_num@+ -> Int -- ^ @patch_num@+ -> m (Status, Double, Double)+meshPatternGetControlPoint p point_num patch_num = liftIO$ Internal.meshPatternGetControlPoint p point_num patch_num+++-- | Gets the color information in corner @corner_num@ of patch @patch_num@ from a mesh pattern.+--+-- qv <https://www.cairographics.org/manual/cairo-cairo-pattern-t.html#cairo-mesh-pattern-get-corner-color-rgba>+meshPatternGetCornerColorRGBA ::+ MonadIO m =>+ Pattern -- ^ the 'Pattern' to query+ -> Int -- ^ @corner_num@+ -> Int -- ^ @patch_num@+ -> m (Status, Double, Double, Double, Double)+meshPatternGetCornerColorRGBA p corner_num patch_num = liftIO$ Internal.meshPatternGetCornerColorRGBA p corner_num patch_num++#endif++ -- | Modifies the current transformation matrix (CTM) by translating the
Graphics/Rendering/Cairo/Internal/Drawing/Cairo.chs view
@@ -29,13 +29,13 @@ {#fun get_target as getTarget { unCairo `Cairo' } -> `Surface' mkSurface*#} {#fun push_group as ^ { unCairo `Cairo' } -> `()' #} {#fun push_group_with_content as ^ { unCairo `Cairo', cFromEnum `Content' } -> `()' #}-{#fun pop_group as ^ { unCairo `Cairo' } -> `Pattern' Pattern #}+{#fun pop_group as ^ { unCairo `Cairo' } -> `Pattern' mkPattern* #} {#fun pop_group_to_source as ^ { unCairo `Cairo' } -> `()' #} {#fun set_source_rgb as setSourceRGB { unCairo `Cairo', `Double', `Double', `Double' } -> `()'#} {#fun set_source_rgba as setSourceRGBA { unCairo `Cairo', `Double', `Double', `Double', `Double' } -> `()'#}-{#fun set_source as setSource { unCairo `Cairo', unPattern `Pattern' } -> `()'#}+{#fun set_source as setSource { unCairo `Cairo', withPattern* `Pattern' } -> `()'#} {#fun set_source_surface as setSourceSurface { unCairo `Cairo', withSurface* `Surface', `Double', `Double' } -> `()'#}-{#fun get_source as getSource { unCairo `Cairo' } -> `Pattern' Pattern#}+{#fun get_source as getSource { unCairo `Cairo' } -> `Pattern' clonePattern* #} {#fun set_antialias as setAntialias { unCairo `Cairo', cFromEnum `Antialias' } -> `()'#} {#fun get_antialias as getAntialias { unCairo `Cairo' } -> `Antialias' cToEnum#} setDash context xs offset = withArrayLen (map (cFloatConv) xs) $ \len ptr ->@@ -62,7 +62,7 @@ {#fun fill_preserve as fillPreserve { unCairo `Cairo' } -> `()'#} {#fun fill_extents as fillExtents { unCairo `Cairo', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `()'#} {#fun in_fill as inFill { unCairo `Cairo', `Double', `Double' } -> `Bool' cToBool#}-{#fun mask as mask { unCairo `Cairo', unPattern `Pattern' } -> `()'#}+{#fun mask as mask { unCairo `Cairo', withPattern* `Pattern' } -> `()'#} {#fun mask_surface as maskSurface { unCairo `Cairo', withSurface* `Surface', `Double', `Double' } -> `()'#} {#fun paint as paint { unCairo `Cairo' } -> `()'#} {#fun paint_with_alpha as paintWithAlpha { unCairo `Cairo', `Double' } -> `()'#}
Graphics/Rendering/Cairo/Internal/Drawing/Paths.chs view
@@ -17,12 +17,17 @@ import Foreign import Foreign.C-import Data.Text+import Foreign.Marshal.Alloc (mallocBytes,finalizerFree) import Graphics.Rendering.Cairo.Internal.Utilities (CairoString(..)) {#context lib="cairo" prefix="cairo"#} +{#pointer *path_t as CPath newtype#}+unPath :: CPath -> Ptr CPath+unPath (CPath p) = p++ {#fun get_current_point as getCurrentPoint { unCairo `Cairo', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `()'#} {#fun new_path as newPath { unCairo `Cairo' } -> `()'#} {#fun close_path as closePath { unCairo `Cairo' } -> `()'#}@@ -40,3 +45,165 @@ {#fun rel_curve_to as relCurveTo { unCairo `Cairo', `Double', `Double', `Double', `Double', `Double', `Double' } -> `()'#} {#fun rel_line_to as relLineTo { unCairo `Cairo', `Double', `Double' } -> `()'#} {#fun rel_move_to as relMoveTo { unCairo `Cairo', `Double', `Double' } -> `()'#}+{#fun copy_path as copyPathC { unCairo `Cairo' } -> `CPath' CPath #}+{#fun copy_path_flat as copyPathFlatC { unCairo `Cairo' } -> `CPath' CPath #}+{#fun append_path as appendPathC { unCairo `Cairo', unPath `CPath' } -> `()' #}+{#fun path_destroy as pathDestroy { unPath `CPath' } -> `()' #}+{#fun path_extents as pathExtents { unCairo `Cairo', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `()' #}++{#enum path_data_type_t as PathDataRecordType {underscoreToCase} deriving(Eq,Show)#}++data PathDataRecord+ = PathHeaderRecord PathDataRecordType Int+ | PathPointRecord Double Double+ deriving (Eq,Show)+++copyPath :: Cairo -> IO [PathElement]+copyPath ctx = do+ p <- copyPathC ctx+ xs <- pathToList p+ pathDestroy p+ return xs+++copyPathFlat :: Cairo -> IO [PathElement]+copyPathFlat ctx = do+ p <- copyPathFlatC ctx+ xs <- pathToList p+ pathDestroy p+ return xs+++appendPath :: Cairo -> [PathElement] -> IO ()+appendPath ctx es = do+ path <- mkPathPtr es+ appendPathC ctx path+ deallocPath path+++pathToList :: CPath -> IO [PathElement]+pathToList p = pathToList' <$> pathToList'' p++++pathToList' :: [PathDataRecord] -> [PathElement]+pathToList' [] = []+pathToList' ((PathHeaderRecord htype hlen):rs)+ | hlen >= 1 = let (mine,rest) = splitAt (hlen-1) rs+ in (consElem htype mine) : pathToList' rest+ | otherwise = error "invalid path data (invalid header length)"+pathToList' _ = error "invalid path data (expected header record)"++++pathToList'' :: CPath -> IO [PathDataRecord]+pathToList'' (CPath p) = do+ numdata <- {#get path_t->num_data #} p+ dptr <- {#get path_t->data#} p+ getPathData 0 (cIntConv numdata) (castPtr dptr)++ where size = {#sizeof path_data_t#}+ getPathData :: Int -> Int -> Ptr PathDataRecord -> IO [PathDataRecord]+ getPathData currpos numdata dptr+ | currpos < numdata = do+ let dptr' = dptr `plusPtr` (size*currpos)+ h@(PathHeaderRecord _ hlen) <- peekHeader dptr'+ ds <- peekPoints dptr' hlen+ rest <- getPathData (currpos+hlen) numdata dptr+ return$ h:(ds++rest)+ | otherwise = return []++ peekHeader :: Ptr PathDataRecord -> IO PathDataRecord+ peekHeader p = do+ -- the more intuitive statement+ -- htype <- {#get path_data_t->header.type #} p+ -- generates an error+ -- "CHS module contains errors: The phrase `type' is not allowed here."+ htype <- peekByteOff p 0 :: IO CInt+ hlen <- {#get path_data_t->header.length #} p+ return$ PathHeaderRecord (cToEnum htype) (cIntConv hlen)++ peekPoint :: Ptr PathDataRecord -> IO PathDataRecord+ peekPoint p = do+ x <- {#get path_data_t->point.x #} p+ y <- {#get path_data_t->point.y #} p+ return$ PathPointRecord (cFloatConv x) (cFloatConv y)++ peekPoints :: Ptr PathDataRecord -> Int -> IO [PathDataRecord]+ peekPoints p n = mapM (\i -> peekPoint (p `plusPtr` (size*i))) [1..(n-1)]++++getPts = \(PathPointRecord x y) -> (x,y)+++pokeRecord :: Ptr PathDataRecord -> PathDataRecord -> IO ()+pokeRecord ptr (PathHeaderRecord htype hlen) = do+ pokeByteOff ptr 0 (cFromEnum htype :: CInt) -- the member named 'type' of the header is misunderstood by c2hs (see above)+ {#set path_data_t->header.length #} ptr (cIntConv hlen)++pokeRecord ptr (PathPointRecord x y) = do+ {#set path_data_t->point.x #} ptr (cFloatConv x)+ {#set path_data_t->point.y #} ptr (cFloatConv y)++++++consElem :: PathDataRecordType -> [PathDataRecord] -> PathElement+consElem PathMoveTo ps+ | length ps < 1 = error "invalid path data (not enough points)"+ | otherwise = uncurry MoveTo $ getPts (ps!!0)+consElem PathLineTo ps+ | length ps < 1 = error "invalid path data (not enough points)"+ | otherwise = uncurry LineTo $ getPts (ps!!0)+consElem PathCurveTo ps+ | length ps < 3 = error "invalid path data (not enough points)"+ | otherwise = let ps' = map getPts (take 3 ps)+ in uncurry (uncurry (uncurry CurveTo (ps'!!0)) (ps'!!1)) (ps'!!2)+consElem PathClosePath ps = ClosePath+++consRecs :: PathElement -> [PathDataRecord]+consRecs (MoveTo x y) =+ [ PathHeaderRecord PathMoveTo 2, PathPointRecord x y]+consRecs (LineTo x y) =+ [ PathHeaderRecord PathLineTo 2, PathPointRecord x y]+consRecs (CurveTo x₀ y₀ x₁ y₁ x₂ y₂) =+ [ PathHeaderRecord PathCurveTo 4+ , PathPointRecord x₀ y₀+ , PathPointRecord x₁ y₁+ , PathPointRecord x₂ y₂+ ]+consRecs ClosePath = [PathHeaderRecord PathClosePath 1]++++mkPathPtr :: [PathElement] -> IO CPath+mkPathPtr es = do+ (dptr,numdata) <- mkDataPtr es+ ptr <- mallocBytes {#sizeof path_t#}+ {#set path_t->status #} ptr (cFromEnum StatusSuccess)+ {#set path_t->data #} ptr (castPtr dptr)+ {#set path_t->num_data #} ptr (cIntConv numdata)+ return (CPath ptr)++++mkDataPtr :: [PathElement] -> IO (Ptr PathDataRecord, Int)+mkDataPtr es = do+ let rs = concatMap consRecs es+ len = length rs+ size = {#sizeof path_data_t#}+ dptr <- mallocBytes (len*size) :: IO (Ptr PathDataRecord)+ mapM_ (\(r,i) -> pokeRecord (dptr `plusPtr` (i*size)) r) (zip rs [0..])+ return (dptr,len)+++deallocPath :: CPath -> IO ()+deallocPath (CPath ptr) = do+ dptr <- {#get path_t->data#} ptr+ free dptr+ free ptr+
Graphics/Rendering/Cairo/Internal/Drawing/Patterns.chs view
@@ -14,25 +14,68 @@ module Graphics.Rendering.Cairo.Internal.Drawing.Patterns where {#import Graphics.Rendering.Cairo.Types#}+{#import Graphics.Rendering.Cairo.Internal.Drawing.Paths #} ( CPath(..), pathDestroy, pathToList ) + import Foreign import Foreign.C {#context lib="cairo" prefix="cairo"#} -{#fun pattern_add_color_stop_rgb as patternAddColorStopRGB { unPattern `Pattern', `Double', `Double', `Double', `Double' } -> `()'#}-{#fun pattern_add_color_stop_rgba as patternAddColorStopRGBA { unPattern `Pattern', `Double', `Double', `Double', `Double', `Double' } -> `()'#}-{#fun pattern_create_rgb as patternCreateRGB { `Double', `Double', `Double' } -> `Pattern' Pattern#}-{#fun pattern_create_rgba as patternCreateRGBA { `Double', `Double', `Double', `Double' } -> `Pattern' Pattern#}-{#fun pattern_create_for_surface as patternCreateForSurface { withSurface* `Surface' } -> `Pattern' Pattern#}-{#fun pattern_create_linear as patternCreateLinear { `Double', `Double', `Double', `Double' } -> `Pattern' Pattern#}-{#fun pattern_create_radial as patternCreateRadial { `Double', `Double', `Double', `Double', `Double', `Double' } -> `Pattern' Pattern#}-{#fun pattern_destroy as patternDestroy { unPattern `Pattern' } -> `()'#}-{#fun pattern_reference as patternReference { unPattern `Pattern' } -> `Pattern' Pattern#}-{#fun pattern_status as patternStatus { unPattern `Pattern' } -> `Status' cToEnum#}-{#fun pattern_set_extend as patternSetExtend { unPattern `Pattern', cFromEnum `Extend' } -> `()'#}-{#fun pattern_get_extend as patternGetExtend { unPattern `Pattern' } -> `Extend' cToEnum#}-{#fun pattern_set_filter as patternSetFilter { unPattern `Pattern', cFromEnum `Filter' } -> `()'#}-{#fun pattern_get_filter as patternGetFilter { unPattern `Pattern' } -> `Filter' cToEnum#}-{#fun pattern_set_matrix as patternSetMatrix { unPattern `Pattern', `Matrix' } -> `()'#}-{#fun pattern_get_matrix as patternGetMatrix { unPattern `Pattern', alloca- `Matrix' peek*} -> `()'#}+{#fun pattern_create_rgb as patternCreateRGB { `Double', `Double', `Double' } -> `Pattern' mkPattern* #}+{#fun pattern_create_rgba as patternCreateRGBA { `Double', `Double', `Double', `Double' } -> `Pattern' mkPattern* #}+{#fun pattern_get_rgba as patternGetRGBA { withPattern* `Pattern', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `Status' cToEnum #}++{#fun pattern_create_linear as patternCreateLinear { `Double', `Double', `Double', `Double' } -> `Pattern' mkPattern* #}+{#fun pattern_create_radial as patternCreateRadial { `Double', `Double', `Double', `Double', `Double', `Double' } -> `Pattern' mkPattern* #}+{#fun pattern_add_color_stop_rgb as patternAddColorStopRGB { withPattern* `Pattern', `Double', `Double', `Double', `Double' } -> `()' #}+{#fun pattern_add_color_stop_rgba as patternAddColorStopRGBA { withPattern* `Pattern', `Double', `Double', `Double', `Double', `Double' } -> `()'#}+{#fun pattern_get_color_stop_count as patternGetColorStopCount { withPattern* `Pattern', alloca- `Int' peekIntConv* } -> `Status' cToEnum #}+{#fun pattern_get_color_stop_rgba as patternGetColorStopRGBA { withPattern* `Pattern', `Int', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*} -> `Status' cToEnum #}+{#fun pattern_get_linear_points as patternGetLinearPoints { withPattern* `Pattern', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `Status' cToEnum #}+{#fun pattern_get_radial_circles as patternGetRadialCircles { withPattern* `Pattern', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `Status' cToEnum #}++{#fun pattern_create_for_surface as patternCreateForSurface { withSurface* `Surface' } -> `Pattern' mkPattern* #}++{#fun pattern_status as patternStatus { withPattern* `Pattern' } -> `Status' cToEnum#}+{#fun pattern_get_type as patternGetType { withPattern* `Pattern' } -> `PatternType' cToEnum #}++{#fun pattern_set_extend as patternSetExtend { withPattern* `Pattern', cFromEnum `Extend' } -> `()'#}+{#fun pattern_get_extend as patternGetExtend { withPattern* `Pattern' } -> `Extend' cToEnum#}+{#fun pattern_set_filter as patternSetFilter { withPattern* `Pattern', cFromEnum `Filter' } -> `()'#}+{#fun pattern_get_filter as patternGetFilter { withPattern* `Pattern' } -> `Filter' cToEnum#}+{#fun pattern_set_matrix as patternSetMatrix { withPattern* `Pattern', `Matrix' } -> `()'#}+{#fun pattern_get_matrix as patternGetMatrix { withPattern* `Pattern', alloca- `Matrix' peek*} -> `()'#}+++-- support for mesh patterns / tensor product patches+#if CAIRO_CHECK_VERSION(1,12,0)+{#fun pattern_create_mesh as patternCreateMesh { } -> `Pattern' mkPattern* #}+{#fun mesh_pattern_begin_patch as meshPatternBeginPatch { withPattern* `Pattern' } -> `()' #}+{#fun mesh_pattern_end_patch as meshPatternEndPatch { withPattern* `Pattern' } -> `()' #}+{#fun mesh_pattern_move_to as meshPatternMoveTo { withPattern* `Pattern', `Double', `Double' } -> `()' #}+{#fun mesh_pattern_line_to as meshPatternLineTo { withPattern* `Pattern', `Double', `Double' } -> `()' #}+{#fun mesh_pattern_curve_to as meshPatternCurveTo { withPattern* `Pattern', `Double', `Double', `Double', `Double', `Double', `Double' } -> `()' #}+{#fun mesh_pattern_set_control_point as meshPatternSetControlPoint { withPattern* `Pattern', fromIntegral `Int', `Double', `Double' } -> `()' #}+{#fun mesh_pattern_set_corner_color_rgb as meshPatternSetCornerColorRGB { withPattern* `Pattern', fromIntegral `Int', `Double', `Double', `Double' } -> `()' #}+{#fun mesh_pattern_set_corner_color_rgba as meshPatternSetCornerColorRGBA { withPattern* `Pattern', fromIntegral `Int', `Double', `Double', `Double', `Double'} -> `()' #}+{#fun mesh_pattern_get_patch_count as meshPatternGetPatchCount { withPattern* `Pattern', alloca- `Int' peekIntConv* } -> `Status' cToEnum #}+{#fun mesh_pattern_get_path as meshPatternGetPathC { withPattern* `Pattern', fromIntegral `Int' } -> `CPath' CPath #}+{#fun mesh_pattern_get_control_point as meshPatternGetControlPoint { withPattern* `Pattern', fromIntegral `Int', fromIntegral `Int', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `Status' cToEnum #}+{#fun mesh_pattern_get_corner_color_rgba as meshPatternGetCornerColorRGBA { withPattern* `Pattern', fromIntegral `Int', fromIntegral `Int', alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv*, alloca- `Double' peekFloatConv* } -> `Status' cToEnum #}++meshPatternGetPath :: Pattern -> Int -> IO [PathElement]+meshPatternGetPath pat n = do+ path <- meshPatternGetPathC pat n+ xs <- pathToList path+ pathDestroy path+ return xs++convertPathElement :: Pattern -> PathElement -> IO ()+convertPathElement pat (MoveTo x y) = meshPatternMoveTo pat x y+convertPathElement pat (LineTo x y) = meshPatternLineTo pat x y+convertPathElement pat (CurveTo x1 y1 x2 y2 x3 y3) = meshPatternCurveTo pat x1 y1 x2 y2 x3 y3+convertPathElement _ ClosePath = return ()++#endif+
Graphics/Rendering/Cairo/Types.chs view
@@ -19,7 +19,7 @@ , Matrix(Matrix), MatrixPtr , Cairo(Cairo), unCairo , Surface(Surface), withSurface, mkSurface, manageSurface- , Pattern(Pattern), unPattern+ , Pattern(Pattern), withPattern, mkPattern, clonePattern , Status(..) , Operator(..) , Antialias(..)@@ -39,7 +39,7 @@ , HintStyle(..) , HintMetrics(..) , FontOptions(..), withFontOptions, mkFontOptions- , Path(..), unPath+ , Path, PathElement(..) #if CAIRO_CHECK_VERSION(1,10,0) , RectangleInt(..) , RegionOverlap(..)@@ -49,6 +49,8 @@ , Format(..) , Extend(..) , Filter(..)+ , SurfaceType(..)+ , PatternType(..) , cIntConv , cFloatConv@@ -58,6 +60,7 @@ , cFromEnum , peekFloatConv , withFloatConv+ , peekIntConv ) where @@ -92,14 +95,34 @@ foreign import ccall unsafe "&cairo_surface_destroy" surfaceDestroy :: FinalizerPtr Surface ++{#enum cairo_surface_type_t as SurfaceType {underscoreToCase} deriving(Eq,Read,Show) #}+ -- | Patterns can be simple solid colors, various kinds of gradients or -- bitmaps. The current pattern for a 'Render' context is used by the 'stroke', -- 'fill' and paint operations. These operations composite the current pattern -- with the target surface using the currently selected 'Operator'. ---{#pointer *pattern_t as Pattern newtype#}-unPattern (Pattern x) = x+{#pointer *pattern_t as Pattern foreign newtype#}+withPattern (Pattern x) = withForeignPtr x +foreign import ccall unsafe "&cairo_pattern_destroy"+ patternDestroy :: FinalizerPtr Pattern++mkPattern :: Ptr Pattern -> IO Pattern+mkPattern ptr = Pattern <$> newForeignPtr patternDestroy ptr++clonePattern :: Ptr Pattern -> IO Pattern+clonePattern ptr = patternReference ptr >>= mkPattern++{#fun pattern_reference as patternReference { castPtr `Ptr Pattern' } -> `Ptr Pattern' castPtr #}+++++{#enum cairo_pattern_type_t as PatternType {underscoreToCase} deriving(Eq,Read,Show) #}++ -- | Cairo status. -- -- * 'Status' is used to indicate errors that can occur when using@@ -323,14 +346,11 @@ -- -- http://cairographics.org/manual/bindings-path.html ----- {#enum path_data_type_t as PathDataType {underscoreToCase}#}------ type Point = (Double, Double)--- data PathData = PathMoveTo Point--- | PathLineTo Point--- | PathCurveTo Point Point Point--- | PathClose-+data PathElement = MoveTo Double Double+ | LineTo Double Double+ | CurveTo Double Double Double Double Double Double+ | ClosePath+ deriving (Eq, Read, Show) -- | A Cairo path. -- -- * A path is a sequence of drawing operations that are accumulated until@@ -338,9 +358,9 @@ -- useful when drawing lines with special join styles and -- 'Graphics.Rendering.Cairo.closePath'. ---{#pointer *path_t as Path newtype#}-unPath (Path x) = x+type Path = [PathElement] + #if CAIRO_CHECK_VERSION(1,10,0) {#pointer *rectangle_int_t as RectangleIntPtr -> RectangleInt#}@@ -391,12 +411,16 @@ {#enum content_t as Content {underscoreToCase} deriving(Eq,Show)#} -data Format = FormatARGB32- | FormatRGB24- | FormatA8- | FormatA1- deriving (Enum,Show,Eq)+{#enum format_t as Format {CAIRO_FORMAT_ARGB32 as FormatARGB32,+ CAIRO_FORMAT_RGB24 as FormatRGB24,+ CAIRO_FORMAT_A8 as FormatA8,+ CAIRO_FORMAT_A1 as FormatA1,+ CAIRO_FORMAT_RGB16_565 as FormatRGB16565,+ CAIRO_FORMAT_RGB30 as FormatRGB30+ } deriving (Eq,Show)+#} + -- | FIXME: We should find out about this. {#enum extend_t as Extend {underscoreToCase} deriving(Eq,Show)#} @@ -440,3 +464,7 @@ {-# INLINE withArrayFloatConv #-} withArrayFloatConv :: (Storable b, RealFloat a, RealFloat b) => [a] -> (Ptr b -> IO b1) -> IO b1 withArrayFloatConv = withArray . map (cFloatConv)++{-# INLINE peekIntConv #-}+peekIntConv :: (Storable a, Integral a, Integral b) => Ptr a -> IO b+peekIntConv = liftM cIntConv . peek
cairo.cabal view
@@ -1,5 +1,5 @@ Name: cairo-Version: 0.13.5.0+Version: 0.13.6.0 License: BSD3 License-file: COPYRIGHT Copyright: (c) 2001-2010 The Gtk2Hs Team, (c) Paolo Martini 2005, (c) Abraham Egnor 2003, 2004, (c) Aetion Technologies LLC 2004@@ -53,7 +53,7 @@ custom-setup setup-depends: base >= 4.6,- Cabal >= 1.24 && < 2.3,+ Cabal >= 1.24 && < 2.5, gtk2hs-buildtools >= 0.13.2.0 && < 0.14 Library@@ -94,4 +94,4 @@ if flag(cairo_svg) pkgconfig-depends: cairo-svg if os(darwin) || os(freebsd)- cpp-options: -D__attribute__(A)= -D_Nullable= -D_Nonnull=+ cpp-options: -D__attribute__(A)= -D_Nullable= -D_Nonnull= -D_Noreturn=
demo/gtk3/Makefile view
@@ -1,6 +1,7 @@ -PROGS = drawing drawing2 starandring text clock graph sdldrawing-SOURCES = Drawing.hs Drawing2.hs StarAndRing.hs Text.hs Clock.hs Graph.hs CairoSDL.hs+PROGS = drawing drawing2 starandring text clock graph sdldrawing paths+SOURCES = Drawing.hs Drawing2.hs StarAndRing.hs Text.hs Clock.hs Graph.hs CairoSDL.hs Paths.hs+OUTPUT = paths.png all : $(PROGS) @@ -25,9 +26,12 @@ sdldrawing : CairoSDL.hs $(HC_RULE) +paths : Paths.hs+ $(HC_RULE)+ HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS) clean:- rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS) $(OUTPUT) HC=ghc