{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DeriveDataTypeable        #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TemplateHaskell           #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE TypeSynonymInstances      #-}
{-# LANGUAGE ViewPatterns              #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Backend.Cairo.Internal
-- Copyright   :  (c) 2011 Diagrams-cairo team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- This module contains the internal implementation guts of the
-- diagrams cairo backend.  If you want to see how the cairo backend
-- works under the hood, you are in the right place (try clicking on
-- the \"Source\" links).  (Guts under the hood, what an awful mixed
-- metaphor.)  If you know what you are doing and really want access
-- to the internals of the implementation, you are also in the right
-- place.  Otherwise, you should have no need of this module; import
-- "Diagrams.Backend.Cairo.CmdLine" or "Diagrams.Backend.Cairo"
-- instead.
--
-- The one exception is that this module may have to be imported
-- sometimes to work around an apparent bug in certain versions of
-- GHC, which results in a \"not in scope\" error for 'CairoOptions'.
--
-- The types of all the @fromX@ functions look funny in the Haddock
-- output, which displays them like @Type -> Type@.  In fact they are
-- all of the form @Type -> Graphics.Rendering.Cairo.Type@, /i.e./
-- they convert from a diagrams type to a cairo type of the same name.
-----------------------------------------------------------------------------
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)

-- | This data declaration is simply used as a token to distinguish
--   the cairo backend: (1) when calling functions where the type
--   inference engine would otherwise have no way to know which
--   backend you wanted to use, and (2) as an argument to the
--   'Backend' and 'Renderable' type classes.
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
$c== :: Cairo -> Cairo -> Bool
== :: Cairo -> Cairo -> Bool
$c/= :: Cairo -> Cairo -> Bool
/= :: 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
$ccompare :: Cairo -> Cairo -> Ordering
compare :: Cairo -> Cairo -> Ordering
$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
>= :: Cairo -> Cairo -> Bool
$cmax :: Cairo -> Cairo -> Cairo
max :: Cairo -> Cairo -> Cairo
$cmin :: Cairo -> Cairo -> Cairo
min :: Cairo -> Cairo -> Cairo
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
$creadsPrec :: Int -> ReadS Cairo
readsPrec :: Int -> ReadS Cairo
$creadList :: ReadS [Cairo]
readList :: ReadS [Cairo]
$creadPrec :: ReadPrec Cairo
readPrec :: ReadPrec Cairo
$creadListPrec :: ReadPrec [Cairo]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> Cairo -> ShowS
showsPrec :: Int -> Cairo -> ShowS
$cshow :: Cairo -> String
show :: Cairo -> String
$cshowList :: [Cairo] -> ShowS
showList :: [Cairo] -> ShowS
Show,Typeable)

type B = Cairo

type instance V Cairo = V2
type instance N Cairo = Double

-- | Output types supported by cairo, including four different file
--   types (PNG, PS, PDF, SVG).  If you want to output directly to GTK
--   windows, see the @diagrams-gtk@ package.
data OutputType =
    PNG         -- ^ Portable Network Graphics output.
  | PS          -- ^ PostScript output
  | PDF         -- ^ Portable Document Format output.
  | SVG         -- ^ Scalable Vector Graphics output.
  | RenderOnly  -- ^ Don't output any file; the returned @IO ()@
                --   action will do nothing, but the @Render ()@
                --   action can be used (/e.g./ to draw to a Gtk
                --   window; see the @diagrams-gtk@ package).
  deriving (OutputType -> OutputType -> Bool
(OutputType -> OutputType -> Bool)
-> (OutputType -> OutputType -> Bool) -> Eq OutputType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OutputType -> OutputType -> Bool
== :: OutputType -> OutputType -> Bool
$c/= :: OutputType -> OutputType -> Bool
/= :: 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
$ccompare :: OutputType -> OutputType -> Ordering
compare :: OutputType -> OutputType -> Ordering
$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
>= :: OutputType -> OutputType -> Bool
$cmax :: OutputType -> OutputType -> OutputType
max :: OutputType -> OutputType -> OutputType
$cmin :: OutputType -> OutputType -> OutputType
min :: OutputType -> OutputType -> OutputType
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
$creadsPrec :: Int -> ReadS OutputType
readsPrec :: Int -> ReadS OutputType
$creadList :: ReadS [OutputType]
readList :: ReadS [OutputType]
$creadPrec :: ReadPrec OutputType
readPrec :: ReadPrec OutputType
$creadListPrec :: ReadPrec [OutputType]
readListPrec :: ReadPrec [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
$cshowsPrec :: Int -> OutputType -> ShowS
showsPrec :: Int -> OutputType -> ShowS
$cshow :: OutputType -> String
show :: OutputType -> String
$cshowList :: [OutputType] -> ShowS
showList :: [OutputType] -> ShowS
Show, OutputType
OutputType -> OutputType -> Bounded OutputType
forall a. a -> a -> Bounded a
$cminBound :: OutputType
minBound :: OutputType
$cmaxBound :: OutputType
maxBound :: 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
$csucc :: OutputType -> OutputType
succ :: OutputType -> OutputType
$cpred :: OutputType -> OutputType
pred :: OutputType -> OutputType
$ctoEnum :: Int -> OutputType
toEnum :: Int -> OutputType
$cfromEnum :: OutputType -> Int
fromEnum :: OutputType -> Int
$cenumFrom :: OutputType -> [OutputType]
enumFrom :: OutputType -> [OutputType]
$cenumFromThen :: OutputType -> OutputType -> [OutputType]
enumFromThen :: OutputType -> OutputType -> [OutputType]
$cenumFromTo :: OutputType -> OutputType -> [OutputType]
enumFromTo :: OutputType -> OutputType -> [OutputType]
$cenumFromThenTo :: OutputType -> OutputType -> OutputType -> [OutputType]
enumFromThenTo :: OutputType -> OutputType -> 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
$cfrom :: forall x. OutputType -> Rep OutputType x
from :: forall x. OutputType -> Rep OutputType x
$cto :: forall x. Rep OutputType x -> OutputType
to :: forall x. Rep OutputType x -> OutputType
Generic)

instance Hashable OutputType

-- | Custom state tracked in the 'RenderM' monad.
data CairoState
  = CairoState { CairoState -> Style V2 Double
_accumStyle :: Style V2 Double
                 -- ^ The current accumulated style.
               , CairoState -> Bool
_ignoreFill :: Bool
                 -- ^ Whether or not we saw any lines in the most
                 --   recent path (as opposed to loops).  If we did,
                 --   we should ignore any fill attribute.
                 --   diagrams-lib separates lines and loops into
                 --   separate path primitives so we don't have to
                 --   worry about seeing them together in the same
                 --   path.
               }

$(makeLenses ''CairoState)

instance Default CairoState where
  def :: CairoState
def = CairoState
        { _accumStyle :: Style V2 Double
_accumStyle       = Style V2 Double
forall a. Monoid a => a
mempty
        , _ignoreFill :: Bool
_ignoreFill       = Bool
False
        }

-- | The custom monad in which intermediate drawing options take
--   place; 'Graphics.Rendering.Cairo.Render' is cairo's own rendering
--   monad.
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 (m :: * -> *) a.
Monad m =>
m a -> StateStackT CairoState m 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 = (RenderM a -> CairoState -> Render a)
-> CairoState -> RenderM a -> Render a
forall a b c. (a -> b -> c) -> b -> a -> c
flip RenderM 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

-- | Push the current context onto a stack.
save :: RenderM ()
save :: RenderM ()
save =  RenderM ()
forall s (m :: * -> *). MonadStateStack s m => m ()
SS.save RenderM () -> RenderM () -> RenderM ()
forall a b.
StateStackT CairoState Render a
-> StateStackT CairoState Render b
-> StateStackT CairoState Render b
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 the context from a stack.
restore :: RenderM ()
restore :: RenderM ()
restore = Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC Render ()
C.restore RenderM () -> RenderM () -> RenderM ()
forall a b.
StateStackT CairoState Render a
-> StateStackT CairoState Render b
-> StateStackT CairoState Render b
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     -- ^ The name of the file you want generated
          , Options Cairo V2 Double -> SizeSpec V2 Double
_cairoSizeSpec   :: SizeSpec V2 Double -- ^ The requested size of the output
          , Options Cairo V2 Double -> OutputType
_cairoOutputType :: OutputType -- ^ the output format and associated options
          , Options Cairo V2 Double -> Bool
_cairoBypassAdjust  :: Bool    -- ^ Should the 'adjustDia' step be bypassed during rendering?
          }
    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
$cshowsPrec :: Int -> Options Cairo V2 Double -> ShowS
showsPrec :: Int -> Options Cairo V2 Double -> ShowS
$cshow :: Options Cairo V2 Double -> String
show :: Options Cairo V2 Double -> String
$cshowList :: [Options Cairo V2 Double] -> ShowS
showList :: [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
$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
/= :: 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 b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
w) (Double -> Int
forall b. Integral b => Double -> b
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 a. a -> IO a
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 (SizeSpec V2 Double -> f (SizeSpec V2 Double))
-> Options Cairo V2 Double -> f (Options Cairo V2 Double)
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 a b.
StateStackT CairoState Render a
-> StateStackT CairoState Render b
-> StateStackT CairoState Render b
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 a. a -> StateStackT CairoState Render a
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 m a. Monoid m => (a -> m) -> [a] -> m
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 m a. Monoid m => (a -> m) -> [a] -> m
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})

-- | Render an object that the cairo backend knows how to render.
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

-- | Get an accumulated style attribute from the render monad state.
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 a b. (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

-- | Handle those style attributes for which we can immediately emit
--   cairo instructions as we encounter them in the tree (clip, font
--   size, fill rule, line width, cap, join, and dashing).  Other
--   attributes (font face, slant, weight; fill color, stroke color,
--   opacity) must be accumulated.
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 a b. (a -> b) -> Maybe a -> Maybe b
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 a b.
StateStackT CairoState Render a
-> StateStackT CairoState Render b
-> StateStackT CairoState Render b
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 [Path V2 Double] -> Clip Double
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

-- | Multiply the current transformation matrix by the given 2D
--   transformation.
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 (V (Segment Closed V2 Double)) (N (Segment Closed V2 Double))
RenderM () -> Render Cairo V2 Double
C (RenderM ()
 -> Render
      Cairo
      (V (Segment Closed V2 Double))
      (N (Segment Closed V2 Double)))
-> (Render () -> RenderM ())
-> Render ()
-> Render
     Cairo (V (Segment Closed V2 Double)) (N (Segment Closed V2 Double))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render ()
 -> Render
      Cairo
      (V (Segment Closed V2 Double))
      (N (Segment Closed V2 Double)))
-> Render ()
-> Render
     Cairo (V (Segment Closed V2 Double)) (N (Segment Closed 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 (V (Segment Closed V2 Double)) (N (Segment Closed V2 Double))
RenderM () -> Render Cairo V2 Double
C (RenderM ()
 -> Render
      Cairo
      (V (Segment Closed V2 Double))
      (N (Segment Closed V2 Double)))
-> (Render () -> RenderM ())
-> Render ()
-> Render
     Cairo (V (Segment Closed V2 Double)) (N (Segment Closed V2 Double))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render ()
 -> Render
      Cairo
      (V (Segment Closed V2 Double))
      (N (Segment Closed V2 Double)))
-> Render ()
-> Render
     Cairo (V (Segment Closed V2 Double)) (N (Segment Closed 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)

        -- remember that we saw a Line, so we will ignore fill attribute
        (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
          -- let closePath handle the last segment if it is linear
          ([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

          -- otherwise we have to draw it explicitly
          ([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

-- Add a path to the Cairo context, without stroking or filling it.
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}.
(V a ~ V2, N a ~ Double, Renderable a Cairo) =>
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)
P2 Double -> (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 (f :: * -> *).
Functor f =>
(n -> f n) -> GradientStop n -> f (GradientStop 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 (f :: * -> *).
Functor f =>
(SomeColor -> f SomeColor) -> GradientStop n -> f (GradientStop n)
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

-- XXX should handle opacity in a more straightforward way, using
-- cairo's built-in support for transparency?  See also
-- https://github.com/diagrams/diagrams-cairo/issues/15 .
setTexture :: Maybe (Texture Double) -> RenderM ()
setTexture :: Maybe (Texture Double) -> RenderM ()
setTexture Maybe (Texture Double)
Nothing = () -> RenderM ()
forall a. a -> StateStackT CairoState Render a
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 (f :: * -> *).
Functor f =>
([GradientStop n] -> f [GradientStop n])
-> LGradient n -> f (LGradient 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 (f :: * -> *).
Functor f =>
(SpreadMethod -> f SpreadMethod) -> LGradient n -> f (LGradient n)
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 (f :: * -> *).
Functor f =>
(Transformation V2 n -> f (Transformation V2 n))
-> LGradient n -> f (LGradient n)
lGradTrans))
    (Double
x0, Double
y0) = P2 Double -> (Double, Double)
forall n. P2 n -> (n, n)
unp2 (LGradient Double
gLGradient Double
-> Getting (P2 Double) (LGradient Double) (P2 Double) -> P2 Double
forall s a. s -> Getting a s a -> a
^.Getting (P2 Double) (LGradient Double) (P2 Double)
forall n (f :: * -> *).
Functor f =>
(Point V2 n -> f (Point V2 n)) -> LGradient n -> f (LGradient n)
lGradStart)
    (Double
x1, Double
y1) = P2 Double -> (Double, Double)
forall n. P2 n -> (n, n)
unp2 (LGradient Double
gLGradient Double
-> Getting (P2 Double) (LGradient Double) (P2 Double) -> P2 Double
forall s a. s -> Getting a s a -> a
^.Getting (P2 Double) (LGradient Double) (P2 Double)
forall n (f :: * -> *).
Functor f =>
(Point V2 n -> f (Point V2 n)) -> LGradient n -> f (LGradient 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 (f :: * -> *).
Functor f =>
([GradientStop n] -> f [GradientStop n])
-> RGradient n -> f (RGradient 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 (f :: * -> *).
Functor f =>
(SpreadMethod -> f SpreadMethod) -> RGradient n -> f (RGradient n)
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 (f :: * -> *).
Functor f =>
(Transformation V2 n -> f (Transformation V2 n))
-> RGradient n -> f (RGradient 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 (f :: * -> *).
Functor f =>
(n -> f n) -> RGradient n -> f (RGradient 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 (f :: * -> *).
Functor f =>
(n -> f n) -> RGradient n -> f (RGradient n)
rGradRadius1)
    (Double
x0', Double
y0') = P2 Double -> (Double, Double)
forall n. P2 n -> (n, n)
unp2 (RGradient Double
gRGradient Double
-> Getting (P2 Double) (RGradient Double) (P2 Double) -> P2 Double
forall s a. s -> Getting a s a -> a
^.Getting (P2 Double) (RGradient Double) (P2 Double)
forall n (f :: * -> *).
Functor f =>
(Point V2 n -> f (Point V2 n)) -> RGradient n -> f (RGradient n)
rGradCenter0)
    (Double
x1', Double
y1') = P2 Double -> (Double, Double)
forall n. P2 n -> (n, n)
unp2 (RGradient Double
gRGradient Double
-> Getting (P2 Double) (RGradient Double) (P2 Double) -> P2 Double
forall s a. s -> Getting a s a -> a
^.Getting (P2 Double) (RGradient Double) (P2 Double)
forall n (f :: * -> *).
Functor f =>
(Point V2 n -> f (Point V2 n)) -> RGradient n -> f (RGradient 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')

-- Can only do PNG files at the moment...
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 (V (DImage Double External)) (N (DImage Double External))
RenderM () -> Render Cairo V2 Double
C (RenderM ()
 -> Render
      Cairo (V (DImage Double External)) (N (DImage Double External)))
-> (Render () -> RenderM ())
-> Render ()
-> Render
     Cairo (V (DImage Double External)) (N (DImage Double External))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render ()
 -> Render
      Cairo (V (DImage Double External)) (N (DImage Double External)))
-> Render ()
-> Render
     Cairo (V (DImage Double External)) (N (DImage Double External))
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 a. IO a -> Render a
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 a. IO a -> Render a
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 a. IO a -> Render a
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
">."
          ]

-- Copied from Rasterific backend. This function should probably be in JuicyPixels!
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 _ (DImage path w h tr) =
  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 (V (DImage Double Embedded)) (N (DImage Double Embedded))
RenderM () -> Render Cairo V2 Double
C (RenderM ()
 -> Render
      Cairo (V (DImage Double Embedded)) (N (DImage Double Embedded)))
-> (Render () -> RenderM ())
-> Render ()
-> Render
     Cairo (V (DImage Double Embedded)) (N (DImage Double Embedded))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render ()
 -> Render
      Cairo (V (DImage Double Embedded)) (N (DImage Double Embedded)))
-> Render ()
-> Render
     Cairo (V (DImage Double Embedded)) (N (DImage Double Embedded))
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 a. IO a -> Render a
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 a. IO a -> Render a
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
Traversal
  (Image PixelRGBA8)
  (Image PixelRGBA8)
  (Int, Int, PixelRGBA8)
  PixelRGBA8
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 a. IO a -> Render a
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 a. a -> Render a
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 #-}
-- Actually the name should be toBGRA, since that's the component order used by Cairo.
-- Really, what's happening here is just a swap of the R and B channels.
-- It seems a lot like this is dependent on endianness; perhaps we should handle this...
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 a. a -> m a
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
    -- Uncomment the lines below to draw a rectangle at the extent of each Text
    -- let (w, h) = unr2 $ ref ^* 2   -- XXX Debugging
    -- cairoPath $ rect w h           -- XXX Debugging
    Render () -> RenderM ()
forall a. Render a -> RenderM a
liftC (Render () -> RenderM ()) -> Render () -> RenderM ()
forall a b. (a -> b) -> a -> b
$ do
      -- C.setLineWidth 0.5 -- XXX Debugging
      -- C.stroke -- XXX Debugging
      -- C.newPath -- XXX Debugging
      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 a b. (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 -- non-uniform scale
    PangoLayout
layout <- String -> Render PangoLayout
forall string. GlibString string => string -> Render PangoLayout
P.createLayout String
str
    -- set font, including size
    IO () -> Render ()
forall a. IO a -> Render a
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
    -- geometric translation
    V2 Double
ref <- IO (V2 Double) -> Render (V2 Double)
forall a. IO a -> Render a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> Render a
forall (m :: * -> *) a. Monad m => a -> m a
return PangoLayout
layout