diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for simple-cairo + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Yoshikuni Jujo (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Yoshikuni Jujo nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# simple-cairo diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/data/HaskellLogo.png b/data/HaskellLogo.png new file mode 100644 Binary files /dev/null and b/data/HaskellLogo.png differ diff --git a/simple-cairo.cabal b/simple-cairo.cabal new file mode 100644 --- /dev/null +++ b/simple-cairo.cabal @@ -0,0 +1,169 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 7c3e571101f6a187c78f2a538fd77a1ce529acc5dc775036e798b6c186a1c8bc + +name: simple-cairo +version: 0.1.0.5 +synopsis: Binding to Cairo library +description: Please see the README on GitHub at +category: Graphics +homepage: https://github.com/YoshikuniJujo/simple-cairo#readme +bug-reports: https://github.com/YoshikuniJujo/simple-cairo/issues +author: Yoshikuni Jujo +maintainer: PAF01143@nifty.ne.jp +copyright: Yoshikuni Jujo +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md +data-files: + HaskellLogo.png +data-dir: data + +source-repository head + type: git + location: https://github.com/YoshikuniJujo/simple-cairo + +library + exposed-modules: + Data.CairoContext + Graphics.Cairo.Drawing.CairoPatternT + Graphics.Cairo.Drawing.CairoPatternT.Basic + Graphics.Cairo.Drawing.CairoPatternT.Mesh + Graphics.Cairo.Drawing.CairoPatternT.Setting + Graphics.Cairo.Drawing.CairoT + Graphics.Cairo.Drawing.CairoT.Basic + Graphics.Cairo.Drawing.CairoT.CairoOperatorT + Graphics.Cairo.Drawing.CairoT.Clip + Graphics.Cairo.Drawing.CairoT.Page + Graphics.Cairo.Drawing.CairoT.SaveAndRestore + Graphics.Cairo.Drawing.CairoT.Setting + Graphics.Cairo.Drawing.Extents + Graphics.Cairo.Drawing.Paths + Graphics.Cairo.Drawing.Paths.Basic + Graphics.Cairo.Drawing.Paths.CairoPathT + Graphics.Cairo.Drawing.Paths.CopyAppend + Graphics.Cairo.Drawing.Paths.Relative + Graphics.Cairo.Drawing.Regions + Graphics.Cairo.Drawing.TagsAndLinks + Graphics.Cairo.Drawing.Text + Graphics.Cairo.Drawing.Transformations + Graphics.Cairo.Exception + Graphics.Cairo.Surfaces.CairoSurfaceT + Graphics.Cairo.Surfaces.CairoSurfaceT.Internal + Graphics.Cairo.Surfaces.CairoSurfaceTypeT + Graphics.Cairo.Surfaces.CairoSurfaceTypeT.Template + Graphics.Cairo.Surfaces.CairoWriteFuncT + Graphics.Cairo.Surfaces.ImageSurfaces + Graphics.Cairo.Surfaces.PdfSurfaces + Graphics.Cairo.Surfaces.PdfSurfaces.Template + Graphics.Cairo.Surfaces.PngSupport + Graphics.Cairo.Surfaces.SvgSurfaces + Graphics.Cairo.Surfaces.SvgSurfaces.Template + Graphics.Cairo.Template + Graphics.Cairo.Types + Graphics.Cairo.Utilities.CairoMatrixT + Graphics.Cairo.Utilities.CairoMatrixT.Internal + Graphics.Cairo.Utilities.Types + Graphics.Cairo.Values + other-modules: + Paths_simple_cairo + hs-source-dirs: + src + pkgconfig-depends: + cairo + build-depends: + base >=4.7 && <5 + , bytestring + , c-struct + , cairo-image + , exception-hierarchy + , primitive + , stm + , template-haskell + , text + , union-angle + , union-color + , vector + default-language: Haskell2010 + +test-suite cairo-image-test + type: exitcode-stdio-1.0 + main-is: cairo-image-test.hs + other-modules: + Title + Paths_simple_cairo + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bytestring + , c-struct + , cairo-image + , exception-hierarchy + , primitive + , simple-cairo + , stm + , template-haskell + , text + , union-angle + , union-color + , vector + default-language: Haskell2010 + +test-suite exception-test + type: exitcode-stdio-1.0 + main-is: exception.hs + other-modules: + Title + Paths_simple_cairo + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bytestring + , c-struct + , cairo-image + , exception-hierarchy + , primitive + , simple-cairo + , stm + , template-haskell + , text + , union-angle + , union-color + , vector + default-language: Haskell2010 + +test-suite test-rotate + type: exitcode-stdio-1.0 + main-is: test-rotate.hs + other-modules: + Title + Paths_simple_cairo + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bytestring + , c-struct + , cairo-image + , exception-hierarchy + , primitive + , simple-cairo + , stm + , template-haskell + , text + , union-angle + , union-color + , vector + default-language: Haskell2010 diff --git a/src/Data/CairoContext.hs b/src/Data/CairoContext.hs new file mode 100644 --- /dev/null +++ b/src/Data/CairoContext.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Data.CairoContext where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Control.Monad.Primitive + +newtype CairoT r s = CairoT (ForeignPtr (CairoT r s)) deriving Show + +type CairoTIO r = CairoT r RealWorld + +withCairoT :: PrimMonad m => CairoT r (PrimState m) -> (Ptr (CairoT r (PrimState m)) -> IO a) -> m a +withCairoT (CairoT fcr) = unsafeIOToPrim . withForeignPtr fcr diff --git a/src/Graphics/Cairo/Drawing/CairoPatternT.hs b/src/Graphics/Cairo/Drawing/CairoPatternT.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/CairoPatternT.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.CairoPatternT ( + cairoPatternAddColorStopRgb, cairoPatternAddColorStopRgba, + cairoPatternCreateLinear, cairoPatternCreateRadial, + cairoPatternCreateForSurface + ) where + +import Graphics.Cairo.Drawing.CairoPatternT.Basic diff --git a/src/Graphics/Cairo/Drawing/CairoPatternT/Basic.hsc b/src/Graphics/Cairo/Drawing/CairoPatternT/Basic.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/CairoPatternT/Basic.hsc @@ -0,0 +1,304 @@ +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.CairoPatternT.Basic where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Control.Monad.Primitive +import Data.Traversable +import Data.Maybe +import Data.Word +import Data.Color +import System.IO.Unsafe + +import Graphics.Cairo.Exception +import Graphics.Cairo.Surfaces.CairoSurfaceT.Internal + +#include + +class IsCairoPatternT pt where toCairoPatternT :: pt s -> CairoPatternT s + +newtype CairoPatternT s = CairoPatternT (ForeignPtr (CairoPatternT s)) deriving Show + +instance IsCairoPatternT CairoPatternT where toCairoPatternT = id + +makeCairoPatternT :: Ptr (CairoPatternT s) -> IO (CairoPatternT s) +makeCairoPatternT p = CairoPatternT <$> newForeignPtr p (c_cairo_pattern_destroy p) + +returnCairoPatternT :: PrimMonad m => IO (Ptr (CairoPatternT (PrimState m))) -> m (CairoPatternT (PrimState m)) +returnCairoPatternT io = unsafeIOToPrim $ makeCairoPatternT =<< io + +foreign import ccall "cairo_pattern_destroy" c_cairo_pattern_destroy :: + Ptr (CairoPatternT s) -> IO () + +newtype CairoPatternTypeT = CairoPatternTypeT #{type cairo_pattern_type_t} deriving Show + +pattern CairoPatternTypeSolid :: CairoPatternTypeT +pattern CairoPatternTypeSolid <- CairoPatternTypeT #{const CAIRO_PATTERN_TYPE_SOLID} where + CairoPatternTypeSolid = CairoPatternTypeT #{const CAIRO_PATTERN_TYPE_SOLID} + +pattern CairoPatternTypeSurface :: CairoPatternTypeT +pattern CairoPatternTypeSurface <- CairoPatternTypeT #{const CAIRO_PATTERN_TYPE_SURFACE} where + CairoPatternTypeSurface = CairoPatternTypeT #{const CAIRO_PATTERN_TYPE_SURFACE} + +pattern CairoPatternTypeLinear :: CairoPatternTypeT +pattern CairoPatternTypeLinear <- CairoPatternTypeT #{const CAIRO_PATTERN_TYPE_LINEAR} where + CairoPatternTypeLinear = CairoPatternTypeT #{const CAIRO_PATTERN_TYPE_LINEAR} + +pattern CairoPatternTypeRadial :: CairoPatternTypeT +pattern CairoPatternTypeRadial <- CairoPatternTypeT #{const CAIRO_PATTERN_TYPE_RADIAL} where + CairoPatternTypeRadial = CairoPatternTypeT #{const CAIRO_PATTERN_TYPE_RADIAL} + +pattern CairoPatternTypeMesh :: CairoPatternTypeT +pattern CairoPatternTypeMesh <- CairoPatternTypeT #{const CAIRO_PATTERN_TYPE_MESH} where + CairoPatternTypeMesh = CairoPatternTypeT #{const CAIRO_PATTERN_TYPE_MESH} + +pattern CairoPatternTypeRasterSource :: CairoPatternTypeT +pattern CairoPatternTypeRasterSource <- CairoPatternTypeT #{const CAIRO_PATTERN_TYPE_RASTER_SOURCE} where + CairoPatternTypeRasterSource = CairoPatternTypeT #{const CAIRO_PATTERN_TYPE_RASTER_SOURCE} + +cairoPatternGetType :: CairoPatternT s -> CairoPatternTypeT +cairoPatternGetType (CairoPatternT fpt) = unsafePerformIO $ withForeignPtr fpt \pt -> + CairoPatternTypeT <$> c_cairo_pattern_get_type pt + +foreign import ccall "cairo_pattern_get_type" c_cairo_pattern_get_type :: + Ptr (CairoPatternT s) -> IO #{type cairo_pattern_type_t} + +newtype CairoPatternSolidT s = CairoPatternSolidT (ForeignPtr (CairoPatternT s)) deriving Show + +instance IsCairoPatternT CairoPatternSolidT where toCairoPatternT = CairoPatternTSolid + +pattern CairoPatternTSolid :: CairoPatternSolidT s -> CairoPatternT s +pattern CairoPatternTSolid pts <- (cairoPatternSolidT -> Just pts) where + CairoPatternTSolid (CairoPatternSolidT pts) = CairoPatternT pts + +cairoPatternSolidT :: CairoPatternT s -> Maybe (CairoPatternSolidT s) +cairoPatternSolidT pt@(CairoPatternT fpt) = case cairoPatternGetType pt of + CairoPatternTypeSolid -> Just $ CairoPatternSolidT fpt + _ -> Nothing + +cairoPatternCreateRgb :: PrimMonad m => Rgb CDouble -> m (CairoPatternSolidT (PrimState m)) +cairoPatternCreateRgb (RgbDouble r g b) = unsafeIOToPrim do + ppt <- c_cairo_pattern_create_rgb r g b + pt <- CairoPatternSolidT <$> newForeignPtr ppt (c_cairo_pattern_destroy ppt) + pt <$ raiseIfErrorPattern (CairoPatternTSolid pt) + +foreign import ccall "cairo_pattern_create_rgb" c_cairo_pattern_create_rgb :: + CDouble -> CDouble -> CDouble -> IO (Ptr (CairoPatternT s)) + +cairoPatternCreateRgba :: PrimMonad m => Rgba CDouble -> m (CairoPatternSolidT (PrimState m)) +cairoPatternCreateRgba (RgbaDouble r g b a) = unsafeIOToPrim do + ppt <- c_cairo_pattern_create_rgba r g b a + pt <- CairoPatternSolidT <$> newForeignPtr ppt (c_cairo_pattern_destroy ppt) + pt <$ raiseIfErrorPattern (CairoPatternTSolid pt) + +foreign import ccall "cairo_pattern_create_rgba" c_cairo_pattern_create_rgba :: + CDouble -> CDouble -> CDouble -> CDouble -> IO (Ptr (CairoPatternT s)) + +cairoPatternGetRgba :: PrimMonad m => CairoPatternSolidT (PrimState m) -> m (Rgba CDouble) +cairoPatternGetRgba (CairoPatternSolidT fpts) = unsafeIOToPrim $ withForeignPtr fpts \pts -> + alloca \r -> alloca \g -> alloca \b -> alloca \a -> do + cairoStatusToThrowError =<< c_cairo_pattern_get_rgba pts r g b a + rgbaDouble <$> peek r <*> peek g <*> peek b <*> peek a >>= \case + Just rgba -> pure rgba + Nothing -> error $ "(r, g, b, a) = " ++ show (r, g, b, a) + +foreign import ccall "cairo_pattern_get_rgba" c_cairo_pattern_get_rgba :: + Ptr (CairoPatternT s) -> + Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> + IO #{type cairo_status_t} + +class IsCairoPatternT pt => IsCairoPatternGradientT pt where + toCairoPatternGradientT :: pt s -> CairoPatternGradientT s + +newtype CairoPatternGradientT s = CairoPatternGradientT (ForeignPtr (CairoPatternT s)) deriving Show + +instance IsCairoPatternT CairoPatternGradientT where + toCairoPatternT = CairoPatternTGradient + +instance IsCairoPatternGradientT CairoPatternGradientT where + toCairoPatternGradientT = id + +pattern CairoPatternTGradient :: CairoPatternGradientT s -> CairoPatternT s +pattern CairoPatternTGradient ptg <- (cairoPatternGradientT -> Just ptg) where + CairoPatternTGradient (CairoPatternGradientT ptg) = CairoPatternT ptg + +cairoPatternGradientT :: CairoPatternT s -> Maybe (CairoPatternGradientT s) +cairoPatternGradientT pt@(CairoPatternT fpt) = case cairoPatternGetType pt of + CairoPatternTypeLinear -> Just $ CairoPatternGradientT fpt + CairoPatternTypeRadial -> Just $ CairoPatternGradientT fpt + _ -> Nothing + +cairoPatternAddColorStopRgb :: (PrimMonad m, IsCairoPatternGradientT pt) => + pt (PrimState m) -> CDouble -> Rgb CDouble -> m () +cairoPatternAddColorStopRgb (toCairoPatternGradientT -> CairoPatternGradientT fpt) os (RgbDouble r g b) = + unsafeIOToPrim $ withForeignPtr fpt \ppt -> c_cairo_pattern_add_color_stop_rgb ppt os r g b + +foreign import ccall "cairo_pattern_add_color_stop_rgb" c_cairo_pattern_add_color_stop_rgb :: + Ptr (CairoPatternT s) -> CDouble -> CDouble -> CDouble -> CDouble -> IO () + +cairoPatternAddColorStopRgba :: (PrimMonad m, IsCairoPatternGradientT pt) => + pt (PrimState m) -> CDouble -> Rgba CDouble -> m () +cairoPatternAddColorStopRgba (toCairoPatternGradientT -> CairoPatternGradientT fpt) os (RgbaDouble r g b a) = + unsafeIOToPrim $ withForeignPtr fpt \ppt -> c_cairo_pattern_add_color_stop_rgba ppt os r g b a + +foreign import ccall "cairo_pattern_add_color_stop_rgba" c_cairo_pattern_add_color_stop_rgba :: + Ptr (CairoPatternT s) -> CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> IO () + +newtype CairoPatternLinearT s = CairoPatternLinearT (ForeignPtr (CairoPatternT s)) deriving Show + +instance IsCairoPatternGradientT CairoPatternLinearT where + toCairoPatternGradientT = CairoPatternGradientTLinear + +instance IsCairoPatternT CairoPatternLinearT where + toCairoPatternT = CairoPatternTGradient . toCairoPatternGradientT + +pattern CairoPatternGradientTLinear :: CairoPatternLinearT s -> CairoPatternGradientT s +pattern CairoPatternGradientTLinear ptl <- (cairoPatternGradientLinearT -> Just ptl) where + CairoPatternGradientTLinear (CairoPatternLinearT ptl) = CairoPatternGradientT ptl + +cairoPatternGradientLinearT :: CairoPatternGradientT s -> Maybe (CairoPatternLinearT s) +cairoPatternGradientLinearT pt@(CairoPatternGradientT fpt) = case cairoPatternGetType $ CairoPatternTGradient pt of + CairoPatternTypeLinear -> Just $ CairoPatternLinearT fpt + _ -> Nothing + +cairoPatternCreateLinear :: PrimMonad m => + CDouble -> CDouble -> CDouble -> CDouble -> m (CairoPatternLinearT (PrimState m)) +cairoPatternCreateLinear x0 y0 x1 y1 = unsafeIOToPrim + $ CairoPatternLinearT <$> do + p <- c_cairo_pattern_create_linear x0 y0 x1 y1 + newForeignPtr p $ c_cairo_pattern_destroy p + +foreign import ccall "cairo_pattern_create_linear" c_cairo_pattern_create_linear :: + CDouble -> CDouble -> CDouble -> CDouble -> IO (Ptr (CairoPatternT s)) + +cairoPatternGetLinearPoints :: PrimMonad m => + CairoPatternLinearT (PrimState m) -> m ((CDouble, CDouble), (CDouble, CDouble)) +cairoPatternGetLinearPoints (CairoPatternLinearT fpt) = unsafeIOToPrim + $ withForeignPtr fpt \ppt -> alloca \x0 -> alloca \y0 -> alloca \x1 -> alloca \y1 -> do + cs <- c_cairo_pattern_get_linear_points ppt x0 y0 x1 y1 + cairoStatusToThrowError cs + (,) <$> ((,) <$> peek x0 <*> peek y0) <*> ((,) <$> peek x1 <*> peek y1) + +foreign import ccall "cairo_pattern_get_linear_points" c_cairo_pattern_get_linear_points :: + Ptr (CairoPatternT s) -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO #{type cairo_status_t} + +cairoPatternGetColorStopRgbaList :: (PrimMonad m, IsCairoPatternGradientT pt) => + pt (PrimState m) -> m [(CDouble, Rgba CDouble)] +cairoPatternGetColorStopRgbaList pt = cairoPatternGetColorStopCount pt >>= \n -> + for [0 .. n - 1] \i -> cairoPatternGetColorStopRgba pt i + +cairoPatternGetColorStopCount :: (PrimMonad m, IsCairoPatternGradientT pt) => + pt (PrimState m) -> m CInt +cairoPatternGetColorStopCount (toCairoPatternGradientT -> CairoPatternGradientT fpt) = unsafeIOToPrim + $ withForeignPtr fpt \ppt -> alloca \n -> do + cs <- c_cairo_pattern_get_color_stop_count ppt n + cairoStatusToThrowError cs + peek n + +foreign import ccall "cairo_pattern_get_color_stop_count" c_cairo_pattern_get_color_stop_count :: + Ptr (CairoPatternT s) -> Ptr CInt -> IO #{type cairo_status_t} + +cairoPatternGetColorStopRgba :: (PrimMonad m, IsCairoPatternGradientT pt) => + pt (PrimState m) -> CInt -> m (CDouble, Rgba CDouble) +cairoPatternGetColorStopRgba (toCairoPatternGradientT -> CairoPatternGradientT fpt) i = unsafeIOToPrim + $ withForeignPtr fpt \ppt -> alloca \os -> alloca \rd -> alloca \gr -> alloca \bl -> alloca \al -> do + cs <- c_cairo_pattern_get_color_stop_rgba ppt i os rd gr bl al + cairoStatusToThrowError cs + (,) <$> peek os <*> ((\r g b a -> fromJust $ rgbaDouble r g b a) <$> peek rd <*> peek gr <*> peek bl <*> peek al) + +foreign import ccall "cairo_pattern_get_color_stop_rgba" c_cairo_pattern_get_color_stop_rgba :: + Ptr (CairoPatternT s) -> CInt -> + Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO #{type cairo_status_t} + +newtype CairoPatternRadialT s = CairoPatternRadialT (ForeignPtr (CairoPatternT s)) deriving Show + +instance IsCairoPatternT CairoPatternRadialT where + toCairoPatternT = CairoPatternTGradient . toCairoPatternGradientT + +instance IsCairoPatternGradientT CairoPatternRadialT where + toCairoPatternGradientT = CairoPatternGradientTRadial + +pattern CairoPatternGradientTRadial :: CairoPatternRadialT s -> CairoPatternGradientT s +pattern CairoPatternGradientTRadial pt <- (cairoPatternGradientRadialT -> Just pt) where + CairoPatternGradientTRadial (CairoPatternRadialT fpt) = CairoPatternGradientT fpt + +cairoPatternGradientRadialT :: CairoPatternGradientT s -> Maybe (CairoPatternRadialT s) +cairoPatternGradientRadialT pt@(CairoPatternGradientT fpt) = case cairoPatternGetType $ CairoPatternTGradient pt of + CairoPatternTypeRadial -> Just $ CairoPatternRadialT fpt + _ -> Nothing + +cairoPatternCreateRadial :: PrimMonad m => + CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> + m (CairoPatternRadialT (PrimState m)) +cairoPatternCreateRadial cx0 cy0 r0 cx1 cy1 r1 = unsafeIOToPrim + $ CairoPatternRadialT <$> do + p <- c_cairo_pattern_create_radial cx0 cy0 r0 cx1 cy1 r1 + newForeignPtr p $ c_cairo_pattern_destroy p + +foreign import ccall "cairo_pattern_create_radial" c_cairo_pattern_create_radial :: + CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> IO (Ptr (CairoPatternT s)) + +cairoPatternGetRadialCircles :: PrimMonad m => + CairoPatternRadialT (PrimState m) -> m ((CDouble, CDouble, CDouble), (CDouble, CDouble, CDouble)) +cairoPatternGetRadialCircles (CairoPatternRadialT fpt) = unsafeIOToPrim + $ withForeignPtr fpt \ppt -> alloca \x0 -> alloca \y0 -> alloca \r0 -> alloca \x1 -> alloca \y1 -> alloca \r1 -> do + cs <- c_cairo_pattern_get_radial_circles ppt x0 y0 r0 x1 y1 r1 + cairoStatusToThrowError cs + (,) <$> ((,,) <$> peek x0 <*> peek y0 <*> peek r0) <*> ((,,) <$> peek x1 <*> peek y1 <*> peek r1) + +foreign import ccall "cairo_pattern_get_radial_circles" c_cairo_pattern_get_radial_circles :: + Ptr (CairoPatternT s) -> + Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO #{type cairo_status_t} + +newtype CairoPatternSurfaceT s = CairoPatternSurfaceT (ForeignPtr (CairoPatternT s)) deriving Show + +instance IsCairoPatternT CairoPatternSurfaceT where + toCairoPatternT = CairoPatternTSurface + +pattern CairoPatternTSurface :: CairoPatternSurfaceT s -> CairoPatternT s +pattern CairoPatternTSurface pt <- (cairoPatternTSurface -> Just pt) where + CairoPatternTSurface (CairoPatternSurfaceT fpt) = CairoPatternT fpt + +cairoPatternTSurface :: CairoPatternT s -> Maybe (CairoPatternSurfaceT s) +cairoPatternTSurface pt@(CairoPatternT fpt) = case cairoPatternGetType pt of + CairoPatternTypeSurface -> Just $ CairoPatternSurfaceT fpt + _ -> Nothing + +cairoPatternCreateForSurface :: (PrimMonad m, IsCairoSurfaceT sr) => + sr s (PrimState m) -> m (CairoPatternSurfaceT (PrimState m)) +cairoPatternCreateForSurface (toCairoSurfaceT -> CairoSurfaceT fs) = + unsafeIOToPrim $ CairoPatternSurfaceT <$> withForeignPtr fs \ps -> do + p <- c_cairo_pattern_create_for_surface ps + newForeignPtr p $ touchForeignPtr fs >> c_cairo_pattern_destroy p + +foreign import ccall "cairo_pattern_create_for_surface" c_cairo_pattern_create_for_surface :: + Ptr (CairoSurfaceT s ps) -> IO (Ptr (CairoPatternT ps)) + +cairoPatternGetSurface :: PrimMonad m => + CairoPatternSurfaceT (PrimState m) -> m (CairoSurfaceT s (PrimState m)) +cairoPatternGetSurface (CairoPatternSurfaceT fpt) = + unsafeIOToPrim $ CairoSurfaceT <$> withForeignPtr fpt \ppt -> alloca \pps -> do + cairoStatusToThrowError =<< c_cairo_pattern_get_surface ppt pps + p <- c_cairo_surface_reference =<< peek pps + newForeignPtr p $ c_cairo_surface_destroy p + +foreign import ccall "cairo_pattern_get_surface" c_cairo_pattern_get_surface :: + Ptr (CairoPatternT ps) -> Ptr (Ptr (CairoSurfaceT s ps)) -> IO #{type cairo_status_t} + +foreign import ccall "cairo_surface_reference" c_cairo_surface_reference :: + Ptr (CairoSurfaceT s ps) -> IO (Ptr (CairoSurfaceT s ps)) + +raiseIfErrorPattern :: CairoPatternT s -> IO () +raiseIfErrorPattern (CairoPatternT fpt) = withForeignPtr fpt \pt -> + cairoStatusToThrowError =<< c_cairo_pattern_status pt + +foreign import ccall "cairo_pattern_status" c_cairo_pattern_status :: + Ptr (CairoPatternT s) -> IO #{type cairo_status_t} diff --git a/src/Graphics/Cairo/Drawing/CairoPatternT/Mesh.hsc b/src/Graphics/Cairo/Drawing/CairoPatternT/Mesh.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/CairoPatternT/Mesh.hsc @@ -0,0 +1,216 @@ +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.CairoPatternT.Mesh where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Control.Monad +import Control.Monad.Primitive +import Data.Word +import Data.Maybe +import Data.Color + +import Graphics.Cairo.Exception +import Graphics.Cairo.Drawing.Paths.CairoPathT + +#include + +import Graphics.Cairo.Drawing.CairoPatternT.Basic + +newtype CairoPatternMeshT s = CairoPatternMeshT (ForeignPtr (CairoPatternT s)) deriving Show + +instance IsCairoPatternT CairoPatternMeshT where + toCairoPatternT = CairoPatternTMesh + +pattern CairoPatternTMesh :: CairoPatternMeshT s -> CairoPatternT s +pattern CairoPatternTMesh pt <- (cairoPatternMeshT -> Just pt) where + CairoPatternTMesh (CairoPatternMeshT fpt) = CairoPatternT fpt + +cairoPatternMeshT :: CairoPatternT s -> Maybe (CairoPatternMeshT s) +cairoPatternMeshT pt@(CairoPatternT fpt) = case cairoPatternGetType pt of + CairoPatternTypeMesh -> Just $ CairoPatternMeshT fpt + _ -> Nothing + +cairoPatternCreateMesh :: PrimMonad m => m (CairoPatternMeshT (PrimState m)) +cairoPatternCreateMesh = unsafeIOToPrim do + p <- c_cairo_pattern_create_mesh + CairoPatternMeshT <$> newForeignPtr p (c_cairo_pattern_destroy p) + +foreign import ccall "cairo_pattern_create_mesh" c_cairo_pattern_create_mesh :: + IO (Ptr (CairoPatternT s)) + +data Color = ColorRgb (Rgb CDouble) | ColorRgba (Rgba CDouble) deriving Show + +data Point = Point CDouble CDouble deriving Show + +cairoMeshPatternAddPatchDefaultControlPoints3 :: PrimMonad m => CairoPatternMeshT (PrimState m) -> + MoveTo -> LineCurveTo -> LineCurveTo -> CloseTo -> + Color -> Color -> Color -> m () +cairoMeshPatternAddPatchDefaultControlPoints3 pt mv lc1 lc2 cls c0 c1 c2 = do + cairoMeshPatternBeginPatch pt + cairoMeshPatternMoveTo pt mv + cairoMeshPatternLineTo pt `mapM_` [lc1, lc2] + cairoMeshPatternCloseTo pt mv cls + zipWithM_ (cairoMeshPatternSetCornerColor pt) [0 ..] [c0, c1, c2] + cairoMeshPatternEndPatch pt + +cairoMeshPatternAddPatchDefaultControlPoints :: PrimMonad m => + CairoPatternMeshT (PrimState m) -> + MoveTo -> LineCurveTo -> LineCurveTo -> LineCurveTo -> CloseTo -> + Color -> Color -> Color -> Color -> m () +cairoMeshPatternAddPatchDefaultControlPoints pt mv lc1 lc2 lc3 cls c0 c1 c2 c3 = do + cairoMeshPatternBeginPatch pt + cairoMeshPatternMoveTo pt mv + cairoMeshPatternLineTo pt `mapM_` [lc1, lc2, lc3] + cairoMeshPatternCloseTo pt mv cls + zipWithM_ (cairoMeshPatternSetCornerColor pt) [0 ..] [c0, c1, c2, c3] + cairoMeshPatternEndPatch pt + +cairoMeshPatternAddPatch :: PrimMonad m => CairoPatternMeshT (PrimState m) -> + MoveTo -> LineCurveTo -> LineCurveTo -> LineCurveTo -> CloseTo -> + Color -> Color -> Color -> Color -> + Maybe Point -> Maybe Point -> Maybe Point -> Maybe Point -> m () +cairoMeshPatternAddPatch pt mv lc1 lc2 lc3 cls c0 c1 c2 c3 cp0 cp1 cp2 cp3 = do + cairoMeshPatternBeginPatch pt + cairoMeshPatternMoveTo pt mv + cairoMeshPatternLineTo pt `mapM_` [lc1, lc2, lc3] + cairoMeshPatternCloseTo pt mv cls + zipWithM_ (cairoMeshPatternSetCornerColor pt) [0 ..] [c0, c1, c2, c3] + zipWithM_ (cairoMeshPatternSetControlPointMaybe pt) [0 ..] [cp0, cp1, cp2, cp3] + cairoMeshPatternEndPatch pt + +cairoMeshPatternBeginPatch :: PrimMonad m => CairoPatternMeshT (PrimState m) -> m () +cairoMeshPatternBeginPatch (CairoPatternMeshT fpt) = unsafeIOToPrim + $ withForeignPtr fpt c_cairo_mesh_pattern_begin_patch + +foreign import ccall "cairo_mesh_pattern_begin_patch" c_cairo_mesh_pattern_begin_patch :: + Ptr (CairoPatternT s) -> IO () + +cairoMeshPatternEndPatch :: PrimMonad m => CairoPatternMeshT (PrimState m) -> m () +cairoMeshPatternEndPatch (CairoPatternMeshT fpt) = unsafeIOToPrim + $ withForeignPtr fpt c_cairo_mesh_pattern_end_patch + +foreign import ccall "cairo_mesh_pattern_end_patch" c_cairo_mesh_pattern_end_patch :: + Ptr (CairoPatternT s) -> IO () + +cairoMeshPatternMoveTo :: PrimMonad m => + CairoPatternMeshT (PrimState m) -> MoveTo -> m () +cairoMeshPatternMoveTo (CairoPatternMeshT fpt) (MoveTo x y) = unsafeIOToPrim + $ withForeignPtr fpt \ppt -> c_cairo_mesh_pattern_move_to ppt x y + +foreign import ccall "cairo_mesh_pattern_move_to" c_cairo_mesh_pattern_move_to :: + Ptr (CairoPatternT s) -> CDouble -> CDouble -> IO () + +cairoMeshPatternLineTo :: PrimMonad m => + CairoPatternMeshT (PrimState m) -> LineCurveTo -> m () +cairoMeshPatternLineTo (CairoPatternMeshT fpt) = \case + LineTo x y -> unsafeIOToPrim + $ withForeignPtr fpt \ppt -> c_cairo_mesh_pattern_line_to ppt x y + CurveTo x1 y1 x2 y2 x3 y3 -> unsafeIOToPrim + $ withForeignPtr fpt \ppt -> c_cairo_mesh_pattern_curve_to ppt x1 y1 x2 y2 x3 y3 + +cairoMeshPatternCloseTo :: PrimMonad m => + CairoPatternMeshT (PrimState m) -> MoveTo -> CloseTo -> m () +cairoMeshPatternCloseTo (CairoPatternMeshT fpt) (MoveTo x0 y0) cls = + unsafeIOToPrim $ withForeignPtr fpt \ppt -> case cls of + CloseLineTo -> pure () + CloseCurveTo x1 y1 x2 y2 -> c_cairo_mesh_pattern_curve_to ppt x1 y1 x2 y2 x0 y0 + +foreign import ccall "cairo_mesh_pattern_line_to" c_cairo_mesh_pattern_line_to :: + Ptr (CairoPatternT s) -> CDouble -> CDouble -> IO () + +foreign import ccall "cairo_mesh_pattern_curve_to" c_cairo_mesh_pattern_curve_to :: + Ptr (CairoPatternT s) -> + CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> IO () + +cairoMeshPatternSetControlPointMaybe :: PrimMonad m => + CairoPatternMeshT (PrimState m) -> CUInt -> Maybe Point -> m () +cairoMeshPatternSetControlPointMaybe (CairoPatternMeshT fpt) i = \case + Nothing -> pure () + Just (Point x y) -> unsafeIOToPrim + $ withForeignPtr fpt \ppt -> c_cairo_mesh_pattern_set_control_point ppt i x y + +foreign import ccall "cairo_mesh_pattern_set_control_point" c_cairo_mesh_pattern_set_control_point :: + Ptr (CairoPatternT s) -> CUInt -> CDouble -> CDouble -> IO () + +cairoMeshPatternSetCornerColor :: PrimMonad m => + CairoPatternMeshT (PrimState m) -> CUInt -> Color -> m () +cairoMeshPatternSetCornerColor (CairoPatternMeshT fpt) i c = + unsafeIOToPrim $ withForeignPtr fpt \ppt -> case c of + ColorRgb (RgbDouble r g b) -> c_cairo_mesh_pattern_set_corner_color_rgb ppt i r g b + ColorRgba (RgbaDouble r g b a) -> c_cairo_mesh_pattern_set_corner_color_rgba ppt i r g b a + +foreign import ccall "cairo_mesh_pattern_set_corner_color_rgb" c_cairo_mesh_pattern_set_corner_color_rgb :: + Ptr (CairoPatternT s) -> CUInt -> CDouble -> CDouble -> CDouble -> IO () + +foreign import ccall "cairo_mesh_pattern_set_corner_color_rgba" c_cairo_mesh_pattern_set_corner_color_rgba :: + Ptr (CairoPatternT s) -> CUInt -> CDouble -> CDouble -> CDouble -> CDouble -> IO () + +cairoMeshPatternGetPatchCount :: PrimMonad m => + CairoPatternMeshT (PrimState m) -> m CUInt +cairoMeshPatternGetPatchCount (CairoPatternMeshT fpt) = + unsafeIOToPrim $ withForeignPtr fpt \ppt -> alloca \cnt -> do + cairoStatusToThrowError =<< c_cairo_mesh_pattern_get_patch_count ppt cnt + peek cnt + +foreign import ccall "cairo_mesh_pattern_get_patch_count" c_cairo_mesh_pattern_get_patch_count :: + Ptr (CairoPatternT s) -> Ptr CUInt -> IO #{type cairo_status_t} + +cairoMeshPatternGetPath :: PrimMonad m => + CairoPatternMeshT (PrimState m) -> CUInt -> m CairoPatchPathT +cairoMeshPatternGetPath (CairoPatternMeshT fpt) i = + unsafeIOToPrim $ withForeignPtr fpt \ppt -> + mkCairoPatchPathT =<< c_cairo_mesh_pattern_get_path ppt i + +foreign import ccall "cairo_mesh_pattern_get_path" c_cairo_mesh_pattern_get_path :: + Ptr (CairoPatternT s) -> CUInt -> IO (Ptr CairoPathT) + +cairoMeshPatternGetControlPoint :: PrimMonad m => + CairoPatternMeshT (PrimState m) -> CUInt -> CUInt -> m Point +cairoMeshPatternGetControlPoint (CairoPatternMeshT fpt) i j = + unsafeIOToPrim $ withForeignPtr fpt \ppt -> alloca \x -> alloca \y -> do + cairoStatusToThrowError =<< c_cairo_mesh_pattern_get_control_point ppt i j x y + Point <$> peek x <*> peek y + +foreign import ccall "cairo_mesh_pattern_get_control_point" c_cairo_mesh_pattern_get_control_point :: + Ptr (CairoPatternT s) -> CUInt -> CUInt -> Ptr CDouble -> Ptr CDouble -> IO #{type cairo_status_t} + +cairoMeshPatternGetCornerColorRgba :: PrimMonad m => + CairoPatternMeshT (PrimState m) -> CUInt -> CUInt -> m (Rgba CDouble) +cairoMeshPatternGetCornerColorRgba (CairoPatternMeshT fpt) i j = + unsafeIOToPrim $ withForeignPtr fpt \ppt -> alloca \r -> alloca \g -> alloca \b -> alloca \a -> do + cairoStatusToThrowError =<< c_cairo_mesh_pattern_get_corner_color_rgba ppt i j r g b a + fromJust <$> (rgbaDouble <$> peek r <*> peek g <*> peek b <*> peek a) + +foreign import ccall "cairo_mesh_pattern_get_corner_color_rgba" c_cairo_mesh_pattern_get_corner_color_rgba :: + Ptr (CairoPatternT s) -> CUInt -> CUInt -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO #{type cairo_status_t} + +cairoMeshPatternGetPatch1 :: PrimBase m => CairoPatternMeshT (PrimState m) -> CUInt -> + m (CairoPatchPathT, (Rgba CDouble, Rgba CDouble, Rgba CDouble, Rgba CDouble), (Point, Point, Point, Point)) +cairoMeshPatternGetPatch1 pt i = do + pth <- unsafeInterleave $ cairoMeshPatternGetPath pt i + (unsafeInterleave . cairoMeshPatternGetCornerColorRgba pt i) `mapM` [0, 1, 2, 3] >>= \case + [c0, c1, c2, c3] -> + (unsafeInterleave . cairoMeshPatternGetControlPoint pt i) `mapMLazy` [0, 1, 2, 3] >>= \case + [p0, p1, p2, p3] -> pure (pth, (c0, c1, c2, c3), (p0, p1, p2, p3)) + _ -> error "never occur" + _ -> error "never occur" + +forLazy :: PrimBase m => [a] -> (a -> m b) -> m [b] +forLazy [] _ = pure [] +forLazy (x : xs) f = unsafeInterleave $ (:) <$> f x <*> forLazy xs f + +mapMLazy :: PrimBase m => (a -> m b) -> [a] -> m [b] +mapMLazy = flip forLazy + +cairoMeshPatternGetPatchList :: PrimBase m => CairoPatternMeshT (PrimState m) -> + m [(CairoPatchPathT, (Rgba CDouble, Rgba CDouble, Rgba CDouble, Rgba CDouble), (Point, Point, Point, Point))] +cairoMeshPatternGetPatchList pt = do + n <- cairoMeshPatternGetPatchCount pt + forLazy [0 .. n - 1] $ unsafeInterleave . cairoMeshPatternGetPatch1 pt diff --git a/src/Graphics/Cairo/Drawing/CairoPatternT/Setting.hsc b/src/Graphics/Cairo/Drawing/CairoPatternT/Setting.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/CairoPatternT/Setting.hsc @@ -0,0 +1,118 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.CairoPatternT.Setting where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Control.Monad.Primitive +import Data.Word +import Graphics.Cairo.Drawing.CairoPatternT.Basic +import Graphics.Cairo.Utilities.CairoMatrixT.Internal + +#include + +class CairoPatternSetting s where + cairoPatternSet :: (PrimMonad m, IsCairoPatternT pt) => pt (PrimState m) -> s -> m () + cairoPatternGet :: (PrimMonad m, IsCairoPatternT pt) => pt (PrimState m) -> m s + +newtype CairoExtendT = CairoExtendT #{type cairo_extend_t} deriving Show + +pattern CairoExtendNone :: CairoExtendT +pattern CairoExtendNone <- CairoExtendT #{const CAIRO_EXTEND_NONE} where + CairoExtendNone = CairoExtendT #{const CAIRO_EXTEND_NONE} + +pattern CairoExtendRepeat :: CairoExtendT +pattern CairoExtendRepeat <- CairoExtendT #{const CAIRO_EXTEND_REPEAT} where + CairoExtendRepeat = CairoExtendT #{const CAIRO_EXTEND_REPEAT} + +pattern CairoExtendReflect :: CairoExtendT +pattern CairoExtendReflect <- CairoExtendT #{const CAIRO_EXTEND_REFLECT} where + CairoExtendReflect = CairoExtendT #{const CAIRO_EXTEND_REFLECT} + +pattern CairoExtendPad :: CairoExtendT +pattern CairoExtendPad <- CairoExtendT #{const CAIRO_EXTEND_PAD} where + CairoExtendPad = CairoExtendT #{const CAIRO_EXTEND_PAD} + +instance CairoPatternSetting CairoExtendT where + cairoPatternSet = cairoPatternSetExtend + cairoPatternGet = cairoPatternGetExtend + +cairoPatternSetExtend :: (PrimMonad m, IsCairoPatternT pt) => pt (PrimState m) -> CairoExtendT -> m () +cairoPatternSetExtend (toCairoPatternT -> CairoPatternT fpt) (CairoExtendT ex) = + unsafeIOToPrim $ withForeignPtr fpt \ppt -> c_cairo_pattern_set_extend ppt ex + +foreign import ccall "cairo_pattern_set_extend" c_cairo_pattern_set_extend :: + Ptr (CairoPatternT s) -> #{type cairo_extend_t} -> IO () + +cairoPatternGetExtend :: (PrimMonad m, IsCairoPatternT pt) => pt (PrimState m) -> m CairoExtendT +cairoPatternGetExtend (toCairoPatternT -> CairoPatternT fpt) = + unsafeIOToPrim $ CairoExtendT <$> withForeignPtr fpt c_cairo_pattern_get_extend + +foreign import ccall "cairo_pattern_get_extend" c_cairo_pattern_get_extend :: + Ptr (CairoPatternT s) -> IO #{type cairo_extend_t} + +newtype CairoFilterT = CairoFilterT #{type cairo_filter_t} deriving Show + +pattern CairoFilterFast :: CairoFilterT +pattern CairoFilterFast <- CairoFilterT #{const CAIRO_FILTER_FAST} where + CairoFilterFast = CairoFilterT #{const CAIRO_FILTER_FAST} + +pattern CairoFilterGood :: CairoFilterT +pattern CairoFilterGood <- CairoFilterT #{const CAIRO_FILTER_GOOD} where + CairoFilterGood = CairoFilterT #{const CAIRO_FILTER_GOOD} + +pattern CairoFilterBest :: CairoFilterT +pattern CairoFilterBest <- CairoFilterT #{const CAIRO_FILTER_BEST} where + CairoFilterBest = CairoFilterT #{const CAIRO_FILTER_BEST} + +pattern CairoFilterNearest :: CairoFilterT +pattern CairoFilterNearest <- CairoFilterT #{const CAIRO_FILTER_NEAREST} where + CairoFilterNearest = CairoFilterT #{const CAIRO_FILTER_NEAREST} + +pattern CairoFilterBilinear :: CairoFilterT +pattern CairoFilterBilinear <- CairoFilterT #{const CAIRO_FILTER_BILINEAR} where + CairoFilterBilinear = CairoFilterT #{const CAIRO_FILTER_BILINEAR} + +pattern CairoFilterGaussian :: CairoFilterT +pattern CairoFilterGaussian <- CairoFilterT #{const CAIRO_FILTER_GAUSSIAN} where + CairoFilterGaussian = CairoFilterT #{const CAIRO_FILTER_GAUSSIAN} + +instance CairoPatternSetting CairoFilterT where + cairoPatternSet = cairoPatternSetFilter + cairoPatternGet = cairoPatternGetFilter + +cairoPatternSetFilter :: (PrimMonad m, IsCairoPatternT pt) => + pt (PrimState m) -> CairoFilterT -> m () +cairoPatternSetFilter (toCairoPatternT -> CairoPatternT fpt) (CairoFilterT flt) = + unsafeIOToPrim $ withForeignPtr fpt \ppt -> c_cairo_pattern_set_filter ppt flt + +foreign import ccall "cairo_pattern_set_filter" c_cairo_pattern_set_filter :: + Ptr (CairoPatternT s) -> #{type cairo_filter_t} -> IO () + +cairoPatternGetFilter :: (PrimMonad m, IsCairoPatternT pt) => + pt (PrimState m) -> m CairoFilterT +cairoPatternGetFilter (toCairoPatternT -> CairoPatternT fpt) = + unsafeIOToPrim $ CairoFilterT <$> withForeignPtr fpt c_cairo_pattern_get_filter + +foreign import ccall "cairo_pattern_get_filter" c_cairo_pattern_get_filter :: + Ptr (CairoPatternT s) -> IO #{type cairo_filter_t} + +cairoPatternSetMatrix :: (PrimMonad m, IsCairoPatternT pt, IsCairoMatrixT mtx) => + pt (PrimState m) -> mtx (PrimState m) -> m () +cairoPatternSetMatrix (toCairoPatternT -> CairoPatternT fpt) (toCairoMatrixT -> CairoMatrixT fmtx) = + unsafeIOToPrim $ withForeignPtr fpt \ppt -> withForeignPtr fmtx \pmtx -> + c_cairo_pattern_set_matrix ppt pmtx + +foreign import ccall "cairo_pattern_set_matrix" c_cairo_pattern_set_matrix :: + Ptr (CairoPatternT s) -> Ptr (CairoMatrixT s) -> IO () + +cairoPatternGetMatrix :: (PrimMonad m, IsCairoPatternT pt) => + pt (PrimState m) -> m (CairoMatrixT (PrimState m)) +cairoPatternGetMatrix (toCairoPatternT -> CairoPatternT fpt) = (CairoMatrixT <$>) + $ cairoMatrixAlloc \pmtx -> withForeignPtr fpt \ppt -> + c_cairo_pattern_get_matrix ppt pmtx + +foreign import ccall "cairo_pattern_get_matrix" c_cairo_pattern_get_matrix :: + Ptr (CairoPatternT s) -> Ptr (CairoMatrixT s) -> IO () diff --git a/src/Graphics/Cairo/Drawing/CairoT.hsc b/src/Graphics/Cairo/Drawing/CairoT.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/CairoT.hsc @@ -0,0 +1,47 @@ +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.CairoT ( + -- * Basic + cairoCreate, + -- * Push and Pop Group + cairoPushGroup, cairoPopGroup, cairoPopGroupToSource, + -- * Set Source + cairoSetSourceRgb, cairoSetSourceRgba, cairoSetSource, cairoSetSourceSurface, + -- * Set Attribute + cairoSetLineWidth, + -- * Verb + cairoFill, cairoMask, cairoPaint, cairoPaintWithAlpha, + cairoStroke, cairoStrokePreserve, cairoStrokeExtents, + ) where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Control.Monad.Primitive + +import Graphics.Cairo.Exception + +import Graphics.Cairo.Drawing.CairoT.Basic +import Graphics.Cairo.Drawing.CairoT.Setting + +import Data.CairoContext + +import Graphics.Cairo.Drawing.CairoPatternT.Basic + +foreign import ccall "cairo_push_group" c_cairo_push_group :: + Ptr (CairoT r s) -> IO () + +cairoPushGroup :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoPushGroup = (`withCairoT` c_cairo_push_group) + +foreign import ccall "cairo_pop_group_to_source" c_cairo_pop_group_to_source :: + Ptr (CairoT r s) -> IO () + +cairoPopGroupToSource :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoPopGroupToSource cr@(CairoT fcr) = unsafeIOToPrim $ withForeignPtr fcr c_cairo_pop_group_to_source <* raiseIfError cr + +foreign import ccall "cairo_pop_group" c_cairo_pop_group :: + Ptr (CairoT r s) -> IO (Ptr (CairoPatternT s)) + +cairoPopGroup :: PrimMonad m => CairoT r s -> m (CairoPatternT s) +cairoPopGroup (CairoT fcr) = unsafeIOToPrim $ makeCairoPatternT =<< withForeignPtr fcr c_cairo_pop_group diff --git a/src/Graphics/Cairo/Drawing/CairoT/Basic.hsc b/src/Graphics/Cairo/Drawing/CairoT/Basic.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/CairoT/Basic.hsc @@ -0,0 +1,157 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.CairoT.Basic ( + cairoCreate, + cairoSetSourceRgb, cairoSetSourceRgba, cairoSetSource, cairoSetSourceSurface, + cairoStroke, cairoStrokePreserve, cairoStrokeExtents, cairoInStroke, + cairoFill, cairoFillPreserve, cairoFillExtents, cairoInFill, + cairoPaint, cairoPaintWithAlpha, + cairoMask, cairoMaskSurface, + + CairoExtents(..), + pattern CairoExtentsLeftTopWidthHeight, cairoExtentsLeft, cairoExtentsTop, cairoExtentsWidth, cairoExtentsHeight + ) where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr, addForeignPtrFinalizer) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Control.Monad.Primitive +import Control.Concurrent.STM +import Data.Int + +import Graphics.Cairo.Surfaces.CairoSurfaceT.Internal +import Graphics.Cairo.Exception +import Graphics.Cairo.Drawing.Extents + +import Data.Color +import Data.CairoContext + +import Graphics.Cairo.Drawing.CairoPatternT.Basic + +#include + +cairoCreate :: (PrimMonad m, IsCairoSurfaceT sr) => + sr s (PrimState m) -> m (CairoT r (PrimState m)) +cairoCreate sr_ = unsafeIOToPrim do + cr <- withForeignPtr sr c_cairo_create >>= \pcr -> + CairoT <$> newForeignPtr pcr (do + atomically (readTChan =<< ck) + putStrLn "begin CairoT destroy" + c_cairo_destroy pcr + putStrLn "end CairoT destroy") + cr <$ raiseIfError cr + where + CairoSurfaceT sr = toCairoSurfaceT sr_ + ck = cairoSurfaceTFinishChecker sr_ + +foreign import ccall "cairo_create" + c_cairo_create :: Ptr (CairoSurfaceT s ps) -> IO (Ptr (CairoT r ps)) +foreign import ccall "cairo_destroy" c_cairo_destroy :: Ptr (CairoT r s) -> IO () + +cairoSetSourceRgb :: PrimMonad m => CairoT r (PrimState m) -> Rgb CDouble -> m () +cairoSetSourceRgb cr (RgbDouble r g b) = + withCairoT cr \pcr -> c_cairo_set_source_rgb pcr r g b + +foreign import ccall "cairo_set_source_rgb" c_cairo_set_source_rgb :: + Ptr (CairoT r s) -> CDouble -> CDouble -> CDouble -> IO () + +cairoSetSourceRgba :: PrimMonad m => CairoT r (PrimState m) -> Rgba CDouble -> m () +cairoSetSourceRgba cr (RgbaDouble r g b a) = + withCairoT cr \pcr -> c_cairo_set_source_rgba pcr r g b a + +foreign import ccall "cairo_set_source_rgba" c_cairo_set_source_rgba :: + Ptr (CairoT r s) -> CDouble -> CDouble -> CDouble -> CDouble -> IO () + +cairoSetSource :: (PrimMonad m, IsCairoPatternT pt) => CairoT r s -> pt s -> m () +cairoSetSource cr@(CairoT fcr) (toCairoPatternT -> CairoPatternT fpt) = unsafeIOToPrim do + withForeignPtr fcr \pcr -> withForeignPtr fpt \ppt -> c_cairo_set_source pcr ppt >> raiseIfError cr + addForeignPtrFinalizer fcr $ touchForeignPtr fpt + +foreign import ccall "cairo_set_source" c_cairo_set_source :: + Ptr (CairoT r s) -> Ptr (CairoPatternT s) -> IO () + +cairoSetSourceSurface :: (PrimMonad m, IsCairoSurfaceT sr) => + CairoT r ps -> sr s ps -> CDouble -> CDouble -> m () +cairoSetSourceSurface (CairoT fcr) (toCairoSurfaceT -> CairoSurfaceT fsr) x y = unsafeIOToPrim + $ withForeignPtr fcr \cr -> withForeignPtr fsr \sr -> c_cairo_set_source_surface cr sr x y + +foreign import ccall "cairo_set_source_surface" c_cairo_set_source_surface :: + Ptr (CairoT r ps) -> Ptr (CairoSurfaceT s ps) -> CDouble -> CDouble -> IO () + +cairoStroke :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoStroke = (`withCairoT` c_cairo_stroke) + +foreign import ccall "cairo_stroke" c_cairo_stroke :: Ptr (CairoT r s) -> IO () + +cairoStrokePreserve :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoStrokePreserve = (`withCairoT` c_cairo_stroke_preserve) + +foreign import ccall "cairo_stroke_preserve" c_cairo_stroke_preserve :: Ptr (CairoT r s) -> IO () + +cairoStrokeExtents :: PrimMonad m => CairoT r (PrimState m) -> m CairoExtents +cairoStrokeExtents = flip withCairoT \pcr -> alloca \x1 -> alloca \y1 -> alloca \x2 -> alloca \y2 -> do + c_cairo_stroke_extents pcr x1 y1 x2 y2 + CairoExtentsLeftTopRightBottom <$> peek x1 <*> peek y1 <*> peek x2 <*> peek y2 + +foreign import ccall "cairo_stroke_extents" c_cairo_stroke_extents :: + Ptr (CairoT r s) -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO () + +cairoInStroke :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> CDouble -> m Bool +cairoInStroke cr x y = withCairoT cr \pcr -> (/= 0) <$> c_cairo_in_stroke pcr x y + +foreign import ccall "cairo_in_stroke" c_cairo_in_stroke :: + Ptr (CairoT r s) -> CDouble -> CDouble -> IO #{type cairo_bool_t} + +cairoFill :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoFill = (`withCairoT` c_cairo_fill) + +foreign import ccall "cairo_fill" c_cairo_fill :: Ptr (CairoT r s) -> IO () + +cairoFillPreserve :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoFillPreserve = (`withCairoT` c_cairo_fill_preserve) + +foreign import ccall "cairo_fill_preserve" c_cairo_fill_preserve :: Ptr (CairoT r s) -> IO () + +cairoFillExtents :: PrimMonad m => CairoT r (PrimState m) -> m CairoExtents +cairoFillExtents = flip withCairoT \pcr -> alloca \x1 -> alloca \y1 -> alloca \x2 -> alloca \y2 -> do + c_cairo_fill_extents pcr x1 y1 x2 y2 + CairoExtentsLeftTopRightBottom <$> peek x1 <*> peek y1 <*> peek x2 <*> peek y2 + +foreign import ccall "cairo_fill_extents" c_cairo_fill_extents :: + Ptr (CairoT r s) -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO () + +cairoInFill :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> CDouble -> m Bool +cairoInFill cr x y = withCairoT cr \pcr -> (/= 0) <$> c_cairo_in_fill pcr x y + +foreign import ccall "cairo_in_fill" c_cairo_in_fill :: + Ptr (CairoT r s) -> CDouble -> CDouble -> IO #{type cairo_bool_t} + +cairoPaint :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoPaint cr = withCairoT cr \pcr -> c_cairo_paint pcr >> raiseIfError cr + +foreign import ccall "cairo_paint" c_cairo_paint :: Ptr (CairoT r s) -> IO () + +cairoPaintWithAlpha :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> m () +cairoPaintWithAlpha cr a = withCairoT cr \pcr -> c_cairo_paint_with_alpha pcr a + +foreign import ccall "cairo_paint_with_alpha" c_cairo_paint_with_alpha :: + Ptr (CairoT r s) -> CDouble -> IO () + +cairoMask :: (PrimMonad m, IsCairoPatternT pt) => CairoT r s -> pt s -> m () +cairoMask cr@(CairoT fcr) (toCairoPatternT -> CairoPatternT fpt) = unsafeIOToPrim + $ withForeignPtr fcr \pcr -> withForeignPtr fpt (c_cairo_mask pcr) >> raiseIfError cr + +foreign import ccall "cairo_mask" c_cairo_mask :: + Ptr (CairoT r s) -> Ptr (CairoPatternT s) -> IO () + +cairoMaskSurface :: (PrimMonad m, IsCairoSurfaceT sr) => CairoT r ps -> sr s ps -> CDouble -> CDouble -> m () +cairoMaskSurface (CairoT fcr) (toCairoSurfaceT -> CairoSurfaceT fsr) x y = unsafeIOToPrim + $ withForeignPtr fcr \cr -> withForeignPtr fsr \sr -> c_cairo_mask_surface cr sr x y + +foreign import ccall "cairo_mask_surface" c_cairo_mask_surface :: + Ptr (CairoT r ps) -> Ptr (CairoSurfaceT s ps) -> CDouble -> CDouble -> IO () diff --git a/src/Graphics/Cairo/Drawing/CairoT/CairoOperatorT.hsc b/src/Graphics/Cairo/Drawing/CairoT/CairoOperatorT.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/CairoT/CairoOperatorT.hsc @@ -0,0 +1,126 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.CairoT.CairoOperatorT where + +import Data.Word + +#include + +newtype Operator = Operator #{type cairo_operator_t} deriving Show + +pattern OperatorClear :: Operator +pattern OperatorClear <- Operator #{const CAIRO_OPERATOR_CLEAR} where + OperatorClear = Operator #{const CAIRO_OPERATOR_CLEAR} + +pattern OperatorSource :: Operator +pattern OperatorSource <- Operator #{const CAIRO_OPERATOR_SOURCE} where + OperatorSource = Operator #{const CAIRO_OPERATOR_SOURCE} + +pattern OperatorOver :: Operator +pattern OperatorOver <- Operator #{const CAIRO_OPERATOR_OVER} where + OperatorOver = Operator #{const CAIRO_OPERATOR_OVER} + +pattern OperatorIn :: Operator +pattern OperatorIn <- Operator #{const CAIRO_OPERATOR_IN} where + OperatorIn = Operator #{const CAIRO_OPERATOR_IN} + +pattern OperatorOut :: Operator +pattern OperatorOut <- Operator #{const CAIRO_OPERATOR_OUT} where + OperatorOut = Operator #{const CAIRO_OPERATOR_OUT} + +pattern OperatorAtop :: Operator +pattern OperatorAtop <- Operator #{const CAIRO_OPERATOR_ATOP} where + OperatorAtop = Operator #{const CAIRO_OPERATOR_ATOP} + +pattern OperatorDest :: Operator +pattern OperatorDest <- Operator #{const CAIRO_OPERATOR_DEST} where + OperatorDest = Operator #{const CAIRO_OPERATOR_DEST} + +pattern OperatorDestOver :: Operator +pattern OperatorDestOver <- Operator #{const CAIRO_OPERATOR_DEST_OVER} where + OperatorDestOver = Operator #{const CAIRO_OPERATOR_DEST_OVER} + +pattern OperatorDestIn :: Operator +pattern OperatorDestIn <- Operator #{const CAIRO_OPERATOR_DEST_IN} where + OperatorDestIn = Operator #{const CAIRO_OPERATOR_DEST_IN} + +pattern OperatorDestOut :: Operator +pattern OperatorDestOut <- Operator #{const CAIRO_OPERATOR_DEST_OUT} where + OperatorDestOut = Operator #{const CAIRO_OPERATOR_DEST_OUT} + +pattern OperatorDestAtop :: Operator +pattern OperatorDestAtop <- Operator #{const CAIRO_OPERATOR_DEST_ATOP} where + OperatorDestAtop = Operator #{const CAIRO_OPERATOR_DEST_ATOP} + +pattern OperatorXor :: Operator +pattern OperatorXor <- Operator #{const CAIRO_OPERATOR_XOR} where + OperatorXor = Operator #{const CAIRO_OPERATOR_XOR} + +pattern OperatorAdd :: Operator +pattern OperatorAdd <- Operator #{const CAIRO_OPERATOR_ADD} where + OperatorAdd = Operator #{const CAIRO_OPERATOR_ADD} + +pattern OperatorSaturate :: Operator +pattern OperatorSaturate <- Operator #{const CAIRO_OPERATOR_ADD} where + OperatorSaturate = Operator #{const CAIRO_OPERATOR_SATURATE} + +pattern OperatorMultiply :: Operator +pattern OperatorMultiply <- Operator #{const CAIRO_OPERATOR_MULTIPLY} where + OperatorMultiply = Operator #{const CAIRO_OPERATOR_MULTIPLY} + +pattern OperatorScreen :: Operator +pattern OperatorScreen <- Operator #{const CAIRO_OPERATOR_SCREEN} where + OperatorScreen = Operator #{const CAIRO_OPERATOR_SCREEN} + +pattern OperatorOverlay :: Operator +pattern OperatorOverlay <- Operator #{const CAIRO_OPERATOR_OVERLAY} where + OperatorOverlay = Operator #{const CAIRO_OPERATOR_OVERLAY} + +pattern OperatorDarken :: Operator +pattern OperatorDarken <- Operator #{const CAIRO_OPERATOR_DARKEN} where + OperatorDarken = Operator #{const CAIRO_OPERATOR_DARKEN} + +pattern OperatorLighten :: Operator +pattern OperatorLighten <- Operator #{const CAIRO_OPERATOR_LIGHTEN} where + OperatorLighten = Operator #{const CAIRO_OPERATOR_LIGHTEN} + +pattern OperatorColorDodge :: Operator +pattern OperatorColorDodge <- Operator #{const CAIRO_OPERATOR_COLOR_DODGE} where + OperatorColorDodge = Operator #{const CAIRO_OPERATOR_COLOR_DODGE} + +pattern OperatorColorBurn :: Operator +pattern OperatorColorBurn <- Operator #{const CAIRO_OPERATOR_COLOR_BURN} where + OperatorColorBurn = Operator #{const CAIRO_OPERATOR_COLOR_BURN} + +pattern OperatorHardLight :: Operator +pattern OperatorHardLight <- Operator #{const CAIRO_OPERATOR_HARD_LIGHT} where + OperatorHardLight = Operator #{const CAIRO_OPERATOR_HARD_LIGHT} + +pattern OperatorSoftLight :: Operator +pattern OperatorSoftLight <- Operator #{const CAIRO_OPERATOR_SOFT_LIGHT} where + OperatorSoftLight = Operator #{const CAIRO_OPERATOR_SOFT_LIGHT} + +pattern OperatorDifference :: Operator +pattern OperatorDifference <- Operator #{const CAIRO_OPERATOR_DIFFERENCE} where + OperatorDifference = Operator #{const CAIRO_OPERATOR_DIFFERENCE} + +pattern OperatorExclusion :: Operator +pattern OperatorExclusion <- Operator #{const CAIRO_OPERATOR_EXCLUSION} where + OperatorExclusion = Operator #{const CAIRO_OPERATOR_EXCLUSION} + +pattern OperatorHslHue :: Operator +pattern OperatorHslHue <- Operator #{const CAIRO_OPERATOR_HSL_HUE} where + OperatorHslHue = Operator #{const CAIRO_OPERATOR_HSL_HUE} + +pattern OperatorHslSaturation :: Operator +pattern OperatorHslSaturation <- Operator #{const CAIRO_OPERATOR_HSL_SATURATION} where + OperatorHslSaturation = Operator #{const CAIRO_OPERATOR_HSL_SATURATION} + +pattern OperatorHslColor :: Operator +pattern OperatorHslColor <- Operator #{const CAIRO_OPERATOR_HSL_COLOR} where + OperatorHslColor = Operator #{const CAIRO_OPERATOR_HSL_COLOR} + +pattern OperatorHslLuminosity :: Operator +pattern OperatorHslLuminosity <- Operator #{const CAIRO_OPERATOR_HSL_LUMINOSITY} where + OperatorHslLuminosity = Operator #{const CAIRO_OPERATOR_HSL_LUMINOSITY} diff --git a/src/Graphics/Cairo/Drawing/CairoT/Clip.hsc b/src/Graphics/Cairo/Drawing/CairoT/Clip.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/CairoT/Clip.hsc @@ -0,0 +1,43 @@ +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.CairoT.Clip where + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.Marshal +import Foreign.Storable +import Control.Monad.Primitive +import Data.Int +import Data.CairoContext +import Graphics.Cairo.Drawing.Extents + +#include + +cairoClip, cairoClipPreserve :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoClip = (`withCairoT` c_cairo_clip) +cairoClipPreserve = (`withCairoT` c_cairo_clip_preserve) + +foreign import ccall "cairo_clip" c_cairo_clip :: Ptr (CairoT r s) -> IO () + +foreign import ccall "cairo_clip_preserve" c_cairo_clip_preserve :: Ptr (CairoT r s) -> IO () + +cairoClipExtents :: PrimMonad m => CairoT r (PrimState m) -> m CairoExtents +cairoClipExtents = flip withCairoT \pcr -> alloca \x1 -> alloca \y1 -> alloca \x2 -> alloca \y2 -> do + c_cairo_clip_extents pcr x1 y1 x2 y2 + CairoExtentsLeftTopRightBottom <$> peek x1 <*> peek y1 <*> peek x2 <*> peek y2 + +foreign import ccall "cairo_clip_extents" c_cairo_clip_extents :: + Ptr (CairoT r s) -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO () + +cairoInClip :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> CDouble -> m Bool +cairoInClip cr x y = withCairoT cr \pcr -> (/= 0) <$> c_cairo_in_clip pcr x y + +foreign import ccall "cairo_in_clip" c_cairo_in_clip :: + Ptr (CairoT r s) -> CDouble -> CDouble -> IO #{type cairo_bool_t} + +cairoResetClip :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoResetClip = (`withCairoT` c_cairo_reset_clip) + +foreign import ccall "cairo_reset_clip" c_cairo_reset_clip :: + Ptr (CairoT r s) -> IO () diff --git a/src/Graphics/Cairo/Drawing/CairoT/Page.hs b/src/Graphics/Cairo/Drawing/CairoT/Page.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/CairoT/Page.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.CairoT.Page where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Control.Monad.Primitive +import Data.CairoContext + +cairoCopyPage :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoCopyPage (CairoT fcr) = + unsafeIOToPrim $ withForeignPtr fcr c_cairo_copy_page + +foreign import ccall "cairo_copy_page" c_cairo_copy_page :: + Ptr (CairoT r s) -> IO () + +cairoShowPage :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoShowPage (CairoT fcr) = + unsafeIOToPrim $ withForeignPtr fcr c_cairo_show_page + +foreign import ccall "cairo_show_page" c_cairo_show_page :: + Ptr (CairoT r s) -> IO () diff --git a/src/Graphics/Cairo/Drawing/CairoT/SaveAndRestore.hs b/src/Graphics/Cairo/Drawing/CairoT/SaveAndRestore.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/CairoT/SaveAndRestore.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.CairoT.SaveAndRestore where + +import Foreign.Ptr +import Control.Monad.Primitive +import Data.CairoContext + +cairoSave :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoSave = (`withCairoT` c_cairo_save) + +foreign import ccall "cairo_save" c_cairo_save :: Ptr (CairoT r s) -> IO () + +cairoRestore :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoRestore = (`withCairoT` c_cairo_restore) + +foreign import ccall "cairo_restore" c_cairo_restore :: Ptr (CairoT r s) -> IO () diff --git a/src/Graphics/Cairo/Drawing/CairoT/Setting.hsc b/src/Graphics/Cairo/Drawing/CairoT/Setting.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/CairoT/Setting.hsc @@ -0,0 +1,154 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIOnS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.CairoT.Setting where + +import Foreign.Ptr +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Control.Monad.Primitive +import Data.Word +import Data.CairoContext +import Graphics.Cairo.Exception + +import Graphics.Cairo.Drawing.CairoT.CairoOperatorT + +#include + +class CairoSetting s where + cairoSet :: PrimMonad m => CairoT r (PrimState m) -> s -> m () + cairoGet :: PrimMonad m => CairoT r (PrimState m) -> m s + +newtype LineWidth = LineWidth { getLineWidth :: CDouble } deriving Show + +instance CairoSetting LineWidth where + cairoSet cr = cairoSetLineWidth cr . getLineWidth + cairoGet cr = LineWidth <$> withCairoT cr c_cairo_get_line_width + +cairoSetLineWidth :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> m () +cairoSetLineWidth cr w = withCairoT cr \pcr -> c_cairo_set_line_width pcr w + +foreign import ccall "cairo_set_line_width" c_cairo_set_line_width :: + Ptr (CairoT r s) -> CDouble -> IO () + +foreign import ccall "cairo_get_line_width" c_cairo_get_line_width :: + Ptr (CairoT r s) -> IO CDouble + +data Dash = Dash [CDouble] CDouble deriving Show + +instance CairoSetting Dash where + cairoSet cr (Dash ds ofs) = cairoSetDash cr ds ofs + cairoGet cr = uncurry Dash <$> cairoGetDash cr + +cairoSetDash :: PrimMonad m => CairoT r (PrimState m) -> [CDouble] -> CDouble -> m () +cairoSetDash cr ds ofs = withCairoT cr \pcr -> withArrayLen ds \lds pds -> do + c_cairo_set_dash pcr pds (fromIntegral lds) ofs + raiseIfError cr + +foreign import ccall "cairo_set_dash" c_cairo_set_dash :: + Ptr (CairoT r s) -> Ptr CDouble -> CInt -> CDouble -> IO () + +cairoGetDash :: PrimMonad m => CairoT r (PrimState m) -> m ([CDouble], CDouble) +cairoGetDash cr = withCairoT cr \pcr -> do + ln <- fromIntegral <$> c_cairo_get_dash_count pcr + allocaArray ln \ds -> alloca \ofs -> do + c_cairo_get_dash pcr ds ofs + (,) <$> peekArray ln ds <*> peek ofs + +foreign import ccall "cairo_get_dash_count" c_cairo_get_dash_count :: Ptr (CairoT r s) -> IO CInt + +foreign import ccall "cairo_get_dash" c_cairo_get_dash :: + Ptr (CairoT r s) -> Ptr CDouble -> Ptr CDouble -> IO () + +newtype FillRule = FillRule #{type cairo_fill_rule_t} deriving Show + +pattern FillRuleWinding :: FillRule +pattern FillRuleWinding <- FillRule #{const CAIRO_FILL_RULE_WINDING} where + FillRuleWinding = FillRule #{const CAIRO_FILL_RULE_WINDING} + +pattern FillRuleEvenOdd :: FillRule +pattern FillRuleEvenOdd <- FillRule #{const CAIRO_FILL_RULE_EVEN_ODD} where + FillRuleEvenOdd = FillRule #{const CAIRO_FILL_RULE_EVEN_ODD} + +instance CairoSetting FillRule where + cairoSet cr (FillRule fr) = withCairoT cr \pcr -> c_cairo_set_fill_rule pcr fr + cairoGet cr = FillRule <$> withCairoT cr c_cairo_get_fill_rule + +foreign import ccall "cairo_set_fill_rule" c_cairo_set_fill_rule :: + Ptr (CairoT r s) -> #{type cairo_fill_rule_t} -> IO () + +foreign import ccall "cairo_get_fill_rule" c_cairo_get_fill_rule :: + Ptr (CairoT r s) -> IO #{type cairo_fill_rule_t} + +newtype LineCap = LineCap { + getLineCap :: #{type cairo_line_cap_t} } deriving Show + +pattern LineCapButt :: LineCap +pattern LineCapButt <- LineCap #{const CAIRO_LINE_CAP_BUTT} where + LineCapButt = LineCap #{const CAIRO_LINE_CAP_BUTT} + +pattern LineCapRound :: LineCap +pattern LineCapRound <- LineCap #{const CAIRO_LINE_CAP_ROUND} where + LineCapRound = LineCap #{const CAIRO_LINE_CAP_ROUND} + +pattern LineCapSquare :: LineCap +pattern LineCapSquare <- LineCap #{const CAIRO_LINE_CAP_SQUARE} where + LineCapSquare = LineCap #{const CAIRO_LINE_CAP_SQUARE} + +instance CairoSetting LineCap where + cairoSet cr (LineCap c) = withCairoT cr (`c_cairo_set_line_cap` c) + cairoGet cr = LineCap <$> withCairoT cr c_cairo_get_line_cap + +foreign import ccall "cairo_set_line_cap" c_cairo_set_line_cap :: + Ptr (CairoT r s) -> #{type cairo_line_cap_t} -> IO () + +foreign import ccall "cairo_get_line_cap" c_cairo_get_line_cap :: + Ptr (CairoT r s) -> IO #{type cairo_line_cap_t} + +newtype LineJoin = LineJoin #{type cairo_line_join_t} deriving Show + +pattern LineJoinMiter :: LineJoin +pattern LineJoinMiter <- LineJoin #{const CAIRO_LINE_JOIN_MITER} where + LineJoinMiter = LineJoin #{const CAIRO_LINE_JOIN_MITER} + +pattern LineJoinRound :: LineJoin +pattern LineJoinRound <- LineJoin #{const CAIRO_LINE_JOIN_ROUND} where + LineJoinRound = LineJoin #{const CAIRO_LINE_JOIN_ROUND} + +pattern LineJoinBevel :: LineJoin +pattern LineJoinBevel <- LineJoin #{const CAIRO_LINE_JOIN_BEVEL} where + LineJoinBevel = LineJoin #{const CAIRO_LINE_JOIN_BEVEL} + +instance CairoSetting LineJoin where + cairoSet cr (LineJoin j) = withCairoT cr (`c_cairo_set_line_join` j) + cairoGet cr = LineJoin <$> withCairoT cr c_cairo_get_line_join + +foreign import ccall "cairo_set_line_join" c_cairo_set_line_join :: + Ptr (CairoT r s) -> #{type cairo_line_join_t} -> IO () + +foreign import ccall "cairo_get_line_join" c_cairo_get_line_join :: + Ptr (CairoT r s) -> IO #{type cairo_line_join_t} + +newtype MiterLimit = MiterLimit CDouble deriving Show + +instance CairoSetting MiterLimit where + cairoSet cr (MiterLimit ml) = withCairoT cr (`c_cairo_set_miter_limit` ml) + cairoGet cr = MiterLimit <$> withCairoT cr c_cairo_get_miter_limit + +foreign import ccall "cairo_set_miter_limit" c_cairo_set_miter_limit :: + Ptr (CairoT r s) -> CDouble -> IO () + +foreign import ccall "cairo_get_miter_limit" c_cairo_get_miter_limit :: + Ptr (CairoT r s) -> IO CDouble + +instance CairoSetting Operator where + cairoSet cr (Operator o) = withCairoT cr (`c_cairo_set_operator` o) + cairoGet cr = Operator <$> withCairoT cr c_cairo_get_operator + +foreign import ccall "cairo_set_operator" c_cairo_set_operator :: + Ptr (CairoT r s) -> #{type cairo_operator_t} -> IO () + +foreign import ccall "cairo_get_operator" c_cairo_get_operator :: + Ptr (CairoT r s) -> IO #{type cairo_operator_t} diff --git a/src/Graphics/Cairo/Drawing/Extents.hs b/src/Graphics/Cairo/Drawing/Extents.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/Extents.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.Extents where + +import Foreign.C.Types + +data CairoExtents = CairoExtentsLeftTopRightBottom { + cairoExtentsLeftX :: CDouble, + cairoExtentsTopY :: CDouble, + cairoExtentsRightX :: CDouble, + cairoExtentsBottomY :: CDouble } deriving Show + +pattern CairoExtentsLeftTopWidthHeight :: CDouble -> CDouble -> CDouble -> CDouble -> CairoExtents +pattern CairoExtentsLeftTopWidthHeight { + cairoExtentsLeft, cairoExtentsTop, + cairoExtentsWidth, cairoExtentsHeight } <- + (cairoExtentsLeftTopWidthHeight -> (cairoExtentsLeft, cairoExtentsTop, cairoExtentsWidth, cairoExtentsHeight)) where + CairoExtentsLeftTopWidthHeight l t w h = CairoExtentsLeftTopRightBottom l t (l + w) (t + h) + +cairoExtentsLeftTopWidthHeight :: CairoExtents -> (CDouble, CDouble, CDouble, CDouble) +cairoExtentsLeftTopWidthHeight (CairoExtentsLeftTopRightBottom l t r b) = (l, t, r - l, b - t) diff --git a/src/Graphics/Cairo/Drawing/Paths.hs b/src/Graphics/Cairo/Drawing/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/Paths.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.Paths ( + cairoClosePath, cairoArc, cairoLineTo, cairoMoveTo, cairoRectangle, + cairoRelCurveTo, cairoRelLineTo, + + cairoNewPath + ) where + +import Graphics.Cairo.Drawing.Paths.Basic +import Graphics.Cairo.Drawing.Paths.Relative diff --git a/src/Graphics/Cairo/Drawing/Paths/Basic.hs b/src/Graphics/Cairo/Drawing/Paths/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/Paths/Basic.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.Paths.Basic where + +import Foreign.Ptr +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Control.Monad.Primitive +import Data.Angle +import Data.CairoContext + +import Graphics.Cairo.Drawing.Extents + +cairoNewPath :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoNewPath = (`withCairoT` c_cairo_new_path) + +foreign import ccall "cairo_new_path" c_cairo_new_path :: Ptr (CairoT r s) -> IO () + +cairoNewSubPath :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoNewSubPath = (`withCairoT` c_cairo_new_sub_path) + +foreign import ccall "cairo_new_sub_path" c_cairo_new_sub_path :: Ptr (CairoT r s) -> IO () + +cairoMoveTo :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> CDouble -> m () +cairoMoveTo cr x y = withCairoT cr \pcr -> c_cairo_move_to pcr x y + +foreign import ccall "cairo_move_to" c_cairo_move_to :: + Ptr (CairoT r s) -> CDouble -> CDouble -> IO () + +cairoLineTo :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> CDouble -> m () +cairoLineTo cr x y = withCairoT cr \pcr -> c_cairo_line_to pcr x y + +foreign import ccall "cairo_line_to" c_cairo_line_to :: + Ptr (CairoT r s) -> CDouble -> CDouble -> IO () + +cairoCurveTo :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> CDouble -> + CDouble -> CDouble -> CDouble -> CDouble -> m () +cairoCurveTo cr x1 y1 x2 y2 x3 y3 = withCairoT cr \pcr -> c_cairo_curve_to pcr x1 y1 x2 y2 x3 y3 + +foreign import ccall "cairo_curve_to" c_cairo_curve_to :: + Ptr (CairoT r s) -> CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> IO () + +cairoClosePath :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoClosePath = (`withCairoT` c_cairo_close_path) + +foreign import ccall "cairo_close_path" c_cairo_close_path :: + Ptr (CairoT r s) -> IO () + +cairoRectangle :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> CDouble -> CDouble -> CDouble -> m () +cairoRectangle cr x y w h = withCairoT cr \pcr -> c_cairo_rectangle pcr x y w h + +foreign import ccall "cairo_rectangle" c_cairo_rectangle :: + Ptr (CairoT r s) -> CDouble -> CDouble -> CDouble -> CDouble -> IO () + +cairoArc :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> CDouble -> + CDouble -> Angle CDouble -> Angle CDouble -> m () +cairoArc cr xc yc r (Radian a1) (Radian a2) = + withCairoT cr \pcr -> c_cairo_arc pcr xc yc r a1 a2 + +foreign import ccall "cairo_arc" c_cairo_arc :: Ptr (CairoT r s) -> + CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> IO () + +cairoArcNegative :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> CDouble -> + CDouble -> Angle CDouble -> Angle CDouble -> m () +cairoArcNegative cr xc yc r (Radian a1) (Radian a2) = + withCairoT cr \pcr -> c_cairo_arc_negative pcr xc yc r a1 a2 + +foreign import ccall "cairo_arc_negative" c_cairo_arc_negative :: + Ptr (CairoT r s) -> CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> + IO () + +cairoPathExtents :: PrimMonad m => CairoT r (PrimState m) -> m CairoExtents +cairoPathExtents = flip withCairoT \pcr -> alloca \x1 -> alloca \y1 -> alloca \x2 -> alloca \y2 -> do + c_cairo_path_extents pcr x1 y1 x2 y2 + CairoExtentsLeftTopRightBottom <$> peek x1 <*> peek y1 <*> peek x2 <*> peek y2 + +foreign import ccall "cairo_path_extents" c_cairo_path_extents :: + Ptr (CairoT r s) -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO () diff --git a/src/Graphics/Cairo/Drawing/Paths/CairoPathT.hsc b/src/Graphics/Cairo/Drawing/Paths/CairoPathT.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/Paths/CairoPathT.hsc @@ -0,0 +1,393 @@ +{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.Paths.CairoPathT ( + Path(..), CairoPathT, pattern CairoPathT, withCairoPathT, mkCairoPathT, + MoveTo(..), LineCurveTo(..), CloseTo(..), + CairoPatchPathT, pattern CairoPatchPathT, + pattern CairoPathTPatch, mkCairoPatchPathT ) where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Data.Bool +import Data.Word + +import Graphics.Cairo.Exception + +import System.IO.Unsafe + +#include + +newtype CairoPathT = CairoPathT_ (ForeignPtr CairoPathT) deriving Show + +pattern CairoPathT :: [Path] -> CairoPathT +pattern CairoPathT ps <- (unsafePerformIO . cairoPathTPathList -> ps) where + CairoPathT = unsafePerformIO . pathListToCairoPathT + +withCairoPathT :: CairoPathT -> (Ptr CairoPathT -> IO a) -> IO a +withCairoPathT (CairoPathT_ fpth) = withForeignPtr fpth + +mkCairoPathT :: Ptr CairoPathT -> IO CairoPathT +mkCairoPathT p = + CairoPathT_ <$> newForeignPtr p (c_cairo_path_destroy p) + <* (cairoStatusToThrowError =<< cairoPathTStatus p) + +foreign import ccall "cairo_path_destroy" c_cairo_path_destroy :: + Ptr CairoPathT -> IO () + +cairoPathTStatus :: Ptr CairoPathT -> IO #{type cairo_status_t} +cairoPathTStatus = #{peek cairo_path_t, status} + +cairoPathTData ::Ptr CairoPathT -> IO (Ptr CairoPathDataT) +cairoPathTData = #{peek cairo_path_t, data} + +cairoPathTNumData :: Ptr CairoPathT -> IO CInt +cairoPathTNumData = #{peek cairo_path_t, num_data} + +newtype CairoPathDataT = CairoPathDataT (Ptr CairoPathDataT) deriving Show + +nextPtr :: Ptr a -> Int -> Int -> Ptr a +nextPtr p sz al = alignPtr (plusPtr p sz) al + +nextCairoPathDataT :: Ptr CairoPathDataT -> Ptr CairoPathDataT +nextCairoPathDataT p = nextPtr p #{size cairo_path_data_t} #{alignment cairo_path_data_t} + +nextByLength :: Ptr CairoPathDataT -> CInt -> Ptr CairoPathDataT +nextByLength p n | n < 1 = p +nextByLength p n = nextCairoPathDataT $ nextByLength p (n - 1) + +cairoPathDataTHeaderType :: Ptr CairoPathDataT -> IO #{type cairo_path_data_type_t} +cairoPathDataTHeaderType = #{peek cairo_path_data_t, header.type} + +cairoPathDataTHeaderLength :: Ptr CairoPathDataT -> IO CInt +cairoPathDataTHeaderLength = #{peek cairo_path_data_t, header.length} + +cairoPathDataTPointX, cairoPathDataTPointY :: Ptr CairoPathDataT -> IO CDouble +cairoPathDataTPointX = #{peek cairo_path_data_t, point.x} +cairoPathDataTPointY = #{peek cairo_path_data_t, point.y} + +data Path + = PathMoveTo CDouble CDouble + | PathLineTo CDouble CDouble + | PathCurveTo CDouble CDouble CDouble CDouble CDouble CDouble + | PathClosePath + deriving Show + +cairoPathTPathList :: CairoPathT -> IO [Path] +cairoPathTPathList (CairoPathT_ fp) = withForeignPtr fp \p -> do + d <- cairoPathTData p + n <- cairoPathTNumData p + cairoPathDataTPathList d n + +cairoPathDataTPathList :: Ptr CairoPathDataT -> CInt -> IO [Path] +cairoPathDataTPathList _ n | n < 1 = pure [] +cairoPathDataTPathList p n = unsafeInterleaveIO do + pth <- unsafeInterleaveIO $ cairoPathDataTHeaderType p >>= \case + #{const CAIRO_PATH_MOVE_TO} -> PathMoveTo + <$> cairoPathDataTPointX p1 <*> cairoPathDataTPointY p1 + #{const CAIRO_PATH_LINE_TO} -> PathLineTo + <$> cairoPathDataTPointX p1 <*> cairoPathDataTPointY p1 + #{const CAIRO_PATH_CURVE_TO} -> PathCurveTo + <$> cairoPathDataTPointX p1 <*> cairoPathDataTPointY p1 + <*> cairoPathDataTPointX p2 <*> cairoPathDataTPointY p2 + <*> cairoPathDataTPointX p3 <*> cairoPathDataTPointY p3 + #{const CAIRO_PATH_CLOSE_PATH} -> pure PathClosePath + _ -> error "no such path" + ln <- cairoPathDataTHeaderLength p + (pth :) <$> cairoPathDataTPathList (nextByLength p ln) (n - ln) + where + p1 = nextByLength p 1 + p2 = nextByLength p 2 + p3 = nextByLength p 3 + +pathToNumData :: Path -> Int +pathToNumData = \case + PathMoveTo _ _ -> 2; PathLineTo _ _ -> 2; PathCurveTo _ _ _ _ _ _ -> 4; PathClosePath -> 1 + +pathToCairoPathData :: Ptr CairoPathDataT -> Path -> IO () +pathToCairoPathData p = \case + PathMoveTo x y -> do + #{poke cairo_path_data_t, header.type} p (#{const CAIRO_PATH_MOVE_TO} :: #{type cairo_path_data_type_t}) + #{poke cairo_path_data_t, header.length} p (2 :: CInt) + #{poke cairo_path_data_t, point.x} p1 x + #{poke cairo_path_data_t, point.y} p1 y + PathLineTo x y -> do + #{poke cairo_path_data_t, header.type} p (#{const CAIRO_PATH_LINE_TO} :: #{type cairo_path_data_type_t}) + #{poke cairo_path_data_t, header.length} p (2 :: CInt) + #{poke cairo_path_data_t, point.x} p1 x + #{poke cairo_path_data_t, point.y} p1 y + PathCurveTo x1 y1 x2 y2 x3 y3 -> do + #{poke cairo_path_data_t, header.type} p (#{const CAIRO_PATH_CURVE_TO} :: #{type cairo_path_data_type_t}) + #{poke cairo_path_data_t, header.length} p (4 :: CInt) + #{poke cairo_path_data_t, point.x} p1 x1 + #{poke cairo_path_data_t, point.y} p1 y1 + #{poke cairo_path_data_t, point.x} p2 x2 + #{poke cairo_path_data_t, point.y} p2 y2 + #{poke cairo_path_data_t, point.x} p3 x3 + #{poke cairo_path_data_t, point.y} p3 y3 + PathClosePath -> do + #{poke cairo_path_data_t, header.type} p (#{const CAIRO_PATH_CLOSE_PATH} :: #{type cairo_path_data_type_t}) + #{poke cairo_path_data_t, header.length} p (1 :: CInt) + where + p1 = nextByLength p 1 + p2 = nextByLength p 2 + p3 = nextByLength p 3 + +calcAlignedSize :: Int -> Int -> Int +calcAlignedSize sz al = (sz `div` al + signum (sz `mod` al)) * al + +cairoPathDataTSize :: Int +cairoPathDataTSize = calcAlignedSize #{size cairo_path_data_t} #{alignment cairo_path_data_t} + +pathListToCairoPathT :: [Path] -> IO CairoPathT +pathListToCairoPathT pths = CairoPathT_ <$> do + pd <- mallocBytes $ sum (pathToNumData <$> pths) * cairoPathDataTSize + pathListToCairoPathDataT pd pths + p <- mallocBytes #{size cairo_path_t} + #{poke cairo_path_t, status} p (#{const CAIRO_STATUS_SUCCESS} :: #{type cairo_status_t}) + #{poke cairo_path_t, data} p pd + #{poke cairo_path_t, num_data} p $ sum (pathToNumData <$> pths) + newForeignPtr p $ free pd >> free p + +pathListToCairoPathDataT :: Ptr CairoPathDataT -> [Path] -> IO () +pathListToCairoPathDataT pd = \case + [] -> pure () + pth : pths -> pathToCairoPathData pd pth >> pathListToCairoPathDataT (pd `plusPtr` (cairoPathDataTSize * pathToNumData pth)) pths + +cairoPathTCheckPaths :: CairoPathT -> [#{type cairo_path_data_type_t} -> Bool] -> IO Bool +cairoPathTCheckPaths (CairoPathT_ fpth) ts = withForeignPtr fpth \ppth -> do + d <- cairoPathTData ppth + n <- cairoPathTNumData ppth + cairoPathDataCheckPaths d ts n + +cairoPathDataCheckPaths :: Ptr CairoPathDataT -> [#{type cairo_path_data_type_t} -> Bool] -> CInt -> IO Bool +cairoPathDataCheckPaths _ [] 0 = pure True +cairoPathDataCheckPaths _ [] _ = pure False +cairoPathDataCheckPaths _ _ 0 = pure False +cairoPathDataCheckPaths p (t : ts) n = do + b <- t <$> cairoPathDataTHeaderType p + ln <- cairoPathDataTHeaderLength p + (b &&) <$> unsafeInterleaveIO (cairoPathDataCheckPaths (nextByLength p ln) ts (n - ln)) + +cairoPathTGetGoal :: CairoPathT -> Int -> IO (Maybe (CDouble, CDouble)) +cairoPathTGetGoal (CairoPathT_ fpth) i = withForeignPtr fpth \ppth -> do + d <- cairoPathTData ppth + n <- cairoPathTNumData ppth + cairoPathDataTGetGoal d i n + +cairoPathDataTGetGoal :: Ptr CairoPathDataT -> Int -> CInt -> IO (Maybe (CDouble, CDouble)) +cairoPathDataTGetGoal _ _ n | n < 1 = pure Nothing +cairoPathDataTGetGoal p 0 _ = unsafeInterleaveIO do + cairoPathDataTHeaderType p >>= \case + #{const CAIRO_PATH_MOVE_TO} -> (\x y -> Just (x, y)) + <$> cairoPathDataTPointX p1 <*> cairoPathDataTPointY p1 + #{const CAIRO_PATH_LINE_TO} -> (\x y -> Just (x, y)) + <$> cairoPathDataTPointX p1 <*> cairoPathDataTPointY p1 + #{const CAIRO_PATH_CURVE_TO} -> (\x y -> Just (x, y)) + <$> cairoPathDataTPointX p3 <*> cairoPathDataTPointY p3 + #{const CAIRO_PATH_CLOSE_PATH} -> pure Nothing + _ -> error "no such path" + where p1 = nextByLength p 1; p3 = nextByLength p 3 +cairoPathDataTGetGoal p i n = do + ln <- cairoPathDataTHeaderLength p + cairoPathDataTGetGoal (nextByLength p ln) (i - 1) (n - ln) + +lineOrCurve :: #{type cairo_path_data_type_t} -> Bool +lineOrCurve = (||) <$> (== #{const CAIRO_PATH_LINE_TO}) <*> (== #{const CAIRO_PATH_CURVE_TO}) + +isCairoPatchPath :: CairoPathT -> IO Bool +isCairoPatchPath pth = do + b1 <- cairoPathTCheckPaths pth [ + (== #{const CAIRO_PATH_MOVE_TO}), lineOrCurve, lineOrCurve, lineOrCurve, + (== #{const CAIRO_PATH_CLOSE_PATH}) ] + b2 <- cairoPathTCheckPaths pth [ + (== #{const CAIRO_PATH_MOVE_TO}), lineOrCurve, lineOrCurve, lineOrCurve, lineOrCurve ] + b3 <- cairoPathTGetGoal pth 0 >>= \case + Nothing -> pure False + Just (x0, y0) -> cairoPathTGetGoal pth 4 >>= \case + Nothing -> pure False + Just (xc, yc) -> pure $ xc == x0 && yc == y0 + pure $ b1 || (b2 && b3) + +newtype CairoPatchPathT = CairoPatchPathT_ (ForeignPtr CairoPathT) deriving Show + +mkCairoPatchPathT :: Ptr CairoPathT -> IO CairoPatchPathT +mkCairoPatchPathT p = + CairoPatchPathT_ <$> newForeignPtr p (c_cairo_path_destroy p) + <* (cairoStatusToThrowError =<< cairoPathTStatus p) + +pattern CairoPathTPatch :: CairoPatchPathT -> CairoPathT +pattern CairoPathTPatch ppth <- (unsafePerformIO . cairoPathTPatch -> Just ppth) where + CairoPathTPatch (CairoPatchPathT_ fpth) = CairoPathT_ fpth + +cairoPathTPatch :: CairoPathT -> IO (Maybe CairoPatchPathT) +cairoPathTPatch pth@(CairoPathT_ fpth) = + bool Nothing (Just $ CairoPatchPathT_ fpth) <$> isCairoPatchPath pth + +data MoveTo = MoveTo CDouble CDouble deriving Show + +data LineCurveTo + = LineTo CDouble CDouble + | CurveTo CDouble CDouble CDouble CDouble CDouble CDouble + deriving Show + +data CloseTo + = CloseLineTo + | CloseCurveTo CDouble CDouble CDouble CDouble + deriving Show + +pattern CairoPatchPathT :: MoveTo -> LineCurveTo -> LineCurveTo -> LineCurveTo -> CloseTo -> CairoPatchPathT +pattern CairoPatchPathT mt lct1 lct2 lct3 cls <- (unsafePerformIO . drawFromCairoPatchPathT -> (mt, lct1, lct2, lct3, cls)) where + CairoPatchPathT mt lct1 lct2 lct3 cls = unsafePerformIO $ patchPathsToCairoPatchPathT mt lct1 lct2 lct3 cls + +drawFromCairoPatchPathT :: CairoPatchPathT -> IO (MoveTo, LineCurveTo, LineCurveTo, LineCurveTo, CloseTo) +drawFromCairoPatchPathT (CairoPatchPathT_ fpth) = withForeignPtr fpth \ppth -> do + d <- cairoPathTData ppth + n <- cairoPathTNumData ppth + drawFromCairoPathDataT d n >>= \case + (Just r, 0) -> pure r + _ -> error "badbadbad" + +drawFromCairoPathDataT :: Ptr CairoPathDataT -> CInt -> + IO (Maybe (MoveTo, LineCurveTo, LineCurveTo, LineCurveTo, CloseTo), CInt) +drawFromCairoPathDataT p0 n0 = do + (mmt, pn1) <- drawMoveToFromCairoPathDataT p0 n0 + (mlct1, pn2) <- uncurry drawLineCurveToFromCairoPathDataT pn1 + (mlct2, pn3) <- uncurry drawLineCurveToFromCairoPathDataT pn2 + (mlct3, pn4) <- uncurry drawLineCurveToFromCairoPathDataT pn3 + (mcls_, (_p5, n5)) <- uncurry drawCloseToFromCairoPathDataT pn4 + let mcls = case mmt of + Nothing -> error "bad" + Just (MoveTo x0 y0) -> case mcls_ of + Nothing -> error "bad" + Just (m, Nothing) -> Just m + Just (m, Just (x1, y1)) + | x0 == x1 && y0 == y1 -> Just m + | otherwise -> error "bad" + if n5 /= 0 then error "bad" else pure + . (, n5) $ (,,,,) <$> mmt <*> mlct1 <*> mlct2 <*> mlct3 <*> mcls + +drawMoveToFromCairoPathDataT :: Ptr CairoPathDataT -> CInt -> IO (Maybe MoveTo, (Ptr CairoPathDataT, CInt)) +drawMoveToFromCairoPathDataT p n = do + mt <- cairoPathDataTHeaderType p >>= \case + #{const CAIRO_PATH_MOVE_TO} -> Just + <$> (MoveTo <$> cairoPathDataTPointX p1 <*> cairoPathDataTPointY p1) + _ -> pure Nothing + ln <- cairoPathDataTHeaderLength p + if n - ln < 0 then error "bad" else pure (mt, (nextByLength p ln, n - ln)) + where p1 = nextByLength p 1 + +drawLineCurveToFromCairoPathDataT :: Ptr CairoPathDataT -> CInt -> IO (Maybe LineCurveTo, (Ptr CairoPathDataT, CInt)) +drawLineCurveToFromCairoPathDataT p n = do + lct <- cairoPathDataTHeaderType p >>= \case + #{const CAIRO_PATH_LINE_TO} -> Just + <$> (LineTo <$> cairoPathDataTPointX p1 <*> cairoPathDataTPointY p1) + #{const CAIRO_PATH_CURVE_TO} -> (Just <$>) $ CurveTo + <$> cairoPathDataTPointX p1 <*> cairoPathDataTPointY p1 + <*> cairoPathDataTPointX p2 <*> cairoPathDataTPointY p2 + <*> cairoPathDataTPointX p3 <*> cairoPathDataTPointY p3 + _ -> pure Nothing + ln <- cairoPathDataTHeaderLength p + if n - ln < 0 then error "bad" else pure (lct, (nextByLength p ln, n - ln)) + where p1 = nextByLength p 1; p2 = nextByLength p 2; p3 = nextByLength p 3 + +drawCloseToFromCairoPathDataT :: Ptr CairoPathDataT -> CInt -> IO (Maybe (CloseTo, Maybe (CDouble, CDouble)), (Ptr CairoPathDataT, CInt)) +drawCloseToFromCairoPathDataT p n = do + ctgl <- cairoPathDataTHeaderType p >>= \case + #{const CAIRO_PATH_LINE_TO} -> (Just <$>) $ ((CloseLineTo ,) . Just <$>) $ + (,) <$> cairoPathDataTPointX p1 <*> cairoPathDataTPointY p1 + #{const CAIRO_PATH_CURVE_TO} -> (Just <$>) $ (,) + <$> (CloseCurveTo + <$> cairoPathDataTPointX p1 <*> cairoPathDataTPointY p1 + <*> cairoPathDataTPointX p2 <*> cairoPathDataTPointY p2) + <*> (Just <$> ((,) <$> cairoPathDataTPointX p3 <*> cairoPathDataTPointY p3)) + #{const CAIRO_PATH_CLOSE_PATH} -> pure $ Just (CloseLineTo, Nothing) + _ -> pure Nothing + ln <- cairoPathDataTHeaderLength p + if n - ln < 0 then error "bad" else pure (ctgl, (nextByLength p ln, n - ln)) + where [p1, p2, p3] = nextByLength p <$> [1, 2, 3] + +patchPathsToCairoPatchPathT :: + MoveTo -> LineCurveTo -> LineCurveTo -> LineCurveTo -> CloseTo -> IO CairoPatchPathT +patchPathsToCairoPatchPathT mt lct1 lct2 lct3 cls = CairoPatchPathT_ <$> do + pd <- mallocBytes $ patchPathSize mt lct1 lct2 lct3 cls * cairoPathDataTSize + patchPathsToCairoPathDataT pd mt lct1 lct2 lct3 cls + p <- mallocBytes #{size cairo_path_t} + #{poke cairo_path_t, status} p (#{const CAIRO_STATUS_SUCCESS} :: #{type cairo_status_t}) + #{poke cairo_path_t, data} p pd + #{poke cairo_path_t, num_data} p $ patchPathSize mt lct1 lct2 lct3 cls + newForeignPtr p $ free pd >> free p + +patchPathSize :: MoveTo -> LineCurveTo -> LineCurveTo -> LineCurveTo -> CloseTo -> Int +patchPathSize _mt lct1 lct2 lct3 cls = + 2 + sum (lineCurveToSize <$> [lct1, lct2, lct3]) + closeToSize cls + +lineCurveToSize :: LineCurveTo -> Int +lineCurveToSize (LineTo _ _) = 2 +lineCurveToSize (CurveTo _ _ _ _ _ _) = 4 + +closeToSize :: CloseTo -> Int +closeToSize CloseLineTo = 1 +closeToSize (CloseCurveTo _ _ _ _) = 4 + +patchPathsToCairoPathDataT :: Ptr CairoPathDataT -> + MoveTo -> LineCurveTo -> LineCurveTo -> LineCurveTo -> CloseTo -> IO () +patchPathsToCairoPathDataT pd mt lct1 lct2 lct3 cls = do + pd1 <- moveToToCairoPathDataT pd mt + pd2 <- lineCurveToToCairoPathDataT pd1 lct1 + pd3 <- lineCurveToToCairoPathDataT pd2 lct2 + pd4 <- lineCurveToToCairoPathDataT pd3 lct3 + _ <- closeToToCairoPathDataT pd4 mt cls + pure () + +moveToToCairoPathDataT :: Ptr CairoPathDataT -> MoveTo -> IO (Ptr CairoPathDataT) +moveToToCairoPathDataT p (MoveTo x y) = do + #{poke cairo_path_data_t, header.type} p (#{const CAIRO_PATH_MOVE_TO} :: #{type cairo_path_data_type_t}) + #{poke cairo_path_data_t, header.length} p (2 :: CInt) + #{poke cairo_path_data_t, point.x} p1 x + #{poke cairo_path_data_t, point.y} p1 y + pure $ p `plusPtr` (cairoPathDataTSize * 2) + where p1 = nextByLength p 1 + +lineCurveToToCairoPathDataT :: Ptr CairoPathDataT -> LineCurveTo -> IO (Ptr CairoPathDataT) +lineCurveToToCairoPathDataT p = \case + LineTo x y -> do + #{poke cairo_path_data_t, header.type} p (#{const CAIRO_PATH_LINE_TO} :: #{type cairo_path_data_type_t}) + #{poke cairo_path_data_t, header.length} p (2 :: CInt) + #{poke cairo_path_data_t, point.x} p1 x + #{poke cairo_path_data_t, point.y} p1 y + pure $ p `plusPtr` (cairoPathDataTSize * 2) + CurveTo x1 y1 x2 y2 x3 y3 -> do + #{poke cairo_path_data_t, header.type} p (#{const CAIRO_PATH_CURVE_TO} :: #{type cairo_path_data_type_t}) + #{poke cairo_path_data_t, header.length} p (4 :: CInt) + #{poke cairo_path_data_t, point.x} p1 x1 + #{poke cairo_path_data_t, point.y} p1 y1 + #{poke cairo_path_data_t, point.x} p2 x2 + #{poke cairo_path_data_t, point.y} p2 y2 + #{poke cairo_path_data_t, point.x} p3 x3 + #{poke cairo_path_data_t, point.y} p3 y3 + pure $ p `plusPtr` (cairoPathDataTSize * 4) + where p1 = nextByLength p 1; p2 = nextByLength p 2; p3 = nextByLength p 3 + +closeToToCairoPathDataT :: Ptr CairoPathDataT -> MoveTo -> CloseTo -> IO (Ptr CairoPathDataT) +closeToToCairoPathDataT p (MoveTo x0 y0) = \case + CloseLineTo -> do + #{poke cairo_path_data_t, header.type} p (#{const CAIRO_PATH_CLOSE_PATH} :: #{type cairo_path_data_type_t}) + #{poke cairo_path_data_t, header.length} p (1 :: CInt) + pure $ p `plusPtr` cairoPathDataTSize + CloseCurveTo x1 y1 x2 y2 -> do + #{poke cairo_path_data_t, header.type} p (#{const CAIRO_PATH_CURVE_TO} :: #{type cairo_path_data_type_t}) + #{poke cairo_path_data_t, header.length} p (4 :: CInt) + #{poke cairo_path_data_t, point.x} p1 x1 + #{poke cairo_path_data_t, point.y} p1 y1 + #{poke cairo_path_data_t, point.x} p2 x2 + #{poke cairo_path_data_t, point.y} p2 y2 + #{poke cairo_path_data_t, point.x} p3 x0 + #{poke cairo_path_data_t, point.y} p3 y0 + pure $ p `plusPtr` (cairoPathDataTSize * 4) + where p1 = nextByLength p 1; p2 = nextByLength p 2; p3 = nextByLength p 3 diff --git a/src/Graphics/Cairo/Drawing/Paths/CopyAppend.hs b/src/Graphics/Cairo/Drawing/Paths/CopyAppend.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/Paths/CopyAppend.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.Paths.CopyAppend where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Control.Monad.Primitive +import Data.CairoContext +import Graphics.Cairo.Drawing.Paths.CairoPathT + +cairoCopyPath :: PrimMonad m => CairoT r (PrimState m) -> m CairoPathT +cairoCopyPath (CairoT fcr) = unsafeIOToPrim + $ withForeignPtr fcr \pcr -> mkCairoPathT =<< c_cairo_copy_path pcr + +foreign import ccall "cairo_copy_path" c_cairo_copy_path :: + Ptr (CairoT r s) -> IO (Ptr CairoPathT) + +cairoCopyPathFlat :: PrimMonad m => CairoT r (PrimState m) -> m CairoPathT +cairoCopyPathFlat (CairoT fcr) = unsafeIOToPrim + $ withForeignPtr fcr \pcr -> mkCairoPathT =<< c_cairo_copy_path_flat pcr + +foreign import ccall "cairo_copy_path_flat" c_cairo_copy_path_flat :: + Ptr (CairoT r s) -> IO (Ptr CairoPathT) + +cairoAppendPath :: PrimMonad m => + CairoT r (PrimState m) -> CairoPathT -> m () +cairoAppendPath (CairoT fcr) pth = unsafeIOToPrim + $ withForeignPtr fcr \pcr -> withCairoPathT pth \ppth -> + c_cairo_append_path pcr ppth + +foreign import ccall "cairo_append_path" c_cairo_append_path :: + Ptr (CairoT r s) -> Ptr CairoPathT -> IO () diff --git a/src/Graphics/Cairo/Drawing/Paths/Relative.hs b/src/Graphics/Cairo/Drawing/Paths/Relative.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/Paths/Relative.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.Paths.Relative where + +import Foreign.Ptr +import Foreign.C.Types +import Control.Monad.Primitive +import Data.CairoContext +import Graphics.Cairo.Exception + +cairoRelMoveTo :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> CDouble -> m () +cairoRelMoveTo cr dx dy = do + withCairoT cr \pcr -> c_cairo_rel_move_to pcr dx dy + unsafeIOToPrim $ raiseIfError cr + +foreign import ccall "cairo_rel_move_to" c_cairo_rel_move_to :: + Ptr (CairoT r s) -> CDouble -> CDouble -> IO () + +cairoRelLineTo :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> CDouble -> m () +cairoRelLineTo cr x y = do + withCairoT cr \pcr -> c_cairo_rel_line_to pcr x y + unsafeIOToPrim $ raiseIfError cr + +foreign import ccall "cairo_rel_line_to" c_cairo_rel_line_to :: + Ptr (CairoT r s) -> CDouble -> CDouble -> IO () + +cairoRelCurveTo :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> CDouble -> + CDouble -> CDouble -> + CDouble -> CDouble -> m () +cairoRelCurveTo cr dx1 dy1 dx2 dy2 dx3 dy3 = do + withCairoT cr \pcr -> c_cairo_rel_curve_to pcr dx1 dy1 dx2 dy2 dx3 dy3 + unsafeIOToPrim $ raiseIfError cr + +foreign import ccall "cairo_rel_curve_to" c_cairo_rel_curve_to :: + Ptr (CairoT r s) -> CDouble -> CDouble -> + CDouble -> CDouble -> + CDouble -> CDouble -> IO () diff --git a/src/Graphics/Cairo/Drawing/Regions.hs-boot b/src/Graphics/Cairo/Drawing/Regions.hs-boot new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/Regions.hs-boot @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.Regions where + +import Foreign.ForeignPtr + +newtype CairoRegionT s = CairoRegionT (ForeignPtr (CairoRegionT s)) diff --git a/src/Graphics/Cairo/Drawing/Regions.hsc b/src/Graphics/Cairo/Drawing/Regions.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/Regions.hsc @@ -0,0 +1,57 @@ +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.Regions where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.C.Types +import Control.Monad.Primitive + +import Graphics.Cairo.Exception +import Graphics.Cairo.Utilities.Types + +#include + +newtype CairoRegionT s = CairoRegionT (ForeignPtr (CairoRegionT s)) deriving Show + +makeCairoRegionT :: Ptr (CairoRegionT s) -> IO (CairoRegionT s) +makeCairoRegionT p = CairoRegionT <$> newForeignPtr p (c_cairo_region_destroy p) + +foreign import ccall "cairo_region_destroy" c_cairo_region_destroy :: + Ptr (CairoRegionT s) -> IO () + +foreign import ccall "cairo_region_create" c_cairo_region_create :: IO (Ptr (CairoRegionT s)) + +cairoRegionCreate :: PrimMonad m => m (CairoRegionT (PrimState m)) +cairoRegionCreate = unsafeIOToPrim do + r <- makeCairoRegionT =<< c_cairo_region_create + r <$ raiseIfErrorRegion r + +foreign import ccall "cairo_region_create_rectangle" c_cairo_region_create_rectangle :: + Ptr CairoRectangleIntT -> IO (Ptr (CairoRegionT s)) + +cairoRegionCreateRectangle :: PrimMonad m => CairoRectangleIntT -> m (CairoRegionT (PrimState m)) +cairoRegionCreateRectangle (CairoRectangleIntT_ fr) = unsafeIOToPrim $ withForeignPtr fr \prct -> do + r <- makeCairoRegionT =<< c_cairo_region_create_rectangle prct + r <$ raiseIfErrorRegion r + +cairoRegionNumRectangles :: PrimMonad m => CairoRegionT (PrimState m) -> m CInt +cairoRegionNumRectangles (CairoRegionT frg) = + unsafeIOToPrim $ withForeignPtr frg c_cairo_region_num_rectangles + +foreign import ccall "cairo_region_num_rectangles" + c_cairo_region_num_rectangles :: Ptr (CairoRegionT s) -> IO CInt + +cairoRegionGetRectangle :: PrimMonad m => CairoRegionT (PrimState m) -> CInt -> + CairoRectangleIntTPrim (PrimState m) -> m () +cairoRegionGetRectangle rg@(CairoRegionT frg) n (CairoRectangleIntTPrim frc) = + unsafeIOToPrim + $ withForeignPtr frg \prg -> withForeignPtr frc \prc -> do + c_cairo_region_get_rectangle prg n prc + raiseIfErrorRegion rg + +foreign import ccall "cairo_region_get_rectangle" + c_cairo_region_get_rectangle :: + Ptr (CairoRegionT s) -> CInt -> Ptr CairoRectangleIntT -> IO () diff --git a/src/Graphics/Cairo/Drawing/TagsAndLinks.hsc b/src/Graphics/Cairo/Drawing/TagsAndLinks.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/TagsAndLinks.hsc @@ -0,0 +1,72 @@ +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.TagsAndLinks where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.C.String +import Control.Monad.Primitive +import Data.CairoContext + +import Graphics.Cairo.Exception + +#include + +cairoTagLinkInternal :: PrimMonad m => + CairoT r (PrimState m) -> Name -> m a -> m a +cairoTagLinkInternal cr d = cairoTagLinkInternalDestPage cr $ Left d + +cairoTagLinkInternalDestPage :: PrimMonad m => CairoT r (PrimState m) -> + Either Name (Int, Maybe (Double, Double)) -> m a -> m a +cairoTagLinkInternalDestPage cr@(CairoT fcr) d m = do + unsafeIOToPrim $ withForeignPtr fcr \pcr -> do + tl <- newCString #{const_str CAIRO_TAG_LINK} + internalAttributes d $ c_cairo_tag_begin pcr tl + m <* unsafeIOToPrim do + withForeignPtr fcr \pcr -> c_cairo_tag_end pcr + =<< newCString #{const_str CAIRO_TAG_LINK} + raiseIfError cr + +internalAttributes :: Either Name (Int, Maybe (Double, Double)) -> (CString -> IO a) -> IO a +internalAttributes = \case + Left n -> withCString $ "dest='" ++ escape n ++ "'" + Right (p, Nothing) -> withCString $ "page=" ++ show p + Right (p, Just (x, y)) -> withCString $ "page=" ++ show p ++ " pos=[" ++ show x ++ " " ++ show y ++ "]" + +cairoTagLinkUri :: PrimMonad m => CairoT r (PrimState m) -> Uri -> m a -> m a +cairoTagLinkUri cr@(CairoT fcr) u m = do + unsafeIOToPrim $ withForeignPtr fcr \pcr -> do + tl <- newCString #{const_str CAIRO_TAG_LINK} + c_cairo_tag_begin pcr tl =<< newCString ("uri='" ++ escape u ++ "'") + m <* unsafeIOToPrim do + withForeignPtr fcr \pcr -> c_cairo_tag_end pcr + =<< newCString #{const_str CAIRO_TAG_LINK} + raiseIfError cr + +type Uri = String + +cairoTagDestination :: PrimMonad m => CairoT r (PrimState m) -> Name -> m a -> m a +cairoTagDestination cr@(CairoT fcr) n m = do + unsafeIOToPrim $ withForeignPtr fcr \pcr -> do + td <- newCString #{const_str CAIRO_TAG_DEST} + c_cairo_tag_begin pcr td =<< newCString ("name='" ++ escape n ++ "'") + m <* unsafeIOToPrim do + withForeignPtr fcr \pcr -> c_cairo_tag_end pcr + =<< newCString #{const_str CAIRO_TAG_DEST} + raiseIfError cr + +type Name = String + +foreign import ccall "cairo_tag_begin" c_cairo_tag_begin :: + Ptr (CairoT r s) -> CString -> CString -> IO () + +foreign import ccall "cairo_tag_end" c_cairo_tag_end :: + Ptr (CairoT r s) -> CString -> IO () + +escape :: String -> String +escape = \case + "" -> "" + '\'' : cs -> "\\'" ++ escape cs + '\\' : cs -> "\\\\" ++ escape cs + c : cs -> c : escape cs diff --git a/src/Graphics/Cairo/Drawing/Text.hsc b/src/Graphics/Cairo/Drawing/Text.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/Text.hsc @@ -0,0 +1,56 @@ +{-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.Text ( + cairoSelectFontFace, cairoSetFontSize, cairoShowText, cairoTextExtents + ) where + +import Foreign.Ptr +import Foreign.Marshal +import Foreign.Storable +import Foreign.C +import Control.Monad.Primitive +import Data.Word + +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Graphics.Cairo.Types +import Graphics.Cairo.Values + +import Data.CairoContext + +#include + +foreign import ccall "cairo_select_font_face" c_cairo_select_font_face :: + Ptr (CairoT r s) -> CString -> + #{type cairo_font_slant_t} -> #{type cairo_font_weight_t} -> IO () + +cairoSelectFontFace :: PrimMonad m => + CairoT r (PrimState m) -> T.Text -> CairoFontSlantT -> CairoFontWeightT -> m () +cairoSelectFontFace cr ff (CairoFontSlantT sl) (CairoFontWeightT wt) = + withCairoT cr \pcr -> encode ff \cs -> + c_cairo_select_font_face pcr cs sl wt + +foreign import ccall "cairo_set_font_size" c_cairo_set_font_size :: + Ptr (CairoT r s) -> #{type double} -> IO () + +cairoSetFontSize :: PrimMonad m => CairoT r (PrimState m) -> #{type double} -> m () +cairoSetFontSize cr fs = withCairoT cr \pcr -> c_cairo_set_font_size pcr fs + +foreign import ccall "cairo_text_extents" c_cairo_text_extents :: + Ptr (CairoT r s) -> CString -> Ptr CairoTextExtentsT -> IO () + +cairoTextExtents :: PrimMonad m => CairoT r (PrimState m) -> T.Text -> m CairoTextExtentsT +cairoTextExtents cr t = withCairoT cr \pcr -> + encode t \cs -> alloca \p -> c_cairo_text_extents pcr cs p *> peek p + +encode :: T.Text -> (CString -> IO a) -> IO a +encode t = BS.useAsCString $ T.encodeUtf8 t + +foreign import ccall "cairo_show_text" c_cairo_show_text :: + Ptr (CairoT r s) -> CString -> IO () + +cairoShowText :: PrimMonad m => CairoT r (PrimState m) -> T.Text -> m () +cairoShowText cr t = withCairoT cr \pcr -> encode t \cs -> c_cairo_show_text pcr cs diff --git a/src/Graphics/Cairo/Drawing/Transformations.hsc b/src/Graphics/Cairo/Drawing/Transformations.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Drawing/Transformations.hsc @@ -0,0 +1,121 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Drawing.Transformations where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Storable +import Foreign.C.Types +import Foreign.Marshal +import Control.Monad +import Control.Monad.Primitive + +import Data.CairoContext + +import Graphics.Cairo.Utilities.CairoMatrixT.Internal + +#include + +cairoTranslate :: PrimMonad m => + CairoT r (PrimState m) -> CDouble -> CDouble -> m () +cairoTranslate (CairoT fcr) tx ty = + unsafeIOToPrim $ withForeignPtr fcr \cr -> c_cairo_translate cr tx ty + +foreign import ccall "cairo_translate" c_cairo_translate :: + Ptr (CairoT r s) -> CDouble -> CDouble -> IO () + +cairoScale :: PrimMonad m => + CairoT r (PrimState m) -> CDouble -> CDouble -> m () +cairoScale (CairoT fcr) sx sy = + unsafeIOToPrim $ withForeignPtr fcr \cr -> c_cairo_scale cr sx sy + +foreign import ccall "cairo_scale" c_cairo_scale :: + Ptr (CairoT r s) -> CDouble -> CDouble -> IO () + +cairoRotate :: PrimMonad m => CairoT r (PrimState m) -> CDouble -> m () +cairoRotate (CairoT fcr) a = + unsafeIOToPrim $ withForeignPtr fcr \cr -> c_cairo_rotate cr a + +foreign import ccall "cairo_rotate" c_cairo_rotate :: + Ptr (CairoT r s) -> CDouble -> IO () + +cairoTransform :: (PrimMonad m, IsCairoMatrixT mtx) => + CairoT r (PrimState m) -> mtx (PrimState m) -> m () +cairoTransform (CairoT fcr) (toCairoMatrixT -> CairoMatrixT fmtx) = + unsafeIOToPrim $ withForeignPtr fcr \pcr -> withForeignPtr fmtx \pmtx -> + c_cairo_transform pcr pmtx + +foreign import ccall "cairo_transform" c_cairo_transform :: + Ptr (CairoT r s) -> Ptr (CairoMatrixT s) -> IO () + +cairoSetMatrix :: (PrimMonad m, IsCairoMatrixT mtx) => + CairoT r (PrimState m) -> mtx (PrimState m) -> m () +cairoSetMatrix (CairoT fcr) (toCairoMatrixT -> CairoMatrixT fmtx) = + unsafeIOToPrim $ withForeignPtr fcr \pcr -> withForeignPtr fmtx \pmtx -> + c_cairo_set_matrix pcr pmtx + +cairoGetMatrix :: PrimMonad m => CairoT r (PrimState m) -> m (CairoMatrixT (PrimState m)) +cairoGetMatrix (CairoT fcr) = unsafeIOToPrim + $ CairoMatrixT <$> withForeignPtr fcr \pcr -> do + p <- mallocBytes #{size cairo_matrix_t} + c_cairo_get_matrix pcr p + newForeignPtr p (free p) + +foreign import ccall "cairo_set_matrix" c_cairo_set_matrix :: + Ptr (CairoT r s) -> Ptr (CairoMatrixT s) -> IO () + +foreign import ccall "cairo_get_matrix" c_cairo_get_matrix :: + Ptr (CairoT r s) -> Ptr (CairoMatrixT s) -> IO () + +cairoIdentityMatrix :: PrimMonad m => CairoT r (PrimState m) -> m () +cairoIdentityMatrix (CairoT fcr) = + unsafeIOToPrim $ withForeignPtr fcr c_cairo_identity_matrix + +foreign import ccall "cairo_identity_matrix" c_cairo_identity_matrix :: Ptr (CairoT r s) -> IO () + +cairoUserToDevice :: PrimMonad m => + CairoT r (PrimState m) -> CDouble -> CDouble -> m (CDouble, CDouble) +cairoUserToDevice (CairoT fcr) x y = + unsafeIOToPrim $ withForeignPtr fcr \pcr -> alloca \px -> alloca \py -> do + zipWithM_ poke [px, py] [x, y] + c_cairo_user_to_device pcr px py + (,) <$> peek px <*> peek py + +foreign import ccall "cairo_user_to_device" c_cairo_user_to_device :: + Ptr (CairoT r s) -> Ptr CDouble -> Ptr CDouble -> IO () + +cairoUserToDeviceDistance :: PrimMonad m => + CairoT r (PrimState m) -> CDouble -> CDouble -> m (CDouble, CDouble) +cairoUserToDeviceDistance (CairoT fcr) dx dy = + unsafeIOToPrim $ withForeignPtr fcr \pcr -> alloca \px -> alloca \py -> do + zipWithM_ poke [px, py] [dx, dy] + c_cairo_user_to_device_distance pcr px py + (,) <$> peek px <*> peek py + +foreign import ccall "cairo_user_to_device_distance" c_cairo_user_to_device_distance :: + Ptr (CairoT r s) -> Ptr CDouble -> Ptr CDouble -> IO () + +cairoDeviceToUser :: PrimMonad m => + (CairoT r (PrimState m)) -> CDouble -> CDouble -> m (CDouble, CDouble) +cairoDeviceToUser (CairoT fcr) x y = + unsafeIOToPrim $ withForeignPtr fcr \pcr -> alloca \px -> alloca \py -> do + zipWithM_ poke [px, py] [x, y] + c_cairo_device_to_user pcr px py + (,) <$> peek px <*> peek py + +foreign import ccall "cairo_device_to_user" c_cairo_device_to_user :: + Ptr (CairoT r s) -> Ptr CDouble -> Ptr CDouble -> IO () + +cairoDeviceToUserDistance :: PrimMonad m => + (CairoT r (PrimState m)) -> CDouble -> CDouble -> m (CDouble, CDouble) +cairoDeviceToUserDistance (CairoT fcr) dx dy = + unsafeIOToPrim $ withForeignPtr fcr \pcr -> alloca \px -> alloca \py -> do + zipWithM_ poke [px, py] [dx, dy] + c_cairo_device_to_user_distance pcr px py + (,) <$> peek px <*> peek py + +foreign import ccall "cairo_device_to_user_distance" c_cairo_device_to_user_distance :: + Ptr (CairoT r s) -> Ptr CDouble -> Ptr CDouble -> IO () diff --git a/src/Graphics/Cairo/Exception.hsc b/src/Graphics/Cairo/Exception.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Exception.hsc @@ -0,0 +1,119 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Exception where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Control.Exception +import Control.Exception.Hierarchy +import Data.Word + +import Data.CairoContext + +import {-# SOURCE #-} Graphics.Cairo.Drawing.Regions +import Graphics.Cairo.Surfaces.CairoSurfaceT.Internal + +#include + +data CairoStatusNoMemory = CairoStatusNoMemory deriving Show +data CairoStatusInvalidRestore = CairoStatusInvalidRestore deriving Show +data CairoStatusInvalidPopGroup = CairoStatusInvalidPopGroup deriving Show +data CairoStatusNoCurrentPoint = CairoStatusNoCurrentPoint deriving Show +data CairoStatusInvalidMatrix = CairoStatusInvalidMatrix deriving Show +data CairoStatusInvalidStatus = CairoStatusInvalidStatus deriving Show +data CairoStatusNullPointer = CairoStatusNullPointer deriving Show +data CairoStatusInvalidString = CairoStatusInvalidString deriving Show +data CairoStatusInvalidPathData = CairoStatusInvalidPathData deriving Show +data CairoStatusReadError = CairoStatusReadError deriving Show +data CairoStatusWriteError = CairoStatusWriteError deriving Show +data CairoStatusFileNotFound = CairoStatusFileNotFound deriving Show +data CairoStatusInvalidDash = CairoStatusInvalidDash deriving Show +data CairoStatusInvalidMeshConstruction = CairoStatusInvalidMeshConstruction deriving Show +data CairoStatusOthers = CairoStatusOthers #{type cairo_status_t} deriving Show + +exceptionHierarchy Nothing $ ExNode "CairoStatus" [ + ExType ''CairoStatusNoMemory, + ExType ''CairoStatusInvalidRestore, + ExType ''CairoStatusInvalidPopGroup, + ExType ''CairoStatusNoCurrentPoint, + ExType ''CairoStatusInvalidMatrix, + ExType ''CairoStatusInvalidStatus, + ExType ''CairoStatusNullPointer, + ExType ''CairoStatusInvalidString, + ExType ''CairoStatusInvalidPathData, + ExType ''CairoStatusReadError, + ExType ''CairoStatusWriteError, + ExType ''CairoStatusFileNotFound, + ExType ''CairoStatusInvalidDash, + ExType ''CairoStatusInvalidMeshConstruction, + ExType ''CairoStatusOthers + ] + +newtype CairoStatusT = CairoStatusT #{type cairo_status_t} deriving (Show, Eq) + +foreign import ccall "cairo_status" c_cairo_status :: Ptr (CairoT r s) -> IO #type cairo_status_t + +raiseIfError :: CairoT r s -> IO () +raiseIfError (CairoT fcr) = withForeignPtr fcr \pcr -> cairoStatusToThrowError =<< c_cairo_status pcr + +raiseIfErrorRegion :: CairoRegionT s -> IO () +raiseIfErrorRegion (CairoRegionT fr) = withForeignPtr fr \r -> cairoStatusToThrowError =<< c_cairo_region_status r + +foreign import ccall "cairo_region_status" c_cairo_region_status :: + Ptr (CairoRegionT s) -> IO #type cairo_status_t + +foreign import ccall "cairo_surface_status" c_cairo_surface_status :: Ptr (CairoSurfaceT s ps) -> IO #type cairo_status_t + +raiseIfErrorSurface :: CairoSurfaceT s ps -> IO () +raiseIfErrorSurface (CairoSurfaceT fsr) = withForeignPtr fsr \sr -> cairoStatusToThrowError =<< c_cairo_surface_status sr + +raiseIfErrorPtrSurface :: Ptr (CairoSurfaceT s ps) -> IO () +raiseIfErrorPtrSurface sr = cairoStatusToThrowError =<< c_cairo_surface_status sr + +cairoStatusToThrowError :: #{type cairo_status_t} -> IO () +cairoStatusToThrowError = \case + #{const CAIRO_STATUS_SUCCESS} -> pure () + #{const CAIRO_STATUS_NO_MEMORY} -> throw CairoStatusNoMemory + #{const CAIRO_STATUS_INVALID_RESTORE} -> throw CairoStatusInvalidRestore + #{const CAIRO_STATUS_INVALID_POP_GROUP} -> throw CairoStatusInvalidPopGroup + #{const CAIRO_STATUS_NO_CURRENT_POINT} -> throw CairoStatusNoCurrentPoint + #{const CAIRO_STATUS_INVALID_MATRIX} -> throw CairoStatusInvalidMatrix + #{const CAIRO_STATUS_INVALID_STATUS} -> throw CairoStatusInvalidStatus + #{const CAIRO_STATUS_NULL_POINTER} -> throw CairoStatusNullPointer + #{const CAIRO_STATUS_INVALID_STRING} -> throw CairoStatusInvalidString + #{const CAIRO_STATUS_INVALID_PATH_DATA} -> throw CairoStatusInvalidPathData + #{const CAIRO_STATUS_READ_ERROR} -> throw CairoStatusReadError + #{const CAIRO_STATUS_WRITE_ERROR} -> throw CairoStatusWriteError + #{const CAIRO_STATUS_FILE_NOT_FOUND} -> throw CairoStatusFileNotFound + #{const CAIRO_STATUS_INVALID_DASH} -> throw CairoStatusInvalidDash + #{const CAIRO_STATUS_INVALID_MESH_CONSTRUCTION} -> throw CairoStatusInvalidMeshConstruction + st -> throw $ CairoStatusOthers st + +#enum CairoStatusT, CairoStatusT, CAIRO_STATUS_SUCCESS, \ + CAIRO_STATUS_NO_MEMORY, CAIRO_STATUS_INVALID_RESTORE, \ + CAIRO_STATUS_INVALID_POP_GROUP, CAIRO_STATUS_NO_CURRENT_POINT + +tryCairoWriteFunc :: IO a -> IO #{type cairo_status_t} +tryCairoWriteFunc io = (<$> try io) \case + Left CairoStatusWriteError -> #{const CAIRO_STATUS_WRITE_ERROR} + Right _ -> #{const CAIRO_STATUS_SUCCESS} + +{- +pattern CairoStatusSuccess :: CairoStatusT +pattern CairoStatusSuccess = CairoStatusT #const CAIRO_STATUS_SUCCESS + +pattern CairoStatusNoMemory :: CairoStatusT +pattern CairoStatusNoMemory = CairoStatusT #const CAIRO_STATUS_NO_MEMORY + +pattern CairoStatusInvalidRestore :: CairoStatusT +pattern CairoStatusInvalidRestore = CairoStatusT #const CAIRO_STATUS_INVALID_RESTORE + +pattern CairoStatusInvalidPopGroup :: CairoStatusT +pattern CairoStatusInvalidPopGroup = CairoStatusT #const CAIRO_STATUS_INVALID_POP_GROUP + +pattern CairoStatusNoCurrentPoint :: CairoStatusT +pattern CairoStatusNoCurrentPoint = CairoStatusT #const CAIRO_STATUS_NO_CURRENT_POINT + -} diff --git a/src/Graphics/Cairo/Surfaces/CairoSurfaceT.hs b/src/Graphics/Cairo/Surfaces/CairoSurfaceT.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Surfaces/CairoSurfaceT.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Surfaces.CairoSurfaceT ( + IsCairoSurfaceT, CairoSurfaceT, + cairoSurfaceGetType, cairoSurfaceGetContent, + cairoSurfaceFlush ) where + +import Graphics.Cairo.Surfaces.CairoSurfaceT.Internal diff --git a/src/Graphics/Cairo/Surfaces/CairoSurfaceT/Internal.hsc b/src/Graphics/Cairo/Surfaces/CairoSurfaceT/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Surfaces/CairoSurfaceT/Internal.hsc @@ -0,0 +1,65 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Surfaces.CairoSurfaceT.Internal where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Control.Monad.Primitive +import Control.Concurrent.STM +import Data.Word +import System.IO.Unsafe + +import Graphics.Cairo.Surfaces.CairoSurfaceTypeT + +import Graphics.Cairo.Template + +#include + +class IsCairoSurfaceT sr where + toCairoSurfaceT :: sr s ps -> CairoSurfaceT s ps + cairoSurfaceTFinishChecker :: sr s ps -> STM (TChan ()) + + cairoSurfaceTFinishChecker _ = newTChan >>= \c -> c <$ writeTChan c () + +instance IsCairoSurfaceT CairoSurfaceT where toCairoSurfaceT = id + +newtype CairoSurfaceT s ps = CairoSurfaceT (ForeignPtr (CairoSurfaceT s ps)) deriving Show + +mkCairoSurfaceT :: Ptr (CairoSurfaceT s ps) -> IO (CairoSurfaceT s ps) +mkCairoSurfaceT p = CairoSurfaceT <$> newForeignPtr p (c_cairo_surface_destroy p) + +foreign import ccall "cairo_surface_destroy" c_cairo_surface_destroy :: + Ptr (CairoSurfaceT s ps) -> IO () + +foreign import ccall "cairo_surface_finish" c_cairo_surface_finish :: + Ptr (CairoSurfaceT s ps) -> IO () + +cairoSurfaceFlush :: (IsCairoSurfaceT sr, PrimMonad m) => sr s (PrimState m) -> m () +cairoSurfaceFlush (toCairoSurfaceT -> CairoSurfaceT fsr) = unsafeIOToPrim + $ withForeignPtr fsr c_cairo_surface_flush + +foreign import ccall "cairo_surface_flush" c_cairo_surface_flush :: + Ptr (CairoSurfaceT s ps) -> IO () + +cairoSurfaceGetType :: IsCairoSurfaceT sr => sr s ps -> CairoSurfaceTypeT +cairoSurfaceGetType (toCairoSurfaceT -> CairoSurfaceT fsr) = unsafePerformIO + $ CairoSurfaceTypeT <$> withForeignPtr fsr c_cairo_surface_get_type + +foreign import ccall "cairo_surface_get_type" c_cairo_surface_get_type :: + Ptr (CairoSurfaceT s ps) -> IO #{type cairo_surface_type_t} + +cairoSurfaceGetContent :: IsCairoSurfaceT sr => sr s ps -> CairoContentT +cairoSurfaceGetContent (toCairoSurfaceT -> CairoSurfaceT fsr) = unsafePerformIO + $ CairoContentT <$> withForeignPtr fsr c_cairo_surface_get_content + +foreign import ccall "cairo_surface_get_content" c_cairo_surface_get_content :: + Ptr (CairoSurfaceT s ps) -> IO #{type cairo_content_t} + +newtype CairoContentT = CairoContentT #{type cairo_content_t} deriving Show + +mkMemberGen ''CairoContentT 'CairoContentT "CairoContentColor" #{const CAIRO_CONTENT_COLOR} +mkMemberGen ''CairoContentT 'CairoContentT "CairoContentAlpha" #{const CAIRO_CONTENT_ALPHA} +mkMemberGen ''CairoContentT 'CairoContentT "CairoContentColorAlpha" #{const CAIRO_CONTENT_COLOR_ALPHA} diff --git a/src/Graphics/Cairo/Surfaces/CairoSurfaceTypeT.hsc b/src/Graphics/Cairo/Surfaces/CairoSurfaceTypeT.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Surfaces/CairoSurfaceTypeT.hsc @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Surfaces.CairoSurfaceTypeT ( + CairoSurfaceTypeT(..), + module Graphics.Cairo.Surfaces.CairoSurfaceTypeT + ) where + +import Graphics.Cairo.Surfaces.CairoSurfaceTypeT.Template + +#include + +mkMember "CairoSurfaceTypeImage" #{const CAIRO_SURFACE_TYPE_IMAGE} +mkMember "CairoSurfaceTypePdf" #{const CAIRO_SURFACE_TYPE_PDF} +mkMember "CairoSurfaceTypePs" #{const CAIRO_SURFACE_TYPE_PS} +mkMember "CairoSurfaceTypeXlib" #{const CAIRO_SURFACE_TYPE_XLIB} +mkMember "CairoSurfaceTypeXcb" #{const CAIRO_SURFACE_TYPE_XCB} +mkMember "CairoSurfaceTypeGlitz" #{const CAIRO_SURFACE_TYPE_GLITZ} +mkMember "CairoSurfaceTypeQuartz" #{const CAIRO_SURFACE_TYPE_QUARTZ} +mkMember "CairoSurfaceTypeWin32" #{const CAIRO_SURFACE_TYPE_WIN32} +mkMember "CairoSurfaceTypeBeos" #{const CAIRO_SURFACE_TYPE_DIRECTFB} +mkMember "CairoSurfaceTypeSvg" #{const CAIRO_SURFACE_TYPE_SVG} +mkMember "CairoSurfaceTypeOs2" #{const CAIRO_SURFACE_TYPE_OS2} +mkMember "CairoSurfaceTypeWin32Printing" + #{const CAIRO_SURFACE_TYPE_WIN32_PRINTING} +mkMember "CairoSurfaceTypeQuartzImage" #{const CAIRO_SURFACE_TYPE_QUARTZ_IMAGE} +mkMember "CairoSurfaceTypeScript" #{const CAIRO_SURFACE_TYPE_SCRIPT} +mkMember "CairoSurfaceTypeQt" #{const CAIRO_SURFACE_TYPE_QT} +mkMember "CairoSurfaceTypeRecording" #{const CAIRO_SURFACE_TYPE_RECORDING} +mkMember "CairoSurfaceTypeVg" #{const CAIRO_SURFACE_TYPE_VG} +mkMember "CairoSurfaceTypeGl" #{const CAIRO_SURFACE_TYPE_GL} +mkMember "CairoSurfaceTypeDrm" #{const CAIRO_SURFACE_TYPE_DRM} +mkMember "CairoSurfaceTypeTee" #{const CAIRO_SURFACE_TYPE_TEE} +mkMember "CairoSurfaceTypeXml" #{const CAIRO_SURFACE_TYPE_XML} +mkMember "CairoSurafceTypeSkia" #{const CAIRO_SURFACE_TYPE_SKIA} +mkMember "CairoSurfaceTypeSubsurface" #{const CAIRO_SURFACE_TYPE_SUBSURFACE} +mkMember "CairoSurfaceTypeCogl" #{const CAIRO_SURFACE_TYPE_COGL} diff --git a/src/Graphics/Cairo/Surfaces/CairoSurfaceTypeT/Template.hsc b/src/Graphics/Cairo/Surfaces/CairoSurfaceTypeT/Template.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Surfaces/CairoSurfaceTypeT/Template.hsc @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Surfaces.CairoSurfaceTypeT.Template where + +import Language.Haskell.TH +import Data.Word + +import Graphics.Cairo.Template + +#include + +newtype CairoSurfaceTypeT = CairoSurfaceTypeT #{type cairo_surface_type_t} deriving Show + +mkMember :: String -> Integer -> DecsQ +mkMember = mkMemberGen ''CairoSurfaceTypeT 'CairoSurfaceTypeT diff --git a/src/Graphics/Cairo/Surfaces/CairoWriteFuncT.hsc b/src/Graphics/Cairo/Surfaces/CairoWriteFuncT.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Surfaces/CairoWriteFuncT.hsc @@ -0,0 +1,50 @@ +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Surfaces.CairoWriteFuncT where + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String +import Control.Monad.Primitive +import Data.Word + +import qualified Data.Text as T +import qualified Data.Text.Foreign as T + +import qualified Data.ByteString as BS + +#include + +data WriteResult = WriteFailure | WriteSuccess deriving Show + +writeResultToCairoStatusT :: WriteResult -> #{type cairo_status_t} +writeResultToCairoStatusT = \case + WriteFailure -> #{const CAIRO_STATUS_WRITE_ERROR} + WriteSuccess -> #{const CAIRO_STATUS_SUCCESS} + +foreign import ccall "wrapper" c_wrap_cairo_write_func_t :: + (Ptr a -> CString -> CInt -> IO #{type cairo_status_t}) -> + IO (FunPtr (Ptr a -> CString -> CInt -> IO #{type cairo_status_t})) + +wrapCairoWriteFuncTText :: PrimBase m => (Ptr a -> T.Text -> m WriteResult) -> + IO (FunPtr (Ptr a -> CString -> CInt -> IO #{type cairo_status_t})) +wrapCairoWriteFuncTText wf = c_wrap_cairo_write_func_t $ convertCairoWriteFuncTText wf + +wrapCairoWriteFuncTByteString :: PrimBase m => (Ptr a -> BS.ByteString -> m WriteResult) -> + IO (FunPtr (Ptr a -> CString -> CInt -> IO #{type cairo_status_t})) +wrapCairoWriteFuncTByteString = c_wrap_cairo_write_func_t . convertCairoWriteFuncTByteString + +convertCairoWriteFuncT :: (Ptr a -> String -> IO #{type cairo_status_t}) -> + Ptr a -> CString -> CInt -> IO #{type cairo_status_t} +convertCairoWriteFuncT wf p cs ln = peekCStringLen (cs, fromIntegral ln) >>= \s -> wf p s + +convertCairoWriteFuncTText :: PrimBase m => (Ptr a -> T.Text -> m WriteResult) -> + Ptr a -> CString -> CInt -> IO #{type cairo_status_t} +convertCairoWriteFuncTText wf p cs ln = writeResultToCairoStatusT + <$> (T.peekCStringLen (cs, fromIntegral ln) >>= \t -> unsafePrimToIO $ wf p t) + +convertCairoWriteFuncTByteString :: PrimBase m => (Ptr a -> BS.ByteString -> m WriteResult) -> + Ptr a -> CString -> CInt -> IO #{type cairo_status_t} +convertCairoWriteFuncTByteString wf p cs ln = writeResultToCairoStatusT + <$> (BS.packCStringLen (cs, fromIntegral ln) >>= \bs -> unsafePrimToIO $ wf p bs) diff --git a/src/Graphics/Cairo/Surfaces/ImageSurfaces.hsc b/src/Graphics/Cairo/Surfaces/ImageSurfaces.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Surfaces/ImageSurfaces.hsc @@ -0,0 +1,149 @@ +{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Surfaces.ImageSurfaces ( + CairoSurfaceImageT, + pattern CairoSurfaceTImage, + + cairoImageSurfaceCreate, + + cairoImageSurfaceCreateForCairoImage, + cairoImageSurfaceCreateForCairoImageMut, + + cairoImageSurfaceGetCairoImage, + cairoImageSurfaceGetCairoImageMut, + + cairoImageSurfaceGetWidth, + cairoImageSurfaceGetHeight, + cairoImageSurfaceGetStride, + + mkCairoSurfaceImageT + ) where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Control.Monad.Primitive +import Data.Word +import Data.Int + +import Graphics.Cairo.Surfaces.CairoSurfaceT.Internal +import Graphics.Cairo.Surfaces.CairoSurfaceTypeT + +import Data.CairoImage.Internal hiding (Argb32, pixelAt, Image, Pixel) + +#include + +newtype CairoSurfaceImageT s ps = CairoSurfaceImageT (ForeignPtr (CairoSurfaceT s ps)) deriving Show + +pattern CairoSurfaceTImage :: CairoSurfaceImageT s ps -> CairoSurfaceT s ps +pattern CairoSurfaceTImage sr <- (cairoSurfaceTImage -> Just sr) where + CairoSurfaceTImage = toCairoSurfaceT + +cairoSurfaceTImage :: CairoSurfaceT s ps -> Maybe (CairoSurfaceImageT s ps) +cairoSurfaceTImage sr@(CairoSurfaceT fsr) = case cairoSurfaceGetType sr of + CairoSurfaceTypeImage -> Just $ CairoSurfaceImageT fsr + _ -> Nothing + +instance IsCairoSurfaceT CairoSurfaceImageT where + toCairoSurfaceT (CairoSurfaceImageT fsr) = CairoSurfaceT fsr + +cairoImageSurfaceCreate :: PrimMonad m => CairoFormatT -> #{type int} -> #{type int} -> m (CairoSurfaceImageT s (PrimState m)) +cairoImageSurfaceCreate (CairoFormatT f) w h = + returnCairoSurfaceT $ c_cairo_image_surface_create f w h + +foreign import ccall "cairo_image_surface_create" c_cairo_image_surface_create :: + #{type cairo_format_t} -> #{type int} -> #{type int} -> IO (Ptr (CairoSurfaceT s ps)) + +foreign import ccall "cairo_image_surface_get_format" c_cairo_image_surface_get_format :: + Ptr (CairoSurfaceT s ps) -> IO #type cairo_format_t + +foreign import ccall "cairo_image_surface_get_stride" c_cairo_image_surface_get_stride :: + Ptr (CairoSurfaceT s ps) -> IO #type int + +foreign import ccall "cairo_image_surface_get_width" c_cairo_image_surface_get_width :: + Ptr (CairoSurfaceT s ps) -> IO #type int + +foreign import ccall "cairo_image_surface_get_height" c_cairo_image_surface_get_height :: + Ptr (CairoSurfaceT s ps) -> IO #type int + +cairoImageSurfaceGetCairoImage :: PrimMonad m => CairoSurfaceImageT s (PrimState m) -> m CairoImage +cairoImageSurfaceGetCairoImage = argCairoSurfaceT \sfc -> do + d <- c_cairo_image_surface_get_data sfc + f <- c_cairo_image_surface_get_format sfc + w <- c_cairo_image_surface_get_width sfc + h <- c_cairo_image_surface_get_height sfc + s <- c_cairo_image_surface_get_stride sfc + p <- mallocBytes . fromIntegral $ s * h + copyBytes p d . fromIntegral $ s * h + fd <- newForeignPtr (castPtr p) $ free (castPtr p) + pure $ CairoImage (CairoFormatT f) (fromIntegral w) (fromIntegral h) (fromIntegral s) fd + +cairoImageSurfaceGetCairoImageMut :: PrimMonad m => CairoSurfaceImageT s (PrimState m) -> m (CairoImageMut (PrimState m)) +cairoImageSurfaceGetCairoImageMut = argCairoSurfaceT \sfc -> do + d <- c_cairo_image_surface_get_data sfc + f <- c_cairo_image_surface_get_format sfc + w <- c_cairo_image_surface_get_width sfc + h <- c_cairo_image_surface_get_height sfc + s <- c_cairo_image_surface_get_stride sfc + p <- mallocBytes . fromIntegral $ s * h + copyBytes p d . fromIntegral $ s * h + fd <- newForeignPtr (castPtr p) $ free (castPtr p) + pure $ CairoImageMut (CairoFormatT f) (fromIntegral w) (fromIntegral h) (fromIntegral s) fd + +newtype Argb32 = Argb32 Word32 deriving (Show, Storable) + +foreign import ccall "cairo_image_surface_create_for_data" c_cairo_image_surface_create_for_data :: + Ptr #{type unsigned char} -> #{type cairo_format_t} -> #{type int} -> #{type int} -> #{type int} -> IO (Ptr (CairoSurfaceT s ps)) + +cairoImageSurfaceCreateForCairoImage :: + PrimMonad m => CairoImage -> m (CairoSurfaceImageT s (PrimState m)) +cairoImageSurfaceCreateForCairoImage (CairoImage (CairoFormatT f) w h s d) = unsafeIOToPrim do + p <- mallocBytes n + withForeignPtr d \pd -> copyBytes p pd n + sp <- c_cairo_image_surface_create_for_data (castPtr p) f (fromIntegral w) (fromIntegral h) (fromIntegral s) + mkCairoSurfaceImageT' sp p + where n = fromIntegral $ s * h + +cairoImageSurfaceCreateForCairoImageMut :: + PrimMonad m => CairoImageMut (PrimState m) -> m (CairoSurfaceImageT s (PrimState m)) +cairoImageSurfaceCreateForCairoImageMut (CairoImageMut (CairoFormatT f) w h s d) = unsafeIOToPrim do + p <- mallocBytes n + withForeignPtr d \pd -> copyBytes p pd n + sp <- c_cairo_image_surface_create_for_data (castPtr p) f (fromIntegral w) (fromIntegral h) (fromIntegral s) + mkCairoSurfaceImageT' sp p + where n = fromIntegral $ s * h + +foreign import ccall "cairo_image_surface_get_data" c_cairo_image_surface_get_data :: + Ptr (CairoSurfaceT s ps) -> IO (Ptr #{type unsigned char}) + +argCairoSurfaceT :: PrimMonad m => (Ptr (CairoSurfaceT s (PrimState m)) -> IO a) -> CairoSurfaceImageT s (PrimState m) -> m a +argCairoSurfaceT io (CairoSurfaceImageT fs) = unsafeIOToPrim $ withForeignPtr fs io + +returnCairoSurfaceT :: PrimMonad m => IO (Ptr (CairoSurfaceT s (PrimState m))) -> m (CairoSurfaceImageT s (PrimState m)) +returnCairoSurfaceT io = unsafeIOToPrim $ mkCairoSurfaceImageT =<< io + +mkCairoSurfaceImageT :: Ptr (CairoSurfaceT s ps) -> IO (CairoSurfaceImageT s ps) +mkCairoSurfaceImageT p = CairoSurfaceImageT <$> newForeignPtr p (c_cairo_surface_destroy p) + +mkCairoSurfaceImageT' :: Ptr (CairoSurfaceT s ps) -> Ptr a -> IO (CairoSurfaceImageT s ps) +mkCairoSurfaceImageT' ps p = CairoSurfaceImageT <$> newForeignPtr ps (free p >> c_cairo_surface_destroy ps) + +cairoImageSurfaceGetWidth :: PrimMonad m => + CairoSurfaceImageT s (PrimState m) -> m #{type int} +cairoImageSurfaceGetWidth = argCairoSurfaceT \sfc -> + c_cairo_image_surface_get_width sfc + +cairoImageSurfaceGetHeight :: PrimMonad m => + CairoSurfaceImageT s (PrimState m) -> m #{type int} +cairoImageSurfaceGetHeight = argCairoSurfaceT \sfc -> + c_cairo_image_surface_get_height sfc + +cairoImageSurfaceGetStride :: PrimMonad m => + CairoSurfaceImageT s (PrimState m) -> m #{type int} +cairoImageSurfaceGetStride = argCairoSurfaceT \sfc -> + c_cairo_image_surface_get_stride sfc diff --git a/src/Graphics/Cairo/Surfaces/PdfSurfaces.hsc b/src/Graphics/Cairo/Surfaces/PdfSurfaces.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Surfaces/PdfSurfaces.hsc @@ -0,0 +1,203 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Surfaces.PdfSurfaces where + +import GHC.Foreign hiding (peekCString) +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Foreign.C.String hiding (withCString) +import Control.Monad.Primitive +import Control.Concurrent.STM +import Data.Bits +import Data.Word +import System.IO + +import Graphics.Cairo.Exception +import Graphics.Cairo.Surfaces.CairoWriteFuncT +import Graphics.Cairo.Surfaces.CairoSurfaceT.Internal +import Graphics.Cairo.Surfaces.CairoSurfaceTypeT +import Graphics.Cairo.Drawing.TagsAndLinks + +import Graphics.Cairo.Surfaces.PdfSurfaces.Template + +import qualified Data.ByteString as BS + +#include +#include + +data CairoSurfacePdfT s ps = CairoSurfacePdfT (ForeignPtr (CairoSurfaceT s ps)) (STM (TChan ())) + +pattern CairoSurfaceTPdf :: CairoSurfacePdfT s ps -> CairoSurfaceT s ps +pattern CairoSurfaceTPdf sr <- (cairoSurfaceTPdf -> Just sr) where + CairoSurfaceTPdf = toCairoSurfaceT + +cairoSurfaceTPdf :: CairoSurfaceT s ps -> Maybe (CairoSurfacePdfT s ps) +cairoSurfaceTPdf sr@(CairoSurfaceT fsr) = case cairoSurfaceGetType sr of + CairoSurfaceTypePdf -> Just $ CairoSurfacePdfT fsr newTChan + _ -> Nothing + +instance IsCairoSurfaceT CairoSurfacePdfT where + toCairoSurfaceT (CairoSurfacePdfT fsr _) = CairoSurfaceT fsr + cairoSurfaceTFinishChecker (CairoSurfacePdfT _ ck) = ck + +cairoPdfSurfaceWith :: FilePath -> CDouble -> CDouble -> + (forall s . CairoSurfacePdfT s RealWorld -> IO a) -> IO a +cairoPdfSurfaceWith fp w h f = do + sr@(CairoSurfacePdfT fsr mck) <- cairoPdfSurfaceCreateNoGC fp w h + ck <- atomically mck + f sr <* withForeignPtr fsr + (\psr -> do + c_cairo_surface_finish psr + c_cairo_surface_destroy psr + putStrLn "PDF Surface destroyed" + atomically (writeTChan ck ()) + putStrLn "writeTChan ck () finished") + +cairoPdfSurfaceCreate :: FilePath -> CDouble -> CDouble -> IO (CairoSurfacePdfT s RealWorld) +cairoPdfSurfaceCreate fp w h = do + ck <- atomically newTChan + (`CairoSurfacePdfT` pure ck) <$> withCString utf8 fp \cstr -> do + p <- c_cairo_pdf_surface_create cstr w h + newForeignPtr p (c_cairo_surface_destroy p) <* raiseIfErrorPtrSurface p + +cairoPdfSurfaceCreateNoGC :: FilePath -> CDouble -> CDouble -> IO (CairoSurfacePdfT s RealWorld) +cairoPdfSurfaceCreateNoGC fp w h = do + ck <- atomically newTChan + (`CairoSurfacePdfT` pure ck) <$> withCString utf8 fp \cstr -> do + p <- c_cairo_pdf_surface_create cstr w h + newForeignPtr p (pure ()) <* raiseIfErrorPtrSurface p + +foreign import ccall "cairo_pdf_surface_create" c_cairo_pdf_surface_create :: + CString -> CDouble -> CDouble -> IO (Ptr (CairoSurfaceT s ps)) + +unsafeCairoSurfaceFinish :: CairoSurfaceT s RealWorld -> IO () +unsafeCairoSurfaceFinish (CairoSurfaceT fsr) = + withForeignPtr fsr c_cairo_surface_finish + +cairoPdfSurfaceWithForStream :: PrimBase m => + (Ptr a -> BS.ByteString -> m WriteResult) -> Ptr a -> CDouble -> CDouble -> + (forall s . CairoSurfacePdfT s (PrimState m) -> m a) -> m a +cairoPdfSurfaceWithForStream wf cl w h f = do + sr@(CairoSurfacePdfT fsr mck) <- cairoPdfSurfaceCreateForStreamNoGC wf cl w h + ck <- unsafeIOToPrim $ atomically mck + f sr <* unsafeIOToPrim (withForeignPtr fsr $ + \psr -> c_cairo_surface_finish psr >> atomically (writeTChan ck ()) >> c_cairo_surface_destroy psr) + +cairoPdfSurfaceCreateForStream :: PrimBase m => + (Ptr a -> BS.ByteString -> m WriteResult) -> Ptr a -> CDouble -> CDouble -> + m (CairoSurfacePdfT s (PrimState m)) +cairoPdfSurfaceCreateForStream wf cl w h = do + ck <- unsafeIOToPrim $ atomically newTChan + (`CairoSurfacePdfT` pure ck) <$> unsafeIOToPrim do + p <- (wrapCairoWriteFuncTByteString wf >>= \pwf -> + c_cairo_pdf_surface_create_for_stream pwf cl w h) + newForeignPtr p (c_cairo_surface_destroy p) <* raiseIfErrorPtrSurface p + +cairoPdfSurfaceCreateForStreamNoGC :: PrimBase m => + (Ptr a -> BS.ByteString -> m WriteResult) -> Ptr a -> CDouble -> CDouble -> + m (CairoSurfacePdfT s (PrimState m)) +cairoPdfSurfaceCreateForStreamNoGC wf cl w h = do + ck <- unsafeIOToPrim $ atomically newTChan + (`CairoSurfacePdfT` pure ck) <$> unsafeIOToPrim do + p <- (wrapCairoWriteFuncTByteString wf >>= \pwf -> + c_cairo_pdf_surface_create_for_stream pwf cl w h) + newForeignPtr p (pure ()) <* raiseIfErrorPtrSurface p + +foreign import ccall "cairo_pdf_surface_create_for_stream" + c_cairo_pdf_surface_create_for_stream :: + FunPtr (Ptr a -> CString -> CInt -> IO #{type cairo_status_t}) -> + Ptr a -> CDouble -> CDouble -> IO (Ptr (CairoSurfaceT s ps)) + +newtype CairoPdfOutlineT = CairoPdfOutlineT CInt deriving Show + +pattern CairoPdfOutlineRoot :: CairoPdfOutlineT +pattern CairoPdfOutlineRoot <- CairoPdfOutlineT #{const CAIRO_PDF_OUTLINE_ROOT} where + CairoPdfOutlineRoot = CairoPdfOutlineT #{const CAIRO_PDF_OUTLINE_ROOT} + +mkOFlag "CairoPdfOutlineFlagOpen" #{const CAIRO_PDF_OUTLINE_FLAG_OPEN} +mkOFlag "CairoPdfOutlineFlagBold" #{const CAIRO_PDF_OUTLINE_FLAG_BOLD} +mkOFlag "CairoPdfOutlineFlagItalic" #{const CAIRO_PDF_OUTLINE_FLAG_ITALIC} + +join :: CairoPdfOutlineFlagsT -> CairoPdfOutlineFlagsT -> CairoPdfOutlineFlagsT +join (CairoPdfOutlineFlagsT f1) (CairoPdfOutlineFlagsT f2) = CairoPdfOutlineFlagsT $ f1 .|. f2 + +cairoPdfSurfaceAddOutline :: PrimMonad m => + CairoSurfacePdfT s (PrimState m) -> CairoPdfOutlineT -> Name -> + Either Name (Int, Maybe (Double, Double)) -> [CairoPdfOutlineFlagsT] -> m CairoPdfOutlineT +cairoPdfSurfaceAddOutline (CairoSurfacePdfT fsr _) (CairoPdfOutlineT pid) nm d fs = unsafeIOToPrim + $ CairoPdfOutlineT <$> withForeignPtr fsr \psr -> withCString utf8 nm \cnm -> internalAttributes d \cd -> + c_cairo_pdf_surface_add_outline psr pid cnm cd f + where + CairoPdfOutlineFlagsT f = foldr join (CairoPdfOutlineFlagsT 0) fs + +foreign import ccall "cairo_pdf_surface_add_outline" c_cairo_pdf_surface_add_outline :: + Ptr (CairoSurfaceT s ps) -> CInt -> CString -> CString -> #{type cairo_pdf_outline_flags_t} -> IO CInt + +cairoPdfSurfaceSetSize :: PrimMonad m => + CairoSurfacePdfT s (PrimState m) -> CDouble -> CDouble -> m () +cairoPdfSurfaceSetSize (CairoSurfacePdfT fsr _) w h = + unsafeIOToPrim $ withForeignPtr fsr \psr -> c_cairo_pdf_surface_set_size psr w h + +foreign import ccall "cairo_pdf_surface_set_size" c_cairo_pdf_surface_set_size :: + Ptr (CairoSurfaceT s ps) -> CDouble -> CDouble -> IO () + +mkMeta "CairoPdfMetadataTitle" #{const CAIRO_PDF_METADATA_TITLE} +mkMeta "CairoPdfMetadataAuthor" #{const CAIRO_PDF_METADATA_AUTHOR} +mkMeta "CairoPdfMetadataSubject" #{const CAIRO_PDF_METADATA_SUBJECT} +mkMeta "CairoPdfMetadataKeywords" #{const CAIRO_PDF_METADATA_KEYWORDS} +mkMeta "CairoPdfMetadataCreator" #{const CAIRO_PDF_METADATA_CREATOR} +mkMeta "CairoPdfMetadataCreateDate" #{const CAIRO_PDF_METADATA_CREATE_DATE} +mkMeta "CairoPdfMetadataModDate" #{const CAIRO_PDF_METADATA_MOD_DATE} + +cairoPdfSurfaceSetMetadata :: PrimMonad m => + CairoSurfacePdfT s (PrimState m) -> CairoPdfMetadataT -> String -> m () +cairoPdfSurfaceSetMetadata (CairoSurfacePdfT fsr _) (CairoPdfMetadataT md) v = + unsafeIOToPrim $ withForeignPtr fsr \psr -> withCString utf8 v \cv -> + c_cairo_pdf_surface_set_metadata psr md cv + +foreign import ccall "cairo_pdf_surface_set_metadata" c_cairo_pdf_surface_set_metadata :: + Ptr (CairoSurfaceT s ps) -> #{type cairo_pdf_metadata_t} -> CString -> IO () + +cairoPdfSurfaceSetPageLabel :: PrimMonad m => + CairoSurfacePdfT s (PrimState m) -> String -> m () +cairoPdfSurfaceSetPageLabel (CairoSurfacePdfT fsr _) pl = + unsafeIOToPrim $ withForeignPtr fsr \psr -> withCString utf8 pl \cpl -> + c_cairo_pdf_surface_set_page_label psr cpl + +foreign import ccall "cairo_pdf_surface_set_page_label" c_cairo_pdf_surface_set_page_label :: + Ptr (CairoSurfaceT s ps) -> CString -> IO () + +mkVersion "CairoPdfVersion1_4" #{const CAIRO_PDF_VERSION_1_4} +mkVersion "CairoPdfVersion1_5" #{const CAIRO_PDF_VERSION_1_5} + +cairoPdfSurfaceRestrictToVersion :: PrimMonad m => + CairoSurfacePdfT s (PrimState m) -> CairoPdfVersionT -> m () +cairoPdfSurfaceRestrictToVersion (CairoSurfacePdfT fsr _) (CairoPdfVersionT v) = + unsafeIOToPrim $ withForeignPtr fsr \psr -> + c_cairo_pdf_surface_restrict_to_version psr v + +foreign import ccall "cairo_pdf_surface_restrict_to_version" c_cairo_pdf_surface_restrict_to_version :: + Ptr (CairoSurfaceT s ps) -> #{type cairo_pdf_version_t} -> IO () + +cairoPdfGetVersions :: IO [CairoPdfVersionT] +cairoPdfGetVersions = (CairoPdfVersionT <$>) <$> alloca \ppv -> alloca \pn -> do + c_cairo_pdf_get_versions ppv pn + n <- peek pn + peekArray (fromIntegral n) =<< peek ppv + +foreign import ccall "cairo_pdf_get_versions" c_cairo_pdf_get_versions :: + Ptr (Ptr #{type cairo_pdf_version_t}) -> Ptr CInt -> IO () + +cairoPdfVersionToString :: CairoPdfVersionT -> IO String +cairoPdfVersionToString (CairoPdfVersionT v) = peekCString =<< c_cairo_pdf_version_to_string v + +foreign import ccall "cairo_pdf_version_to_string" c_cairo_pdf_version_to_string :: + #{type cairo_pdf_version_t} -> IO CString diff --git a/src/Graphics/Cairo/Surfaces/PdfSurfaces/Template.hsc b/src/Graphics/Cairo/Surfaces/PdfSurfaces/Template.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Surfaces/PdfSurfaces/Template.hsc @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Surfaces.PdfSurfaces.Template where + +import Language.Haskell.TH +import Data.Word +import Graphics.Cairo.Template + +#include + +newtype CairoPdfOutlineFlagsT = CairoPdfOutlineFlagsT #{type cairo_pdf_outline_flags_t} deriving Show + +mkOFlag :: String -> Integer -> DecsQ +mkOFlag = mkMemberGen ''CairoPdfOutlineFlagsT 'CairoPdfOutlineFlagsT + +newtype CairoPdfMetadataT = CairoPdfMetadataT #{type cairo_pdf_metadata_t} deriving Show + +mkMeta :: String -> Integer -> DecsQ +mkMeta = mkMemberGen ''CairoPdfMetadataT 'CairoPdfMetadataT + +newtype CairoPdfVersionT = CairoPdfVersionT #{type cairo_pdf_version_t} deriving Show + +mkVersion :: String -> Integer -> DecsQ +mkVersion = mkMemberGen ''CairoPdfVersionT 'CairoPdfVersionT diff --git a/src/Graphics/Cairo/Surfaces/PngSupport.hsc b/src/Graphics/Cairo/Surfaces/PngSupport.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Surfaces/PngSupport.hsc @@ -0,0 +1,71 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Surfaces.PngSupport ( + cairoSurfaceCreateFromPng, cairoSurfaceCreateFromPngByteString, + cairoSurfaceWriteToPng + ) where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Marshal.Utils +import Foreign.C +import Control.Monad.Primitive +import Control.Concurrent.STM +import Data.Word +import Data.ByteString qualified as BS +import Data.ByteString.Internal qualified as BS + +import Graphics.Cairo.Surfaces.CairoSurfaceT.Internal +import Graphics.Cairo.Exception + +import Graphics.Cairo.Surfaces.ImageSurfaces + +#include + +foreign import ccall "cairo_surface_write_to_png" c_cairo_surface_write_to_png :: + Ptr (CairoSurfaceT s ps) -> CString -> IO #type cairo_status_t + +cairoSurfaceWriteToPng :: IsCairoSurfaceT sfc => sfc s ps -> FilePath -> IO CairoStatusT +cairoSurfaceWriteToPng (toCairoSurfaceT -> CairoSurfaceT s) fp = withCString fp \cs -> CairoStatusT + <$> (withForeignPtr s \p -> c_cairo_surface_write_to_png p cs) + +foreign import ccall "cairo_image_surface_create_from_png" c_cairo_surface_create_from_png :: + CString -> IO (Ptr (CairoSurfaceT s ps)) + +cairoSurfaceCreateFromPng :: FilePath -> IO (CairoSurfaceImageT s ps) +cairoSurfaceCreateFromPng fp = withCString fp \cs -> + mkCairoSurfaceImageT =<< c_cairo_surface_create_from_png cs + +cairoSurfaceCreateFromPngByteString :: PrimMonad m => + BS.ByteString -> m (CairoSurfaceImageT s (PrimState m)) +cairoSurfaceCreateFromPngByteString bs = unsafeIOToPrim do + tbs <- atomically $ newTVar bs + fn <- c_cairo_read_func_t $ byteStringToCCairoReadFunc tbs + mkCairoSurfaceImageT + =<< c_cairo_image_surface_create_from_png_stream fn nullPtr + +foreign import ccall "cairo_image_surface_create_from_png_stream" + c_cairo_image_surface_create_from_png_stream :: + FunPtr (CCairoReadFunc a) -> Ptr a -> IO (Ptr (CairoSurfaceT s ps)) + +type CCairoReadFunc a = Ptr a -> CString -> #{type unsigned int} -> IO #{type cairo_status_t} + +foreign import ccall "wrapper" c_cairo_read_func_t :: + CCairoReadFunc a -> IO (FunPtr (CCairoReadFunc a)) + +byteStringToCCairoReadFunc :: TVar BS.ByteString -> CCairoReadFunc a +byteStringToCCairoReadFunc tbs _cls dt ln = do + bs <- atomically $ readTVar tbs + if BS.length bs < (fromIntegral ln) then + pure #{const CAIRO_STATUS_READ_ERROR} else do + tx' <- atomically do + let (tx, bs') = BS.splitAt (fromIntegral ln) bs + writeTVar tbs bs' + pure tx + let (fptr, ln') = BS.toForeignPtr0 tx' + withForeignPtr fptr \ptr -> do + copyBytes dt (castPtr ptr) ln' + pure #{const CAIRO_STATUS_SUCCESS} diff --git a/src/Graphics/Cairo/Surfaces/SvgSurfaces.hsc b/src/Graphics/Cairo/Surfaces/SvgSurfaces.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Surfaces/SvgSurfaces.hsc @@ -0,0 +1,131 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Surfaces.SvgSurfaces where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Foreign.C.String +import Control.Monad.Primitive +import Data.Word +import System.IO.Unsafe +import Graphics.Cairo.Exception +import Graphics.Cairo.Surfaces.CairoSurfaceT.Internal +import Graphics.Cairo.Surfaces.CairoSurfaceTypeT + +import qualified Data.Text as T + +import Graphics.Cairo.Surfaces.CairoWriteFuncT +import Graphics.Cairo.Surfaces.SvgSurfaces.Template + +#include +#include + +newtype CairoSurfaceSvgT s ps = CairoSurfaceSvgT (ForeignPtr (CairoSurfaceT s ps)) deriving Show + +pattern CairoSurfaceTSvg :: CairoSurfaceSvgT s ps -> CairoSurfaceT s ps +pattern CairoSurfaceTSvg sr <- (cairoSurfaceTSvg -> Just sr) where + CairoSurfaceTSvg = toCairoSurfaceT + +cairoSurfaceTSvg :: CairoSurfaceT s ps -> Maybe (CairoSurfaceSvgT s ps) +cairoSurfaceTSvg sr@(CairoSurfaceT fsr) = case cairoSurfaceGetType sr of + CairoSurfaceTypeSvg -> Just $ CairoSurfaceSvgT fsr + _ -> Nothing + +instance IsCairoSurfaceT CairoSurfaceSvgT where + toCairoSurfaceT (CairoSurfaceSvgT fsr) = CairoSurfaceT fsr + +foreign import ccall "cairo_svg_surface_create" c_cairo_svg_surface_create :: + CString -> CDouble -> CDouble -> IO (Ptr (CairoSurfaceT s ps)) + +cairoSvgSurfaceWith :: FilePath -> CDouble -> CDouble -> (forall s . CairoSurfaceSvgT s RealWorld -> IO a) -> IO a +cairoSvgSurfaceWith fp w h f = do + sr@(CairoSurfaceSvgT fsr) <- cairoSvgSurfaceCreate fp w h + f sr <* withForeignPtr fsr c_cairo_surface_finish + + +cairoSvgSurfaceCreate :: FilePath -> CDouble -> CDouble -> IO (CairoSurfaceSvgT s RealWorld) +cairoSvgSurfaceCreate fp w h = withCString fp \cs -> do + p <- c_cairo_svg_surface_create cs w h + mkCairoSurfaceSvgT p <* raiseIfErrorPtrSurface p + +foreign import ccall "cairo_svg_surface_create_for_stream" c_cairo_svg_surface_create_for_stream :: + FunPtr (Ptr a -> CString -> CInt -> IO #{type cairo_status_t}) -> Ptr a -> CDouble -> CDouble -> IO (Ptr (CairoSurfaceT s ps)) + +cairoSvgSurfaceWithForStream :: PrimBase m => (Ptr a -> T.Text -> m WriteResult) -> Ptr a -> CDouble -> CDouble -> + (forall s . CairoSurfaceSvgT s (PrimState m) -> m a) -> m a +cairoSvgSurfaceWithForStream wf cl w h f = do + sr@(CairoSurfaceSvgT fsr) <- cairoSvgSurfaceCreateForStream wf cl w h + f sr <* unsafeIOToPrim (withForeignPtr fsr c_cairo_surface_finish) + +cairoSvgSurfaceCreateForStream :: PrimBase m => + (Ptr a -> T.Text -> m WriteResult) -> Ptr a -> CDouble -> CDouble -> m (CairoSurfaceSvgT s (PrimState m)) +cairoSvgSurfaceCreateForStream wf cl w h = unsafeIOToPrim do + p <- (wrapCairoWriteFuncTText wf >>= \pwf -> + c_cairo_svg_surface_create_for_stream pwf cl w h) + sr <- mkCairoSurfaceSvgT p + sr <$ raiseIfErrorPtrSurface p + +mkCairoSurfaceSvgT :: Ptr (CairoSurfaceT s ps) -> IO (CairoSurfaceSvgT s ps) +mkCairoSurfaceSvgT p = CairoSurfaceSvgT <$> newForeignPtr p (c_cairo_surface_destroy p) + +mkUnitMember "CairoSvgUnitUser" #{const CAIRO_SVG_UNIT_USER} +mkUnitMember "CairoSvgUnitEm" #{const CAIRO_SVG_UNIT_EM} +mkUnitMember "CairoSvgUnitEx" #{const CAIRO_SVG_UNIT_EX} +mkUnitMember "CairoSvgUnitPx" #{const CAIRO_SVG_UNIT_PX} +mkUnitMember "CairoSvgUnitIn" #{const CAIRO_SVG_UNIT_IN} +mkUnitMember "CairoSvgUnitCm" #{const CAIRO_SVG_UNIT_CM} +mkUnitMember "CairoSvgUnitMm" #{const CAIRO_SVG_UNIT_MM} +mkUnitMember "CairoSvgUnitPt" #{const CAIRO_SVG_UNIT_PT} +mkUnitMember "CairoSvgUnitPc" #{const CAIRO_SVG_UNIT_PC} +mkUnitMember "CAiroSvgUnitPercent" #{const CAIRO_SVG_UNIT_PERCENT} + +cairoSvgSurfaceGetDocumentUnit :: PrimMonad m => + CairoSurfaceSvgT s (PrimState m) -> m CairoSvgUnitT +cairoSvgSurfaceGetDocumentUnit (CairoSurfaceSvgT fsr) = unsafeIOToPrim + $ CairoSvgUnitT <$> withForeignPtr fsr c_cairo_svg_surface_get_document_unit + +foreign import ccall "cairo_svg_surface_get_document_unit" c_cairo_svg_surface_get_document_unit :: + Ptr (CairoSurfaceT s ps) -> IO #{type cairo_svg_unit_t} + +cairoSvgSurfaceSetDocumentUnit :: PrimMonad m => + CairoSurfaceSvgT s (PrimState m) -> CairoSvgUnitT -> m () +cairoSvgSurfaceSetDocumentUnit (CairoSurfaceSvgT fsr) (CairoSvgUnitT u) = + unsafeIOToPrim $ withForeignPtr fsr \psr -> c_cairo_svg_surface_set_document_unit psr u + +foreign import ccall "cairo_svg_surface_set_document_unit" c_cairo_svg_surface_set_document_unit :: + Ptr (CairoSurfaceT s ps) -> #{type cairo_svg_unit_t} -> IO () + +mkVersionMember "CairoSvgVersion1_1" #{const CAIRO_SVG_VERSION_1_1} +mkVersionMember "CairoSvgVersion1_2" #{const CAIRO_SVG_VERSION_1_2} + +cairoSvgSurfaceRestrictToVersion :: PrimMonad m => + CairoSurfaceSvgT s (PrimState m) -> CairoSvgVersionT -> m () +cairoSvgSurfaceRestrictToVersion (CairoSurfaceSvgT fsr) (CairoSvgVersionT v) = + unsafeIOToPrim $ withForeignPtr fsr \psr -> c_cairo_svg_surface_restrict_to_version psr v + +foreign import ccall "cairo_svg_surface_restrict_to_version" c_cairo_svg_surface_restrict_to_version :: + Ptr (CairoSurfaceT s ps) -> #{type cairo_svg_version_t} -> IO () + +cairoSvgGetVersions :: IO [CairoSvgVersionT] +cairoSvgGetVersions = (CairoSvgVersionT <$>) <$> alloca \pvs -> alloca \pn -> do + c_cairo_svg_surface_get_versions pvs pn + n <- peek pn + peekArray (fromIntegral n) =<< peek pvs + +foreign import ccall "cairo_svg_get_versions" c_cairo_svg_surface_get_versions :: + Ptr (Ptr #{type cairo_svg_version_t}) -> Ptr CInt -> IO () + +cairoSvgVersionToString :: CairoSvgVersionT -> String +cairoSvgVersionToString (CairoSvgVersionT v) = unsafePerformIO do + peekCString =<< c_cairo_svg_version_to_string v + +foreign import ccall "cairo_svg_version_to_string" c_cairo_svg_version_to_string :: + #{type cairo_svg_version_t} -> IO CString diff --git a/src/Graphics/Cairo/Surfaces/SvgSurfaces/Template.hsc b/src/Graphics/Cairo/Surfaces/SvgSurfaces/Template.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Surfaces/SvgSurfaces/Template.hsc @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Surfaces.SvgSurfaces.Template where + +import Language.Haskell.TH +import Data.Word +import Graphics.Cairo.Template + +#include + +newtype CairoSvgUnitT = CairoSvgUnitT #{type cairo_svg_unit_t} deriving Show + +mkUnitMember :: String -> Integer -> DecsQ +mkUnitMember = mkMemberGen ''CairoSvgUnitT 'CairoSvgUnitT + +newtype CairoSvgVersionT = CairoSvgVersionT #{type cairo_svg_version_t} + deriving Show + +mkVersionMember :: String -> Integer -> DecsQ +mkVersionMember = mkMemberGen ''CairoSvgVersionT 'CairoSvgVersionT diff --git a/src/Graphics/Cairo/Template.hs b/src/Graphics/Cairo/Template.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Template.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Template where + +import Language.Haskell.TH + +mkMemberGen :: Name -> Name -> String -> Integer -> DecsQ +mkMemberGen t c n v = sequence [ + patSynSigD (mkName n) (conT t), + patSynD (mkName n) (prefixPatSyn []) + (explBidir [clause [] (normalB (conE c `appE` litE (IntegerL v))) []]) + (conP c [litP (IntegerL v)]) + ] diff --git a/src/Graphics/Cairo/Types.hsc b/src/Graphics/Cairo/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Types.hsc @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Types where + +import Foreign.Storable +import Data.Int + +#include + +data CairoTextExtentsT = CairoTextExtentsT { + cairoTextExtentsTXBearing :: #{type double}, + cairoTextExtentsTYBearing :: #{type double}, + cairoTextExtentsTWidth :: #{type double}, + cairoTextExtentsTHeight :: #{type double}, + cairoTextExtentsTXAdvance :: #{type double}, + cairoTextExtentsTYAdvance :: #{type double} } deriving Show + +instance Storable CairoTextExtentsT where + sizeOf _ = #{size cairo_text_extents_t} + alignment _ = #{alignment cairo_text_extents_t} + peek p = CairoTextExtentsT + <$> #{peek cairo_text_extents_t, x_bearing} p + <*> #{peek cairo_text_extents_t, y_bearing} p + <*> #{peek cairo_text_extents_t, width} p + <*> #{peek cairo_text_extents_t, height} p + <*> #{peek cairo_text_extents_t, x_advance} p + <*> #{peek cairo_text_extents_t, y_advance} p + poke p (CairoTextExtentsT xb yb w h xa ya) = do + #{poke cairo_text_extents_t, x_bearing} p xb + #{poke cairo_text_extents_t, y_bearing} p yb + #{poke cairo_text_extents_t, width} p w + #{poke cairo_text_extents_t, height} p h + #{poke cairo_text_extents_t, x_advance} p xa + #{poke cairo_text_extents_t, y_advance} p ya diff --git a/src/Graphics/Cairo/Utilities/CairoMatrixT.hs b/src/Graphics/Cairo/Utilities/CairoMatrixT.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Utilities/CairoMatrixT.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Utilities.CairoMatrixT ( + Matrix(..), IsCairoMatrixT, CairoMatrixT, CairoMatrixRegularT, + cairoMatrixGet, cairoMatrixCopyFromRegular, + cairoMatrixNew, cairoMatrixRegularNew, cairoMatrixNewIdentity, + cairoMatrixNewTranslate, + cairoMatrixNewScale, cairoMatrixRegularNewScale, cairoMatrixNewRotate, + cairoMatrixTranslate, cairoMatrixScale, cairoMatrixRotate, cairoMatrixInvert, + cairoMatrixMultiply, + Distance(..), cairoMatrixTransformDistance, + Point(..), cairoMatrixTransformPoint ) where + +import Graphics.Cairo.Utilities.CairoMatrixT.Internal diff --git a/src/Graphics/Cairo/Utilities/CairoMatrixT/Internal.hsc b/src/Graphics/Cairo/Utilities/CairoMatrixT/Internal.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Utilities/CairoMatrixT/Internal.hsc @@ -0,0 +1,211 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeApplications, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Utilities.CairoMatrixT.Internal ( + Matrix(..), IsCairoMatrixT(..), + CairoMatrixT(..), CairoMatrixRegularT, cairoMatrixCopyFromRegular, + cairoMatrixAlloc, cairoMatrixGet, + cairoMatrixNew, cairoMatrixRegularNew, + cairoMatrixNewIdentity, + cairoMatrixNewTranslate, + cairoMatrixNewScale, cairoMatrixRegularNewScale, cairoMatrixNewRotate, + cairoMatrixTranslate, cairoMatrixScale, cairoMatrixRotate, cairoMatrixInvert, + cairoMatrixMultiply, + Distance(..), cairoMatrixTransformDistance, + Point(..), cairoMatrixTransformPoint ) where + +import Foreign.Ptr +import Foreign.ForeignPtr hiding (newForeignPtr) +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Control.Monad +import Control.Monad.Primitive +import Data.Word + +import Graphics.Cairo.Exception + +#include + +class IsCairoMatrixT mtx where + toCairoMatrixT :: mtx s -> CairoMatrixT s + fromCairoMatrixT :: CairoMatrixT s -> mtx s + +withCairoMatrixT :: (PrimMonad m, IsCairoMatrixT mtx) => + mtx (PrimState m) -> (Ptr (CairoMatrixT (PrimState m)) -> IO a) -> m a +withCairoMatrixT (toCairoMatrixT -> CairoMatrixT fmtx) = unsafeIOToPrim . withForeignPtr fmtx + +newtype CairoMatrixT s = CairoMatrixT (ForeignPtr (CairoMatrixT s)) deriving Show + +instance IsCairoMatrixT CairoMatrixT where + toCairoMatrixT = id + fromCairoMatrixT = id + +newtype CairoMatrixRegularT s = CairoMatrixRegularT (ForeignPtr (CairoMatrixT s)) deriving Show + +instance IsCairoMatrixT CairoMatrixRegularT where + toCairoMatrixT (CairoMatrixRegularT f) = CairoMatrixT f + fromCairoMatrixT (CairoMatrixT f) = CairoMatrixRegularT f + +cairoMatrixAlloc :: PrimMonad m => + (Ptr (CairoMatrixT (PrimState m)) -> IO a) -> + m (ForeignPtr (CairoMatrixT (PrimState m))) +cairoMatrixAlloc f = unsafeIOToPrim do + p <- mallocBytes #{size cairo_matrix_t} + (($) <$> newForeignPtr <*> free $ p) <* f p + +data Matrix = Matrix CDouble CDouble CDouble CDouble CDouble CDouble deriving Show + +cairoMatrixGet :: (PrimMonad m, IsCairoMatrixT mtx) => mtx (PrimState m) -> m Matrix +cairoMatrixGet mtx = withCairoMatrixT mtx \p -> Matrix + <$> #{peek cairo_matrix_t, xx} p <*> #{peek cairo_matrix_t, yx} p + <*> #{peek cairo_matrix_t, xy} p <*> #{peek cairo_matrix_t, yy} p + <*> #{peek cairo_matrix_t, x0} p <*> #{peek cairo_matrix_t, y0} p + +cairoMatrixNew :: PrimMonad m => + CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> + m (CairoMatrixT (PrimState m)) +cairoMatrixNew xx yx xy yy x0 y0 = CairoMatrixT + <$> cairoMatrixAlloc \p -> c_cairo_matrix_init p xx yx xy yy x0 y0 + +cairoMatrixRegularNew :: PrimMonad m => + CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> + m (Either (CairoMatrixT (PrimState m)) (CairoMatrixRegularT (PrimState m))) +cairoMatrixRegularNew xx yx xy yy x0 y0 = mk + <$> cairoMatrixAlloc \p -> c_cairo_matrix_init p xx yx xy yy x0 y0 + where mk = case xx * yy - yx * xy of + 0 -> Left . CairoMatrixT; _ -> Right . CairoMatrixRegularT + +foreign import ccall "cairo_matrix_init" c_cairo_matrix_init :: + Ptr (CairoMatrixT s) -> CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> CDouble -> IO () + +cairoMatrixNewIdentity :: (PrimMonad m, IsCairoMatrixT mtx) => m (mtx (PrimState m)) +cairoMatrixNewIdentity = fromCairoMatrixT . CairoMatrixT + <$> cairoMatrixAlloc c_cairo_matrix_init_identity + +foreign import ccall "cairo_matrix_init_identity" c_cairo_matrix_init_identity :: + Ptr (CairoMatrixT s) -> IO () + +cairoMatrixNewTranslate :: (PrimMonad m, IsCairoMatrixT mtx) => + CDouble -> CDouble -> m (mtx (PrimState m)) +cairoMatrixNewTranslate tx ty = fromCairoMatrixT . CairoMatrixT + <$> cairoMatrixAlloc \p -> c_cairo_matrix_init_translate p tx ty + +foreign import ccall "cairo_matrix_init_translate" c_cairo_matrix_init_translate :: + Ptr (CairoMatrixT s) -> CDouble -> CDouble -> IO () + +cairoMatrixNewScale :: PrimMonad m => + CDouble -> CDouble -> m (CairoMatrixT (PrimState m)) +cairoMatrixNewScale sx sy = CairoMatrixT + <$> cairoMatrixAlloc \p -> c_cairo_matrix_init_scale p sx sy + +cairoMatrixRegularNewScale :: PrimMonad m => + CDouble -> CDouble -> + m (Either (CairoMatrixT (PrimState m)) (CairoMatrixRegularT (PrimState m))) +cairoMatrixRegularNewScale sx sy = mk + <$> cairoMatrixAlloc \p -> c_cairo_matrix_init_scale p sx sy + where mk = case (sx, sy) of + (_, 0) -> Left . CairoMatrixT + (0, _) -> Left . CairoMatrixT + _ -> Right . CairoMatrixRegularT + +foreign import ccall "cairo_matrix_init_scale" c_cairo_matrix_init_scale :: + Ptr (CairoMatrixT s) -> CDouble -> CDouble -> IO () + +cairoMatrixNewRotate :: (PrimMonad m, IsCairoMatrixT mtx) => CDouble -> m (mtx (PrimState m)) +cairoMatrixNewRotate rad = fromCairoMatrixT . CairoMatrixT + <$> cairoMatrixAlloc \p -> c_cairo_matrix_init_rotate p rad + +foreign import ccall "cairo_matrix_init_rotate" c_cairo_matrix_init_rotate :: + Ptr (CairoMatrixT s) -> CDouble -> IO () + +cairoMatrixTranslate :: (PrimMonad m, IsCairoMatrixT mtx) => + mtx (PrimState m) -> CDouble -> CDouble -> m () +cairoMatrixTranslate mtx tx ty = + withCairoMatrixT mtx \p -> c_cairo_matrix_translate p tx ty + +foreign import ccall "cairo_matrix_translate" c_cairo_matrix_translate :: + Ptr (CairoMatrixT s) -> CDouble -> CDouble -> IO () + +cairoMatrixScale :: PrimMonad m => + CairoMatrixT (PrimState m) -> CDouble -> CDouble -> m () +cairoMatrixScale mtx sx sy = + withCairoMatrixT mtx \p -> c_cairo_matrix_scale p sx sy + +foreign import ccall "cairo_matrix_scale" c_cairo_matrix_scale :: + Ptr (CairoMatrixT s) -> CDouble -> CDouble -> IO () + +cairoMatrixRotate :: (PrimMonad m, IsCairoMatrixT mtx) => + mtx (PrimState m) -> CDouble -> m () +cairoMatrixRotate mtx rad = + withCairoMatrixT mtx \p -> c_cairo_matrix_rotate p rad + +foreign import ccall "cairo_matrix_rotate" c_cairo_matrix_rotate :: + Ptr (CairoMatrixT s) -> CDouble -> IO () + +cairoMatrixInvert :: PrimMonad m => + CairoMatrixRegularT (PrimState m) -> m () +cairoMatrixInvert (CairoMatrixRegularT fmtx) = + unsafeIOToPrim $ withForeignPtr fmtx \pmtx -> + cairoStatusToThrowError =<< c_cairo_matrix_invert pmtx + +foreign import ccall "cairo_matrix_invert" c_cairo_matrix_invert :: + Ptr (CairoMatrixT s) -> IO #{type cairo_status_t} + +cairoMatrixMultiply :: (PrimMonad m, IsCairoMatrixT mtx) => + mtx (PrimState m) -> mtx (PrimState m) -> mtx (PrimState m) -> m () +cairoMatrixMultiply + (toCairoMatrixT -> CairoMatrixT fr) + (toCairoMatrixT -> CairoMatrixT fa) + (toCairoMatrixT -> CairoMatrixT fb) = unsafeIOToPrim + $ withForeignPtr fr \pr -> withForeignPtr fa \pa -> withForeignPtr fb \pb -> + c_cairo_matrix_multiply pr pa pb + +foreign import ccall "cairo_matrix_multiply" c_cairo_matrix_multiply :: + Ptr (CairoMatrixT s) -> Ptr (CairoMatrixT s) -> Ptr (CairoMatrixT s) -> IO () + +data Distance = Distance CDouble CDouble deriving Show + +cairoMatrixTransformDistance :: (PrimMonad m, IsCairoMatrixT mtx) => + mtx (PrimState m) -> Distance -> m Distance +cairoMatrixTransformDistance mtx (Distance dx dy) = + withCairoMatrixT mtx \pmtx -> alloca \pdx -> alloca \pdy -> do + zipWithM_ poke [pdx, pdy] [dx, dy] + c_cairo_matrix_transform_distance pmtx pdx pdy + Distance <$> peek pdx <*> peek pdy + +foreign import ccall "cairo_matrix_transform_distance" c_cairo_matrix_transform_distance :: + Ptr (CairoMatrixT s) -> Ptr CDouble -> Ptr CDouble -> IO () + +data Point = Point CDouble CDouble deriving Show + +cairoMatrixTransformPoint :: (PrimMonad m, IsCairoMatrixT mtx) => + mtx (PrimState m) -> Point -> m Point +cairoMatrixTransformPoint mtx (Point x y) = + withCairoMatrixT mtx \pmtx -> alloca \px -> alloca \py -> do + zipWithM_ poke [px, py] [x, y] + c_cairo_matrix_transform_point pmtx px py + Point <$> peek px <*> peek py + +foreign import ccall "cairo_matrix_transform_point" c_cairo_matrix_transform_point :: + Ptr (CairoMatrixT s) -> Ptr CDouble -> Ptr CDouble -> IO () + +cairoMatrixCopyFromRegular :: PrimMonad m => + CairoMatrixRegularT (PrimState m) -> m (CairoMatrixT (PrimState m)) +cairoMatrixCopyFromRegular (CairoMatrixRegularT fmtx) = unsafeIOToPrim + $ CairoMatrixT <$> withForeignPtr fmtx \pmtx -> do + p <- cairoMatrixCopy pmtx + newForeignPtr p (free p) + +cairoMatrixCopy :: Ptr (CairoMatrixT s) -> IO (Ptr (CairoMatrixT s)) +cairoMatrixCopy p0 = do + p <- mallocBytes #{size cairo_matrix_t} + #{poke cairo_matrix_t, xx} p =<< (#{peek cairo_matrix_t, xx} p0 :: IO CDouble) + #{poke cairo_matrix_t, yx} p =<< (#{peek cairo_matrix_t, yx} p0 :: IO CDouble) + #{poke cairo_matrix_t, xy} p =<< (#{peek cairo_matrix_t, xy} p0 :: IO CDouble) + #{poke cairo_matrix_t, yy} p =<< (#{peek cairo_matrix_t, yy} p0 :: IO CDouble) + #{poke cairo_matrix_t, x0} p =<< (#{peek cairo_matrix_t, x0} p0 :: IO CDouble) + #{poke cairo_matrix_t, y0} p =<< (#{peek cairo_matrix_t, y0} p0 :: IO CDouble) + pure p diff --git a/src/Graphics/Cairo/Utilities/Types.hsc b/src/Graphics/Cairo/Utilities/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Utilities/Types.hsc @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BlockArguments, TupleSections #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Utilities.Types where + +import Foreign.Ptr +import Foreign.Concurrent +import Foreign.Marshal +import Foreign.Storable +import Foreign.C.Types +import Foreign.C.Struct +import Control.Monad.Primitive + +#include + +struct "CairoRectangleIntT" #{size cairo_rectangle_int_t} + #{alignment cairo_rectangle_int_t} + [ ("x", ''CInt, [| #{peek cairo_rectangle_int_t, x} |], + [| #{poke cairo_rectangle_int_t, x} |]), + ("y", ''CInt, [| #{peek cairo_rectangle_int_t, y} |], + [| #{poke cairo_rectangle_int_t, y} |]), + ("width", ''CInt, [| #{peek cairo_rectangle_int_t, width} |], + [| #{poke cairo_rectangle_int_t, width} |]), + ("height", ''CInt, [| #{peek cairo_rectangle_int_t, height} |], + [| #{poke cairo_rectangle_int_t, height} |]) ] + [''Show] + +c_cairo_rectangle_int_t_copy :: + Ptr CairoRectangleIntT -> IO (Ptr CairoRectangleIntT) +c_cairo_rectangle_int_t_copy s = do + d <- mallocBytes #{size cairo_rectangle_int_t} + d <$ copyBytes d s #{size cairo_rectangle_int_t} + +c_cairo_rectangle_int_t_free :: Ptr CairoRectangleIntT -> IO () +c_cairo_rectangle_int_t_free = free + +structPrim "CairoRectangleIntT" + 'c_cairo_rectangle_int_t_copy 'c_cairo_rectangle_int_t_free [''Show] + +cairoRectangleIntTNew :: PrimMonad m => m (CairoRectangleIntTPrim (PrimState m)) +cairoRectangleIntTNew = CairoRectangleIntTPrim <$> unsafeIOToPrim do + p <- mallocBytes #{size cairo_rectangle_int_t} + newForeignPtr p $ free p diff --git a/src/Graphics/Cairo/Values.hsc b/src/Graphics/Cairo/Values.hsc new file mode 100644 --- /dev/null +++ b/src/Graphics/Cairo/Values.hsc @@ -0,0 +1,25 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Graphics.Cairo.Values where + +import Data.Word +import Data.Int + +#include + +newtype CairoFontSlantT = CairoFontSlantT #{type cairo_font_slant_t} deriving Show + +#enum CairoFontSlantT, CairoFontSlantT, CAIRO_FONT_SLANT_NORMAL, \ + CAIRO_FONT_SLANT_ITALIC, CAIRO_FONT_SLANT_OBLIQUE + +newtype CairoFontWeightT = CairoFontWeightT #{type cairo_font_weight_t} deriving Show + +#enum CairoFontWeightT, CairoFontWeightT, \ + CAIRO_FONT_WEIGHT_NORMAL, CAIRO_FONT_WEIGHT_BOLD + +newtype CairoFormatT = CairoFormatT #{type cairo_format_t} deriving Show + +#enum CairoFormatT, CairoFormatT, CAIRO_FORMAT_INVALID, CAIRO_FORMAT_ARGB32, \ + CAIRO_FORMAT_RGB24, CAIRO_FORMAT_A8, CAIRO_FORMAT_A1, \ + CAIRO_FORMAT_RGB16_565, CAIRO_FORMAT_RGB30 diff --git a/test/Title.hs b/test/Title.hs new file mode 100644 --- /dev/null +++ b/test/Title.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Title where + +import Data.Char + +titleWidth :: Int +titleWidth = 80 + +titleWidthHalf1, titleWidthHalf2 :: Int +titleWidthHalf1 = titleWidth `div` 2 +titleWidthHalf2 = titleWidth - titleWidthHalf1 + +mkTitle :: String -> String +mkTitle ttl = + replicate titleWidth '*' ++ "\n" ++ + "*" ++ replicate (titleWidthHalf1 - 1 - s2) ' ' ++ + ttl' ++ replicate (titleWidthHalf2 - 1 - s1) ' ' ++ "*\n" ++ + replicate titleWidth '*' ++ "\n" + where + ttl' = toUpper <$> ttl + s = length ttl; s1 = s `div` 2; s2 = s - s1 diff --git a/test/cairo-image-test.hs b/test/cairo-image-test.hs new file mode 100644 --- /dev/null +++ b/test/cairo-image-test.hs @@ -0,0 +1,17 @@ +{-# OPTIOnS_GHC -Wall -fno-warn-tabs #-} + +module Main where + +import Data.Word +import Data.CairoImage + +main :: IO () +main = do + let pxl = PixelArgb32 0x01 0x02 0x03 0x04 + PixelArgb32 a r g b = pxl + print pxl + print (a, r, g, b) + +foo :: (Word8, Word8, Word8, Word8) +foo = case PixelArgb32 0x01 0x02 0x03 0x04 of + PixelArgb32 a r g b -> (a, r, g, b) diff --git a/test/exception.hs b/test/exception.hs new file mode 100644 --- /dev/null +++ b/test/exception.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +import Graphics.Cairo.Values +import Graphics.Cairo.Drawing.CairoT +import Graphics.Cairo.Drawing.Paths +import Graphics.Cairo.Surfaces.ImageSurfaces +import Graphics.Cairo.Monad + +main :: IO () +main = do + s <- cairoImageSurfaceCreate cairoFormatArgb32 500 500 + cr <- cairoCreate s + cairoLineTo cr 100 100 + cairoNewPath cr + cairoLineTo cr 0 0 + cairoStroke cr + cairoPopGroupToSource cr + print =<< cairoImageSurfaceGetData s diff --git a/test/test-rotate.hs b/test/test-rotate.hs new file mode 100644 --- /dev/null +++ b/test/test-rotate.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +import Graphics.Cairo.Exception +import Graphics.Cairo.Values +import Graphics.Cairo.Drawing.CairoT +import Graphics.Cairo.Drawing.CairoPatternT +import Graphics.Cairo.Drawing.Transformations +import Graphics.Cairo.Surfaces.ImageSurfaces +import Graphics.Cairo.Surfaces.PngSupport + +import Paths_simple_cairo + +main :: IO () +main = do + putStrLn "*** TEST ROTATE BEGIN ***" + sfc0 <- cairoImageSurfaceCreate cairoFormatArgb32 256 256 + cr <- cairoCreate sfc0 + sfc <- cairoSurfaceCreateFromPng =<< getDataFileName "HaskellLogo.png" + ptn <- cairoPatternCreateForSurface sfc + cairoTranslate cr 128 ((256 - sqrt 2 * 128) / 2) + cairoRotate cr (pi / 4) + cairoSetSource cr ptn + cairoPaint cr + cairoStatusToThrowError . (\(CairoStatusT w) -> w) =<< cairoSurfaceWriteToPng sfc0 "HaskellLogoRotated.png" + putStrLn "*** TEST ROTATE END ***" +