{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Diagrams.Backend.Cairo.Internal where
import Diagrams.Core.Compile
import Diagrams.Core.Transform
import Diagrams.Prelude hiding (font, opacity, view)
import Diagrams.TwoD.Adjust (adjustDia2D,
setDefault2DAttributes)
import Diagrams.TwoD.Path (Clip (Clip), getFillRule)
import Diagrams.TwoD.Text hiding (font)
import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Cairo.Matrix as CM
import qualified Graphics.Rendering.Pango as P
import Codec.Picture
import Codec.Picture.Types (convertImage, packPixel,
promoteImage)
import Control.Exception (try)
import Control.Monad (when)
import Control.Monad.IO.Class
import qualified Control.Monad.StateStack as SS
import Control.Monad.Trans (lift)
import qualified Data.Array.MArray as MA
import Data.Bits (rotateL, (.&.))
import qualified Data.Foldable as F
import Data.Hashable (Hashable (..))
import Data.List (isSuffixOf)
import Data.Maybe (catMaybes, fromMaybe, isJust)
import Data.Tree
import Data.Typeable
import Data.Word (Word32)
import GHC.Generics (Generic)
data Cairo = Cairo
deriving (Cairo -> Cairo -> Bool
(Cairo -> Cairo -> Bool) -> (Cairo -> Cairo -> Bool) -> Eq Cairo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cairo -> Cairo -> Bool
$c/= :: Cairo -> Cairo -> Bool
== :: Cairo -> Cairo -> Bool
$c== :: Cairo -> Cairo -> Bool
Eq,Eq Cairo
Eq Cairo
-> (Cairo -> Cairo -> Ordering)
-> (Cairo -> Cairo -> Bool)
-> (Cairo -> Cairo -> Bool)
-> (Cairo -> Cairo -> Bool)
-> (Cairo -> Cairo -> Bool)
-> (Cairo -> Cairo -> Cairo)
-> (Cairo -> Cairo -> Cairo)
-> Ord Cairo
Cairo -> Cairo -> Bool
Cairo -> Cairo -> Ordering
Cairo -> Cairo -> Cairo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Cairo -> Cairo -> Cairo
$cmin :: Cairo -> Cairo -> Cairo
max :: Cairo -> Cairo -> Cairo
$cmax :: Cairo -> Cairo -> Cairo
>= :: Cairo -> Cairo -> Bool
$c>= :: Cairo -> Cairo -> Bool
> :: Cairo -> Cairo -> Bool
$c> :: Cairo -> Cairo -> Bool
<= :: Cairo -> Cairo -> Bool
$c<= :: Cairo -> Cairo -> Bool
< :: Cairo -> Cairo -> Bool
$c< :: Cairo -> Cairo -> Bool
compare :: Cairo -> Cairo -> Ordering
$ccompare :: Cairo -> Cairo -> Ordering
Ord,ReadPrec [Cairo]
ReadPrec Cairo
Int -> ReadS Cairo
ReadS [Cairo]
(Int -> ReadS Cairo)
-> ReadS [Cairo]
-> ReadPrec Cairo
-> ReadPrec [Cairo]
-> Read Cairo
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Cairo]
$creadListPrec :: ReadPrec [Cairo]
readPrec :: ReadPrec Cairo
$creadPrec :: ReadPrec Cairo
readList :: ReadS [Cairo]
$creadList :: ReadS [Cairo]
readsPrec :: Int -> ReadS Cairo
$creadsPrec :: Int -> ReadS Cairo
Read,Int -> Cairo -> ShowS
[Cairo] -> ShowS
Cairo -> String
(Int -> Cairo -> ShowS)
-> (Cairo -> String) -> ([Cairo] -> ShowS) -> Show Cairo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cairo] -> ShowS
$cshowList :: [Cairo] -> ShowS
show :: Cairo -> String
$cshow :: Cairo -> String
showsPrec :: Int -> Cairo -> ShowS
$cshowsPrec :: Int -> Cairo -> ShowS
Show,Typeable)
type B = Cairo
type instance V Cairo = V2
type instance N Cairo = Double
data OutputType =
PNG
| PS
| PDF
| SVG
| RenderOnly
deriving (OutputType -> OutputType -> Bool
(OutputType -> OutputType -> Bool)
-> (OutputType -> OutputType -> Bool) -> Eq OutputType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutputType -> OutputType -> Bool
$c/= :: OutputType -> OutputType -> Bool
== :: OutputType -> OutputType -> Bool
$c== :: OutputType -> OutputType -> Bool
Eq, Eq OutputType
Eq OutputType
-> (OutputType -> OutputType -> Ordering)
-> (OutputType -> OutputType -> Bool)
-> (OutputType -> OutputType -> Bool)
-> (OutputType -> OutputType -> Bool)
-> (OutputType -> OutputType -> Bool)
-> (OutputType -> OutputType -> OutputType)
-> (OutputType -> OutputType -> OutputType)
-> Ord OutputType
OutputType -> OutputType -> Bool
OutputType -> OutputType -> Ordering
OutputType -> OutputType -> OutputType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: OutputType -> OutputType -> OutputType
$cmin :: OutputType -> OutputType -> OutputType
max :: OutputType -> OutputType -> OutputType
$cmax :: OutputType -> OutputType -> OutputType
>= :: OutputType -> OutputType -> Bool
$c>= :: OutputType -> OutputType -> Bool
> :: OutputType -> OutputType -> Bool
$c> :: OutputType -> OutputType -> Bool
<= :: OutputType -> OutputType -> Bool
$c<= :: OutputType -> OutputType -> Bool
< :: OutputType -> OutputType -> Bool
$c< :: OutputType -> OutputType -> Bool
compare :: OutputType -> OutputType -> Ordering
$ccompare :: OutputType -> OutputType -> Ordering
Ord, ReadPrec [OutputType]
ReadPrec OutputType
Int -> ReadS OutputType
ReadS [OutputType]
(Int -> ReadS OutputType)
-> ReadS [OutputType]
-> ReadPrec OutputType
-> ReadPrec [OutputType]
-> Read OutputType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [OutputType]
$creadListPrec :: ReadPrec [OutputType]
readPrec :: ReadPrec OutputType
$creadPrec :: ReadPrec OutputType
readList :: ReadS [OutputType]
$creadList :: ReadS [OutputType]
readsPrec :: Int -> ReadS OutputType
$creadsPrec :: Int -> ReadS OutputType
Read, Int -> OutputType -> ShowS
[OutputType] -> ShowS
OutputType -> String
(Int -> OutputType -> ShowS)
-> (OutputType -> String)
-> ([OutputType] -> ShowS)
-> Show OutputType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OutputType] -> ShowS
$cshowList :: [OutputType] -> ShowS
show :: OutputType -> String
$cshow :: OutputType -> String
showsPrec :: Int -> OutputType -> ShowS
$cshowsPrec :: Int -> OutputType -> ShowS
Show, OutputType
OutputType -> OutputType -> Bounded OutputType
forall a. a -> a -> Bounded a
maxBound :: OutputType
$cmaxBound :: OutputType
minBound :: OutputType
$cminBound :: OutputType
Bounded, Int -> OutputType
OutputType -> Int
OutputType -> [OutputType]
OutputType -> OutputType
OutputType -> OutputType -> [OutputType]
OutputType -> OutputType -> OutputType -> [OutputType]
(OutputType -> OutputType)
-> (OutputType -> OutputType)
-> (Int -> OutputType)
-> (OutputType -> Int)
-> (OutputType -> [OutputType])
-> (OutputType -> OutputType -> [OutputType])
-> (OutputType -> OutputType -> [OutputType])
-> (OutputType -> OutputType -> OutputType -> [OutputType])
-> Enum OutputType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: OutputType -> OutputType -> OutputType -> [OutputType]
$cenumFromThenTo :: OutputType -> OutputType -> OutputType -> [OutputType]
enumFromTo :: OutputType -> OutputType -> [OutputType]
$cenumFromTo :: OutputType -> OutputType -> [OutputType]
enumFromThen :: OutputType -> OutputType -> [OutputType]
$cenumFromThen :: OutputType -> OutputType -> [OutputType]
enumFrom :: OutputType -> [OutputType]
$cenumFrom :: OutputType -> [OutputType]
fromEnum :: OutputType -> Int
$cfromEnum :: OutputType -> Int
toEnum :: Int -> OutputType
$ctoEnum :: Int -> OutputType
pred :: OutputType -> OutputType
$cpred :: OutputType -> OutputType
succ :: OutputType -> OutputType
$csucc :: OutputType -> OutputType
Enum, Typeable, (forall x. OutputType -> Rep OutputType x)
-> (forall x. Rep OutputType x -> OutputType) -> Generic OutputType
forall x. Rep OutputType x -> OutputType
forall x. OutputType -> Rep OutputType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OutputType x -> OutputType
$cfrom :: forall x. OutputType -> Rep OutputType x
Generic)
instance Hashable OutputType
data CairoState
= CairoState { CairoState -> Style V2 Double
_accumStyle :: Style V2 Double
, CairoState -> Bool
_ignoreFill :: Bool
}
$(makeLenses ''CairoState)
instance Default CairoState where
def :: CairoState
def = CairoState :: Style V2 Double -> Bool -> CairoState
CairoState
{ _accumStyle :: Style V2 Double
_accumStyle = Style V2 Double
forall a. Monoid a => a
mempty
, _ignoreFill :: Bool
_ignoreFill = Bool
False
}
type RenderM a = SS.StateStackT CairoState C.Render a
liftC :: C.Render a -> RenderM a
liftC :: forall a. Render a -> RenderM a
liftC = Render a -> StateStackT CairoState Render a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
runRenderM :: RenderM a -> C.Render a
runRenderM :: forall a. RenderM a -> Render a
runRenderM = (StateStackT CairoState Render a -> CairoState -> Render a)
-> CairoState -> StateStackT CairoState Render a -> Render a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateStackT CairoState Render a -> CairoState -> Render a
forall (m :: * -> *) s a. Monad m => StateStackT s m a -> s -> m a
SS.evalStateStackT CairoState
forall a. Default a => a
def
save :: RenderM ()
save :: RenderM ()
save = RenderM ()
forall s (m :: * -> *). MonadStateStack s m => m ()
SS.save RenderM () -> RenderM () -> RenderM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.save
restore :: RenderM ()
restore :: RenderM ()
restore = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.restore RenderM () -> RenderM () -> RenderM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RenderM ()
forall s (m :: * -> *). MonadStateStack s m => m ()
SS.restore
instance Backend Cairo V2 Double where
data Render Cairo V2 Double = C (RenderM ())
type Result Cairo V2 Double = (IO (), C.Render ())
data Options Cairo V2 Double = CairoOptions
{ Options Cairo V2 Double -> String
_cairoFileName :: String
, Options Cairo V2 Double -> SizeSpec V2 Double
_cairoSizeSpec :: SizeSpec V2 Double
, Options Cairo V2 Double -> OutputType
_cairoOutputType :: OutputType
, Options Cairo V2 Double -> Bool
_cairoBypassAdjust :: Bool
}
deriving (Int -> Options Cairo V2 Double -> ShowS
[Options Cairo V2 Double] -> ShowS
Options Cairo V2 Double -> String
(Int -> Options Cairo V2 Double -> ShowS)
-> (Options Cairo V2 Double -> String)
-> ([Options Cairo V2 Double] -> ShowS)
-> Show (Options Cairo V2 Double)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options Cairo V2 Double] -> ShowS
$cshowList :: [Options Cairo V2 Double] -> ShowS
show :: Options Cairo V2 Double -> String
$cshow :: Options Cairo V2 Double -> String
showsPrec :: Int -> Options Cairo V2 Double -> ShowS
$cshowsPrec :: Int -> Options Cairo V2 Double -> ShowS
Show, Options Cairo V2 Double -> Options Cairo V2 Double -> Bool
(Options Cairo V2 Double -> Options Cairo V2 Double -> Bool)
-> (Options Cairo V2 Double -> Options Cairo V2 Double -> Bool)
-> Eq (Options Cairo V2 Double)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Options Cairo V2 Double -> Options Cairo V2 Double -> Bool
$c/= :: Options Cairo V2 Double -> Options Cairo V2 Double -> Bool
== :: Options Cairo V2 Double -> Options Cairo V2 Double -> Bool
$c== :: Options Cairo V2 Double -> Options Cairo V2 Double -> Bool
Eq)
renderRTree :: Cairo
-> Options Cairo V2 Double
-> RTree Cairo V2 Double Annotation
-> Result Cairo V2 Double
renderRTree Cairo
_ Options Cairo V2 Double
opts RTree Cairo V2 Double Annotation
t = (IO ()
renderIO, Render ()
r)
where
r :: Render ()
r = RenderM () -> Render ()
forall a. RenderM a -> Render a
runRenderM (RenderM () -> Render ())
-> (RTree Cairo V2 Double Annotation -> RenderM ())
-> RTree Cairo V2 Double Annotation
-> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Render Cairo V2 Double -> RenderM ()
runC (Render Cairo V2 Double -> RenderM ())
-> (RTree Cairo V2 Double Annotation -> Render Cairo V2 Double)
-> RTree Cairo V2 Double Annotation
-> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTree Cairo V2 Double Annotation -> Render Cairo V2 Double
forall a. RTree Cairo V2 Double a -> Render Cairo V2 Double
toRender (RTree Cairo V2 Double Annotation -> Render ())
-> RTree Cairo V2 Double Annotation -> Render ()
forall a b. (a -> b) -> a -> b
$ RTree Cairo V2 Double Annotation
t
renderIO :: IO ()
renderIO = do
let surfaceF :: Surface -> IO ()
surfaceF Surface
s = Surface -> Render () -> IO ()
forall (m :: * -> *) a. MonadIO m => Surface -> Render a -> m a
C.renderWith Surface
s Render ()
r
V2 Double
w Double
h = Double -> SizeSpec V2 Double -> V2 Double
forall (v :: * -> *) n.
(Foldable v, Functor v, Num n, Ord n) =>
n -> SizeSpec v n -> v n
specToSize Double
1 (Options Cairo V2 Double
optsOptions Cairo V2 Double
-> Getting
(SizeSpec V2 Double) (Options Cairo V2 Double) (SizeSpec V2 Double)
-> SizeSpec V2 Double
forall s a. s -> Getting a s a -> a
^.Getting
(SizeSpec V2 Double) (Options Cairo V2 Double) (SizeSpec V2 Double)
Lens' (Options Cairo V2 Double) (SizeSpec V2 Double)
cairoSizeSpec)
case Options Cairo V2 Double
optsOptions Cairo V2 Double
-> Getting OutputType (Options Cairo V2 Double) OutputType
-> OutputType
forall s a. s -> Getting a s a -> a
^.Getting OutputType (Options Cairo V2 Double) OutputType
Lens' (Options Cairo V2 Double) OutputType
cairoOutputType of
OutputType
PNG ->
Format -> Int -> Int -> (Surface -> IO ()) -> IO ()
forall a. Format -> Int -> Int -> (Surface -> IO a) -> IO a
C.withImageSurface Format
C.FormatARGB32 (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round Double
w) (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round Double
h) ((Surface -> IO ()) -> IO ()) -> (Surface -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Surface
surface -> do
Surface -> IO ()
surfaceF Surface
surface
Surface -> String -> IO ()
C.surfaceWriteToPNG Surface
surface (Options Cairo V2 Double
optsOptions Cairo V2 Double
-> Getting String (Options Cairo V2 Double) String -> String
forall s a. s -> Getting a s a -> a
^.Getting String (Options Cairo V2 Double) String
Lens' (Options Cairo V2 Double) String
cairoFileName)
OutputType
PS -> String -> Double -> Double -> (Surface -> IO ()) -> IO ()
forall a. String -> Double -> Double -> (Surface -> IO a) -> IO a
C.withPSSurface (Options Cairo V2 Double
optsOptions Cairo V2 Double
-> Getting String (Options Cairo V2 Double) String -> String
forall s a. s -> Getting a s a -> a
^.Getting String (Options Cairo V2 Double) String
Lens' (Options Cairo V2 Double) String
cairoFileName) Double
w Double
h Surface -> IO ()
surfaceF
OutputType
PDF -> String -> Double -> Double -> (Surface -> IO ()) -> IO ()
forall a. String -> Double -> Double -> (Surface -> IO a) -> IO a
C.withPDFSurface (Options Cairo V2 Double
optsOptions Cairo V2 Double
-> Getting String (Options Cairo V2 Double) String -> String
forall s a. s -> Getting a s a -> a
^.Getting String (Options Cairo V2 Double) String
Lens' (Options Cairo V2 Double) String
cairoFileName) Double
w Double
h Surface -> IO ()
surfaceF
OutputType
SVG -> String -> Double -> Double -> (Surface -> IO ()) -> IO ()
forall a. String -> Double -> Double -> (Surface -> IO a) -> IO a
C.withSVGSurface (Options Cairo V2 Double
optsOptions Cairo V2 Double
-> Getting String (Options Cairo V2 Double) String -> String
forall s a. s -> Getting a s a -> a
^.Getting String (Options Cairo V2 Double) String
Lens' (Options Cairo V2 Double) String
cairoFileName) Double
w Double
h Surface -> IO ()
surfaceF
OutputType
RenderOnly -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
adjustDia :: forall m.
(Additive V2, Monoid' m, Num Double) =>
Cairo
-> Options Cairo V2 Double
-> QDiagram Cairo V2 Double m
-> (Options Cairo V2 Double, T2 Double, QDiagram Cairo V2 Double m)
adjustDia Cairo
c Options Cairo V2 Double
opts QDiagram Cairo V2 Double m
d = if Options Cairo V2 Double -> Bool
_cairoBypassAdjust Options Cairo V2 Double
opts
then (Options Cairo V2 Double
opts, T2 Double
forall a. Monoid a => a
mempty, QDiagram Cairo V2 Double m
d QDiagram Cairo V2 Double m
-> (QDiagram Cairo V2 Double m -> QDiagram Cairo V2 Double m)
-> QDiagram Cairo V2 Double m
forall a b. a -> (a -> b) -> b
# QDiagram Cairo V2 Double m -> QDiagram Cairo V2 Double m
forall n m b.
(TypeableFloat n, Semigroup m) =>
QDiagram b V2 n m -> QDiagram b V2 n m
setDefault2DAttributes)
else let (Options Cairo V2 Double
opts', T2 Double
transformation, QDiagram Cairo V2 Double m
d') = Lens' (Options Cairo V2 Double) (SizeSpec V2 Double)
-> Cairo
-> Options Cairo V2 Double
-> QDiagram Cairo V2 Double m
-> (Options Cairo V2 Double, T2 Double, QDiagram Cairo V2 Double m)
forall n m b.
(TypeableFloat n, Monoid' m) =>
Lens' (Options b V2 n) (SizeSpec V2 n)
-> b
-> Options b V2 n
-> QDiagram b V2 n m
-> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m)
adjustDia2D Lens' (Options Cairo V2 Double) (SizeSpec V2 Double)
cairoSizeSpec Cairo
c Options Cairo V2 Double
opts (QDiagram Cairo V2 Double m
d QDiagram Cairo V2 Double m
-> (QDiagram Cairo V2 Double m -> QDiagram Cairo V2 Double m)
-> QDiagram Cairo V2 Double m
forall a b. a -> (a -> b) -> b
# QDiagram Cairo V2 Double m -> QDiagram Cairo V2 Double m
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY)
in (Options Cairo V2 Double
opts', T2 Double
transformation T2 Double -> T2 Double -> T2 Double
forall a. Semigroup a => a -> a -> a
<> T2 Double
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY, QDiagram Cairo V2 Double m
d')
runC :: Render Cairo V2 Double -> RenderM ()
runC :: Render Cairo V2 Double -> RenderM ()
runC (C RenderM ()
r) = RenderM ()
r
instance Semigroup (Render Cairo V2 Double) where
C RenderM ()
rd1 <> :: Render Cairo V2 Double
-> Render Cairo V2 Double -> Render Cairo V2 Double
<> C RenderM ()
rd2 = RenderM () -> Render Cairo V2 Double
C (RenderM ()
rd1 RenderM () -> RenderM () -> RenderM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RenderM ()
rd2)
instance Monoid (Render Cairo V2 Double) where
mempty :: Render Cairo V2 Double
mempty = RenderM () -> Render Cairo V2 Double
C (RenderM () -> Render Cairo V2 Double)
-> RenderM () -> Render Cairo V2 Double
forall a b. (a -> b) -> a -> b
$ () -> RenderM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#if !(MIN_VERSION_base(4,11,0))
mappend = (<>)
#endif
instance Hashable (Options Cairo V2 Double) where
hashWithSalt :: Int -> Options Cairo V2 Double -> Int
hashWithSalt Int
s (CairoOptions String
fn SizeSpec V2 Double
sz OutputType
out Bool
adj)
= Int
s Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
String
fn Int -> SizeSpec V2 Double -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
SizeSpec V2 Double
sz Int -> OutputType -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
OutputType
out Int -> Bool -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
Bool
adj
toRender :: RTree Cairo V2 Double a -> Render Cairo V2 Double
toRender :: forall a. RTree Cairo V2 Double a -> Render Cairo V2 Double
toRender (Node (RPrim Prim Cairo V2 Double
p) [Tree (RNode Cairo V2 Double a)]
_) = Cairo
-> Prim Cairo V2 Double
-> Render
Cairo (V (Prim Cairo V2 Double)) (N (Prim Cairo V2 Double))
forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
render Cairo
Cairo Prim Cairo V2 Double
p
toRender (Node (RStyle Style V2 Double
sty) [Tree (RNode Cairo V2 Double a)]
rs) = RenderM () -> Render Cairo V2 Double
C (RenderM () -> Render Cairo V2 Double)
-> RenderM () -> Render Cairo V2 Double
forall a b. (a -> b) -> a -> b
$ do
RenderM ()
save
Style V2 Double -> RenderM ()
forall (v :: * -> *). Style v Double -> RenderM ()
cairoStyle Style V2 Double
sty
(Style V2 Double -> Identity (Style V2 Double))
-> CairoState -> Identity CairoState
Lens' CairoState (Style V2 Double)
accumStyle ((Style V2 Double -> Identity (Style V2 Double))
-> CairoState -> Identity CairoState)
-> (Style V2 Double -> Style V2 Double) -> RenderM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Style V2 Double -> Style V2 Double -> Style V2 Double
forall a. Semigroup a => a -> a -> a
<> Style V2 Double
sty)
Render Cairo V2 Double -> RenderM ()
runC (Render Cairo V2 Double -> RenderM ())
-> Render Cairo V2 Double -> RenderM ()
forall a b. (a -> b) -> a -> b
$ (Tree (RNode Cairo V2 Double a) -> Render Cairo V2 Double)
-> [Tree (RNode Cairo V2 Double a)] -> Render Cairo V2 Double
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Tree (RNode Cairo V2 Double a) -> Render Cairo V2 Double
forall a. RTree Cairo V2 Double a -> Render Cairo V2 Double
toRender [Tree (RNode Cairo V2 Double a)]
rs
RenderM ()
restore
toRender (Node RNode Cairo V2 Double a
_ [Tree (RNode Cairo V2 Double a)]
rs) = (Tree (RNode Cairo V2 Double a) -> Render Cairo V2 Double)
-> [Tree (RNode Cairo V2 Double a)] -> Render Cairo V2 Double
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Tree (RNode Cairo V2 Double a) -> Render Cairo V2 Double
forall a. RTree Cairo V2 Double a -> Render Cairo V2 Double
toRender [Tree (RNode Cairo V2 Double a)]
rs
cairoFileName :: Lens' (Options Cairo V2 Double) String
cairoFileName :: Lens' (Options Cairo V2 Double) String
cairoFileName = (Options Cairo V2 Double -> String)
-> (Options Cairo V2 Double -> String -> Options Cairo V2 Double)
-> Lens' (Options Cairo V2 Double) String
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(CairoOptions {_cairoFileName :: Options Cairo V2 Double -> String
_cairoFileName = String
f}) -> String
f)
(\Options Cairo V2 Double
o String
f -> Options Cairo V2 Double
R:OptionsCairoV2Double
o {_cairoFileName :: String
_cairoFileName = String
f})
cairoSizeSpec :: Lens' (Options Cairo V2 Double) (SizeSpec V2 Double)
cairoSizeSpec :: Lens' (Options Cairo V2 Double) (SizeSpec V2 Double)
cairoSizeSpec = (Options Cairo V2 Double -> SizeSpec V2 Double)
-> (Options Cairo V2 Double
-> SizeSpec V2 Double -> Options Cairo V2 Double)
-> Lens' (Options Cairo V2 Double) (SizeSpec V2 Double)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(CairoOptions {_cairoSizeSpec :: Options Cairo V2 Double -> SizeSpec V2 Double
_cairoSizeSpec = SizeSpec V2 Double
s}) -> SizeSpec V2 Double
s)
(\Options Cairo V2 Double
o SizeSpec V2 Double
s -> Options Cairo V2 Double
R:OptionsCairoV2Double
o {_cairoSizeSpec :: SizeSpec V2 Double
_cairoSizeSpec = SizeSpec V2 Double
s})
cairoOutputType :: Lens' (Options Cairo V2 Double) OutputType
cairoOutputType :: Lens' (Options Cairo V2 Double) OutputType
cairoOutputType = (Options Cairo V2 Double -> OutputType)
-> (Options Cairo V2 Double
-> OutputType -> Options Cairo V2 Double)
-> Lens' (Options Cairo V2 Double) OutputType
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(CairoOptions {_cairoOutputType :: Options Cairo V2 Double -> OutputType
_cairoOutputType = OutputType
t}) -> OutputType
t)
(\Options Cairo V2 Double
o OutputType
t -> Options Cairo V2 Double
R:OptionsCairoV2Double
o {_cairoOutputType :: OutputType
_cairoOutputType = OutputType
t})
cairoBypassAdjust :: Lens' (Options Cairo V2 Double) Bool
cairoBypassAdjust :: Lens' (Options Cairo V2 Double) Bool
cairoBypassAdjust = (Options Cairo V2 Double -> Bool)
-> (Options Cairo V2 Double -> Bool -> Options Cairo V2 Double)
-> Lens' (Options Cairo V2 Double) Bool
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(CairoOptions {_cairoBypassAdjust :: Options Cairo V2 Double -> Bool
_cairoBypassAdjust = Bool
b}) -> Bool
b)
(\Options Cairo V2 Double
o Bool
b -> Options Cairo V2 Double
R:OptionsCairoV2Double
o {_cairoBypassAdjust :: Bool
_cairoBypassAdjust = Bool
b})
renderC :: (Renderable a Cairo, V a ~ V2, N a ~ Double) => a -> RenderM ()
renderC :: forall a.
(Renderable a Cairo, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC = Render Cairo V2 Double -> RenderM ()
runC (Render Cairo V2 Double -> RenderM ())
-> (a -> Render Cairo V2 Double) -> a -> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cairo -> a -> Render Cairo (V a) (N a)
forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
render Cairo
Cairo
getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib :: forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib a -> b
f = ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Maybe a -> Maybe b)
-> (Style V2 Double -> Maybe a) -> Style V2 Double -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style V2 Double -> Maybe a
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr) (Style V2 Double -> Maybe b)
-> StateStackT CairoState Render (Style V2 Double)
-> StateStackT CairoState Render (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Style V2 Double) CairoState (Style V2 Double)
-> StateStackT CairoState Render (Style V2 Double)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Style V2 Double) CairoState (Style V2 Double)
Lens' CairoState (Style V2 Double)
accumStyle
cairoStyle :: Style v Double -> RenderM ()
cairoStyle :: forall (v :: * -> *). Style v Double -> RenderM ()
cairoStyle Style v Double
s =
[RenderM ()] -> RenderM ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
([RenderM ()] -> RenderM ())
-> ([Maybe (RenderM ())] -> [RenderM ()])
-> [Maybe (RenderM ())]
-> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (RenderM ())] -> [RenderM ()]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (RenderM ())] -> RenderM ())
-> [Maybe (RenderM ())] -> RenderM ()
forall a b. (a -> b) -> a -> b
$ [ (Clip Double -> RenderM ()) -> Maybe (RenderM ())
forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle Clip Double -> RenderM ()
clip
, (FillRule -> RenderM ()) -> Maybe (RenderM ())
forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle FillRule -> RenderM ()
lFillRule
, (LineWidth Double -> RenderM ()) -> Maybe (RenderM ())
forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineWidth Double -> RenderM ()
lWidth
, (LineCap -> RenderM ()) -> Maybe (RenderM ())
forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineCap -> RenderM ()
lCap
, (LineJoin -> RenderM ()) -> Maybe (RenderM ())
forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineJoin -> RenderM ()
lJoin
, (Dashing Double -> RenderM ()) -> Maybe (RenderM ())
forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle Dashing Double -> RenderM ()
lDashing
]
where handle :: AttributeClass a => (a -> RenderM ()) -> Maybe (RenderM ())
handle :: forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle a -> RenderM ()
f = a -> RenderM ()
f (a -> RenderM ()) -> Maybe a -> Maybe (RenderM ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Style v Double -> Maybe a
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v Double
s
clip :: Clip Double -> RenderM ()
clip = (Path V2 Double -> RenderM ()) -> [Path V2 Double] -> RenderM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Path V2 Double
p -> Path V2 Double -> RenderM ()
cairoPath Path V2 Double
p RenderM () -> RenderM () -> RenderM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.clip) ([Path V2 Double] -> RenderM ())
-> (Clip Double -> [Path V2 Double]) -> Clip Double -> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unwrapped (Clip Double) -> Clip Double)
-> Clip Double -> Unwrapped (Clip Double)
forall s. Wrapped s => (Unwrapped s -> s) -> s -> Unwrapped s
op Unwrapped (Clip Double) -> Clip Double
forall n. [Path V2 n] -> Clip n
Clip
lFillRule :: FillRule -> RenderM ()
lFillRule = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ())
-> (FillRule -> Render ()) -> FillRule -> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FillRule -> Render ()
C.setFillRule (FillRule -> Render ())
-> (FillRule -> FillRule) -> FillRule -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FillRule -> FillRule
fromFillRule (FillRule -> FillRule)
-> (FillRule -> FillRule) -> FillRule -> FillRule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FillRule -> FillRule
getFillRule
lWidth :: LineWidth Double -> RenderM ()
lWidth = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ())
-> (LineWidth Double -> Render ())
-> LineWidth Double
-> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Render ()
C.setLineWidth (Double -> Render ())
-> (LineWidth Double -> Double) -> LineWidth Double -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineWidth Double -> Double
forall n. LineWidth n -> n
getLineWidth
lCap :: LineCap -> RenderM ()
lCap = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ())
-> (LineCap -> Render ()) -> LineCap -> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> Render ()
C.setLineCap (LineCap -> Render ())
-> (LineCap -> LineCap) -> LineCap -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> LineCap
fromLineCap (LineCap -> LineCap) -> (LineCap -> LineCap) -> LineCap -> LineCap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> LineCap
getLineCap
lJoin :: LineJoin -> RenderM ()
lJoin = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ())
-> (LineJoin -> Render ()) -> LineJoin -> RenderM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> Render ()
C.setLineJoin (LineJoin -> Render ())
-> (LineJoin -> LineJoin) -> LineJoin -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> LineJoin
fromLineJoin (LineJoin -> LineJoin)
-> (LineJoin -> LineJoin) -> LineJoin -> LineJoin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> LineJoin
getLineJoin
lDashing :: Dashing Double -> RenderM ()
lDashing (Dashing Double -> Dashing Double
forall n. Dashing n -> Dashing n
getDashing -> Dashing [Double]
ds Double
offs) =
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ [Double] -> Double -> Render ()
C.setDash [Double]
ds Double
offs
fromFontSlant :: FontSlant -> P.FontStyle
fromFontSlant :: FontSlant -> FontStyle
fromFontSlant FontSlant
FontSlantNormal = FontStyle
P.StyleNormal
fromFontSlant FontSlant
FontSlantItalic = FontStyle
P.StyleItalic
fromFontSlant FontSlant
FontSlantOblique = FontStyle
P.StyleOblique
fromFontWeight :: FontWeight -> P.Weight
fromFontWeight :: FontWeight -> Weight
fromFontWeight FontWeight
FontWeightBold = Weight
P.WeightBold
fromFontWeight FontWeight
_ = Weight
P.WeightNormal
cairoTransf :: T2 Double -> C.Render ()
cairoTransf :: T2 Double -> Render ()
cairoTransf T2 Double
t = Matrix -> Render ()
C.transform Matrix
m
where m :: Matrix
m = Double -> Double -> Double -> Double -> Double -> Double -> Matrix
CM.Matrix Double
a1 Double
a2 Double
b1 Double
b2 Double
c1 Double
c2
(V2 Double -> (Double, Double)
forall n. V2 n -> (n, n)
unr2 -> (Double
a1,Double
a2)) = T2 Double -> V2 Double -> V2 Double
forall (v :: * -> *) n. Transformation v n -> v n -> v n
apply T2 Double
t V2 Double
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX
(V2 Double -> (Double, Double)
forall n. V2 n -> (n, n)
unr2 -> (Double
b1,Double
b2)) = T2 Double -> V2 Double -> V2 Double
forall (v :: * -> *) n. Transformation v n -> v n -> v n
apply T2 Double
t V2 Double
forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY
(V2 Double -> (Double, Double)
forall n. V2 n -> (n, n)
unr2 -> (Double
c1,Double
c2)) = T2 Double -> V2 Double
forall (v :: * -> *) n. Transformation v n -> v n
transl T2 Double
t
fromLineCap :: LineCap -> C.LineCap
fromLineCap :: LineCap -> LineCap
fromLineCap LineCap
LineCapButt = LineCap
C.LineCapButt
fromLineCap LineCap
LineCapRound = LineCap
C.LineCapRound
fromLineCap LineCap
LineCapSquare = LineCap
C.LineCapSquare
fromLineJoin :: LineJoin -> C.LineJoin
fromLineJoin :: LineJoin -> LineJoin
fromLineJoin LineJoin
LineJoinMiter = LineJoin
C.LineJoinMiter
fromLineJoin LineJoin
LineJoinRound = LineJoin
C.LineJoinRound
fromLineJoin LineJoin
LineJoinBevel = LineJoin
C.LineJoinBevel
fromFillRule :: FillRule -> C.FillRule
fromFillRule :: FillRule -> FillRule
fromFillRule FillRule
Winding = FillRule
C.FillRuleWinding
fromFillRule FillRule
EvenOdd = FillRule
C.FillRuleEvenOdd
instance Renderable (Segment Closed V2 Double) Cairo where
render :: Cairo
-> Segment Closed V2 Double
-> Render
Cairo (V (Segment Closed V2 Double)) (N (Segment Closed V2 Double))
render Cairo
_ (Linear (OffsetClosed V2 Double
v)) = RenderM () -> Render Cairo V2 Double
C (RenderM () -> Render Cairo V2 Double)
-> (Render () -> RenderM ()) -> Render () -> Render Cairo V2 Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> Render Cairo V2 Double)
-> Render () -> Render Cairo V2 Double
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Render ()) -> (Double, Double) -> Render ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> Render ()
C.relLineTo (V2 Double -> (Double, Double)
forall n. V2 n -> (n, n)
unr2 V2 Double
v)
render Cairo
_ (Cubic (V2 Double -> (Double, Double)
forall n. V2 n -> (n, n)
unr2 -> (Double
x1,Double
y1))
(V2 Double -> (Double, Double)
forall n. V2 n -> (n, n)
unr2 -> (Double
x2,Double
y2))
(OffsetClosed (V2 Double -> (Double, Double)
forall n. V2 n -> (n, n)
unr2 -> (Double
x3,Double
y3))))
= RenderM () -> Render Cairo V2 Double
C (RenderM () -> Render Cairo V2 Double)
-> (Render () -> RenderM ()) -> Render () -> Render Cairo V2 Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> Render Cairo V2 Double)
-> Render () -> Render Cairo V2 Double
forall a b. (a -> b) -> a -> b
$ Double
-> Double -> Double -> Double -> Double -> Double -> Render ()
C.relCurveTo Double
x1 Double
y1 Double
x2 Double
y2 Double
x3 Double
y3
instance Renderable (Trail V2 Double) Cairo where
render :: Cairo
-> Trail V2 Double
-> Render Cairo (V (Trail V2 Double)) (N (Trail V2 Double))
render Cairo
_ = (Trail' Line V2 Double -> Render Cairo V2 Double)
-> (Trail' Loop V2 Double -> Render Cairo V2 Double)
-> Trail V2 Double
-> Render Cairo V2 Double
forall (v :: * -> *) n r.
(Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> r
withTrail Trail' Line V2 Double -> Render Cairo V2 Double
renderLine Trail' Loop V2 Double -> Render Cairo V2 Double
renderLoop
where
renderLine :: Trail' Line V2 Double -> Render Cairo V2 Double
renderLine Trail' Line V2 Double
ln = RenderM () -> Render Cairo V2 Double
C (RenderM () -> Render Cairo V2 Double)
-> RenderM () -> Render Cairo V2 Double
forall a b. (a -> b) -> a -> b
$ do
(Segment Closed V2 Double -> RenderM ())
-> [Segment Closed V2 Double] -> RenderM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Segment Closed V2 Double -> RenderM ()
forall a.
(Renderable a Cairo, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC (Trail' Line V2 Double -> [Segment Closed V2 Double]
forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments Trail' Line V2 Double
ln)
(Bool -> Identity Bool) -> CairoState -> Identity CairoState
Lens' CairoState Bool
ignoreFill ((Bool -> Identity Bool) -> CairoState -> Identity CairoState)
-> Bool -> RenderM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
renderLoop :: Trail' Loop V2 Double -> Render Cairo V2 Double
renderLoop Trail' Loop V2 Double
lp = RenderM () -> Render Cairo V2 Double
C (RenderM () -> Render Cairo V2 Double)
-> RenderM () -> Render Cairo V2 Double
forall a b. (a -> b) -> a -> b
$ do
case Trail' Loop V2 Double
-> ([Segment Closed V2 Double], Segment Open V2 Double)
forall (v :: * -> *) n.
Trail' Loop v n -> ([Segment Closed v n], Segment Open v n)
loopSegments Trail' Loop V2 Double
lp of
([Segment Closed V2 Double]
segs, Linear Offset Open V2 Double
_) -> (Segment Closed V2 Double -> RenderM ())
-> [Segment Closed V2 Double] -> RenderM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Segment Closed V2 Double -> RenderM ()
forall a.
(Renderable a Cairo, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC [Segment Closed V2 Double]
segs
([Segment Closed V2 Double], Segment Open V2 Double)
_ -> (Segment Closed V2 Double -> RenderM ())
-> [Segment Closed V2 Double] -> RenderM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Segment Closed V2 Double -> RenderM ()
forall a.
(Renderable a Cairo, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC (Trail' Line V2 Double -> [Segment Closed V2 Double]
forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments (Trail' Line V2 Double -> [Segment Closed V2 Double])
-> (Trail' Loop V2 Double -> Trail' Line V2 Double)
-> Trail' Loop V2 Double
-> [Segment Closed V2 Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trail' Loop V2 Double -> Trail' Line V2 Double
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail' Loop v n -> Trail' Line v n
cutLoop (Trail' Loop V2 Double -> [Segment Closed V2 Double])
-> Trail' Loop V2 Double -> [Segment Closed V2 Double]
forall a b. (a -> b) -> a -> b
$ Trail' Loop V2 Double
lp)
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.closePath
instance Renderable (Path V2 Double) Cairo where
render :: Cairo
-> Path V2 Double
-> Render Cairo (V (Path V2 Double)) (N (Path V2 Double))
render Cairo
_ Path V2 Double
p = RenderM () -> Render Cairo V2 Double
C (RenderM () -> Render Cairo V2 Double)
-> RenderM () -> Render Cairo V2 Double
forall a b. (a -> b) -> a -> b
$ do
Path V2 Double -> RenderM ()
cairoPath Path V2 Double
p
Maybe (Texture Double)
f <- (FillTexture Double -> Texture Double)
-> RenderM (Maybe (Texture Double))
forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib FillTexture Double -> Texture Double
forall n. FillTexture n -> Texture n
getFillTexture
Maybe (Texture Double)
s <- (LineTexture Double -> Texture Double)
-> RenderM (Maybe (Texture Double))
forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib LineTexture Double -> Texture Double
forall n. LineTexture n -> Texture n
getLineTexture
Bool
ign <- Getting Bool CairoState Bool -> StateStackT CairoState Render Bool
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Bool CairoState Bool
Lens' CairoState Bool
ignoreFill
Maybe (Texture Double) -> RenderM ()
setTexture Maybe (Texture Double)
f
Bool -> RenderM () -> RenderM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Texture Double) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Texture Double)
f Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
ign) (RenderM () -> RenderM ()) -> RenderM () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.fillPreserve
Maybe (Texture Double) -> RenderM ()
setTexture Maybe (Texture Double)
s
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.stroke
cairoPath :: Path V2 Double -> RenderM ()
cairoPath :: Path V2 Double -> RenderM ()
cairoPath (Path [Located (Trail V2 Double)]
trs) = do
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.newPath
(Bool -> Identity Bool) -> CairoState -> Identity CairoState
Lens' CairoState Bool
ignoreFill ((Bool -> Identity Bool) -> CairoState -> Identity CairoState)
-> Bool -> RenderM ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False
(Located (Trail V2 Double) -> RenderM ())
-> [Located (Trail V2 Double)] -> RenderM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ Located (Trail V2 Double) -> RenderM ()
forall {a}.
(Renderable a Cairo, V a ~ V2, N a ~ Double) =>
Located a -> RenderM ()
renderTrail [Located (Trail V2 Double)]
trs
where
renderTrail :: Located a -> RenderM ()
renderTrail (Located a -> (Point (V a) (N a), a)
forall a. Located a -> (Point (V a) (N a), a)
viewLoc -> (Point (V a) (N a) -> (Double, Double)
forall n. P2 n -> (n, n)
unp2 -> (Double, Double)
p, a
tr)) = do
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Render ()) -> (Double, Double) -> Render ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> Render ()
C.moveTo (Double, Double)
p
a -> RenderM ()
forall a.
(Renderable a Cairo, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC a
tr
addStop :: MonadIO m => C.Pattern -> GradientStop Double -> m ()
addStop :: forall (m :: * -> *).
MonadIO m =>
Pattern -> GradientStop Double -> m ()
addStop Pattern
p GradientStop Double
s = Pattern -> Double -> Double -> Double -> Double -> Double -> m ()
forall (m :: * -> *).
MonadIO m =>
Pattern -> Double -> Double -> Double -> Double -> Double -> m ()
C.patternAddColorStopRGBA Pattern
p (GradientStop Double
sGradientStop Double
-> Getting Double (GradientStop Double) Double -> Double
forall s a. s -> Getting a s a -> a
^.Getting Double (GradientStop Double) Double
forall n. Lens' (GradientStop n) n
stopFraction) Double
r Double
g Double
b Double
a
where
(Double
r,Double
g,Double
b,Double
a) = SomeColor -> (Double, Double, Double, Double)
forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA (GradientStop Double
sGradientStop Double
-> Getting SomeColor (GradientStop Double) SomeColor -> SomeColor
forall s a. s -> Getting a s a -> a
^.Getting SomeColor (GradientStop Double) SomeColor
forall n. Lens' (GradientStop n) SomeColor
stopColor)
cairoSpreadMethod :: SpreadMethod -> C.Extend
cairoSpreadMethod :: SpreadMethod -> Extend
cairoSpreadMethod SpreadMethod
GradPad = Extend
C.ExtendPad
cairoSpreadMethod SpreadMethod
GradReflect = Extend
C.ExtendReflect
cairoSpreadMethod SpreadMethod
GradRepeat = Extend
C.ExtendRepeat
setTexture :: Maybe (Texture Double) -> RenderM ()
setTexture :: Maybe (Texture Double) -> RenderM ()
setTexture Maybe (Texture Double)
Nothing = () -> RenderM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setTexture (Just (SC (SomeColor c
c))) = do
Double
o <- Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 (Maybe Double -> Double)
-> StateStackT CairoState Render (Maybe Double)
-> StateStackT CairoState Render Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Opacity -> Double) -> StateStackT CairoState Render (Maybe Double)
forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib Opacity -> Double
getOpacity
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Double -> Double -> Double -> Double -> Render ()
C.setSourceRGBA Double
r Double
g Double
b (Double
oDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
a))
where (Double
r,Double
g,Double
b,Double
a) = c -> (Double, Double, Double, Double)
forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA c
c
setTexture (Just (LG LGradient Double
g)) = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$
Double
-> Double
-> Double
-> Double
-> (Pattern -> Render ())
-> Render ()
forall a.
Double
-> Double -> Double -> Double -> (Pattern -> Render a) -> Render a
C.withLinearPattern Double
x0 Double
y0 Double
x1 Double
y1 ((Pattern -> Render ()) -> Render ())
-> (Pattern -> Render ()) -> Render ()
forall a b. (a -> b) -> a -> b
$ \Pattern
pat -> do
(GradientStop Double -> Render ())
-> [GradientStop Double] -> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pattern -> GradientStop Double -> Render ()
forall (m :: * -> *).
MonadIO m =>
Pattern -> GradientStop Double -> m ()
addStop Pattern
pat) (LGradient Double
gLGradient Double
-> Getting
[GradientStop Double] (LGradient Double) [GradientStop Double]
-> [GradientStop Double]
forall s a. s -> Getting a s a -> a
^.Getting
[GradientStop Double] (LGradient Double) [GradientStop Double]
forall n. Lens' (LGradient n) [GradientStop n]
lGradStops)
Pattern -> Matrix -> Render ()
forall (m :: * -> *). MonadIO m => Pattern -> Matrix -> m ()
C.patternSetMatrix Pattern
pat Matrix
m
Pattern -> Extend -> Render ()
forall (m :: * -> *). MonadIO m => Pattern -> Extend -> m ()
C.patternSetExtend Pattern
pat (SpreadMethod -> Extend
cairoSpreadMethod (LGradient Double
gLGradient Double
-> Getting SpreadMethod (LGradient Double) SpreadMethod
-> SpreadMethod
forall s a. s -> Getting a s a -> a
^.Getting SpreadMethod (LGradient Double) SpreadMethod
forall n. Lens' (LGradient n) SpreadMethod
lGradSpreadMethod))
Pattern -> Render ()
C.setSource Pattern
pat
where
m :: Matrix
m = Double -> Double -> Double -> Double -> Double -> Double -> Matrix
CM.Matrix Double
a1 Double
a2 Double
b1 Double
b2 Double
c1 Double
c2
[[Double
a1, Double
a2], [Double
b1, Double
b2], [Double
c1, Double
c2]] = T2 Double -> [[Double]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep (T2 Double -> T2 Double
forall (v :: * -> *) n.
(Functor v, Num n) =>
Transformation v n -> Transformation v n
inv (LGradient Double
gLGradient Double
-> Getting (T2 Double) (LGradient Double) (T2 Double) -> T2 Double
forall s a. s -> Getting a s a -> a
^.Getting (T2 Double) (LGradient Double) (T2 Double)
forall n. Lens' (LGradient n) (Transformation V2 n)
lGradTrans))
(Double
x0, Double
y0) = Point V2 Double -> (Double, Double)
forall n. P2 n -> (n, n)
unp2 (LGradient Double
gLGradient Double
-> Getting (Point V2 Double) (LGradient Double) (Point V2 Double)
-> Point V2 Double
forall s a. s -> Getting a s a -> a
^.Getting (Point V2 Double) (LGradient Double) (Point V2 Double)
forall n. Lens' (LGradient n) (Point V2 n)
lGradStart)
(Double
x1, Double
y1) = Point V2 Double -> (Double, Double)
forall n. P2 n -> (n, n)
unp2 (LGradient Double
gLGradient Double
-> Getting (Point V2 Double) (LGradient Double) (Point V2 Double)
-> Point V2 Double
forall s a. s -> Getting a s a -> a
^.Getting (Point V2 Double) (LGradient Double) (Point V2 Double)
forall n. Lens' (LGradient n) (Point V2 n)
lGradEnd)
setTexture (Just (RG RGradient Double
g)) = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$
Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> (Pattern -> Render ())
-> Render ()
forall a.
Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> (Pattern -> Render a)
-> Render a
C.withRadialPattern Double
x0 Double
y0 Double
r0 Double
x1 Double
y1 Double
r1 ((Pattern -> Render ()) -> Render ())
-> (Pattern -> Render ()) -> Render ()
forall a b. (a -> b) -> a -> b
$ \Pattern
pat -> do
(GradientStop Double -> Render ())
-> [GradientStop Double] -> Render ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pattern -> GradientStop Double -> Render ()
forall (m :: * -> *).
MonadIO m =>
Pattern -> GradientStop Double -> m ()
addStop Pattern
pat) (RGradient Double
gRGradient Double
-> Getting
[GradientStop Double] (RGradient Double) [GradientStop Double]
-> [GradientStop Double]
forall s a. s -> Getting a s a -> a
^.Getting
[GradientStop Double] (RGradient Double) [GradientStop Double]
forall n. Lens' (RGradient n) [GradientStop n]
rGradStops)
Pattern -> Matrix -> Render ()
forall (m :: * -> *). MonadIO m => Pattern -> Matrix -> m ()
C.patternSetMatrix Pattern
pat Matrix
m
Pattern -> Extend -> Render ()
forall (m :: * -> *). MonadIO m => Pattern -> Extend -> m ()
C.patternSetExtend Pattern
pat (SpreadMethod -> Extend
cairoSpreadMethod (RGradient Double
gRGradient Double
-> Getting SpreadMethod (RGradient Double) SpreadMethod
-> SpreadMethod
forall s a. s -> Getting a s a -> a
^.Getting SpreadMethod (RGradient Double) SpreadMethod
forall n. Lens' (RGradient n) SpreadMethod
rGradSpreadMethod))
Pattern -> Render ()
C.setSource Pattern
pat
where
m :: Matrix
m = Double -> Double -> Double -> Double -> Double -> Double -> Matrix
CM.Matrix Double
a1 Double
a2 Double
b1 Double
b2 Double
c1 Double
c2
[[Double
a1, Double
a2], [Double
b1, Double
b2], [Double
c1, Double
c2]] = T2 Double -> [[Double]]
forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep (T2 Double -> T2 Double
forall (v :: * -> *) n.
(Functor v, Num n) =>
Transformation v n -> Transformation v n
inv (RGradient Double
gRGradient Double
-> Getting (T2 Double) (RGradient Double) (T2 Double) -> T2 Double
forall s a. s -> Getting a s a -> a
^.Getting (T2 Double) (RGradient Double) (T2 Double)
forall n. Lens' (RGradient n) (Transformation V2 n)
rGradTrans))
(Double
r0, Double
r1) = (RGradient Double
gRGradient Double
-> Getting Double (RGradient Double) Double -> Double
forall s a. s -> Getting a s a -> a
^.Getting Double (RGradient Double) Double
forall n. Lens' (RGradient n) n
rGradRadius0, RGradient Double
gRGradient Double
-> Getting Double (RGradient Double) Double -> Double
forall s a. s -> Getting a s a -> a
^.Getting Double (RGradient Double) Double
forall n. Lens' (RGradient n) n
rGradRadius1)
(Double
x0', Double
y0') = Point V2 Double -> (Double, Double)
forall n. P2 n -> (n, n)
unp2 (RGradient Double
gRGradient Double
-> Getting (Point V2 Double) (RGradient Double) (Point V2 Double)
-> Point V2 Double
forall s a. s -> Getting a s a -> a
^.Getting (Point V2 Double) (RGradient Double) (Point V2 Double)
forall n. Lens' (RGradient n) (Point V2 n)
rGradCenter0)
(Double
x1', Double
y1') = Point V2 Double -> (Double, Double)
forall n. P2 n -> (n, n)
unp2 (RGradient Double
gRGradient Double
-> Getting (Point V2 Double) (RGradient Double) (Point V2 Double)
-> Point V2 Double
forall s a. s -> Getting a s a -> a
^.Getting (Point V2 Double) (RGradient Double) (Point V2 Double)
forall n. Lens' (RGradient n) (Point V2 n)
rGradCenter1)
(Double
x0, Double
y0, Double
x1, Double
y1) = (Double
x0' Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
r1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
r0) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
r1, Double
y0' Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
r1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
r0) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
r1, Double
x1' ,Double
y1')
instance Renderable (DImage Double External) Cairo where
render :: Cairo
-> DImage Double External
-> Render
Cairo (V (DImage Double External)) (N (DImage Double External))
render Cairo
_ (DImage ImageData External
path Int
w Int
h T2 Double
tr) = RenderM () -> Render Cairo V2 Double
C (RenderM () -> Render Cairo V2 Double)
-> (Render () -> RenderM ()) -> Render () -> Render Cairo V2 Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> Render Cairo V2 Double)
-> Render () -> Render Cairo V2 Double
forall a b. (a -> b) -> a -> b
$ do
let ImageRef String
file = ImageData External
path
if String
".png" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
file
then do
Render ()
C.save
T2 Double -> Render ()
cairoTransf (T2 Double
tr T2 Double -> T2 Double -> T2 Double
forall a. Semigroup a => a -> a -> a
<> T2 Double
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY)
Either IOError Surface
pngSurfChk <- IO (Either IOError Surface) -> Render (Either IOError Surface)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Surface -> IO (Either IOError Surface)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Surface -> IO (Either IOError Surface))
-> IO Surface -> IO (Either IOError Surface)
forall a b. (a -> b) -> a -> b
$ String -> IO Surface
C.imageSurfaceCreateFromPNG String
file
:: IO (Either IOError C.Surface))
case Either IOError Surface
pngSurfChk of
Right Surface
pngSurf -> do
Int
w' <- Surface -> Render Int
forall (m :: * -> *). MonadIO m => Surface -> m Int
C.imageSurfaceGetWidth Surface
pngSurf
Int
h' <- Surface -> Render Int
forall (m :: * -> *). MonadIO m => Surface -> m Int
C.imageSurfaceGetHeight Surface
pngSurf
let sz :: SizeSpec V2 Double
sz = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> SizeSpec V2 Int -> SizeSpec V2 Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> SizeSpec V2 Int
forall n. n -> n -> SizeSpec V2 n
dims2D Int
w Int
h
T2 Double -> Render ()
cairoTransf (T2 Double -> Render ()) -> T2 Double -> Render ()
forall a b. (a -> b) -> a -> b
$ SizeSpec V2 Double -> V2 Double -> T2 Double
forall (v :: * -> *) n.
(Additive v, Foldable v, Fractional n, Ord n) =>
SizeSpec v n -> v n -> Transformation v n
requiredScaling SizeSpec V2 Double
sz (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> V2 Int -> V2 Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 Int
w' Int
h')
Surface -> Double -> Double -> Render ()
C.setSourceSurface Surface
pngSurf (-Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
(-Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
Left IOError
_ ->
IO () -> Render ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Render ()) -> (String -> IO ()) -> String -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> Render ()) -> String -> Render ()
forall a b. (a -> b) -> a -> b
$
String
"Warning: can't read image file <" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
Render ()
C.paint
Render ()
C.restore
else
IO () -> Render ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Render ())
-> ([String] -> IO ()) -> [String] -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStr (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> Render ()) -> [String] -> Render ()
forall a b. (a -> b) -> a -> b
$
[ String
"Warning: Cairo backend can currently only render embedded"
, String
" images in .png format. Ignoring <" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">."
]
toImageRGBA8 :: DynamicImage -> Image PixelRGBA8
toImageRGBA8 :: DynamicImage -> Image PixelRGBA8
toImageRGBA8 (ImageRGBA8 Image PixelRGBA8
i) = Image PixelRGBA8
i
toImageRGBA8 (ImageRGB8 Image PixelRGB8
i) = Image PixelRGB8 -> Image PixelRGBA8
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage Image PixelRGB8
i
toImageRGBA8 (ImageYCbCr8 Image PixelYCbCr8
i) = Image PixelRGB8 -> Image PixelRGBA8
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage (Image PixelYCbCr8 -> Image PixelRGB8
forall a b. ColorSpaceConvertible a b => Image a -> Image b
convertImage Image PixelYCbCr8
i :: Image PixelRGB8)
toImageRGBA8 (ImageY8 Image Pixel8
i) = Image Pixel8 -> Image PixelRGBA8
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage Image Pixel8
i
toImageRGBA8 (ImageYA8 Image PixelYA8
i) = Image PixelYA8 -> Image PixelRGBA8
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage Image PixelYA8
i
toImageRGBA8 (ImageCMYK8 Image PixelCMYK8
i) = Image PixelRGB8 -> Image PixelRGBA8
forall a b. ColorConvertible a b => Image a -> Image b
promoteImage (Image PixelCMYK8 -> Image PixelRGB8
forall a b. ColorSpaceConvertible a b => Image a -> Image b
convertImage Image PixelCMYK8
i :: Image PixelRGB8)
toImageRGBA8 DynamicImage
_ = String -> Image PixelRGBA8
forall a. HasCallStack => String -> a
error String
"Unsupported Pixel type"
instance Renderable (DImage Double Embedded) Cairo where
render :: Cairo
-> DImage Double Embedded
-> Render
Cairo (V (DImage Double Embedded)) (N (DImage Double Embedded))
render Cairo
_ (DImage ImageData Embedded
iD Int
_w Int
_h T2 Double
tr) = RenderM () -> Render Cairo V2 Double
C (RenderM () -> Render Cairo V2 Double)
-> (Render () -> RenderM ()) -> Render () -> Render Cairo V2 Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> Render Cairo V2 Double)
-> Render () -> Render Cairo V2 Double
forall a b. (a -> b) -> a -> b
$ do
Render ()
C.save
T2 Double -> Render ()
cairoTransf (T2 Double
tr T2 Double -> T2 Double -> T2 Double
forall a. Semigroup a => a -> a -> a
<> T2 Double
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY)
let fmt :: Format
fmt = Format
C.FormatARGB32
Surface
dataSurf <- IO Surface -> Render Surface
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Surface -> Render Surface) -> IO Surface -> Render Surface
forall a b. (a -> b) -> a -> b
$ Format -> Int -> Int -> IO Surface
C.createImageSurface Format
fmt Int
w Int
h
SurfaceData Int Word32
surData :: C.SurfaceData Int Word32
<- IO (SurfaceData Int Word32) -> Render (SurfaceData Int Word32)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SurfaceData Int Word32) -> Render (SurfaceData Int Word32))
-> IO (SurfaceData Int Word32) -> Render (SurfaceData Int Word32)
forall a b. (a -> b) -> a -> b
$ Surface -> IO (SurfaceData Int Word32)
forall e. Storable e => Surface -> IO (SurfaceData Int e)
C.imageSurfaceGetPixels Surface
dataSurf
Int
stride <- Surface -> Render Int
forall (m :: * -> *). MonadIO m => Surface -> m Int
C.imageSurfaceGetStride Surface
dataSurf
Image PixelRGBA8
_ <- LensLike
(WrappedMonad Render)
(Image PixelRGBA8)
(Image PixelRGBA8)
(Int, Int, PixelRGBA8)
PixelRGBA8
-> Image PixelRGBA8
-> ((Int, Int, PixelRGBA8) -> Render PixelRGBA8)
-> Render (Image PixelRGBA8)
forall (m :: * -> *) s t a b.
LensLike (WrappedMonad m) s t a b -> s -> (a -> m b) -> m t
forMOf LensLike
(WrappedMonad Render)
(Image PixelRGBA8)
(Image PixelRGBA8)
(Int, Int, PixelRGBA8)
PixelRGBA8
forall pxa pxb.
(Pixel pxa, Pixel pxb) =>
Traversal (Image pxa) (Image pxb) (Int, Int, pxa) pxb
imageIPixels Image PixelRGBA8
img (((Int, Int, PixelRGBA8) -> Render PixelRGBA8)
-> Render (Image PixelRGBA8))
-> ((Int, Int, PixelRGBA8) -> Render PixelRGBA8)
-> Render (Image PixelRGBA8)
forall a b. (a -> b) -> a -> b
$ \(Int
x, Int
y, PixelRGBA8
px) -> do
let p :: Int
p = Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
strideInt -> Int -> Int
forall a. Integral a => a -> a -> a
`div`Int
4) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x
IO () -> Render ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Render ()) -> (Word32 -> IO ()) -> Word32 -> Render ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SurfaceData Int Word32 -> Int -> Word32 -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
MA.writeArray SurfaceData Int Word32
surData Int
p (Word32 -> Render ()) -> Word32 -> Render ()
forall a b. (a -> b) -> a -> b
$ PixelRGBA8 -> Word32
toARGB PixelRGBA8
px
PixelRGBA8 -> Render PixelRGBA8
forall (m :: * -> *) a. Monad m => a -> m a
return PixelRGBA8
px
Surface -> Render ()
forall (m :: * -> *). MonadIO m => Surface -> m ()
C.surfaceMarkDirty Surface
dataSurf
Int
w' <- Surface -> Render Int
forall (m :: * -> *). MonadIO m => Surface -> m Int
C.imageSurfaceGetWidth Surface
dataSurf
Int
h' <- Surface -> Render Int
forall (m :: * -> *). MonadIO m => Surface -> m Int
C.imageSurfaceGetHeight Surface
dataSurf
let sz :: SizeSpec V2 Double
sz = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> SizeSpec V2 Int -> SizeSpec V2 Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> SizeSpec V2 Int
forall n. n -> n -> SizeSpec V2 n
dims2D Int
w Int
h
T2 Double -> Render ()
cairoTransf (T2 Double -> Render ()) -> T2 Double -> Render ()
forall a b. (a -> b) -> a -> b
$ SizeSpec V2 Double -> V2 Double -> T2 Double
forall (v :: * -> *) n.
(Additive v, Foldable v, Fractional n, Ord n) =>
SizeSpec v n -> v n -> Transformation v n
requiredScaling SizeSpec V2 Double
sz (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> V2 Int -> V2 Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 Int
w' Int
h')
Surface -> Double -> Double -> Render ()
C.setSourceSurface Surface
dataSurf (-Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
(-Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)
Render ()
C.paint
Render ()
C.restore
where
ImageRaster DynamicImage
dImg = ImageData Embedded
iD
img :: Image PixelRGBA8
img@(Image Int
w Int
h Vector (PixelBaseComponent PixelRGBA8)
_) = DynamicImage -> Image PixelRGBA8
toImageRGBA8 DynamicImage
dImg
{-# INLINE toARGB #-}
toARGB :: PixelRGBA8 -> Word32
toARGB :: PixelRGBA8 -> Word32
toARGB PixelRGBA8
px = Word32
ga Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
rotateL Word32
rb Int
16
where rgba :: PackedRepresentation PixelRGBA8
rgba = PixelRGBA8 -> PackedRepresentation PixelRGBA8
forall a. PackeablePixel a => a -> PackedRepresentation a
packPixel PixelRGBA8
px
rb :: Word32
rb = Word32
PackedRepresentation PixelRGBA8
rgba Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x00FF00FF
ga :: Word32
ga = Word32
PackedRepresentation PixelRGBA8
rgba Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF00FF00
if' :: Monad m => (a -> m ()) -> Maybe a -> m ()
if' :: forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' = m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
instance Renderable (Text Double) Cairo where
render :: Cairo
-> Text Double -> Render Cairo (V (Text Double)) (N (Text Double))
render Cairo
_ Text Double
txt = RenderM () -> Render Cairo V2 Double
C (RenderM () -> Render Cairo V2 Double)
-> RenderM () -> Render Cairo V2 Double
forall a b. (a -> b) -> a -> b
$ do
RenderM ()
save
Maybe (Texture Double) -> RenderM ()
setTexture (Maybe (Texture Double) -> RenderM ())
-> RenderM (Maybe (Texture Double)) -> RenderM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (FillTexture Double -> Texture Double)
-> RenderM (Maybe (Texture Double))
forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib FillTexture Double -> Texture Double
forall n. FillTexture n -> Texture n
getFillTexture
Style V2 Double
sty <- Getting (Style V2 Double) CairoState (Style V2 Double)
-> StateStackT CairoState Render (Style V2 Double)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Style V2 Double) CairoState (Style V2 Double)
Lens' CairoState (Style V2 Double)
accumStyle
PangoLayout
layout <- Render PangoLayout -> RenderM PangoLayout
forall a. Render a -> RenderM a
liftC (Render PangoLayout -> RenderM PangoLayout)
-> Render PangoLayout -> RenderM PangoLayout
forall a b. (a -> b) -> a -> b
$ Style V2 Double -> Text Double -> Render PangoLayout
layoutStyledText Style V2 Double
sty Text Double
txt
Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ do
PangoLayout -> Render ()
P.showLayout PangoLayout
layout
Render ()
C.newPath
RenderM ()
restore
layoutStyledText :: Style V2 Double -> Text Double -> C.Render P.PangoLayout
layoutStyledText :: Style V2 Double -> Text Double -> Render PangoLayout
layoutStyledText Style V2 Double
sty (Text T2 Double
tt TextAlignment Double
al String
str) =
let tr :: T2 Double
tr = T2 Double
tt T2 Double -> T2 Double -> T2 Double
forall a. Semigroup a => a -> a -> a
<> T2 Double
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY
styAttr :: AttributeClass a => (a -> b) -> Maybe b
styAttr :: forall a b. AttributeClass a => (a -> b) -> Maybe b
styAttr a -> b
f = (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Maybe a -> Maybe b) -> Maybe a -> Maybe b
forall a b. (a -> b) -> a -> b
$ Style V2 Double -> Maybe a
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style V2 Double
sty
ff :: Maybe String
ff = (Font -> String) -> Maybe String
forall a b. AttributeClass a => (a -> b) -> Maybe b
styAttr Font -> String
getFont
fs :: Maybe FontStyle
fs = (FontSlant -> FontStyle) -> Maybe FontStyle
forall a b. AttributeClass a => (a -> b) -> Maybe b
styAttr FontSlant -> FontStyle
fromFontSlant
fw :: Maybe Weight
fw = (FontWeight -> Weight) -> Maybe Weight
forall a b. AttributeClass a => (a -> b) -> Maybe b
styAttr FontWeight -> Weight
fromFontWeight
size' :: Maybe Double
size' = (FontSize Double -> Double) -> Maybe Double
forall a b. AttributeClass a => (a -> b) -> Maybe b
styAttr FontSize Double -> Double
forall n. FontSize n -> n
getFontSize
in do
T2 Double -> Render ()
cairoTransf T2 Double
tr
PangoLayout
layout <- String -> Render PangoLayout
forall string. GlibString string => string -> Render PangoLayout
P.createLayout String
str
IO () -> Render ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Render ()) -> IO () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
FontDescription
font <- IO FontDescription
P.fontDescriptionNew
(String -> IO ()) -> Maybe String -> IO ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' (FontDescription -> String -> IO ()
forall string.
GlibString string =>
FontDescription -> string -> IO ()
P.fontDescriptionSetFamily FontDescription
font) Maybe String
ff
(FontStyle -> IO ()) -> Maybe FontStyle -> IO ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' (FontDescription -> FontStyle -> IO ()
P.fontDescriptionSetStyle FontDescription
font) Maybe FontStyle
fs
(Weight -> IO ()) -> Maybe Weight -> IO ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' (FontDescription -> Weight -> IO ()
P.fontDescriptionSetWeight FontDescription
font) Maybe Weight
fw
(Double -> IO ()) -> Maybe Double -> IO ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
if' (FontDescription -> Double -> IO ()
P.fontDescriptionSetSize FontDescription
font) Maybe Double
size'
PangoLayout -> Maybe FontDescription -> IO ()
P.layoutSetFontDescription PangoLayout
layout (Maybe FontDescription -> IO ()) -> Maybe FontDescription -> IO ()
forall a b. (a -> b) -> a -> b
$ FontDescription -> Maybe FontDescription
forall a. a -> Maybe a
Just FontDescription
font
V2 Double
ref <- IO (V2 Double) -> Render (V2 Double)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (V2 Double) -> Render (V2 Double))
-> IO (V2 Double) -> Render (V2 Double)
forall a b. (a -> b) -> a -> b
$ case TextAlignment Double
al of
BoxAlignedText Double
xt Double
yt -> do
(PangoRectangle
_,P.PangoRectangle Double
_ Double
_ Double
w Double
h) <- PangoLayout -> IO (PangoRectangle, PangoRectangle)
P.layoutGetExtents PangoLayout
layout
V2 Double -> IO (V2 Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (V2 Double -> IO (V2 Double)) -> V2 Double -> IO (V2 Double)
forall a b. (a -> b) -> a -> b
$ (Double, Double) -> V2 Double
forall n. (n, n) -> V2 n
r2 (Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
xt, Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
yt))
TextAlignment Double
BaselineText -> do
Double
baseline <- LayoutIter -> IO Double
P.layoutIterGetBaseline (LayoutIter -> IO Double) -> IO LayoutIter -> IO Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PangoLayout -> IO LayoutIter
P.layoutGetIter PangoLayout
layout
V2 Double -> IO (V2 Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (V2 Double -> IO (V2 Double)) -> V2 Double -> IO (V2 Double)
forall a b. (a -> b) -> a -> b
$ (Double, Double) -> V2 Double
forall n. (n, n) -> V2 n
r2 (Double
0, Double
baseline)
let t :: T2 Double
t = V2 Double -> T2 Double -> T2 Double
forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, HasOrigin t) =>
v n -> t -> t
moveOriginBy V2 Double
ref T2 Double
forall a. Monoid a => a
mempty :: T2 Double
T2 Double -> Render ()
cairoTransf T2 Double
t
PangoLayout -> Render ()
P.updateLayout PangoLayout
layout
PangoLayout -> Render PangoLayout
forall (m :: * -> *) a. Monad m => a -> m a
return PangoLayout
layout