{-# 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
( SVG(..)
, B
, Options(..), sizeSpec, svgDefinitions, idPrefix, svgAttributes, generateDoctype
, svgClass, svgId, svgTitle
, SVGFloat
, renderSVG
, renderSVG'
, renderPretty
, renderPretty'
, loadImageSVG
) where
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
import Control.Monad.Reader
import Control.Monad.State
import Data.Char
import Data.Function (on)
import Data.Typeable
import Data.Hashable (Hashable (), hashWithSalt)
import qualified Data.ByteString as SBS
import qualified Data.ByteString.Lazy as BS
import Control.Lens hiding (transform, ( # ))
import Diagrams.Core.Compile
import Diagrams.Core.Types (Annotation (..), keyVal)
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
import Graphics.Svg hiding ((<>))
import Graphics.Rendering.SVG (SVGFloat)
import qualified Graphics.Rendering.SVG as R
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)
initialSvgRenderState :: SvgRenderState
initialSvgRenderState :: SvgRenderState
initialSvgRenderState = Int -> Int -> Int -> SvgRenderState
SvgRenderState Int
0 Int
0 Int
1
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
renderSvgWithClipping :: forall n. SVGFloat n
=> T.Text
-> Element
-> Style V2 n
-> SvgRenderM n
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
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
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
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
, Options SVG V2 n -> Maybe Element
_svgDefinitions :: Maybe Element
, Options SVG V2 n -> Text
_idPrefix :: T.Text
, Options SVG V2 n -> [Attribute]
_svgAttributes :: [Attribute]
, 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
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"
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"
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"
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 }
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 }
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 }
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 }
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 }
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
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
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)
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)
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
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
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
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
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