{-# LANGUAGE CPP                        #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs               #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE MultiWayIf                 #-}
{-# LANGUAGE NondecreasingIndentation   #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeSynonymInstances       #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Backend.SVG
-- Copyright   :  (c) 2011-2015 diagrams-svg team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- A full-featured rendering backend for diagrams producing SVG files,
-- implemented natively in Haskell (making it easy to use on any
-- platform).
--
-- To invoke the SVG backend, you have three options.
--
-- * You can use the "Diagrams.Backend.SVG.CmdLine" module to create
--   standalone executables which output SVG images when invoked.
--
-- * You can use the 'renderSVG' or 'renderPretty' functions provided by
--   this module, which give you more flexible programmatic control over when
--   and how images are output (making it easy to, for example, write a
--   single program that outputs multiple images, or one that outputs
--   images dynamically based on user input, and so on). The only
--   difference between the two functions is that 'renderPretty', pretty
--   prints the SVG output.
--
-- * For the most flexibility (/e.g./ if you want access to the
--   resulting SVG value directly in memory without writing it to
--   disk), you can manually invoke the 'renderDia' method from the
--   'Diagrams.Core.Types.Backend' instance for @SVG@.  In particular,
--   'Diagrams.Core.Types.renderDia' has the generic type
--
-- > renderDia :: b -> Options b v n -> QDiagram b v n m -> Result b v n
--
-- (omitting a few type class constraints).  @b@ represents the
-- backend type, @v@ the vector space, @n@ the numerical field, and @m@ the
-- type of monoidal query annotations on the diagram.  'Options' and 'Result'
-- are associated data and type families, respectively, which yield the
-- type of option records and rendering results specific to any
-- particular backend.  For @b ~ SVG@, @v ~ V2@, we have
--
-- >data    Options SVG V2 n = SVGOptions
-- >    { _size            :: SizeSpec V2 n   -- ^ The requested size.
-- >    , _svgDefinitions  :: Maybe Element
-- >                          -- ^ Custom definitions that will be added to the @defs@
-- >                          --   section of the output.
-- >    , _idPrefix        :: T.Text
-- >    , _svgAttributes   :: [Attribute]
-- >                          -- ^ Attributes to apply to the entire svg element.
-- >    , _generateDoctype :: Bool
-- >    }
--
-- @
-- data family Render SVG V2 n = R 'SvgRenderM n'
-- @
--
-- @
-- type family Result SVG V2 n = 'Element'
-- @
--
-- So the type of 'renderDia' resolves to
--
-- @
-- renderDia :: SVG -> Options SVG V2 n -> QDiagram SVG V2 n m -> 'Graphics.Rendering.SVG.Element'
-- @
--
-- which you could call like @renderDia SVG (SVGOptions (mkWidth 250)
-- Nothing "" [] True) myDiagram@ (if you have the 'OverloadedStrings' extension
-- enabled; otherwise you can use 'Text.pack ""').  (In some
-- situations GHC may not be able to infer the type @m@, in which case
-- you can use a type annotation to specify it; it may be useful to
-- simply use the type synonym @Diagram SVG = QDiagram SVG V2 Double
-- Any@.) This returns an 'Graphics.Svg.Core.Element' value, which
-- you can, /e.g./ render to a 'ByteString' using 'Graphics.Svg.Core.renderBS'
-- from the 'svg-builder' package.
--
-----------------------------------------------------------------------------

module Diagrams.Backend.SVG
  ( SVG(..) -- rendering token
  , B
    -- for rendering options specific to SVG
  , Options(..), sizeSpec, svgDefinitions, idPrefix, svgAttributes, generateDoctype
  , svgClass, svgId, svgTitle
  , SVGFloat

  , renderSVG
  , renderSVG'
  , renderPretty
  , renderPretty'
  , loadImageSVG
  ) where

-- from JuicyPixels
import           Codec.Picture            (decodeImage, encodeDynamicPng)
import           Codec.Picture.Types      (DynamicImage (ImageYCbCr8),
                                           dynamicMap, imageHeight, imageWidth)

#if __GLASGOW_HASKELL__ < 710
import           Data.Foldable            as F (foldMap)
#endif
import qualified Data.Text                as T
import           Data.Text.Lazy.IO        as LT
import           Data.Tree
import           System.FilePath

-- from base
import           Control.Monad.Reader
import           Control.Monad.State
import           Data.Char
import           Data.Function            (on)
import           Data.Typeable

-- from hashable
import           Data.Hashable            (Hashable (), hashWithSalt)

-- from bytestring
import qualified Data.ByteString          as SBS
import qualified Data.ByteString.Lazy     as BS

-- from lens
import           Control.Lens             hiding (transform, ( # ))

-- from diagrams-core
import           Diagrams.Core.Compile
import           Diagrams.Core.Types      (Annotation (..), keyVal)

-- from diagrams-lib
import           Diagrams.Prelude         hiding (Attribute, local, size, view,
                                           with)
import           Diagrams.TwoD.Adjust     (adjustDia2D)
import           Diagrams.TwoD.Attributes (FillTexture, splitTextureFills)
import           Diagrams.TwoD.Path       (Clip (Clip))
import           Diagrams.TwoD.Text

-- from svg-builder
import           Graphics.Svg             hiding ((<>))

-- from this package
import           Graphics.Rendering.SVG   (SVGFloat)
import qualified Graphics.Rendering.SVG   as R

-- | @SVG@ is simply a token used to identify this rendering backend
--   (to aid type inference).
data SVG = SVG
  deriving (Int -> SVG -> ShowS
[SVG] -> ShowS
SVG -> String
(Int -> SVG -> ShowS)
-> (SVG -> String) -> ([SVG] -> ShowS) -> Show SVG
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SVG] -> ShowS
$cshowList :: [SVG] -> ShowS
show :: SVG -> String
$cshow :: SVG -> String
showsPrec :: Int -> SVG -> ShowS
$cshowsPrec :: Int -> SVG -> ShowS
Show, Typeable)

type B = SVG

type instance V SVG = V2
type instance N SVG = Double

data Environment n = Environment
  { Environment n -> Style V2 n
_style :: Style V2 n
  , Environment n -> Text
__pre  :: T.Text
  }

makeLenses ''Environment

data SvgRenderState = SvgRenderState
  { SvgRenderState -> Int
_clipPathId :: Int
  , SvgRenderState -> Int
_fillGradId :: Int
  , SvgRenderState -> Int
_lineGradId :: Int
  }

makeLenses ''SvgRenderState

initialEnvironment :: SVGFloat n => T.Text -> Environment n
initialEnvironment :: Text -> Environment n
initialEnvironment = Style V2 n -> Text -> Environment n
forall n. Style V2 n -> Text -> Environment n
Environment (Style V2 n
forall a. Monoid a => a
mempty Style V2 n -> (Style V2 n -> Style V2 n) -> Style V2 n
forall a b. a -> (a -> b) -> b
# AlphaColour Double -> Style V2 n -> Style V2 n
forall n a c.
(InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) =>
c -> a -> a
recommendFillColor AlphaColour Double
forall a. Num a => AlphaColour a
transparent)

-- Fill gradients ids are even, line gradient ids are odd.
initialSvgRenderState :: SvgRenderState
initialSvgRenderState :: SvgRenderState
initialSvgRenderState = Int -> Int -> Int -> SvgRenderState
SvgRenderState Int
0 Int
0 Int
1

-- | Monad to keep track of environment and state when rendering an SVG.
type SvgRenderM n = ReaderT (Environment n) (State SvgRenderState) Element

runRenderM :: SVGFloat n => T.Text -> SvgRenderM n -> Element
runRenderM :: Text -> SvgRenderM n -> Element
runRenderM Text
o SvgRenderM n
s = (State SvgRenderState Element -> SvgRenderState -> Element)
-> SvgRenderState -> State SvgRenderState Element -> Element
forall a b c. (a -> b -> c) -> b -> a -> c
flip State SvgRenderState Element -> SvgRenderState -> Element
forall s a. State s a -> s -> a
evalState SvgRenderState
initialSvgRenderState
               (State SvgRenderState Element -> Element)
-> State SvgRenderState Element -> Element
forall a b. (a -> b) -> a -> b
$ SvgRenderM n -> Environment n -> State SvgRenderState Element
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT  SvgRenderM n
s (Text -> Environment n
forall n. SVGFloat n => Text -> Environment n
initialEnvironment Text
o)

instance Semigroup (Render SVG V2 n) where
  R r1 <> :: Render SVG V2 n -> Render SVG V2 n -> Render SVG V2 n
<> R r2_ = SvgRenderM n -> Render SVG V2 n
forall n. SvgRenderM n -> Render SVG V2 n
R (SvgRenderM n -> Render SVG V2 n)
-> SvgRenderM n -> Render SVG V2 n
forall a b. (a -> b) -> a -> b
$ do
    Element
svg1 <- SvgRenderM n
r1
    Element
svg2 <- SvgRenderM n
r2_
    Element -> SvgRenderM n
forall (m :: * -> *) a. Monad m => a -> m a
return (Element
svg1 Element -> Element -> Element
forall a. Monoid a => a -> a -> a
`mappend` Element
svg2)

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

-- Handle clip attributes.
--
renderSvgWithClipping :: forall n. SVGFloat n
                      => T.Text
                      -> Element       -- ^ Input SVG
                      -> Style V2 n    -- ^ Styles
                      -> SvgRenderM n  -- ^ Resulting svg

renderSvgWithClipping :: Text -> Element -> Style V2 n -> SvgRenderM n
renderSvgWithClipping Text
prefix Element
svg Style V2 n
s =
  case (Unwrapped (Clip n) -> Clip n) -> Clip n -> Unwrapped (Clip n)
forall s. Wrapped s => (Unwrapped s -> s) -> s -> Unwrapped s
op Unwrapped (Clip n) -> Clip n
forall n. [Path V2 n] -> Clip n
Clip (Clip n -> [Path V2 n]) -> Maybe (Clip n) -> Maybe [Path V2 n]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Style V2 n -> Maybe (Clip n)
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style V2 n
s of
    Maybe [Path V2 n]
Nothing    -> Element -> SvgRenderM n
forall (m :: * -> *) a. Monad m => a -> m a
return Element
svg
    Just [Path V2 n]
paths -> [Path V2 n] -> SvgRenderM n
renderClips [Path V2 n]
paths
  where
    renderClips :: [Path V2 n] -> SvgRenderM n
    renderClips :: [Path V2 n] -> SvgRenderM n
renderClips []     = Element -> SvgRenderM n
forall (m :: * -> *) a. Monad m => a -> m a
return Element
svg
    renderClips (Path V2 n
p:[Path V2 n]
ps) = do
      (Int -> Identity Int) -> SvgRenderState -> Identity SvgRenderState
Lens' SvgRenderState Int
clipPathId ((Int -> Identity Int)
 -> SvgRenderState -> Identity SvgRenderState)
-> Int -> ReaderT (Environment n) (State SvgRenderState) ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Int
1
      Int
ident <- Getting Int SvgRenderState Int
-> ReaderT (Environment n) (State SvgRenderState) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int SvgRenderState Int
Lens' SvgRenderState Int
clipPathId
      Path V2 n -> Text -> Int -> Element -> Element
forall n.
SVGFloat n =>
Path V2 n -> Text -> Int -> Element -> Element
R.renderClip Path V2 n
p Text
prefix Int
ident (Element -> Element) -> SvgRenderM n -> SvgRenderM n
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Path V2 n] -> SvgRenderM n
renderClips [Path V2 n]
ps

-- | Create a new texture defs svg element using the style and the current
--   id number, then increment the gradient id number.
fillTextureDefs :: SVGFloat n => Style v n -> SvgRenderM n
fillTextureDefs :: Style v n -> SvgRenderM n
fillTextureDefs Style v n
s = do
  Int
ident <- Getting Int SvgRenderState Int
-> ReaderT (Environment n) (State SvgRenderState) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int SvgRenderState Int
Lens' SvgRenderState Int
fillGradId
  (Int -> Identity Int) -> SvgRenderState -> Identity SvgRenderState
Lens' SvgRenderState Int
fillGradId ((Int -> Identity Int)
 -> SvgRenderState -> Identity SvgRenderState)
-> Int -> ReaderT (Environment n) (State SvgRenderState) ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Int
2 -- always even
  Element -> SvgRenderM n
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> SvgRenderM n) -> Element -> SvgRenderM n
forall a b. (a -> b) -> a -> b
$ Int -> Style v n -> Element
forall n (v :: * -> *). SVGFloat n => Int -> Style v n -> Element
R.renderFillTextureDefs Int
ident Style v n
s

lineTextureDefs :: SVGFloat n => Style v n -> SvgRenderM n
lineTextureDefs :: Style v n -> SvgRenderM n
lineTextureDefs Style v n
s = do
  Int
ident <- Getting Int SvgRenderState Int
-> ReaderT (Environment n) (State SvgRenderState) Int
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Int SvgRenderState Int
Lens' SvgRenderState Int
lineGradId
  (Int -> Identity Int) -> SvgRenderState -> Identity SvgRenderState
Lens' SvgRenderState Int
lineGradId ((Int -> Identity Int)
 -> SvgRenderState -> Identity SvgRenderState)
-> Int -> ReaderT (Environment n) (State SvgRenderState) ()
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
ASetter' s a -> a -> m ()
+= Int
2 -- always odd
  Element -> SvgRenderM n
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> SvgRenderM n) -> Element -> SvgRenderM n
forall a b. (a -> b) -> a -> b
$ Int -> Style v n -> Element
forall n (v :: * -> *). SVGFloat n => Int -> Style v n -> Element
R.renderLineTextureDefs Int
ident Style v n
s

instance SVGFloat n => Backend SVG V2 n where
  newtype Render  SVG V2 n = R (SvgRenderM n)
  type    Result  SVG V2 n = Element
  data    Options SVG V2 n = SVGOptions
    { Options SVG V2 n -> SizeSpec V2 n
_size            :: SizeSpec V2 n   -- ^ The requested size.
    , Options SVG V2 n -> Maybe Element
_svgDefinitions  :: Maybe Element
                          -- ^ Custom definitions that will be added to the @defs@
                          --   section of the output.
    , Options SVG V2 n -> Text
_idPrefix        :: T.Text
    , Options SVG V2 n -> [Attribute]
_svgAttributes   :: [Attribute]
                          -- ^ Attriubtes to apply to the entire svg element.
    , Options SVG V2 n -> Bool
_generateDoctype :: Bool
    }
    deriving Options SVG V2 n -> Options SVG V2 n -> Bool
(Options SVG V2 n -> Options SVG V2 n -> Bool)
-> (Options SVG V2 n -> Options SVG V2 n -> Bool)
-> Eq (Options SVG V2 n)
forall n. Eq n => Options SVG V2 n -> Options SVG V2 n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Options SVG V2 n -> Options SVG V2 n -> Bool
$c/= :: forall n. Eq n => Options SVG V2 n -> Options SVG V2 n -> Bool
== :: Options SVG V2 n -> Options SVG V2 n -> Bool
$c== :: forall n. Eq n => Options SVG V2 n -> Options SVG V2 n -> Bool
Eq

  renderRTree :: SVG -> Options SVG V2 n -> RTree SVG V2 n Annotation -> Result SVG V2 n
  renderRTree :: SVG
-> Options SVG V2 n -> RTree SVG V2 n Annotation -> Result SVG V2 n
renderRTree SVG
_ Options SVG V2 n
opts RTree SVG V2 n Annotation
rt = Text -> SvgRenderM n -> Element
forall n. SVGFloat n => Text -> SvgRenderM n -> Element
runRenderM (Options SVG V2 n
opts Options SVG V2 n -> Getting Text (Options SVG V2 n) Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text (Options SVG V2 n) Text
forall n. Lens' (Options SVG V2 n) Text
idPrefix) SvgRenderM n
svgOutput
    where
      svgOutput :: SvgRenderM n
svgOutput = do
        let R r    = RTree SVG V2 n Annotation -> Render SVG V2 n
forall n.
SVGFloat n =>
RTree SVG V2 n Annotation -> Render SVG V2 n
rtree (RTree SVG V2 n Annotation -> RTree SVG V2 n Annotation
forall b (v :: * -> *) n a.
Typeable n =>
RTree b v n a -> RTree b v n a
splitTextureFills RTree SVG V2 n Annotation
rt)
            V2 n
w n
h = 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 SVG V2 n
optsOptions SVG V2 n
-> Getting (SizeSpec V2 n) (Options SVG V2 n) (SizeSpec V2 n)
-> SizeSpec V2 n
forall s a. s -> Getting a s a -> a
^.Getting (SizeSpec V2 n) (Options SVG V2 n) (SizeSpec V2 n)
forall n. Lens' (Options SVG V2 n) (SizeSpec V2 n)
sizeSpec)
        Element
svg <- SvgRenderM n
r
        Element -> SvgRenderM n
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> SvgRenderM n) -> Element -> SvgRenderM n
forall a b. (a -> b) -> a -> b
$ n
-> n -> Maybe Element -> [Attribute] -> Bool -> Element -> Element
forall n.
SVGFloat n =>
n
-> n -> Maybe Element -> [Attribute] -> Bool -> Element -> Element
R.svgHeader n
w n
h (Options SVG V2 n
optsOptions SVG V2 n
-> Getting (Maybe Element) (Options SVG V2 n) (Maybe Element)
-> Maybe Element
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Element) (Options SVG V2 n) (Maybe Element)
forall n. Lens' (Options SVG V2 n) (Maybe Element)
svgDefinitions)
                                 (Options SVG V2 n
optsOptions SVG V2 n
-> Getting [Attribute] (Options SVG V2 n) [Attribute]
-> [Attribute]
forall s a. s -> Getting a s a -> a
^.Getting [Attribute] (Options SVG V2 n) [Attribute]
forall n. Lens' (Options SVG V2 n) [Attribute]
svgAttributes)
                                 (Options SVG V2 n
optsOptions SVG V2 n -> Getting Bool (Options SVG V2 n) Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool (Options SVG V2 n) Bool
forall n. Lens' (Options SVG V2 n) Bool
generateDoctype) Element
svg

  adjustDia :: SVG
-> Options SVG V2 n
-> QDiagram SVG V2 n m
-> (Options SVG V2 n, Transformation V2 n, QDiagram SVG V2 n m)
adjustDia SVG
c Options SVG V2 n
opts QDiagram SVG V2 n m
d = ( Options SVG V2 n
sz, Transformation V2 n
t Transformation V2 n -> Transformation V2 n -> Transformation V2 n
forall a. Semigroup a => a -> a -> a
<> Transformation V2 n
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY, QDiagram SVG V2 n m
d' ) where
    (Options SVG V2 n
sz, Transformation V2 n
t, QDiagram SVG V2 n m
d') = Lens' (Options SVG V2 n) (SizeSpec V2 n)
-> SVG
-> Options SVG V2 n
-> QDiagram SVG V2 n m
-> (Options SVG V2 n, Transformation V2 n, QDiagram SVG 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 SVG V2 n) (SizeSpec V2 n)
Lens' (Options SVG V2 n) (SizeSpec V2 n)
sizeSpec SVG
c Options SVG V2 n
opts (QDiagram SVG V2 n m
d QDiagram SVG V2 n m
-> (QDiagram SVG V2 n m -> QDiagram SVG V2 n m)
-> QDiagram SVG V2 n m
forall a b. a -> (a -> b) -> b
# QDiagram SVG V2 n m -> QDiagram SVG V2 n m
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY)

rtree :: SVGFloat n => RTree SVG V2 n Annotation -> Render SVG V2 n
rtree :: RTree SVG V2 n Annotation -> Render SVG V2 n
rtree (Node RNode SVG V2 n Annotation
n Forest (RNode SVG V2 n Annotation)
rs) = case RNode SVG V2 n Annotation
n of
  RPrim Prim SVG V2 n
p                       -> SVG
-> Prim SVG V2 n
-> Render SVG (V (Prim SVG V2 n)) (N (Prim SVG V2 n))
forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
render SVG
SVG Prim SVG V2 n
p
  RStyle Style V2 n
sty                    -> SvgRenderM n -> Render SVG V2 n
forall n. SvgRenderM n -> Render SVG V2 n
R (SvgRenderM n -> Render SVG V2 n)
-> SvgRenderM n -> Render SVG V2 n
forall a b. (a -> b) -> a -> b
$ (Environment n -> Environment n) -> SvgRenderM n -> SvgRenderM n
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter (Environment n) (Environment n) (Style V2 n) (Style V2 n)
-> (Style V2 n -> Style V2 n) -> Environment n -> Environment n
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Environment n) (Environment n) (Style V2 n) (Style V2 n)
forall n n.
Lens (Environment n) (Environment n) (Style V2 n) (Style V2 n)
style (Style V2 n -> Style V2 n -> Style V2 n
forall a. Semigroup a => a -> a -> a
<> Style V2 n
sty)) SvgRenderM n
r
  RAnnot (OpacityGroup Double
o)       -> SvgRenderM n -> Render SVG V2 n
forall n. SvgRenderM n -> Render SVG V2 n
R (SvgRenderM n -> Render SVG V2 n)
-> SvgRenderM n -> Render SVG V2 n
forall a b. (a -> b) -> a -> b
$ [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
g_ [AttrTag
Opacity_ AttrTag -> Text -> Attribute
<<- Double -> Text
forall a. RealFloat a => a -> Text
toText Double
o] (Element -> Element) -> SvgRenderM n -> SvgRenderM n
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SvgRenderM n
r
  RAnnot (Href String
uri)             -> SvgRenderM n -> Render SVG V2 n
forall n. SvgRenderM n -> Render SVG V2 n
R (SvgRenderM n -> Render SVG V2 n)
-> SvgRenderM n -> Render SVG V2 n
forall a b. (a -> b) -> a -> b
$ [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
a_ [AttrTag
XlinkHref_ AttrTag -> Text -> Attribute
<<- String -> Text
T.pack String
uri] (Element -> Element) -> SvgRenderM n -> SvgRenderM n
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SvgRenderM n
r
  RAnnot (KeyVal (String
"class",String
v))   -> SvgRenderM n -> Render SVG V2 n
forall n. SvgRenderM n -> Render SVG V2 n
R (SvgRenderM n -> Render SVG V2 n)
-> SvgRenderM n -> Render SVG V2 n
forall a b. (a -> b) -> a -> b
$ Element -> [Attribute] -> Element
with (Element -> [Attribute] -> Element)
-> SvgRenderM n
-> ReaderT
     (Environment n) (State SvgRenderState) ([Attribute] -> Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SvgRenderM n
r ReaderT
  (Environment n) (State SvgRenderState) ([Attribute] -> Element)
-> ReaderT (Environment n) (State SvgRenderState) [Attribute]
-> SvgRenderM n
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Attribute]
-> ReaderT (Environment n) (State SvgRenderState) [Attribute]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [AttrTag
Class_ AttrTag -> Text -> Attribute
<<- String -> Text
T.pack String
v]
  RAnnot (KeyVal (String
"id",String
v))      -> SvgRenderM n -> Render SVG V2 n
forall n. SvgRenderM n -> Render SVG V2 n
R (SvgRenderM n -> Render SVG V2 n)
-> SvgRenderM n -> Render SVG V2 n
forall a b. (a -> b) -> a -> b
$ Element -> [Attribute] -> Element
with (Element -> [Attribute] -> Element)
-> SvgRenderM n
-> ReaderT
     (Environment n) (State SvgRenderState) ([Attribute] -> Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SvgRenderM n
r ReaderT
  (Environment n) (State SvgRenderState) ([Attribute] -> Element)
-> ReaderT (Environment n) (State SvgRenderState) [Attribute]
-> SvgRenderM n
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Attribute]
-> ReaderT (Environment n) (State SvgRenderState) [Attribute]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [AttrTag
Id_ AttrTag -> Text -> Attribute
<<- String -> Text
T.pack String
v]
  RAnnot (KeyVal (String
"title",String
v))   -> SvgRenderM n -> Render SVG V2 n
forall n. SvgRenderM n -> Render SVG V2 n
R (SvgRenderM n -> Render SVG V2 n)
-> SvgRenderM n -> Render SVG V2 n
forall a b. (a -> b) -> a -> b
$ do
    Element
e <- SvgRenderM n
r
    Element -> SvgRenderM n
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Element -> SvgRenderM n) -> Element -> SvgRenderM n
forall a b. (a -> b) -> a -> b
$ [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
g_ [] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Element
e Element -> Element -> Element
forall a. Semigroup a => a -> a -> a
<> [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
title_ [] (String -> Element
forall a. ToElement a => a -> Element
toElement String
v)
  RNode SVG V2 n Annotation
_                             -> SvgRenderM n -> Render SVG V2 n
forall n. SvgRenderM n -> Render SVG V2 n
R SvgRenderM n
r
  where
    R r = (RTree SVG V2 n Annotation -> Render SVG V2 n)
-> Forest (RNode SVG V2 n Annotation) -> Render SVG V2 n
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap RTree SVG V2 n Annotation -> Render SVG V2 n
forall n.
SVGFloat n =>
RTree SVG V2 n Annotation -> Render SVG V2 n
rtree Forest (RNode SVG V2 n Annotation)
rs

-- | Set the id for a particular SVG diagram
svgId :: SVGFloat n => String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
svgId :: String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
svgId = ((String, String)
 -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any)
-> String
-> String
-> QDiagram SVG V2 n Any
-> QDiagram SVG V2 n Any
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (String, String) -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Semigroup m) =>
(String, String) -> QDiagram b v n m -> QDiagram b v n m
keyVal String
"id"

-- | Set the class for a particular SVG diagram
svgClass :: SVGFloat n => String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
svgClass :: String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
svgClass = ((String, String)
 -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any)
-> String
-> String
-> QDiagram SVG V2 n Any
-> QDiagram SVG V2 n Any
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (String, String) -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Semigroup m) =>
(String, String) -> QDiagram b v n m -> QDiagram b v n m
keyVal String
"class"

-- | Set the title text for a particular SVG diagram
svgTitle :: SVGFloat n => String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
svgTitle :: String -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
svgTitle = ((String, String)
 -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any)
-> String
-> String
-> QDiagram SVG V2 n Any
-> QDiagram SVG V2 n Any
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (String, String) -> QDiagram SVG V2 n Any -> QDiagram SVG V2 n Any
forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Semigroup m) =>
(String, String) -> QDiagram b v n m -> QDiagram b v n m
keyVal String
"title"

-- | Lens onto the size of the svg options.
sizeSpec :: Lens' (Options SVG V2 n) (SizeSpec V2 n)
sizeSpec :: (SizeSpec V2 n -> f (SizeSpec V2 n))
-> Options SVG V2 n -> f (Options SVG V2 n)
sizeSpec SizeSpec V2 n -> f (SizeSpec V2 n)
f Options SVG V2 n
opts = SizeSpec V2 n -> f (SizeSpec V2 n)
f (Options SVG V2 n -> SizeSpec V2 n
forall n. Options SVG V2 n -> SizeSpec V2 n
_size Options SVG V2 n
opts) f (SizeSpec V2 n)
-> (SizeSpec V2 n -> Options SVG V2 n) -> f (Options SVG V2 n)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \SizeSpec V2 n
s -> Options SVG V2 n
R:OptionsSVGV2n n
opts { _size :: SizeSpec V2 n
_size = SizeSpec V2 n
s }

-- | Lens onto the svg definitions of the svg options.
svgDefinitions :: Lens' (Options SVG V2 n) (Maybe Element)
svgDefinitions :: (Maybe Element -> f (Maybe Element))
-> Options SVG V2 n -> f (Options SVG V2 n)
svgDefinitions Maybe Element -> f (Maybe Element)
f Options SVG V2 n
opts =
  Maybe Element -> f (Maybe Element)
f (Options SVG V2 n -> Maybe Element
forall n. Options SVG V2 n -> Maybe Element
_svgDefinitions Options SVG V2 n
opts) f (Maybe Element)
-> (Maybe Element -> Options SVG V2 n) -> f (Options SVG V2 n)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Maybe Element
ds -> Options SVG V2 n
R:OptionsSVGV2n n
opts { _svgDefinitions :: Maybe Element
_svgDefinitions = Maybe Element
ds }

-- | Lens onto the idPrefix of the svg options. This is the prefix given
--   to clipping paths to distinguish them from other svg files in the
--   same web page.
idPrefix :: Lens' (Options SVG V2 n) T.Text
idPrefix :: (Text -> f Text) -> Options SVG V2 n -> f (Options SVG V2 n)
idPrefix Text -> f Text
f Options SVG V2 n
opts = Text -> f Text
f (Options SVG V2 n -> Text
forall n. Options SVG V2 n -> Text
_idPrefix Options SVG V2 n
opts) f Text -> (Text -> Options SVG V2 n) -> f (Options SVG V2 n)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Text
i -> Options SVG V2 n
R:OptionsSVGV2n n
opts { _idPrefix :: Text
_idPrefix = Text
i }

-- | Lens onto the svgAttributes field of the svg options. This field
--   is provided to supply SVG attributes to the entire diagram.
svgAttributes :: Lens' (Options SVG V2 n) [Attribute]
svgAttributes :: ([Attribute] -> f [Attribute])
-> Options SVG V2 n -> f (Options SVG V2 n)
svgAttributes [Attribute] -> f [Attribute]
f Options SVG V2 n
opts =
  [Attribute] -> f [Attribute]
f (Options SVG V2 n -> [Attribute]
forall n. Options SVG V2 n -> [Attribute]
_svgAttributes Options SVG V2 n
opts) f [Attribute]
-> ([Attribute] -> Options SVG V2 n) -> f (Options SVG V2 n)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[Attribute]
ds -> Options SVG V2 n
R:OptionsSVGV2n n
opts { _svgAttributes :: [Attribute]
_svgAttributes = [Attribute]
ds }

-- | Lens onto the generateDoctype field of the svg options. Set
--   to False if you don't want a doctype tag included in the output.
generateDoctype :: Lens' (Options SVG V2 n) Bool
generateDoctype :: (Bool -> f Bool) -> Options SVG V2 n -> f (Options SVG V2 n)
generateDoctype Bool -> f Bool
f Options SVG V2 n
opts =
  Bool -> f Bool
f (Options SVG V2 n -> Bool
forall n. Options SVG V2 n -> Bool
_generateDoctype Options SVG V2 n
opts) f Bool -> (Bool -> Options SVG V2 n) -> f (Options SVG V2 n)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Bool
ds -> Options SVG V2 n
R:OptionsSVGV2n n
opts { _generateDoctype :: Bool
_generateDoctype = Bool
ds }

-- paths ---------------------------------------------------------------

attributedRender :: SVGFloat n => Element -> SvgRenderM n
attributedRender :: Element -> SvgRenderM n
attributedRender Element
svg = do
  SvgRenderState Int
_idClip Int
idFill Int
idLine <- ReaderT (Environment n) (State SvgRenderState) SvgRenderState
forall s (m :: * -> *). MonadState s m => m s
get
  Environment Style V2 n
sty Text
preT <- ReaderT (Environment n) (State SvgRenderState) (Environment n)
forall r (m :: * -> *). MonadReader r m => m r
ask
  Element
clippedSvg   <- Text -> Element -> Style V2 n -> SvgRenderM n
forall n.
SVGFloat n =>
Text -> Element -> Style V2 n -> SvgRenderM n
renderSvgWithClipping Text
preT Element
svg Style V2 n
sty
  Element
lineGradDefs <- Style V2 n -> SvgRenderM n
forall n (v :: * -> *). SVGFloat n => Style v n -> SvgRenderM n
lineTextureDefs Style V2 n
sty
  Element
fillGradDefs <- Style V2 n -> SvgRenderM n
forall n (v :: * -> *). SVGFloat n => Style v n -> SvgRenderM n
fillTextureDefs Style V2 n
sty
  Element -> SvgRenderM n
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> SvgRenderM n) -> Element -> SvgRenderM n
forall a b. (a -> b) -> a -> b
$ do
    let gDefs :: Element
gDefs = Element -> Element -> Element
forall a. Monoid a => a -> a -> a
mappend Element
fillGradDefs Element
lineGradDefs
    Element
gDefs Element -> Element -> Element
forall a. Monoid a => a -> a -> a
`mappend` [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
g_ (Int -> Int -> Style V2 n -> [Attribute]
forall n (v :: * -> *).
SVGFloat n =>
Int -> Int -> Style v n -> [Attribute]
R.renderStyles Int
idFill Int
idLine Style V2 n
sty) Element
clippedSvg

instance SVGFloat n => Renderable (Path V2 n) SVG where
  render :: SVG -> Path V2 n -> Render SVG (V (Path V2 n)) (N (Path V2 n))
render SVG
_ = SvgRenderM n -> Render SVG V2 n
forall n. SvgRenderM n -> Render SVG V2 n
R (SvgRenderM n -> Render SVG V2 n)
-> (Path V2 n -> SvgRenderM n) -> Path V2 n -> Render SVG V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> SvgRenderM n
forall n. SVGFloat n => Element -> SvgRenderM n
attributedRender (Element -> SvgRenderM n)
-> (Path V2 n -> Element) -> Path V2 n -> SvgRenderM n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path V2 n -> Element
forall n. SVGFloat n => Path V2 n -> Element
R.renderPath

instance SVGFloat n => Renderable (Text n) SVG where
  render :: SVG -> Text n -> Render SVG (V (Text n)) (N (Text n))
render SVG
_ t :: Text n
t@(Text T2 n
tTxt TextAlignment n
_ String
_) = SvgRenderM n -> Render SVG V2 n
forall n. SvgRenderM n -> Render SVG V2 n
R (SvgRenderM n -> Render SVG V2 n)
-> SvgRenderM n -> Render SVG V2 n
forall a b. (a -> b) -> a -> b
$ do
    let svg :: Element
svg = Text n -> Element
forall n. SVGFloat n => Text n -> Element
R.renderText Text n
t
    SvgRenderState Int
_idClip Int
idFill Int
idLine <- ReaderT (Environment n) (State SvgRenderState) SvgRenderState
forall s (m :: * -> *). MonadState s m => m s
get
    Environment Style V2 n
sty Text
preT <- ReaderT (Environment n) (State SvgRenderState) (Environment n)
forall r (m :: * -> *). MonadReader r m => m r
ask
    Element
clippedSvg           <- Text -> Element -> Style V2 n -> SvgRenderM n
forall n.
SVGFloat n =>
Text -> Element -> Style V2 n -> SvgRenderM n
renderSvgWithClipping Text
preT Element
svg Style V2 n
sty

    -- SVG applies the text transform to the gradient before rendering.
    -- This means we need to apply the inverse of the text transform
    -- first, being careful about how we use reflectionY to handle SVG's
    -- coordinates.
    let adjustTrans :: Maybe (FillTexture n) -> Maybe (FillTexture n)
        adjustTrans :: Maybe (FillTexture n) -> Maybe (FillTexture n)
adjustTrans = (FillTexture n -> Identity (FillTexture n))
-> Maybe (FillTexture n) -> Identity (Maybe (FillTexture n))
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((FillTexture n -> Identity (FillTexture n))
 -> Maybe (FillTexture n) -> Identity (Maybe (FillTexture n)))
-> ((T2 n -> Identity (T2 n))
    -> FillTexture n -> Identity (FillTexture n))
-> (T2 n -> Identity (T2 n))
-> Maybe (FillTexture n)
-> Identity (Maybe (FillTexture n))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Recommend (Texture n) -> Identity (Recommend (Texture n)))
-> FillTexture n -> Identity (FillTexture n)
forall n. Iso' (FillTexture n) (Recommend (Texture n))
_FillTexture ((Recommend (Texture n) -> Identity (Recommend (Texture n)))
 -> FillTexture n -> Identity (FillTexture n))
-> ((T2 n -> Identity (T2 n))
    -> Recommend (Texture n) -> Identity (Recommend (Texture n)))
-> (T2 n -> Identity (T2 n))
-> FillTexture n
-> Identity (FillTexture n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Texture n -> Identity (Texture n))
-> Recommend (Texture n) -> Identity (Recommend (Texture n))
forall a b. Iso (Recommend a) (Recommend b) a b
committed ((Texture n -> Identity (Texture n))
 -> Recommend (Texture n) -> Identity (Recommend (Texture n)))
-> ((T2 n -> Identity (T2 n)) -> Texture n -> Identity (Texture n))
-> (T2 n -> Identity (T2 n))
-> Recommend (Texture n)
-> Identity (Recommend (Texture n))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LGradient n -> Identity (LGradient n))
-> Texture n -> Identity (Texture n)
forall n. Prism' (Texture n) (LGradient n)
_LG ((LGradient n -> Identity (LGradient n))
 -> Texture n -> Identity (Texture n))
-> ((T2 n -> Identity (T2 n))
    -> LGradient n -> Identity (LGradient n))
-> (T2 n -> Identity (T2 n))
-> Texture n
-> Identity (Texture n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T2 n -> Identity (T2 n)) -> LGradient n -> Identity (LGradient n)
forall n. Lens' (LGradient n) (Transformation V2 n)
lGradTrans ((T2 n -> Identity (T2 n))
 -> Maybe (FillTexture n) -> Identity (Maybe (FillTexture n)))
-> (T2 n -> T2 n) -> Maybe (FillTexture n) -> Maybe (FillTexture n)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~
          \T2 n
tGrad -> T2 n -> T2 n
forall (v :: * -> *) n.
(Functor v, Num n) =>
Transformation v n -> Transformation v n
inv (T2 n
tTxt T2 n -> T2 n -> T2 n
forall a. Semigroup a => a -> a -> a
<> T2 n
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY) T2 n -> T2 n -> T2 n
forall a. Semigroup a => a -> a -> a
<> T2 n
tGrad T2 n -> T2 n -> T2 n
forall a. Semigroup a => a -> a -> a
<> T2 n
forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY

    Element
fillGradDefs <- Style V2 n -> SvgRenderM n
forall n (v :: * -> *). SVGFloat n => Style v n -> SvgRenderM n
fillTextureDefs (Style V2 n
sty Style V2 n -> (Style V2 n -> Style V2 n) -> Style V2 n
forall a b. a -> (a -> b) -> b
& (Maybe (FillTexture n) -> Identity (Maybe (FillTexture n)))
-> Style V2 n -> Identity (Style V2 n)
forall a (v :: * -> *) n.
AttributeClass a =>
Lens' (Style v n) (Maybe a)
atAttr ((Maybe (FillTexture n) -> Identity (Maybe (FillTexture n)))
 -> Style V2 n -> Identity (Style V2 n))
-> (Maybe (FillTexture n) -> Maybe (FillTexture n))
-> Style V2 n
-> Style V2 n
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Maybe (FillTexture n) -> Maybe (FillTexture n)
adjustTrans)
    Element -> SvgRenderM n
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> SvgRenderM n) -> Element -> SvgRenderM n
forall a b. (a -> b) -> a -> b
$
      Element
fillGradDefs Element -> Element -> Element
forall a. Monoid a => a -> a -> a
`mappend` [Attribute] -> Element -> Element
forall result. Term result => [Attribute] -> result
g_ (Int -> Int -> Style V2 n -> [Attribute]
forall n (v :: * -> *).
SVGFloat n =>
Int -> Int -> Style v n -> [Attribute]
R.renderStyles Int
idFill Int
idLine Style V2 n
sty) Element
clippedSvg

instance SVGFloat n => Renderable (DImage n Embedded) SVG where
  render :: SVG
-> DImage n Embedded
-> Render SVG (V (DImage n Embedded)) (N (DImage n Embedded))
render SVG
_ = SvgRenderM n -> Render SVG V2 n
forall n. SvgRenderM n -> Render SVG V2 n
R (SvgRenderM n -> Render SVG V2 n)
-> (DImage n Embedded -> SvgRenderM n)
-> DImage n Embedded
-> Render SVG V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> SvgRenderM n
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> SvgRenderM n)
-> (DImage n Embedded -> Element)
-> DImage n Embedded
-> SvgRenderM n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DImage n Embedded -> Element
forall n. SVGFloat n => DImage n Embedded -> Element
R.renderDImageEmb

-- | Render a diagram as an SVG, writing to the specified output file
--   and using the requested size.
renderSVG :: SVGFloat n => FilePath -> SizeSpec V2 n -> QDiagram SVG V2 n Any -> IO ()
renderSVG :: String -> SizeSpec V2 n -> QDiagram SVG V2 n Any -> IO ()
renderSVG String
outFile SizeSpec V2 n
spec = String -> Options SVG V2 n -> QDiagram SVG V2 n Any -> IO ()
forall n.
SVGFloat n =>
String -> Options SVG V2 n -> QDiagram SVG V2 n Any -> IO ()
renderSVG' String
outFile (SizeSpec V2 n
-> Maybe Element -> Text -> [Attribute] -> Bool -> Options SVG V2 n
forall n.
SizeSpec V2 n
-> Maybe Element -> Text -> [Attribute] -> Bool -> Options SVG V2 n
SVGOptions SizeSpec V2 n
spec Maybe Element
forall a. Maybe a
Nothing (String -> Text
mkPrefix String
outFile) [] Bool
True)

-- | Render a diagram as a pretty printed SVG.
renderPretty :: SVGFloat n => FilePath -> SizeSpec V2 n -> QDiagram SVG V2 n Any -> IO ()
renderPretty :: String -> SizeSpec V2 n -> QDiagram SVG V2 n Any -> IO ()
renderPretty String
outFile SizeSpec V2 n
spec = String -> Options SVG V2 n -> QDiagram SVG V2 n Any -> IO ()
forall n.
SVGFloat n =>
String -> Options SVG V2 n -> QDiagram SVG V2 n Any -> IO ()
renderPretty' String
outFile (SizeSpec V2 n
-> Maybe Element -> Text -> [Attribute] -> Bool -> Options SVG V2 n
forall n.
SizeSpec V2 n
-> Maybe Element -> Text -> [Attribute] -> Bool -> Options SVG V2 n
SVGOptions SizeSpec V2 n
spec Maybe Element
forall a. Maybe a
Nothing (String -> Text
mkPrefix String
outFile)[] Bool
True)

-- Create a prefile using the basename of the output file. Only standard
-- letters are considered.
mkPrefix :: FilePath -> T.Text
mkPrefix :: String -> Text
mkPrefix = (Char -> Bool) -> Text -> Text
T.filter Char -> Bool
isAlpha (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> ShowS -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeBaseName

-- | Render a diagram as an SVG, writing to the specified output file
--   and using the backend options. The id prefix is derived from the
--   basename of the output file.
renderSVG' :: SVGFloat n => FilePath -> Options SVG V2 n -> QDiagram SVG V2 n Any -> IO ()
renderSVG' :: String -> Options SVG V2 n -> QDiagram SVG V2 n Any -> IO ()
renderSVG' String
outFile Options SVG V2 n
opts = String -> ByteString -> IO ()
BS.writeFile String
outFile (ByteString -> IO ())
-> (QDiagram SVG V2 n Any -> ByteString)
-> QDiagram SVG V2 n Any
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> ByteString
renderBS (Element -> ByteString)
-> (QDiagram SVG V2 n Any -> Element)
-> QDiagram SVG V2 n Any
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SVG -> Options SVG V2 n -> QDiagram SVG V2 n Any -> Result SVG V2 n
forall b (v :: * -> *) n m.
(Backend b v n, HasLinearMap v, Metric v, Typeable n,
 OrderedField n, Monoid' m) =>
b -> Options b v n -> QDiagram b v n m -> Result b v n
renderDia SVG
SVG Options SVG V2 n
opts

-- | Render a diagram as a pretty printed SVG to the specified output
--   file and using the backend options. The id prefix is derived from the
--   basename of the output file.
renderPretty' :: SVGFloat n => FilePath -> Options SVG V2 n -> QDiagram SVG V2 n Any -> IO ()
renderPretty' :: String -> Options SVG V2 n -> QDiagram SVG V2 n Any -> IO ()
renderPretty' String
outFile Options SVG V2 n
opts = String -> Text -> IO ()
LT.writeFile String
outFile (Text -> IO ())
-> (QDiagram SVG V2 n Any -> Text)
-> QDiagram SVG V2 n Any
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Text
prettyText (Element -> Text)
-> (QDiagram SVG V2 n Any -> Element)
-> QDiagram SVG V2 n Any
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SVG -> Options SVG V2 n -> QDiagram SVG V2 n Any -> Result SVG V2 n
forall b (v :: * -> *) n m.
(Backend b v n, HasLinearMap v, Metric v, Typeable n,
 OrderedField n, Monoid' m) =>
b -> Options b v n -> QDiagram b v n m -> Result b v n
renderDia SVG
SVG Options SVG V2 n
opts

data Img = Img !Char !BS.ByteString deriving Typeable

-- | Load images (JPG/PNG/...) in a SVG specific way.
loadImageSVG :: SVGFloat n => FilePath -> IO (QDiagram SVG V2 n Any)
loadImageSVG :: String -> IO (QDiagram SVG V2 n Any)
loadImageSVG String
fp = do
    ByteString
raw <- String -> IO ByteString
SBS.readFile String
fp
    DynamicImage
dyn <- Either String DynamicImage -> IO DynamicImage
forall a. Either String a -> IO a
eIO (Either String DynamicImage -> IO DynamicImage)
-> Either String DynamicImage -> IO DynamicImage
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String DynamicImage
decodeImage ByteString
raw
    let dat :: ByteString
dat = [ByteString] -> ByteString
BS.fromChunks [ByteString
raw]
    let pic :: Char -> ByteString -> IO (QDiagram SVG V2 n Any)
pic Char
t ByteString
d = QDiagram SVG V2 n Any -> IO (QDiagram SVG V2 n Any)
forall (m :: * -> *) a. Monad m => a -> m a
return (QDiagram SVG V2 n Any -> IO (QDiagram SVG V2 n Any))
-> QDiagram SVG V2 n Any -> IO (QDiagram SVG V2 n Any)
forall a b. (a -> b) -> a -> b
$ DImage n (Native Img) -> QDiagram SVG V2 n Any
forall n a b.
(TypeableFloat n, Typeable a, Renderable (DImage n a) b) =>
DImage n a -> QDiagram b V2 n Any
image (ImageData (Native Img)
-> Int -> Int -> Transformation V2 n -> DImage n (Native Img)
forall b a.
ImageData b -> Int -> Int -> Transformation V2 a -> DImage a b
DImage (Img -> ImageData (Native Img)
forall t. t -> ImageData (Native t)
ImageNative (Char -> ByteString -> Img
Img Char
t ByteString
d))
                                   ((forall pixel. Pixel pixel => Image pixel -> Int)
-> DynamicImage -> Int
forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap forall a. Image a -> Int
forall pixel. Pixel pixel => Image pixel -> Int
imageWidth DynamicImage
dyn)
                                   ((forall pixel. Pixel pixel => Image pixel -> Int)
-> DynamicImage -> Int
forall a.
(forall pixel. Pixel pixel => Image pixel -> a)
-> DynamicImage -> a
dynamicMap forall a. Image a -> Int
forall pixel. Pixel pixel => Image pixel -> Int
imageHeight DynamicImage
dyn) Transformation V2 n
forall a. Monoid a => a
mempty)
    if | ByteString
pngHeader ByteString -> ByteString -> Bool
`SBS.isPrefixOf` ByteString
raw -> Char -> ByteString -> IO (QDiagram SVG V2 n Any)
pic Char
'P' ByteString
dat
       | ByteString
jpgHeader ByteString -> ByteString -> Bool
`SBS.isPrefixOf` ByteString
raw -> Char -> ByteString -> IO (QDiagram SVG V2 n Any)
pic Char
'J' ByteString
dat
       | Bool
otherwise -> case DynamicImage
dyn of
           (ImageYCbCr8 Image PixelYCbCr8
_) -> Char -> ByteString -> IO (QDiagram SVG V2 n Any)
pic Char
'J' ByteString
dat
           DynamicImage
_               -> Char -> ByteString -> IO (QDiagram SVG V2 n Any)
pic Char
'P' (ByteString -> IO (QDiagram SVG V2 n Any))
-> IO ByteString -> IO (QDiagram SVG V2 n Any)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either String ByteString -> IO ByteString
forall a. Either String a -> IO a
eIO (DynamicImage -> Either String ByteString
encodeDynamicPng DynamicImage
dyn)
  where pngHeader :: SBS.ByteString
        pngHeader :: ByteString
pngHeader = [Word8] -> ByteString
SBS.pack [Word8
137, Word8
80, Word8
78, Word8
71, Word8
13, Word8
10, Word8
26, Word8
10]
        jpgHeader :: SBS.ByteString
        jpgHeader :: ByteString
jpgHeader = [Word8] -> ByteString
SBS.pack [Word8
0xFF, Word8
0xD8]
        eIO :: Either String a -> IO a
        eIO :: Either String a -> IO a
eIO = (String -> IO a) -> (a -> IO a) -> Either String a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance SVGFloat n => Renderable (DImage n (Native Img)) SVG where
  render :: SVG
-> DImage n (Native Img)
-> Render
     SVG (V (DImage n (Native Img))) (N (DImage n (Native Img)))
render SVG
_ di :: DImage n (Native Img)
di@(DImage (ImageNative (Img t d)) Int
_ Int
_ Transformation V2 n
_) = SvgRenderM n -> Render SVG V2 n
forall n. SvgRenderM n -> Render SVG V2 n
R (SvgRenderM n -> Render SVG V2 n)
-> SvgRenderM n -> Render SVG V2 n
forall a b. (a -> b) -> a -> b
$ do
    String
mime <- case Char
t of
          Char
'J' -> String -> ReaderT (Environment n) (State SvgRenderState) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"image/jpeg"
          Char
'P' -> String -> ReaderT (Environment n) (State SvgRenderState) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"image/png"
          Char
_   -> String -> ReaderT (Environment n) (State SvgRenderState) String
forall a. HasCallStack => String -> a
error  String
"Unknown mime type while rendering image"
    Element -> SvgRenderM n
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> SvgRenderM n) -> Element -> SvgRenderM n
forall a b. (a -> b) -> a -> b
$ DImage n (Native Img) -> Text -> Element
forall n any. SVGFloat n => DImage n any -> Text -> Element
R.renderDImage DImage n (Native Img)
di (Text -> Element) -> Text -> Element
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> Text
R.dataUri String
mime ByteString
d

instance Hashable n => Hashable (Options SVG V2 n) where
  hashWithSalt :: Int -> Options SVG V2 n -> Int
hashWithSalt Int
s  (SVGOptions sz defs ia sa gd) =
    Int
s  Int -> SizeSpec V2 n -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
    SizeSpec V2 n
sz Int -> Maybe ByteString -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
    Maybe ByteString
ds Int -> Text -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
    Text
ia Int -> [Attribute] -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
    [Attribute]
sa Int -> Bool -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt`
    Bool
gd
      where ds :: Maybe ByteString
ds = (Element -> ByteString) -> Maybe Element -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Element -> ByteString
renderBS Maybe Element
defs

-- This is an orphan instance.  Since Element is defined as a newtype
-- of (HashMap Text Text -> Builder), it doesn't really make sense to
-- define an Eq instance for it in general.  However, as of
-- hashable-1.4 an Eq superclass was added to Hashable, so in order to
-- have a Hashable instance for Options SVG, we need to have a
-- matching Eq instance.
instance Eq Element where
  == :: Element -> Element -> Bool
(==) = ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ByteString -> ByteString -> Bool)
-> (Element -> ByteString) -> Element -> Element -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Element -> ByteString
renderBS