packages feed

cairo-image (empty) → 0.1.0.0

raw patch · 11 files changed

+997/−0 lines, 11 filesdep +basedep +c-enumdep +cairo-imagesetup-changed

Dependencies added: base, c-enum, cairo-image, primitive, template-haskell

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for cairo-image++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2021++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 Author name here 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.
+ README.md view
@@ -0,0 +1,1 @@+# cairo-image
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cairo-image.cabal view
@@ -0,0 +1,79 @@+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: 019144719bfd1a9899dfe8c1822b6002ad8233bee5f37fd9c8f169534c7affe3++name:           cairo-image+version:        0.1.0.0+synopsis:       Image for Cairo+description:    Please see the README on GitHub at <https://github.com/githubuser/cairo-image#readme>+category:       Graphics+homepage:       https://github.com/githubuser/cairo-image#readme+bug-reports:    https://github.com/githubuser/cairo-image/issues+author:         Author name here+maintainer:     example@example.com+copyright:      2021 Author name here+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/githubuser/cairo-image++library+  exposed-modules:+      Data.CairoImage+      Data.CairoImage.Internal+  other-modules:+      Data.CairoImage.Parts+      System.TargetEndian+      Paths_cairo_image+  hs-source-dirs:+      src+  pkgconfig-depends:+      cairo+  build-depends:+      base >=4.7 && <5+    , c-enum >=0.1.1 && <0.2+    , primitive >=0.8.0 && <0.10+    , template-haskell >=2.18.0 && <2.21+  default-language: Haskell2010++test-suite cairo-image-test+  type: exitcode-stdio-1.0+  main-is: spec.hs+  other-modules:+      Paths_cairo_image+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , c-enum >=0.1.1 && <0.2+    , cairo-image+    , primitive >=0.8.0 && <0.10+    , template-haskell >=2.18.0 && <2.21+  default-language: Haskell2010++test-suite test-endian+  type: exitcode-stdio-1.0+  main-is: endian.hs+  other-modules:+      Paths_cairo_image+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , c-enum >=0.1.1 && <0.2+    , cairo-image+    , primitive >=0.8.0 && <0.10+    , template-haskell >=2.18.0 && <2.21+  default-language: Haskell2010
+ src/Data/CairoImage.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.CairoImage (+	-- * Class Image and ImageMut+	Image(..), ImageMut(..),+	-- * Type CairoImage and CairoImageMut+	CairoImage, CairoImageMut, cairoImageFreeze, cairoImageThaw,+	-- * Image Format+	-- ** ARGB 32+	PixelArgb32,+	pattern PixelArgb32Premultiplied, pixelArgb32Premultiplied,+	pattern PixelArgb32Straight,+	pattern CairoImageArgb32, Argb32,+	pattern CairoImageMutArgb32, Argb32Mut,+	-- ** RGB 24+	PixelRgb24, pattern PixelRgb24,+	pattern CairoImageRgb24, Rgb24,+	pattern CairoImageMutRgb24, Rgb24Mut,+	-- ** A 8+	PixelA8, pattern PixelA8,+	pattern CairoImageA8, A8,+	pattern CairoImageMutA8, A8Mut,+	-- ** A 1+	PixelA1, pattern PixelA1, Bit(..), bit,+	pattern CairoImageA1, A1,+	pattern CairoImageMutA1, A1Mut,+	-- ** RGB 16 565+	PixelRgb16_565, pattern PixelRgb16_565,+	pattern CairoImageRgb16_565, Rgb16_565,+	pattern CairoImageMutRgb16_565, Rgb16_565Mut,+	-- ** RGB 30+	PixelRgb30, pattern PixelRgb30,+	pattern CairoImageRgb30, Rgb30,+	pattern CairoImageMutRgb30, Rgb30Mut ) where++import Data.CairoImage.Internal (+	Image(..), ImageMut(..),+	CairoImage, CairoImageMut, cairoImageFreeze, cairoImageThaw,+	PixelArgb32,+	pattern PixelArgb32Premultiplied, pixelArgb32Premultiplied,+	pattern PixelArgb32Straight,+	pattern CairoImageArgb32, Argb32,+	pattern CairoImageMutArgb32, Argb32Mut,+	PixelRgb24, pattern PixelRgb24,+	pattern CairoImageRgb24, Rgb24, pattern CairoImageMutRgb24, Rgb24Mut,+	PixelA8, pattern PixelA8,+	pattern CairoImageA8, A8, pattern CairoImageMutA8, A8Mut,+	PixelA1, pattern PixelA1, Bit(..), bit,+	pattern CairoImageA1, A1, pattern CairoImageMutA1, A1Mut,+	PixelRgb16_565, pattern PixelRgb16_565,+	pattern CairoImageRgb16_565, Rgb16_565,+	pattern CairoImageMutRgb16_565, Rgb16_565Mut,+	PixelRgb30, pattern PixelRgb30,+	pattern CairoImageRgb30, Rgb30, pattern CairoImageMutRgb30, Rgb30Mut )
+ src/Data/CairoImage/Internal.hs view
@@ -0,0 +1,664 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE TypeApplications, PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.CairoImage.Internal (+	-- * Class Image and ImageMut+	Image(..), ImageMut(..),+	-- * Type CairoImage and CairoImageMut+	CairoImage(..), CairoImageMut(..), cairoImageFreeze, cairoImageThaw,+	-- * Image Format+	-- ** ARGB 32+	PixelArgb32(..),+	pattern PixelArgb32Premultiplied, pixelArgb32Premultiplied,+	pattern PixelArgb32Straight,+	pattern CairoImageArgb32, Argb32,+	pattern CairoImageMutArgb32, Argb32Mut,+	-- ** RGB 24+	PixelRgb24(..), pattern PixelRgb24,+	pattern CairoImageRgb24, Rgb24,+	pattern CairoImageMutRgb24, Rgb24Mut,+	-- ** A 8+	PixelA8(..),+	pattern CairoImageA8, A8,+	pattern CairoImageMutA8, A8Mut,+	-- ** A 1+	PixelA1(..), Bit(..), bit,+	pattern CairoImageA1, A1,+	pattern CairoImageMutA1, A1Mut,+	-- ** RGB 16 565+	PixelRgb16_565(..), pattern PixelRgb16_565,+	pattern CairoImageRgb16_565, Rgb16_565,+	pattern CairoImageMutRgb16_565, Rgb16_565Mut,+	-- ** RGB 30+	PixelRgb30(..), pattern PixelRgb30,+	pattern CairoImageRgb30, Rgb30,+	pattern CairoImageMutRgb30, Rgb30Mut,++	-- * CairoFormatT+	CairoFormatT(..),+	pattern CairoFormatArgb32, pattern CairoFormatRgb24,+	pattern CairoFormatA8, pattern CairoFormatA1,+	pattern CairoFormatRgb16_565, pattern CairoFormatRgb30 ) where++import Foreign.Ptr (Ptr, castPtr, plusPtr)+import Foreign.ForeignPtr (ForeignPtr, castForeignPtr)+import Foreign.Concurrent (newForeignPtr)+import Foreign.Marshal (mallocBytes, free, copyBytes)+import Foreign.Storable (Storable, peek, poke)+import Foreign.C.Types (CInt(..), CUChar)+import Control.Monad.Primitive (+	PrimMonad(..), PrimBase, unsafeIOToPrim, unsafePrimToIO )+import Control.Monad.ST (runST)+import Data.Foldable (for_)+import Data.List (foldl1')+import Data.Bool (bool)+import Data.Bits ((.|.), testBit, clearBit, setBit, shiftL, shiftR)+import Data.Word (Word8, Word16, Word32)+import Data.CairoImage.Parts+import System.IO.Unsafe (unsafePerformIO)+import System.TargetEndian (endian)++---------------------------------------------------------------------------++-- * CLASS IMAGE AND IMAGE MUTABLE+-- * TYPE CAIRO IMAGE AND CAIRO IMAGE MUTABLE+-- * ARGB 32+--	+ PIXEL+--	+ IMAGE+--	+ IMAGE MUTABLE+-- * RGB 24+--	+ PIXEL+--	+ IMAGE+--	+ IMAGE MUTABLE+-- * A 8+--	+ PIXEL+--	+ IMAGE+--	+ IMAGE MUTABLE+-- * A 1+--	+ PIXEL+--	+ IMAGE+--	+ IMAGE MUTABLE+-- * RGB 16 565+--	+ PIXEL+--	+ IMAGE+--	+ IMAGE MUTABLE+-- * RGB 30+--	+ PIXEL+--	+ IMAGE+--	+ IMAGE MUTABLE+-- * COMMON++---------------------------------------------------------------------------+-- CLASS IMAGE AND IMAGE MUTABLE+---------------------------------------------------------------------------++class Image i where+	type Pixel i+	imageSize :: i -> (CInt, CInt)+	pixelAt :: i -> CInt -> CInt -> Maybe (Pixel i)+	generateImage :: CInt -> CInt -> (CInt -> CInt -> Pixel i) -> i+	generateImagePrimM :: PrimBase m =>+		CInt -> CInt -> (CInt -> CInt -> m (Pixel i)) -> m i++	generateImage w h f =+		runST $ generateImagePrimM w h \x y -> pure $ f x y++class ImageMut im where+	type PixelMut im+	imageMutSize :: im s -> (CInt, CInt)+	getPixel :: PrimMonad m =>+		im (PrimState m) -> CInt -> CInt -> m (Maybe (PixelMut im))+	putPixel :: PrimMonad m =>+		im (PrimState m) -> CInt -> CInt -> PixelMut im -> m ()+	newImageMut :: PrimMonad m => CInt -> CInt -> m (im (PrimState m))++---------------------------------------------------------------------------+-- TYPE CAIRO IMAGE AND CAIRO IMAGE MUTABLE+---------------------------------------------------------------------------++data CairoImage = CairoImage {+	cairoImageFormat :: CairoFormatT,+	cairoImageWidth :: CInt, cairoImageHeight :: CInt,+	cairoImageStride :: CInt, cairoImageData :: ForeignPtr CUChar }+	deriving Show++instance Eq CairoImage where+	ci1 == ci2 = and [+		fmt1 == fmt2, w1 == w2, h1 == h2, str1 == str2,+		unsafePerformIO $ with fd1 \d1 -> with fd2 \d2 ->+			(EQ ==) <$> compareBytes d1 d2 (str1 * h1) ]+		where+		[fmt1, fmt2] = cairoImageFormat <$> [ci1, ci2]+		[w1, w2] = cairoImageWidth <$> [ci1, ci2]+		[h1, h2] = cairoImageHeight <$> [ci1, ci2]+		[str1, str2] = cairoImageStride <$> [ci1, ci2]+		[fd1, fd2] = cairoImageData <$> [ci1, ci2]++compareBytes :: (Ord n, Num n) => Ptr a -> Ptr a -> n -> IO Ordering+compareBytes _ _ n | n < 1 = pure EQ+compareBytes p1 p2 _ | p1 == p2 = pure EQ+compareBytes p1 p2 n = compare <$> peek pb1 <*> peek pb2 >>= \case+	EQ -> compareBytes p1 p2 (n - 1); o -> pure o+	where [pb1, pb2] = castPtr <$> [p1, p2] :: [Ptr Word8]++data CairoImageMut s = CairoImageMut {+	cairoImageMutFormat :: CairoFormatT,+	cairoImageMutWidth :: CInt, cairoImageMutHeight :: CInt,+	cairoImageMutStride :: CInt, cairoImageMutData :: ForeignPtr CUChar }+	deriving Show++cairoImageFreeze :: PrimMonad m => CairoImageMut (PrimState m) -> m CairoImage+cairoImageFreeze im = unsafeIOToPrim $ CairoImage f w h st <$> cidClone st h dt+	where+	f = cairoImageMutFormat im+	w = cairoImageMutWidth im; h = cairoImageMutHeight im+	st = cairoImageMutStride im; dt = cairoImageMutData im++cairoImageThaw :: PrimMonad m => CairoImage -> m (CairoImageMut (PrimState m))+cairoImageThaw i = unsafeIOToPrim $ CairoImageMut f w h st <$> cidClone st h dt+	where+	f = cairoImageFormat i+	w = cairoImageWidth i; h = cairoImageHeight i+	st = cairoImageStride i; dt = cairoImageData i++cidClone :: CInt -> CInt -> ForeignPtr CUChar -> IO (ForeignPtr CUChar)+cidClone st h fd = with fd \d -> mallocBytes n >>= \d' ->+	copyBytes d' d n >> newForeignPtr d' (free d')+	where n = fromIntegral $ st * h++---------------------------------------------------------------------------+-- ARGB 32+---------------------------------------------------------------------------++-- PIXEL++newtype PixelArgb32 = PixelArgb32Word32 Word32 deriving (Show, Storable)++{-# COMPLETE PixelArgb32Premultiplied #-}++pattern PixelArgb32Premultiplied ::+	Word8 -> Word8 -> Word8 -> Word8 -> PixelArgb32+pattern PixelArgb32Premultiplied a r g b <- (pixelArgb32ToArgb -> (a, r, g, b))++pixelArgb32Premultiplied ::+	Word8 -> Word8 -> Word8 -> Word8 -> Maybe PixelArgb32+pixelArgb32Premultiplied a r g b+	| r <= a, g <= a, b <= a = Just $ pixelArgb32FromArgb a r g b+	| otherwise = Nothing++pixelArgb32FromArgb :: Word8 -> Word8 -> Word8 -> Word8 -> PixelArgb32+pixelArgb32FromArgb+	(fromIntegral -> a) (fromIntegral -> r)+	(fromIntegral -> g) (fromIntegral -> b) = PixelArgb32Word32+	. foldl1' (.|.) $ zipWith shiftL [a, r, g, b] [24, 16, 8, 0]++pixelArgb32ToArgb :: PixelArgb32 -> (Word8, Word8, Word8, Word8)+pixelArgb32ToArgb (PixelArgb32Word32 w) = (+	fromIntegral $ w `shiftR` 24, fromIntegral $ w `shiftR` 16,+	fromIntegral $ w `shiftR` 8, fromIntegral w )++{-# COMPLETE PixelArgb32Straight #-}++pattern PixelArgb32Straight :: Word8 -> Word8 -> Word8 -> Word8 -> PixelArgb32+pattern PixelArgb32Straight a r g b <- (pixelArgb32ToArgbSt -> (a, r, g, b))+	where PixelArgb32Straight a r g b = pixelArgb32FromArgb+		a (r `unit` (a, 0xff)) (g `unit` (a, 0xff)) (b `unit` (a, 0xff))++pixelArgb32ToArgbSt :: PixelArgb32 -> (Word8, Word8, Word8, Word8)+pixelArgb32ToArgbSt p = let (a, r, g, b) = pixelArgb32ToArgb p in+	(a, r `unit` (0xff, a), g `unit` (0xff, a), b `unit` (0xff, a))++unit :: Word8 -> (Word8, Word8) -> Word8+(fromIntegral -> n) `unit` ((fromIntegral -> m), (fromIntegral -> d)) =+	fromIntegral @Word16 $ n * m `div'` d++infixl 7 `div'`++div' :: Integral n => n -> n -> n+div' n = \case 0 -> 0; m -> n `div` m++-- IMAGE++data Argb32 = Argb32 {+	argb32Width :: CInt, argb32Height :: CInt,+	argb32Stride :: CInt, argb32Data :: ForeignPtr PixelArgb32 }+	deriving Show++pattern CairoImageArgb32 :: Argb32 -> CairoImage+pattern CairoImageArgb32 a <- (cairoImageToArgb32 -> Just a) where+	CairoImageArgb32 (Argb32 w h s d) =+		CairoImage CairoFormatArgb32 w h s $ castForeignPtr d++cairoImageToArgb32 :: CairoImage -> Maybe Argb32+cairoImageToArgb32 = \case+	CairoImage CairoFormatArgb32 w h s d ->+		Just . Argb32 w h s $ castForeignPtr d+	_ -> Nothing++instance Image Argb32 where+	type Pixel Argb32 = PixelArgb32+	imageSize (Argb32 w h _ _) = (w, h)+	pixelAt (Argb32 w h s d) x y = unsafePerformIO $ with d \p ->+		maybe (pure Nothing) ((Just <$>) . peek) $ ptr w h s p x y+	generateImagePrimM w h f = stride CairoFormatArgb32 w >>= \s ->+		Argb32 w h s <$> gen w h s f++-- IMAGE MUTABLE++data Argb32Mut s = Argb32Mut {+	argb32MutWidth :: CInt, argb32MutHeight :: CInt,+	argb32MutStride :: CInt, argb32MutData :: ForeignPtr PixelArgb32 }+	deriving Show++pattern CairoImageMutArgb32 :: Argb32Mut s -> CairoImageMut s+pattern CairoImageMutArgb32 a <- (cairoImageMutToArgb32 -> Just a) where+	CairoImageMutArgb32 (Argb32Mut w h s d) =+		CairoImageMut CairoFormatArgb32 w h s $ castForeignPtr d++cairoImageMutToArgb32 :: CairoImageMut s -> Maybe (Argb32Mut s)+cairoImageMutToArgb32 = \case+	CairoImageMut CairoFormatArgb32 w h s d ->+		Just . Argb32Mut w h s $ castForeignPtr d+	_ -> Nothing++instance ImageMut Argb32Mut where+	type PixelMut Argb32Mut = PixelArgb32+	imageMutSize (Argb32Mut w h _ _) = (w, h)+	getPixel (Argb32Mut w h s d) x y = unsafeIOToPrim $ with d \p ->+		maybe (pure Nothing) ((Just <$>) . peek) $ ptr w h s p x y+	putPixel (Argb32Mut w h s d) x y px = unsafeIOToPrim $ with d \p ->+		maybe (pure ()) (`poke` px) $ ptr w h s p x y+	newImageMut w h =+		stride CairoFormatArgb32 w >>= \s -> Argb32Mut w h s <$> new s h++---------------------------------------------------------------------------+-- RGB 24+---------------------------------------------------------------------------++-- PIXEL++newtype PixelRgb24 = PixelRgb24Word32 Word32 deriving (Show, Storable)++{-# COMPLETE PixelRgb24 #-}++pattern PixelRgb24 :: Word8 -> Word8 -> Word8 -> PixelRgb24+pattern PixelRgb24 r g b <- (pixelRgb24ToRgb -> (r, g, b)) where+	PixelRgb24 (fromIntegral -> r) (fromIntegral -> g) (fromIntegral -> b) =+		PixelRgb24Word32+			. foldl1' (.|.) $ zipWith shiftL [r, g, b] [16, 8, 0]++pixelRgb24ToRgb :: PixelRgb24 -> (Word8, Word8, Word8)+pixelRgb24ToRgb (PixelRgb24Word32 w) = (+	fromIntegral $ w `shiftR` 16,+	fromIntegral $ w `shiftR` 8, fromIntegral w )++-- IMAGE++data Rgb24 = Rgb24 {+	rgb24Width :: CInt, rgb24Height :: CInt,+	rgb24Stride :: CInt, rgb24Data :: ForeignPtr PixelRgb24 }+	deriving Show++pattern CairoImageRgb24 :: Rgb24 -> CairoImage+pattern CairoImageRgb24 r <- (cairoImageToRgb24 -> Just r) where+	CairoImageRgb24 (Rgb24 w h s d) =+		CairoImage CairoFormatRgb24 w h s $ castForeignPtr d++cairoImageToRgb24 :: CairoImage -> Maybe Rgb24+cairoImageToRgb24 = \case+	CairoImage CairoFormatRgb24 w h s d ->+		Just . Rgb24 w h s $ castForeignPtr d+	_ -> Nothing++instance Image Rgb24 where+	type Pixel Rgb24 = PixelRgb24+	imageSize (Rgb24 w h _ _) = (w, h)+	pixelAt (Rgb24 w h s d) x y = unsafePerformIO $ with d \p ->+		maybe (pure Nothing) ((Just <$>) . peek) $ ptr w h s p x y+	generateImagePrimM w h f =+		stride CairoFormatRgb24 w >>= \s -> Rgb24 w h s <$> gen w h s f++-- IMAGE MUTABLE++data Rgb24Mut s = Rgb24Mut {+	rgb24MutWidth :: CInt, rgb24MutHeight :: CInt,+	rgb24MutStride :: CInt, rgb24MutData :: ForeignPtr PixelRgb24 }+	deriving Show++pattern CairoImageMutRgb24 :: Rgb24Mut s -> CairoImageMut s+pattern CairoImageMutRgb24 r <- (cairoImageMutToRgb24 -> Just r) where+	CairoImageMutRgb24 (Rgb24Mut w h s d) =+		CairoImageMut CairoFormatRgb24 w h s $ castForeignPtr d++cairoImageMutToRgb24 :: CairoImageMut s -> Maybe (Rgb24Mut s)+cairoImageMutToRgb24 = \case+	CairoImageMut CairoFormatRgb24 w h s d ->+		Just . Rgb24Mut w h s $ castForeignPtr d+	_ -> Nothing++instance ImageMut Rgb24Mut where+	type PixelMut Rgb24Mut = PixelRgb24+	imageMutSize (Rgb24Mut w h _ _) = (w, h)+	getPixel (Rgb24Mut w h s d) x y = unsafeIOToPrim $ with d \p ->+		maybe (pure Nothing) ((Just <$>) . peek) $ ptr w h s p x y+	putPixel (Rgb24Mut w h s d) x y px = unsafeIOToPrim $ with d \p ->+		maybe (pure ()) (`poke` px) $ ptr w h s p x y+	newImageMut w h =+		stride CairoFormatRgb24 w >>= \s -> Rgb24Mut w h s <$> new s h++---------------------------------------------------------------------------+-- A 8+---------------------------------------------------------------------------++-- PIXEL++newtype PixelA8 = PixelA8 Word8 deriving (Show, Storable)++-- IMAGE++data A8 = A8 {+	a8Width :: CInt, a8Height :: CInt,+	a8Stride :: CInt, a8Data :: ForeignPtr PixelA8 }+	deriving Show++pattern CairoImageA8 :: A8 -> CairoImage+pattern CairoImageA8 a <- (cairoImageToA8 -> Just a)+	where CairoImageA8 (A8 w h s d) =+		CairoImage CairoFormatA8 w h s $ castForeignPtr d++cairoImageToA8 :: CairoImage -> Maybe A8+cairoImageToA8 = \case+	CairoImage CairoFormatA8 w h s d -> Just . A8 w h s $ castForeignPtr d+	_ -> Nothing++instance Image A8 where+	type Pixel A8 = PixelA8+	imageSize (A8 w h _ _) = (w, h)+	pixelAt (A8 w h s d) x y = unsafePerformIO $ with d \p ->+		maybe (pure Nothing) ((Just <$>) . peek) $ ptr w h s p x y+	generateImagePrimM w h f =+		stride CairoFormatA8 w >>= \s -> A8 w h s <$> gen w h s f++-- IMAGE MUTABLE++data A8Mut s = A8Mut {+	a8MutWidth :: CInt, a8MutHeight :: CInt,+	a8MutStride :: CInt, a8MutData :: ForeignPtr PixelA8 }+	deriving Show++pattern CairoImageMutA8 :: A8Mut s -> CairoImageMut s+pattern CairoImageMutA8 a <- (cairoImageMutToA8 -> Just a)+	where CairoImageMutA8 (A8Mut w h s d) =+		CairoImageMut CairoFormatA8 w h s $ castForeignPtr d++cairoImageMutToA8 :: CairoImageMut s -> Maybe (A8Mut s)+cairoImageMutToA8 = \case+	CairoImageMut CairoFormatA8 w h s d ->+		Just . A8Mut w h s $ castForeignPtr d+	_ -> Nothing++instance ImageMut A8Mut where+	type PixelMut A8Mut = PixelA8+	imageMutSize (A8Mut w h _ _) = (w, h)+	getPixel (A8Mut w h s d) x y = unsafeIOToPrim $ with d \p ->+		maybe (pure Nothing) ((Just <$>) . peek) $ ptr w h s p x y+	putPixel (A8Mut w h s d) x y px = unsafeIOToPrim $ with d \p ->+		maybe (pure ()) (`poke` px) $ ptr w h s p x y+	newImageMut w h =+		stride CairoFormatA8 w >>= \s -> A8Mut w h s <$> new s h++---------------------------------------------------------------------------+-- A 1+---------------------------------------------------------------------------++-- PIXEL++newtype PixelA1 = PixelA1 Bit deriving Show++data Bit = O | I deriving (Show, Enum)++bit :: a -> a -> Bit -> a+bit x y = \case O -> x; I -> y++ptrA1 :: CInt -> CInt -> CInt ->+	Ptr PixelA1 -> CInt -> CInt -> Maybe (Ptr PixelA1, CInt)+ptrA1 w h s p x y+	| 0 <= x && x < w && 0 <= y && y < h = Just+		(p `plusPtr` fromIntegral (y * s + x `div` 32 * 4), x `mod` 32)+	| otherwise = Nothing++peA1 :: (Ptr PixelA1, CInt) -> IO PixelA1+peA1 ((castPtr -> p), (fromIntegral . $(endian [e| id |] [e| (31 -) |]) -> i)) =+	PixelA1 . bool O I . (`testBit` i) <$> peek @Word32 p++poA1 :: (Ptr PixelA1, CInt) -> PixelA1 -> IO ()+poA1 ((castPtr -> p), (fromIntegral . $(endian [e| id |] [e| (31 -) |]) -> i))+	(PixelA1 b) = poke p . flip (bit clearBit setBit b) i =<< peek @Word32 p++-- IMAGE++data A1 = A1 {+	a1Width :: CInt, a1Height :: CInt,+	a1Stride :: CInt, a1Data :: ForeignPtr PixelA1 }+	deriving Show++pattern CairoImageA1 :: A1 -> CairoImage+pattern CairoImageA1 a <- (cairoImageToA1 -> Just a)+	where CairoImageA1 (A1 w h s d) =+		CairoImage CairoFormatA1 w h s $ castForeignPtr d++cairoImageToA1 :: CairoImage -> Maybe A1+cairoImageToA1 = \case+	CairoImage CairoFormatA1 w h s d -> Just . A1 w h s $ castForeignPtr d+	_ -> Nothing++instance Image A1 where+	type Pixel A1 = PixelA1+	imageSize (A1 w h _ _) = (w, h)+	pixelAt (A1 w h s d) x y = unsafePerformIO $ with d \p ->+		maybe (pure Nothing) ((Just <$>) . peA1) $ ptrA1 w h s p x y+	generateImagePrimM = genA1++genA1 :: PrimBase m => CInt -> CInt -> (CInt -> CInt -> m PixelA1) -> m A1+genA1 w h f = unsafeIOToPrim $ stride CairoFormatA1 w >>= \s -> do+	d <- mallocBytes . fromIntegral $ s * h+	for_ [0 .. h - 1] \y -> for_ [0 .. w - 1] \x ->+		unsafePrimToIO (f x y) >>= \px ->+			maybe (pure ()) (`poA1` px) $ ptrA1 w h s d x y+	A1 w h s <$> newForeignPtr d (free d)++-- IMAGE MUTABLE++data A1Mut s = A1Mut {+	a1MutWidth :: CInt, a1MutHeight :: CInt,+	a1MutStride :: CInt, a1MutData :: ForeignPtr PixelA1 }+	deriving Show++pattern CairoImageMutA1 :: A1Mut s -> CairoImageMut s+pattern CairoImageMutA1 a <- (cairoImageMutToA1 -> Just a)+	where CairoImageMutA1 (A1Mut w h s d) =+		CairoImageMut CairoFormatA1 w h s $ castForeignPtr d++cairoImageMutToA1 :: CairoImageMut s -> Maybe (A1Mut s)+cairoImageMutToA1 = \case+	CairoImageMut CairoFormatA1 w h s d ->+		Just . A1Mut w h s $ castForeignPtr d+	_ -> Nothing++instance ImageMut A1Mut where+	type PixelMut A1Mut = PixelA1+	imageMutSize (A1Mut w h _ _) = (w, h)+	getPixel (A1Mut w h s d) x y = unsafeIOToPrim $ with d \p ->+		maybe (pure Nothing) ((Just <$>) . peA1) $ ptrA1 w h s p x y+	putPixel (A1Mut w h s d) x y px = unsafeIOToPrim $ with d \p ->+		maybe (pure ()) (`poA1` px) $ ptrA1 w h s p x y+	newImageMut w h =+		stride CairoFormatA1 w >>= \s -> A1Mut w h s <$> new s h++---------------------------------------------------------------------------+-- RGB 16 565+---------------------------------------------------------------------------++-- PIXEL++newtype PixelRgb16_565 = PixelRgb16_565Word16 Word16 deriving (Show, Storable)++{-# COMPLETE PixelRgb16_565 #-}++pattern PixelRgb16_565 :: Word8 -> Word8 -> Word8 -> PixelRgb16_565+pattern PixelRgb16_565 r g b <- (pixelRgb16_565ToRgb -> (r, g, b))+	where PixelRgb16_565+		(fromIntegral -> r) (fromIntegral -> g) (fromIntegral -> b) =+		PixelRgb16_565Word16 $ r' .|. g' .|. b'+		where+		r' = r `shiftR` 3 `shiftL` 11+		g' = g `shiftR` 2 `shiftL` 5+		b' = b `shiftR` 3++pixelRgb16_565ToRgb :: PixelRgb16_565 -> (Word8, Word8, Word8)+pixelRgb16_565ToRgb (PixelRgb16_565Word16 rgb) =+	(r .|. r `shiftR` 5, g .|. g `shiftR` 6, b .|. b `shiftR` 5)+	where+	r = fromIntegral $ rgb `shiftR` 11 `shiftL` 3+	g = fromIntegral $ rgb `shiftR` 5 `shiftL` 2+	b = fromIntegral $ rgb `shiftL` 3++-- IMAGE++data Rgb16_565 = Rgb16_565 {+	rgb16_565Width :: CInt, rgb16_565Height :: CInt,+	rgb16_565Stride :: CInt, rgb16_565Data :: ForeignPtr PixelRgb16_565 }+	deriving Show++pattern CairoImageRgb16_565 :: Rgb16_565 -> CairoImage+pattern CairoImageRgb16_565 r <- (cairoImageToRgb16_565 -> Just r)+	where CairoImageRgb16_565 (Rgb16_565 w h s d) =+		CairoImage CairoFormatRgb16_565 w h s $ castForeignPtr d++cairoImageToRgb16_565 :: CairoImage -> Maybe Rgb16_565+cairoImageToRgb16_565 = \case+	CairoImage CairoFormatRgb16_565 w h s d ->+		Just . Rgb16_565 w h s $ castForeignPtr d+	_ -> Nothing++instance Image Rgb16_565 where+	type Pixel Rgb16_565 = PixelRgb16_565+	imageSize (Rgb16_565 w h _ _) = (w, h)+	pixelAt (Rgb16_565 w h s d) x y = unsafePerformIO $ with d \p ->+		maybe (pure Nothing) ((Just <$>) . peek) $ ptr w h s p x y+	generateImagePrimM w h f = stride CairoFormatRgb16_565 w >>= \s ->+		Rgb16_565 w h s <$> gen w h s f++-- IMAGE MUTABLE++data Rgb16_565Mut s = Rgb16_565Mut {+	rgb16_565MutWidth :: CInt, rgb16_565MutHeight :: CInt,+	rgb16_565MutStride :: CInt,+	rgb16_565MutData :: ForeignPtr PixelRgb16_565 }+	deriving Show++pattern CairoImageMutRgb16_565 :: Rgb16_565Mut s -> CairoImageMut s+pattern CairoImageMutRgb16_565 r <- (cairoImageMutToRgb16_565 -> Just r)+	where CairoImageMutRgb16_565 (Rgb16_565Mut w h s d) =+		CairoImageMut CairoFormatRgb16_565 w h s $ castForeignPtr d++cairoImageMutToRgb16_565 :: CairoImageMut s -> Maybe (Rgb16_565Mut s)+cairoImageMutToRgb16_565 = \case+	CairoImageMut CairoFormatRgb16_565 w h s d ->+		Just . Rgb16_565Mut w h s $ castForeignPtr d+	_ -> Nothing++instance ImageMut Rgb16_565Mut where+	type PixelMut Rgb16_565Mut = PixelRgb16_565+	imageMutSize (Rgb16_565Mut w h _ _) = (w, h)+	getPixel (Rgb16_565Mut w h s d) x y = unsafeIOToPrim $ with d \p ->+		maybe (pure Nothing) ((Just <$>) . peek) $ ptr w h s p x y+	putPixel (Rgb16_565Mut w h s d) x y px = unsafeIOToPrim $ with d \p ->+		maybe (pure ()) (`poke` px) $ ptr w h s p x y+	newImageMut w h = stride CairoFormatRgb16_565 w >>= \s ->+		Rgb16_565Mut w h s <$> new s h++---------------------------------------------------------------------------+-- RGB 30+---------------------------------------------------------------------------++-- PIXEL++newtype PixelRgb30 = PixelRgb30Word32 Word32 deriving (Show, Storable)++{-# COMPLETE PixelRgb30 #-}++pattern PixelRgb30 :: Word16 -> Word16 -> Word16 -> PixelRgb30+pattern PixelRgb30 r g b <- (pixelRgb30ToRgb -> (r, g, b)) where+	PixelRgb30 (fromIntegral -> r) (fromIntegral -> g) (fromIntegral -> b) =+		PixelRgb30Word32 $ r' .|. g' .|. b'+		where+		r' = r `shiftR` 6 `shiftL` 20+		g' = g `shiftR` 6 `shiftL` 10+		b' = b `shiftR` 6++pixelRgb30ToRgb :: PixelRgb30 -> (Word16, Word16, Word16)+pixelRgb30ToRgb (PixelRgb30Word32 rgb) =+	(r .|. r `shiftR` 10, g .|. g `shiftR` 10, b .|. b `shiftR` 10)+	where+	r = fromIntegral $ rgb `shiftR` 20 `shiftL` 6+	g = fromIntegral $ rgb `shiftR` 10 `shiftL` 6+	b = fromIntegral $ rgb `shiftL` 6++-- IMAGE++data Rgb30 = Rgb30 {+	rgb30Width :: CInt, rgb30Height :: CInt,+	rgb30Stride :: CInt, rgb30Data :: ForeignPtr PixelRgb30 }+	deriving Show++pattern CairoImageRgb30 :: Rgb30 -> CairoImage+pattern CairoImageRgb30 r <- (cairoImageToRgb30 -> Just r)+	where CairoImageRgb30 (Rgb30 w h s d) =+		CairoImage CairoFormatRgb30 w h s $ castForeignPtr d++cairoImageToRgb30 :: CairoImage -> Maybe Rgb30+cairoImageToRgb30 = \case+	CairoImage CairoFormatRgb30 w h s d ->+		Just . Rgb30 w h s $ castForeignPtr d+	_ -> Nothing++instance Image Rgb30 where+	type Pixel Rgb30 = PixelRgb30+	imageSize (Rgb30 w h _ _) = (w, h)+	pixelAt (Rgb30 w h s d) x y = unsafePerformIO $ with d \p ->+		maybe (pure Nothing) ((Just <$>) . peek) $ ptr w h s p x y+	generateImagePrimM w h f =+		stride CairoFormatRgb30 w >>= \s -> Rgb30 w h s <$> gen w h s f++-- IMAGE MUTABLE++data Rgb30Mut s = Rgb30Mut {+	rgb30MutWidth :: CInt, rgb30MutHeight :: CInt,+	rgb30MutStride :: CInt, rgb30MutData :: ForeignPtr PixelRgb30 }+	deriving Show++pattern CairoImageMutRgb30 :: Rgb30Mut s -> CairoImageMut s+pattern CairoImageMutRgb30 r <- (cairoImageMutToRgb30 -> Just r)+	where CairoImageMutRgb30 (Rgb30Mut w h s d) =+		CairoImageMut CairoFormatRgb30 w h s $ castForeignPtr d++cairoImageMutToRgb30 :: CairoImageMut s -> Maybe (Rgb30Mut s)+cairoImageMutToRgb30 = \case+	CairoImageMut CairoFormatRgb30 w h s d ->+		Just . Rgb30Mut w h s $ castForeignPtr d+	_ -> Nothing++instance ImageMut Rgb30Mut where+	type PixelMut Rgb30Mut = PixelRgb30+	imageMutSize (Rgb30Mut w h _ _) = (w, h)+	getPixel (Rgb30Mut w h s d) x y = unsafeIOToPrim $ with d \p ->+		maybe (pure Nothing) ((Just <$>) . peek) $ ptr w h s p x y+	putPixel (Rgb30Mut w h s d) x y px = unsafeIOToPrim $ with d \p ->+		maybe (pure ()) (`poke` px) $ ptr w h s p x y+	newImageMut w h =+		stride CairoFormatRgb30 w >>= \s -> Rgb30Mut w h s <$> new s h
+ src/Data/CairoImage/Parts.hsc view
@@ -0,0 +1,80 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications, PatternSynonyms,+	ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Data.CairoImage.Parts (+	-- * Tool+	gen, new, ptr, stride, with,+	-- * Cairo Format+	CairoFormatT(..),+	pattern CairoFormatArgb32, pattern CairoFormatRgb24,+	pattern CairoFormatA8, pattern CairoFormatA1,+	pattern CairoFormatRgb16_565, pattern CairoFormatRgb30 ) where++import Foreign.Ptr (Ptr, plusPtr)+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)+import Foreign.Concurrent (newForeignPtr)+import Foreign.Marshal (mallocBytes, free)+import Foreign.Storable (Storable, sizeOf, alignment, poke)+import Foreign.C.Types (CInt(..))+import Foreign.C.Enum(enum)+import Control.Monad.Primitive (+	PrimMonad(..), PrimBase, unsafeIOToPrim, unsafePrimToIO )+import Data.Foldable (for_)+import Data.Int (Int32)++#include <cairo.h>++---------------------------------------------------------------------------++-- * CAIRO FORMAT+-- * TOOL++---------------------------------------------------------------------------+-- CAIRO FORMAT+---------------------------------------------------------------------------++enum "CairoFormatT" ''#{type cairo_format_t} [''Show, ''Read, ''Eq] [+	("CairoFormatArgb32", #{const CAIRO_FORMAT_ARGB32}),+	("CairoFormatRgb24", #{const CAIRO_FORMAT_RGB24}),+	("CairoFormatA8", #{const CAIRO_FORMAT_A8}),+	("CairoFormatA1", #{const CAIRO_FORMAT_A1}),+	("CairoFormatRgb16_565", #{const CAIRO_FORMAT_RGB16_565}),+	("CairoFormatRgb30", #{const CAIRO_FORMAT_RGB30}) ]++---------------------------------------------------------------------------+-- TOOL+---------------------------------------------------------------------------++gen :: (PrimBase m, Storable a) =>+	CInt -> CInt -> CInt -> (CInt -> CInt -> m a) -> m (ForeignPtr a)+gen w h s f = unsafeIOToPrim $ mallocBytes (fromIntegral $ s * h) >>= \d -> do+	for_ [0 .. h - 1] \y -> for_ [0 .. w - 1] \x ->+		unsafePrimToIO (f x y) >>= \p ->+			maybe (pure ()) (`poke` p) $ ptr w h s d x y+	newForeignPtr d $ free d++new :: PrimMonad m => CInt -> CInt -> m (ForeignPtr a)+new s h = unsafeIOToPrim+	$ mallocBytes (fromIntegral $ s * h) >>= \d -> newForeignPtr d $ free d++ptr :: forall a . Storable a =>+	CInt -> CInt -> CInt -> Ptr a -> CInt -> CInt -> Maybe (Ptr a)+ptr (fromIntegral -> w) (fromIntegral -> h) (fromIntegral -> s) p+	(fromIntegral -> x) (fromIntegral -> y)+	| 0 <= x && x < w && 0 <= y && y < h = Just $ p `plusPtr` (y * s + b)+	| otherwise = Nothing+	where+	b = x * ((sizeOf @a undefined - 1) `div` al + 1) * al+	al = alignment @a undefined++stride :: PrimMonad m => CairoFormatT -> CInt -> m CInt+stride = (unsafeIOToPrim .) . c_cairo_format_stride_for_width++foreign import ccall "cairo_format_stride_for_width"+	c_cairo_format_stride_for_width :: CairoFormatT -> CInt -> IO CInt++with :: ForeignPtr a -> (Ptr a -> IO b) -> IO b+with = withForeignPtr
+ src/System/TargetEndian.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module System.TargetEndian (+	-- * To Select According To Endian+	endian ) where++import Language.Haskell.TH (ExpQ, runIO)+import Foreign.Ptr (castPtr)+import Foreign.Marshal (alloca, peekArray)+import Foreign.Storable (poke)+import Data.Word (Word8, Word32)+import System.Environment (lookupEnv)++---------------------------------------------------------------------------++endian :: ExpQ -> ExpQ -> ExpQ+endian el eb = runIO targetEndian >>= \case+	Right LittleEndian -> el; Right BigEndian -> eb+	Right UnknownEndian -> error "Unknown endian"; Left emsg -> error emsg++data Endian = LittleEndian | BigEndian | UnknownEndian deriving Show++targetEndian :: IO (Either String Endian)+targetEndian = lookupEnv "GHC_TARGET_ENDIAN" >>= \case+	Just "little-endian" -> pure $ Right LittleEndian+	Just "big-endian" -> pure $ Right BigEndian+	Just edn -> pure . Left $ "no such endian: " ++ edn ++ "\n" +++		"\tGHC_TARGET_ENDIAN: little-endian or big-endian"+	Nothing -> Right <$> checkEndian++checkEndian :: IO Endian+checkEndian = (<$> alloca \p -> poke p word32 >> peekArray 4 (castPtr p)) \case+	[4 :: Word8, 3, 2, 1] -> LittleEndian; [1, 2, 3, 4] -> BigEndian+	_ -> UnknownEndian+	where word32 :: Word32; word32 = 0x01020304
+ test/endian.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++import System.TargetEndian++main :: IO ()+main = do+	putStrLn "test endian"+	putStrLn $(endian [e| "little endian" |] [e| "big endian" |])
+ test/spec.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++import Data.Word+import Data.CairoImage.Internal++main :: IO ()+main = main1 >> main2++main1, main2 :: IO ()+main1 = do+	let	rgb16max = PixelRgb16_565 0xff 0xff 0xff+		PixelRgb16_565 ra ga ba = rgb16max+		rgb16min = PixelRgb16_565 0x00 0x00 0x00+		PixelRgb16_565 ri gi bi = rgb16min+		rgb16foo = PixelRgb16_565 0x12 0x34 0x56+		PixelRgb16_565 rf gf bf = rgb16foo+	print rgb16max+	print (ra, ga, ba)+	print rgb16min+	print (ri, gi, bi)+	print rgb16foo+	print (rf, gf, bf)+	print (0x12 :: Word8, 0x34 :: Word8, 0x56 :: Word8)++main2 = do+	let	rgb30max = PixelRgb30 0xffff 0xffff 0xffff+		PixelRgb30 ra ga ba = rgb30max+		rgb30min = PixelRgb30 0x0000 0x0000 0x0000+		PixelRgb30 ri gi bi = rgb30min+		rgb30foo = PixelRgb30 0x1234 0x5678 0x9abc+		PixelRgb30 rf gf bf = rgb30foo+	print rgb30max+	print (ra, ga, ba)+	print rgb30min+	print (ri, gi, bi)+	print rgb30foo+	print (rf, gf, bf)