{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE ViewPatterns          #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Backend.PGF.Render
-- Copyright   :  (c) 2015 Christopher Chalmers
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- This is an internal module exposing internals for rendering a
-- diagram. This is for advanced use only. 'Diagrams.Backend.PGF'
-- has enough for general use.
--
module Diagrams.Backend.PGF.Render
  ( PGF (..)
  , Options (..)
  , Render (..)

  -- * Lenses
  , surface
  , sizeSpec
  , readable
  , standalone

  -- * Utilities
  , escapeString
  ) where

import           Control.Monad                (when)
import           Data.ByteString.Builder

import qualified Data.Foldable                as F (foldMap)
import           Data.Functor
import           Data.Hashable                (Hashable (..))
import           Data.Tree                    (Tree (Node))

import           Diagrams.Core.Types
import           Diagrams.Prelude             hiding ((<~))

import           Data.Typeable
import           Diagrams.Backend.PGF.Hbox    (Hbox (..))
import           Diagrams.Backend.PGF.Surface (Surface)
import           Diagrams.TwoD.Adjust         (adjustDia2D)
import           Diagrams.TwoD.Path
import           Diagrams.TwoD.Text           (Text (..), TextAlignment (..),
                                               getFontSize, getFontSlant,
                                               getFontWeight)
import qualified Graphics.Rendering.PGF       as P

import           Prelude

-- | This data declaration is simply used as a token to distinguish
--   this rendering engine.
data PGF = PGF
  deriving (Int -> PGF -> ShowS
[PGF] -> ShowS
PGF -> String
(Int -> PGF -> ShowS)
-> (PGF -> String) -> ([PGF] -> ShowS) -> Show PGF
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGF] -> ShowS
$cshowList :: [PGF] -> ShowS
show :: PGF -> String
$cshow :: PGF -> String
showsPrec :: Int -> PGF -> ShowS
$cshowsPrec :: Int -> PGF -> ShowS
Show, Typeable)

type instance V PGF = V2
type instance N PGF = Double

instance TypeableFloat n => Backend PGF V2 n where
  newtype Render  PGF V2 n = R (P.Render n)
  type    Result  PGF V2 n = Builder
  data    Options PGF V2 n = PGFOptions
    { Options PGF V2 n -> Surface
_surface    :: Surface       -- ^ Surface you want to use.
    , Options PGF V2 n -> SizeSpec V2 n
_sizeSpec   :: SizeSpec V2 n -- ^ The requested size.
    , Options PGF V2 n -> Bool
_readable   :: Bool          -- ^ Indented lines for @.tex@ output.
    , Options PGF V2 n -> Bool
_standalone :: Bool          -- ^ Should @.tex@ output be standalone.
    }
    deriving Options PGF V2 n -> Options PGF V2 n -> Bool
(Options PGF V2 n -> Options PGF V2 n -> Bool)
-> (Options PGF V2 n -> Options PGF V2 n -> Bool)
-> Eq (Options PGF V2 n)
forall n. Eq n => Options PGF V2 n -> Options PGF V2 n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Options PGF V2 n -> Options PGF V2 n -> Bool
$c/= :: forall n. Eq n => Options PGF V2 n -> Options PGF V2 n -> Bool
== :: Options PGF V2 n -> Options PGF V2 n -> Bool
$c== :: forall n. Eq n => Options PGF V2 n -> Options PGF V2 n -> Bool
Eq

  renderRTree :: PGF
-> Options PGF V2 n -> RTree PGF V2 n Annotation -> Result PGF V2 n
renderRTree PGF
_ Options PGF V2 n
ops (RTree PGF V2 n Annotation -> Render PGF V2 n
forall n.
TypeableFloat n =>
RTree PGF V2 n Annotation -> Render PGF V2 n
toRender -> R r) =
    Surface -> Bool -> Bool -> V2 n -> Render n -> Builder
forall n.
(RealFloat n, Typeable n) =>
Surface -> Bool -> Bool -> V2 n -> Render n -> Builder
P.renderWith (Options PGF V2 n
opsOptions PGF V2 n
-> Getting Surface (Options PGF V2 n) Surface -> Surface
forall s a. s -> Getting a s a -> a
^.Getting Surface (Options PGF V2 n) Surface
forall n. Lens' (Options PGF V2 n) Surface
surface) (Options PGF V2 n
opsOptions PGF V2 n -> Getting Bool (Options PGF V2 n) Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool (Options PGF V2 n) Bool
forall n. Lens' (Options PGF V2 n) Bool
readable) (Options PGF V2 n
opsOptions PGF V2 n -> Getting Bool (Options PGF V2 n) Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool (Options PGF V2 n) Bool
forall n. Lens' (Options PGF V2 n) Bool
standalone) V2 n
bounds Render n
r
      where
        bounds :: V2 n
bounds = n -> SizeSpec V2 n -> V2 n
forall (v :: * -> *) n.
(Foldable v, Functor v, Num n, Ord n) =>
n -> SizeSpec v n -> v n
specToSize n
100 (Options PGF V2 n
opsOptions PGF V2 n
-> Getting (SizeSpec V2 n) (Options PGF V2 n) (SizeSpec V2 n)
-> SizeSpec V2 n
forall s a. s -> Getting a s a -> a
^.Getting (SizeSpec V2 n) (Options PGF V2 n) (SizeSpec V2 n)
forall n. Lens' (Options PGF V2 n) (SizeSpec V2 n)
sizeSpec)

  adjustDia :: PGF
-> Options PGF V2 n
-> QDiagram PGF V2 n m
-> (Options PGF V2 n, Transformation V2 n, QDiagram PGF V2 n m)
adjustDia = Lens' (Options PGF V2 n) (SizeSpec V2 n)
-> PGF
-> Options PGF V2 n
-> QDiagram PGF V2 n m
-> (Options PGF V2 n, Transformation V2 n, QDiagram PGF V2 n 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 forall n. Lens' (Options PGF V2 n) (SizeSpec V2 n)
Lens' (Options PGF V2 n) (SizeSpec V2 n)
sizeSpec

toRender :: TypeableFloat n => RTree PGF V2 n Annotation -> Render PGF V2 n
toRender :: RTree PGF V2 n Annotation -> Render PGF V2 n
toRender (Node RNode PGF V2 n Annotation
n Forest (RNode PGF V2 n Annotation)
rs) = case RNode PGF V2 n Annotation
n of
  RPrim Prim PGF V2 n
p                 -> PGF
-> Prim PGF V2 n
-> Render PGF (V (Prim PGF V2 n)) (N (Prim PGF V2 n))
forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
render PGF
PGF Prim PGF V2 n
p
  RStyle Style V2 n
sty'             -> Render n -> Render PGF V2 n
forall n. Render n -> Render PGF V2 n
R (Render n -> Render PGF V2 n) -> Render n -> Render PGF V2 n
forall a b. (a -> b) -> a -> b
$ do
    Style V2 n
sty <- (Style V2 n -> (Style V2 n, Style V2 n))
-> RenderState n -> (Style V2 n, RenderState n)
forall n. Lens' (RenderState n) (Style V2 n)
P.style ((Style V2 n -> (Style V2 n, Style V2 n))
 -> RenderState n -> (Style V2 n, RenderState n))
-> Style V2 n
-> RWST RenderInfo Builder (RenderState n) Identity (Style V2 n)
forall s (m :: * -> *) r.
(MonadState s m, Semigroup r) =>
LensLike' ((,) r) s r -> r -> m r
<<<>= Style V2 n
sty'        -- mappend old style
    [Path V2 n]
clips <- Getting [Path V2 n] (RenderState n) [Path V2 n]
-> RWST RenderInfo Builder (RenderState n) Identity [Path V2 n]
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((Style V2 n -> Const [Path V2 n] (Style V2 n))
-> RenderState n -> Const [Path V2 n] (RenderState n)
forall n. Lens' (RenderState n) (Style V2 n)
P.style ((Style V2 n -> Const [Path V2 n] (Style V2 n))
 -> RenderState n -> Const [Path V2 n] (RenderState n))
-> (([Path V2 n] -> Const [Path V2 n] [Path V2 n])
    -> Style V2 n -> Const [Path V2 n] (Style V2 n))
-> Getting [Path V2 n] (RenderState n) [Path V2 n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Path V2 n] -> Const [Path V2 n] [Path V2 n])
-> Style V2 n -> Const [Path V2 n] (Style V2 n)
forall n.
(Typeable n, OrderedField n) =>
Lens' (Style V2 n) [Path V2 n]
_clip)
    [Path V2 n] -> Render n -> Render n
forall n. TypeableFloat n => [Path V2 n] -> Render n -> Render n
clip [Path V2 n]
clips Render n
r Render n -> Render n -> Render n
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ((Style V2 n -> Identity (Style V2 n))
-> RenderState n -> Identity (RenderState n)
forall n. Lens' (RenderState n) (Style V2 n)
P.style ((Style V2 n -> Identity (Style V2 n))
 -> RenderState n -> Identity (RenderState n))
-> Style V2 n -> Render n
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Style V2 n
sty) -- render then revert to old style
  RAnnot (OpacityGroup Double
x) -> Render n -> Render PGF V2 n
forall n. Render n -> Render PGF V2 n
R (Render n -> Render PGF V2 n) -> Render n -> Render PGF V2 n
forall a b. (a -> b) -> a -> b
$ Double -> Render n -> Render n
forall a n. RealFloat a => a -> Render n -> Render n
P.opacityGroup Double
x Render n
r
  RNode PGF V2 n Annotation
_                       -> Render n -> Render PGF V2 n
forall n. Render n -> Render PGF V2 n
R Render n
r
  where R r = (RTree PGF V2 n Annotation -> Render PGF V2 n)
-> Forest (RNode PGF V2 n Annotation) -> Render PGF V2 n
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap RTree PGF V2 n Annotation -> Render PGF V2 n
forall n.
TypeableFloat n =>
RTree PGF V2 n Annotation -> Render PGF V2 n
toRender Forest (RNode PGF V2 n Annotation)
rs

instance Fractional n => Default (Options PGF V2 n) where
  def :: Options PGF V2 n
def = PGFOptions :: forall n.
Surface -> SizeSpec V2 n -> Bool -> Bool -> Options PGF V2 n
PGFOptions
          { _surface :: Surface
_surface    = Surface
forall a. Default a => a
def
          , _sizeSpec :: SizeSpec V2 n
_sizeSpec   = SizeSpec V2 n
forall (v :: * -> *) n. (Additive v, Num n) => SizeSpec v n
absolute
          , _readable :: Bool
_readable   = Bool
True
          , _standalone :: Bool
_standalone = Bool
False
          }

instance Semigroup (Render PGF V2 n) where
  R ra <> :: Render PGF V2 n -> Render PGF V2 n -> Render PGF V2 n
<> R rb = Render n -> Render PGF V2 n
forall n. Render n -> Render PGF V2 n
R (Render n -> Render PGF V2 n) -> Render n -> Render PGF V2 n
forall a b. (a -> b) -> a -> b
$ Render n
ra Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render n
rb

instance Monoid (Render PGF V2 n) where
  mempty :: Render PGF V2 n
mempty  = Render n -> Render PGF V2 n
forall n. Render n -> Render PGF V2 n
R (Render n -> Render PGF V2 n) -> Render n -> Render PGF V2 n
forall a b. (a -> b) -> a -> b
$ () -> Render n
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#if !MIN_VERSION_base(4,11,0)
  mappend = (<>)
#endif

-- | Lens onto the surface used to render.
surface :: Lens' (Options PGF V2 n) Surface
surface :: (Surface -> f Surface) -> Options PGF V2 n -> f (Options PGF V2 n)
surface = (Options PGF V2 n -> Surface)
-> (Options PGF V2 n -> Surface -> Options PGF V2 n)
-> Lens (Options PGF V2 n) (Options PGF V2 n) Surface Surface
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Options PGF V2 n -> Surface
forall n. Options PGF V2 n -> Surface
_surface (\Options PGF V2 n
o Surface
s -> Options PGF V2 n
R:OptionsPGFV2n n
o {_surface :: Surface
_surface = Surface
s})

-- | Lens onto whether a standalone TeX document should be produced.
standalone :: Lens' (Options PGF V2 n) Bool
standalone :: (Bool -> f Bool) -> Options PGF V2 n -> f (Options PGF V2 n)
standalone = (Options PGF V2 n -> Bool)
-> (Options PGF V2 n -> Bool -> Options PGF V2 n)
-> Lens (Options PGF V2 n) (Options PGF V2 n) Bool Bool
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Options PGF V2 n -> Bool
forall n. Options PGF V2 n -> Bool
_standalone (\Options PGF V2 n
o Bool
s -> Options PGF V2 n
R:OptionsPGFV2n n
o {_standalone :: Bool
_standalone = Bool
s})

-- | Lens onto the 'SizeSpec2D'.
sizeSpec :: Lens' (Options PGF V2 n) (SizeSpec V2 n)
sizeSpec :: (SizeSpec V2 n -> f (SizeSpec V2 n))
-> Options PGF V2 n -> f (Options PGF V2 n)
sizeSpec = (Options PGF V2 n -> SizeSpec V2 n)
-> (Options PGF V2 n -> SizeSpec V2 n -> Options PGF V2 n)
-> Lens
     (Options PGF V2 n)
     (Options PGF V2 n)
     (SizeSpec V2 n)
     (SizeSpec V2 n)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Options PGF V2 n -> SizeSpec V2 n
forall n. Options PGF V2 n -> SizeSpec V2 n
_sizeSpec (\Options PGF V2 n
o SizeSpec V2 n
s -> Options PGF V2 n
R:OptionsPGFV2n n
o {_sizeSpec :: SizeSpec V2 n
_sizeSpec = SizeSpec V2 n
s})

-- | Lens onto whether the lines of the TeX output are indented.
readable :: Lens' (Options PGF V2 n) Bool
readable :: (Bool -> f Bool) -> Options PGF V2 n -> f (Options PGF V2 n)
readable = (Options PGF V2 n -> Bool)
-> (Options PGF V2 n -> Bool -> Options PGF V2 n)
-> Lens (Options PGF V2 n) (Options PGF V2 n) Bool Bool
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Options PGF V2 n -> Bool
forall n. Options PGF V2 n -> Bool
_readable (\Options PGF V2 n
o Bool
b -> Options PGF V2 n
R:OptionsPGFV2n n
o {_readable :: Bool
_readable = Bool
b})

-- helper function to easily get options and set them
(<~) :: AttributeClass a => (b -> P.Render n) -> (a -> b) -> P.Render n
b -> Render n
renderF <~ :: (b -> Render n) -> (a -> b) -> Render n
<~ a -> b
getF = do
  Maybe b
s <- LensLike' (Const (Maybe b)) (RenderState n) (Style V2 n)
-> (Style V2 n -> Maybe b)
-> RWST RenderInfo Builder (RenderState n) Identity (Maybe b)
forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses LensLike' (Const (Maybe b)) (RenderState n) (Style V2 n)
forall n. Lens' (RenderState n) (Style V2 n)
P.style ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
getF (Maybe a -> Maybe b)
-> (Style V2 n -> Maybe a) -> Style V2 n -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style V2 n -> Maybe a
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr)
  Render n -> (b -> Render n) -> Maybe b -> Render n
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Render n
forall (m :: * -> *) a. Monad m => a -> m a
return ()) b -> Render n
renderF Maybe b
s

infixr 2 <~

-- | Fade a colour with the opacity from the style.
fade :: Color c => Getting (Endo (Endo Double)) (Style V2 n) Double -> c -> P.RenderM n (AlphaColour Double)
fade :: Getting (Endo (Endo Double)) (Style V2 n) Double
-> c -> RenderM n (AlphaColour Double)
fade Getting (Endo (Endo Double)) (Style V2 n) Double
g c
c = Getting (Style V2 n) (RenderState n) (Style V2 n)
-> RWST RenderInfo Builder (RenderState n) Identity (Style V2 n)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Style V2 n) (RenderState n) (Style V2 n)
forall n. Lens' (RenderState n) (Style V2 n)
P.style RWST RenderInfo Builder (RenderState n) Identity (Style V2 n)
-> (Style V2 n -> AlphaColour Double)
-> RenderM n (AlphaColour Double)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Style V2 n
s ->
  Double -> AlphaColour Double -> AlphaColour Double
forall a. Num a => a -> AlphaColour a -> AlphaColour a
dissolve (Getting (Endo (Endo Double)) (Style V2 n) Double
-> Style V2 n -> Double
forall a s. Num a => Getting (Endo (Endo a)) s a -> s -> a
productOf (Getting (Endo (Endo Double)) (Style V2 n) Double
forall (v :: * -> *) n. Lens' (Style v n) Double
_opacity Getting (Endo (Endo Double)) (Style V2 n) Double
-> Getting (Endo (Endo Double)) (Style V2 n) Double
-> Getting (Endo (Endo Double)) (Style V2 n) Double
forall a. Semigroup a => a -> a -> a
<> Getting (Endo (Endo Double)) (Style V2 n) Double
g) Style V2 n
s) (c -> AlphaColour Double
forall c. Color c => c -> AlphaColour Double
toAlphaColour c
c)

-- The Path is necessary so we can clip/workout gradients.
setFillTexture :: RealFloat n => Path V2 n -> Texture n -> P.Render n
setFillTexture :: Path V2 n -> Texture n -> Render n
setFillTexture Path V2 n
p Texture n
t = case Texture n
t of
  SC (SomeColor c
c) -> Getting (Endo (Endo Double)) (Style V2 n) Double
-> c -> RenderM n (AlphaColour Double)
forall c n.
Color c =>
Getting (Endo (Endo Double)) (Style V2 n) Double
-> c -> RenderM n (AlphaColour Double)
fade Getting (Endo (Endo Double)) (Style V2 n) Double
forall (v :: * -> *) n. Lens' (Style v n) Double
_fillOpacity c
c RenderM n (AlphaColour Double)
-> (AlphaColour Double -> Render n) -> Render n
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AlphaColour Double -> Render n
forall c n. Color c => c -> Render n
P.setFillColor
  LG LGradient n
g             -> Path V2 n -> LGradient n -> Render n
forall n. RealFloat n => Path V2 n -> LGradient n -> Render n
P.linearGradient Path V2 n
p LGradient n
g
  RG RGradient n
g             -> Path V2 n -> RGradient n -> Render n
forall n. RealFloat n => Path V2 n -> RGradient n -> Render n
P.radialGradient Path V2 n
p RGradient n
g

setLineTexture :: RealFloat n => Texture n -> P.Render n
setLineTexture :: Texture n -> Render n
setLineTexture (SC (SomeColor c
c)) = Getting (Endo (Endo Double)) (Style V2 n) Double
-> c -> RenderM n (AlphaColour Double)
forall c n.
Color c =>
Getting (Endo (Endo Double)) (Style V2 n) Double
-> c -> RenderM n (AlphaColour Double)
fade Getting (Endo (Endo Double)) (Style V2 n) Double
forall (v :: * -> *) n. Lens' (Style v n) Double
_strokeOpacity c
c RenderM n (AlphaColour Double)
-> (AlphaColour Double -> Render n) -> Render n
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AlphaColour Double -> Render n
forall a c. (RealFloat a, Color c) => c -> Render a
P.setLineColor
setLineTexture Texture n
_                  = () -> Render n
forall (m :: * -> *) a. Monad m => a -> m a
return ()

clip :: TypeableFloat n => [Path V2 n] -> P.Render n -> P.Render n
clip :: [Path V2 n] -> Render n -> Render n
clip [Path V2 n]
paths Render n
r = [Path V2 n] -> Render n
go [Path V2 n]
paths
  where
    go :: [Path V2 n] -> Render n
go []     = Render n
r
    go (Path V2 n
p:[Path V2 n]
ps) = Render n -> Render n
forall n. Render n -> Render n
P.scope (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ Path V2 n -> Render n
forall n. RealFloat n => Path V2 n -> Render n
P.path Path V2 n
p Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render n
forall n. Render n
P.clip Render n -> Render n -> Render n
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Path V2 n] -> Render n
go [Path V2 n]
ps

-- | Escapes some common characters in a string. Note that this does not
--   mean the string can't create an error; it merely escapes common
--   characters.
escapeString :: String -> String
escapeString :: ShowS
escapeString = (Char -> String) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escapeChar
  where
    escapeChar :: Char -> String
escapeChar Char
ch = case Char
ch of
      Char
'$' -> String
"\\$"
      Char
'%' -> String
"\\letterpercent{}"
      Char
'&' -> String
"\\&"
      Char
'#' -> String
"\\#"
      Char
'_' -> String
"\\_"
      Char
'{' -> String
"$\\{$"
      Char
'}' -> String
"$\\}$"
      Char
'\\'-> String
"$\\backslash{}$"
      Char
'~' -> String
"\\~{}"
      Char
'^' -> String
"\\^{}"
      Char
'[' -> String
"{[}"
      Char
']' -> String
"{]}"
      Char
x   -> [Char
x]

-- Renderable instances ------------------------------------------------

instance TypeableFloat n => Renderable (Path V2 n) PGF where
  render :: PGF -> Path V2 n -> Render PGF (V (Path V2 n)) (N (Path V2 n))
render PGF
_ Path V2 n
path = Render n -> Render PGF V2 n
forall n. Render n -> Render PGF V2 n
R (Render n -> Render PGF V2 n)
-> (Render n -> Render n) -> Render n -> Render PGF V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render n -> Render n
forall n. Render n -> Render n
P.scope (Render n -> Render PGF V2 n) -> Render n -> Render PGF V2 n
forall a b. (a -> b) -> a -> b
$ do
    -- lines and loops are separated when stroking so we only need to
    -- check the first one
    let canFill :: Bool
canFill = Getting Any (Path V2 n) (Trail V2 n)
-> (Trail V2 n -> Bool) -> Path V2 n -> Bool
forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
noneOf ((Located (Trail V2 n) -> Const Any (Located (Trail V2 n)))
-> Path V2 n -> Const Any (Path V2 n)
forall s a. Cons s s a a => Traversal' s a
_head ((Located (Trail V2 n) -> Const Any (Located (Trail V2 n)))
 -> Path V2 n -> Const Any (Path V2 n))
-> ((Trail V2 n -> Const Any (Trail V2 n))
    -> Located (Trail V2 n) -> Const Any (Located (Trail V2 n)))
-> Getting Any (Path V2 n) (Trail V2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Trail V2 n -> Const Any (Trail V2 n))
-> Located (Trail V2 n) -> Const Any (Located (Trail V2 n))
forall a b. SameSpace a b => Lens (Located a) (Located b) a b
located) Trail V2 n -> Bool
forall (v :: * -> *) n. Trail v n -> Bool
isLine Path V2 n
path
    -- solid colours need to be filled with usePath
    Bool
doFill <- if Bool
canFill
      then do
        Maybe (Texture n)
mFillTexture <- Getting (First (Texture n)) (RenderState n) (Texture n)
-> RWST
     RenderInfo Builder (RenderState n) Identity (Maybe (Texture n))
forall s (m :: * -> *) a.
MonadState s m =>
Getting (First a) s a -> m (Maybe a)
preuse ((Style V2 n -> Const (First (Texture n)) (Style V2 n))
-> RenderState n -> Const (First (Texture n)) (RenderState n)
forall n. Lens' (RenderState n) (Style V2 n)
P.style ((Style V2 n -> Const (First (Texture n)) (Style V2 n))
 -> RenderState n -> Const (First (Texture n)) (RenderState n))
-> ((Texture n -> Const (First (Texture n)) (Texture n))
    -> Style V2 n -> Const (First (Texture n)) (Style V2 n))
-> Getting (First (Texture n)) (RenderState n) (Texture n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Texture n -> Const (First (Texture n)) (Texture n))
-> Style V2 n -> Const (First (Texture n)) (Style V2 n)
forall n.
(Typeable n, Floating n) =>
Lens' (Style V2 n) (Texture n)
_fillTexture)
        case Maybe (Texture n)
mFillTexture of
          Maybe (Texture n)
Nothing -> Bool -> RWST RenderInfo Builder (RenderState n) Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          Just Texture n
t  -> do
            Path V2 n -> Texture n -> Render n
forall n. RealFloat n => Path V2 n -> Texture n -> Render n
setFillTexture Path V2 n
path Texture n
t
            FillRule -> Render n
forall n. FillRule -> Render n
P.setFillRule (FillRule -> Render n) -> (FillRule -> FillRule) -> Render n
forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ FillRule -> FillRule
getFillRule
            Bool -> RWST RenderInfo Builder (RenderState n) Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Getting Any (Texture n) SomeColor -> Texture n -> Bool
forall s a. Getting Any s a -> s -> Bool
has Getting Any (Texture n) SomeColor
forall n. Prism' (Texture n) SomeColor
_SC Texture n
t)
      else Bool -> RWST RenderInfo Builder (RenderState n) Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    --
    n
w <- Getting n (RenderState n) n
-> RWST RenderInfo Builder (RenderState n) Identity n
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((Style V2 n -> Const n (Style V2 n))
-> RenderState n -> Const n (RenderState n)
forall n. Lens' (RenderState n) (Style V2 n)
P.style ((Style V2 n -> Const n (Style V2 n))
 -> RenderState n -> Const n (RenderState n))
-> ((n -> Const n n) -> Style V2 n -> Const n (Style V2 n))
-> Getting n (RenderState n) n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe n -> Const n (Maybe n))
-> Style V2 n -> Const n (Style V2 n)
forall n (v :: * -> *). Typeable n => Lens' (Style v n) (Maybe n)
_lineWidthU ((Maybe n -> Const n (Maybe n))
 -> Style V2 n -> Const n (Style V2 n))
-> ((n -> Const n n) -> Maybe n -> Const n (Maybe n))
-> (n -> Const n n)
-> Style V2 n
-> Const n (Style V2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Iso' (Maybe n) n
forall a. Eq a => a -> Iso' (Maybe a) a
non n
0)
    let doStroke :: Bool
doStroke = n
w n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0.0001
    Bool -> Render n -> Render n
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doStroke (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
      n -> Render n
forall n. RealFloat n => n -> Render n
P.setLineWidth n
w
      Texture n -> Render n
forall n. RealFloat n => Texture n -> Render n
setLineTexture (Texture n -> Render n) -> (LineTexture n -> Texture n) -> Render n
forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ LineTexture n -> Texture n
forall n. LineTexture n -> Texture n
getLineTexture
      LineJoin -> Render n
forall n. LineJoin -> Render n
P.setLineJoin  (LineJoin -> Render n) -> (LineJoin -> LineJoin) -> Render n
forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ LineJoin -> LineJoin
getLineJoin
      LineCap -> Render n
forall n. LineCap -> Render n
P.setLineCap   (LineCap -> Render n) -> (LineCap -> LineCap) -> Render n
forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ LineCap -> LineCap
getLineCap
      Dashing n -> Render n
forall n. RealFloat n => Dashing n -> Render n
P.setDash      (Dashing n -> Render n) -> (Dashing n -> Dashing n) -> Render n
forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ Dashing n -> Dashing n
forall n. Dashing n -> Dashing n
getDashing
    --
    Path V2 n -> Render n
forall n. RealFloat n => Path V2 n -> Render n
P.path Path V2 n
path
    Bool -> Bool -> Render n
forall n. Bool -> Bool -> Render n
P.usePath Bool
doFill Bool
doStroke

-- | Does not support full alignment. Text is not escaped.
instance TypeableFloat n => Renderable (Text n) PGF where
  render :: PGF -> Text n -> Render PGF (V (Text n)) (N (Text n))
render PGF
_ (Text T2 n
tt TextAlignment n
txtAlign String
str) = Render n -> Render PGF V2 n
forall n. Render n -> Render PGF V2 n
R (Render n -> Render PGF V2 n)
-> (Render n -> Render n) -> Render n -> Render PGF V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render n -> Render n
forall n. Render n -> Render n
P.scope (Render n -> Render PGF V2 n) -> Render n -> Render PGF V2 n
forall a b. (a -> b) -> a -> b
$ do
    Path V2 n -> Texture n -> Render n
forall n. RealFloat n => Path V2 n -> Texture n -> Render n
setFillTexture Path V2 n
forall a. Monoid a => a
mempty (Texture n -> Render n) -> (FillTexture n -> Texture n) -> Render n
forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ FillTexture n -> Texture n
forall n. FillTexture n -> Texture n
getFillTexture
    --
    T2 n -> Render n
forall n. RealFloat n => Transformation V2 n -> Render n
P.applyTransform T2 n
tt
    (n -> Render n
forall n. RealFloat n => n -> Render n
P.applyScale (n -> Render n) -> (n -> n) -> n -> Render n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> n -> n
forall a. Fractional a => a -> a -> a
/n
8)) (n -> Render n) -> (FontSize n -> n) -> Render n
forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ FontSize n -> n
forall n. FontSize n -> n
getFontSize
        -- (/8) was obtained from trail and error
    --
    [Render n] -> Render n -> Render n
forall n. [Render n] -> Render n -> Render n
P.renderText (TextAlignment n -> [Render n]
forall n. RealFloat n => TextAlignment n -> [Render n]
P.setTextAlign TextAlignment n
txtAlign) (Render n -> Render n) -> Render n -> Render n
forall a b. (a -> b) -> a -> b
$ do
      FontWeight -> Render n
forall n. FontWeight -> Render n
P.setFontWeight (FontWeight -> Render n) -> (FontWeight -> FontWeight) -> Render n
forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ FontWeight -> FontWeight
getFontWeight
      FontSlant -> Render n
forall n. FontSlant -> Render n
P.setFontSlant  (FontSlant -> Render n) -> (FontSlant -> FontSlant) -> Render n
forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ FontSlant -> FontSlant
getFontSlant
      String -> Render n
forall n. String -> Render n
P.rawString String
str

instance TypeableFloat n => Renderable (Hbox n) PGF where
  render :: PGF -> Hbox n -> Render PGF (V (Hbox n)) (N (Hbox n))
render PGF
_ (Hbox Transformation V2 n
tt String
str) = Render n -> Render PGF V2 n
forall n. Render n -> Render PGF V2 n
R (Render n -> Render PGF V2 n)
-> (Render n -> Render n) -> Render n -> Render PGF V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Render n -> Render n
forall n. Render n -> Render n
P.scope (Render n -> Render PGF V2 n) -> Render n -> Render PGF V2 n
forall a b. (a -> b) -> a -> b
$ do
    Transformation V2 n -> Render n
forall n. RealFloat n => Transformation V2 n -> Render n
P.applyTransform Transformation V2 n
tt
    [Render n] -> Render n -> Render n
forall n. [Render n] -> Render n -> Render n
P.renderText (TextAlignment n -> [Render n]
forall n. RealFloat n => TextAlignment n -> [Render n]
P.setTextAlign TextAlignment n
forall n. TextAlignment n
BaselineText) (String -> Render n
forall n. String -> Render n
P.rawString String
str)

-- | Supported: @.pdf@, @.jpg@, @.png@.
instance RealFloat n => Renderable (DImage n External) PGF where
  render :: PGF
-> DImage n External
-> Render PGF (V (DImage n External)) (N (DImage n External))
render PGF
_  = Render n -> Render PGF V2 n
forall n. Render n -> Render PGF V2 n
R (Render n -> Render PGF V2 n)
-> (DImage n External -> Render n)
-> DImage n External
-> Render PGF V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DImage n External -> Render n
forall n. RealFloat n => DImage n External -> Render n
P.image

-- | Supported: 'ImageRGB8'. (Other types from 'DynamicImage' will
--   error)
instance RealFloat n => Renderable (DImage n Embedded) PGF where
  render :: PGF
-> DImage n Embedded
-> Render PGF (V (DImage n Embedded)) (N (DImage n Embedded))
render PGF
_  = Render n -> Render PGF V2 n
forall n. Render n -> Render PGF V2 n
R (Render n -> Render PGF V2 n)
-> (DImage n Embedded -> Render n)
-> DImage n Embedded
-> Render PGF V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DImage n Embedded -> Render n
forall n. RealFloat n => DImage n Embedded -> Render n
P.embeddedImage

------------------------------------------------------------------------
-- Hashable instances

instance Hashable n => Hashable (Options PGF V2 n) where
  hashWithSalt :: Int -> Options PGF V2 n -> Int
hashWithSalt Int
s (PGFOptions sf sz rd st)
    = Int
s  Int -> Surface -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
      Surface
sf Int -> SizeSpec V2 n -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
      SizeSpec V2 n
sz Int -> Bool -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
      Bool
rd Int -> Bool -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
      Bool
st