{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Diagrams.Backend.PGF.Render
( PGF (..)
, Options (..)
, Render (..)
, surface
, sizeSpec
, readable
, standalone
, 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
data PGF = PGF
deriving (Int -> PGF -> ShowS
[PGF] -> ShowS
PGF -> String
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
{ forall n. Options PGF V2 n -> Surface
_surface :: Surface
, forall n. Options PGF V2 n -> SizeSpec V2 n
_sizeSpec :: SizeSpec V2 n
, forall n. Options PGF V2 n -> Bool
_readable :: Bool
, forall n. Options PGF V2 n -> Bool
_standalone :: Bool
}
deriving Options PGF V2 n -> Options PGF V2 n -> Bool
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 (forall n.
TypeableFloat n =>
RTree PGF V2 n Annotation -> Render PGF V2 n
toRender -> R Render n
r) =
forall n.
(RealFloat n, Typeable n) =>
Surface -> Bool -> Bool -> V2 n -> Render n -> Builder
P.renderWith (Options PGF V2 n
opsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Options PGF V2 n) Surface
surface) (Options PGF V2 n
opsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Options PGF V2 n) Bool
readable) (Options PGF V2 n
opsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Options PGF V2 n) Bool
standalone) V2 n
bounds Render n
r
where
bounds :: V2 n
bounds = forall (v :: * -> *) n.
(Foldable v, Functor v, Num n, Ord n) =>
n -> SizeSpec v n -> v n
specToSize n
100 (Options PGF V2 n
opsforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Options PGF V2 n) (SizeSpec V2 n)
sizeSpec)
adjustDia :: forall m.
(Additive V2, Monoid' m, Num n) =>
PGF
-> Options PGF V2 n
-> QDiagram PGF V2 n m
-> (Options PGF V2 n, Transformation V2 n, QDiagram PGF V2 n m)
adjustDia = 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)
sizeSpec
toRender :: TypeableFloat n => RTree PGF V2 n Annotation -> Render PGF V2 n
toRender :: forall n.
TypeableFloat n =>
RTree PGF V2 n Annotation -> Render PGF V2 n
toRender (Node RNode PGF V2 n Annotation
n [Tree (RNode PGF V2 n Annotation)]
rs) = case RNode PGF V2 n Annotation
n of
RPrim Prim PGF V2 n
p -> 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' -> forall n. Render n -> Render PGF V2 n
R forall a b. (a -> b) -> a -> b
$ do
Style V2 n
sty <- forall n. Lens' (RenderState n) (Style V2 n)
P.style forall s (m :: * -> *) r.
(MonadState s m, Semigroup r) =>
LensLike' ((,) r) s r -> r -> m r
<<<>= Style V2 n
sty'
[Path V2 n]
clips <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (forall n. Lens' (RenderState n) (Style V2 n)
P.style forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n.
(Typeable n, OrderedField n) =>
Lens' (Style V2 n) [Path V2 n]
_clip)
forall n. TypeableFloat n => [Path V2 n] -> Render n -> Render n
clip [Path V2 n]
clips Render n
r forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (forall n. Lens' (RenderState n) (Style V2 n)
P.style forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Style V2 n
sty)
RAnnot (OpacityGroup Double
x) -> forall n. Render n -> Render PGF V2 n
R forall a b. (a -> b) -> a -> b
$ forall a n. RealFloat a => a -> Render n -> Render n
P.opacityGroup Double
x Render n
r
RNode PGF V2 n Annotation
_ -> forall n. Render n -> Render PGF V2 n
R Render n
r
where R Render n
r = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap forall n.
TypeableFloat n =>
RTree PGF V2 n Annotation -> Render PGF V2 n
toRender [Tree (RNode PGF V2 n Annotation)]
rs
instance Fractional n => Default (Options PGF V2 n) where
def :: Options PGF V2 n
def = PGFOptions
{ _surface :: Surface
_surface = forall a. Default a => a
def
, _sizeSpec :: SizeSpec V2 n
_sizeSpec = 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 Render n
ra <> :: Render PGF V2 n -> Render PGF V2 n -> Render PGF V2 n
<> R Render n
rb = forall n. Render n -> Render PGF V2 n
R forall a b. (a -> b) -> a -> b
$ Render n
ra 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 = forall n. Render n -> Render PGF V2 n
R forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
#if !MIN_VERSION_base(4,11,0)
mappend = (<>)
#endif
surface :: Lens' (Options PGF V2 n) Surface
surface :: forall n. Lens' (Options PGF V2 n) Surface
surface = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall n. Options PGF V2 n -> Surface
_surface (\Options PGF V2 n
o Surface
s -> Options PGF V2 n
o {_surface :: Surface
_surface = Surface
s})
standalone :: Lens' (Options PGF V2 n) Bool
standalone :: forall n. Lens' (Options PGF V2 n) Bool
standalone = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall n. Options PGF V2 n -> Bool
_standalone (\Options PGF V2 n
o Bool
s -> Options PGF V2 n
o {_standalone :: Bool
_standalone = Bool
s})
sizeSpec :: Lens' (Options PGF V2 n) (SizeSpec V2 n)
sizeSpec :: forall n. Lens' (Options PGF V2 n) (SizeSpec V2 n)
sizeSpec = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall n. Options PGF V2 n -> SizeSpec V2 n
_sizeSpec (\Options PGF V2 n
o SizeSpec V2 n
s -> Options PGF V2 n
o {_sizeSpec :: SizeSpec V2 n
_sizeSpec = SizeSpec V2 n
s})
readable :: Lens' (Options PGF V2 n) Bool
readable :: forall n. Lens' (Options PGF V2 n) Bool
readable = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall n. Options PGF V2 n -> Bool
_readable (\Options PGF V2 n
o Bool
b -> Options PGF V2 n
o {_readable :: Bool
_readable = Bool
b})
(<~) :: AttributeClass a => (b -> P.Render n) -> (a -> b) -> P.Render n
b -> Render n
renderF <~ :: forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ a -> b
getF = do
Maybe b
s <- forall s (m :: * -> *) r a.
MonadState s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
uses forall n. Lens' (RenderState n) (Style V2 n)
P.style (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
getF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) b -> Render n
renderF Maybe b
s
infixr 2 <~
fade :: Color c => Getting (Endo (Endo Double)) (Style V2 n) Double -> c -> P.RenderM n (AlphaColour Double)
fade :: 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
g c
c = forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall n. Lens' (RenderState n) (Style V2 n)
P.style forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Style V2 n
s ->
forall a. Num a => a -> AlphaColour a -> AlphaColour a
dissolve (forall a s. Num a => Getting (Endo (Endo a)) s a -> s -> a
productOf (forall (v :: * -> *) n. Lens' (Style v n) Double
_opacity forall a. Semigroup a => a -> a -> a
<> Getting (Endo (Endo Double)) (Style V2 n) Double
g) Style V2 n
s) (forall c. Color c => c -> AlphaColour Double
toAlphaColour c
c)
setFillTexture :: RealFloat n => Path V2 n -> Texture n -> P.Render n
setFillTexture :: forall n. RealFloat n => Path V2 n -> Texture n -> Render n
setFillTexture Path V2 n
p Texture n
t = case Texture n
t of
SC (SomeColor c
c) -> forall c n.
Color c =>
Getting (Endo (Endo Double)) (Style V2 n) Double
-> c -> RenderM n (AlphaColour Double)
fade forall (v :: * -> *) n. Lens' (Style v n) Double
_fillOpacity c
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall c n. Color c => c -> Render n
P.setFillColor
LG LGradient n
g -> forall n. RealFloat n => Path V2 n -> LGradient n -> Render n
P.linearGradient Path V2 n
p LGradient n
g
RG RGradient n
g -> 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 :: forall n. RealFloat n => Texture n -> Render n
setLineTexture (SC (SomeColor c
c)) = forall c n.
Color c =>
Getting (Endo (Endo Double)) (Style V2 n) Double
-> c -> RenderM n (AlphaColour Double)
fade forall (v :: * -> *) n. Lens' (Style v n) Double
_strokeOpacity c
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c. (RealFloat a, Color c) => c -> Render a
P.setLineColor
setLineTexture Texture n
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
clip :: TypeableFloat n => [Path V2 n] -> P.Render n -> P.Render n
clip :: forall n. TypeableFloat n => [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) = forall n. Render n -> Render n
P.scope forall a b. (a -> b) -> a -> b
$ forall n. RealFloat n => Path V2 n -> Render n
P.path Path V2 n
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall n. Render n
P.clip forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Path V2 n] -> Render n
go [Path V2 n]
ps
escapeString :: String -> String
escapeString :: ShowS
escapeString = 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]
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 = forall n. Render n -> Render PGF V2 n
R forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Render n -> Render n
P.scope forall a b. (a -> b) -> a -> b
$ do
let canFill :: Bool
canFill = forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
noneOf (forall s a. Cons s s a a => Traversal' s a
_head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. SameSpace a b => Lens (Located a) (Located b) a b
located) forall (v :: * -> *) n. Trail v n -> Bool
isLine Path V2 n
path
Bool
doFill <- if Bool
canFill
then do
Maybe (Texture n)
mFillTexture <- forall s (m :: * -> *) a.
MonadState s m =>
Getting (First a) s a -> m (Maybe a)
preuse (forall n. Lens' (RenderState n) (Style V2 n)
P.style forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n.
(Typeable n, Floating n) =>
Lens' (Style V2 n) (Texture n)
_fillTexture)
case Maybe (Texture n)
mFillTexture of
Maybe (Texture n)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just Texture n
t -> do
forall n. RealFloat n => Path V2 n -> Texture n -> Render n
setFillTexture Path V2 n
path Texture n
t
forall n. FillRule -> Render n
P.setFillRule forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ FillRule -> FillRule
getFillRule
forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. Getting Any s a -> s -> Bool
has forall n. Prism' (Texture n) SomeColor
_SC Texture n
t)
else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
n
w <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (forall n. Lens' (RenderState n) (Style V2 n)
P.style forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n (v :: * -> *). Typeable n => Lens' (Style v n) (Maybe n)
_lineWidthU forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> Iso' (Maybe a) a
non n
0)
let doStroke :: Bool
doStroke = n
w forall a. Ord a => a -> a -> Bool
> n
0.0001
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doStroke forall a b. (a -> b) -> a -> b
$ do
forall n. RealFloat n => n -> Render n
P.setLineWidth n
w
forall n. RealFloat n => Texture n -> Render n
setLineTexture forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ forall n. LineTexture n -> Texture n
getLineTexture
forall n. LineJoin -> Render n
P.setLineJoin forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ LineJoin -> LineJoin
getLineJoin
forall n. LineCap -> Render n
P.setLineCap forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ LineCap -> LineCap
getLineCap
forall n. RealFloat n => Dashing n -> Render n
P.setDash forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ forall n. Dashing n -> Dashing n
getDashing
forall n. RealFloat n => Path V2 n -> Render n
P.path Path V2 n
path
forall n. Bool -> Bool -> Render n
P.usePath Bool
doFill Bool
doStroke
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) = forall n. Render n -> Render PGF V2 n
R forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Render n -> Render n
P.scope forall a b. (a -> b) -> a -> b
$ do
forall n. RealFloat n => Path V2 n -> Texture n -> Render n
setFillTexture forall a. Monoid a => a
mempty forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ forall n. FillTexture n -> Texture n
getFillTexture
forall n. RealFloat n => Transformation V2 n -> Render n
P.applyTransform T2 n
tt
(forall n. RealFloat n => n -> Render n
P.applyScale forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Fractional a => a -> a -> a
/n
8)) forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ forall n. FontSize n -> n
getFontSize
forall n. [Render n] -> Render n -> Render n
P.renderText (forall n. RealFloat n => TextAlignment n -> [Render n]
P.setTextAlign TextAlignment n
txtAlign) forall a b. (a -> b) -> a -> b
$ do
forall n. FontWeight -> Render n
P.setFontWeight forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ FontWeight -> FontWeight
getFontWeight
forall n. FontSlant -> Render n
P.setFontSlant forall a b n.
AttributeClass a =>
(b -> Render n) -> (a -> b) -> Render n
<~ FontSlant -> FontSlant
getFontSlant
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) = forall n. Render n -> Render PGF V2 n
R forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Render n -> Render n
P.scope forall a b. (a -> b) -> a -> b
$ do
forall n. RealFloat n => Transformation V2 n -> Render n
P.applyTransform Transformation V2 n
tt
forall n. [Render n] -> Render n -> Render n
P.renderText (forall n. RealFloat n => TextAlignment n -> [Render n]
P.setTextAlign forall n. TextAlignment n
BaselineText) (forall n. String -> Render n
P.rawString String
str)
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
_ = forall n. Render n -> Render PGF V2 n
R forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. RealFloat n => DImage n External -> Render n
P.image
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
_ = forall n. Render n -> Render PGF V2 n
R forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. RealFloat n => DImage n Embedded -> Render n
P.embeddedImage
instance Hashable n => Hashable (Options PGF V2 n) where
hashWithSalt :: Int -> Options PGF V2 n -> Int
hashWithSalt Int
s (PGFOptions Surface
sf SizeSpec V2 n
sz Bool
rd Bool
st)
= Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
Surface
sf forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
SizeSpec V2 n
sz forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
Bool
rd forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
Bool
st