Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Linear #61

Merged
merged 7 commits into from Oct 10, 2014
Merged

Linear #61

Show file tree
Hide file tree
Changes from 6 commits
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
5de2c05
Get it workiing with Double.
cchalmers Sep 5, 2014
fcaeb38
Merge with master.
cchalmers Sep 16, 2014
d0c9757
Fix local font size.
cchalmers Sep 16, 2014
b6d629b
Generalise for any "SVGFloat".
cchalmers Sep 16, 2014
e44159c
UndecidableInstances fix for ghc < 7.7.
cchalmers Sep 16, 2014
1fa68ca
remove trailing whitespace, commented-out code
bergey Sep 19, 2014
c7e7366
remove spurious `vector-space` dependency
bergey Sep 30, 2014
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
108 changes: 58 additions & 50 deletions src/Diagrams/Backend/SVG.hs
View file
Open in desktop
@@ -1,13 +1,18 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE UndecidableInstances #-}
-- UndecidableInstances needed for ghc < 707

{-# LANGUAGE GADTs #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}
Expand Down Expand Up @@ -85,7 +90,8 @@
module Diagrams.Backend.SVG
( SVG(..) -- rendering token
, B
, Options(..), size, svgDefinitions -- for rendering options specific to SVG
, Options(..), sizeSpec, svgDefinitions -- for rendering options specific to SVG
, SVGFloat

, renderSVG
, renderPretty
Expand All @@ -96,7 +102,7 @@ module Diagrams.Backend.SVG
import Codec.Picture
import Codec.Picture.Types(dynamicMap)
-- for testing
import Data.Foldable (foldMap)
import Data.Foldable as F (foldMap, mapM_)
import Data.Tree

-- from base
Expand All @@ -119,7 +125,7 @@ import Diagrams.Core.Compile
import Diagrams.Core.Types (Annotation (..))

-- from diagrams-lib
import Diagrams.Prelude hiding (view)
import Diagrams.Prelude hiding (view, size)
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Do you need to hide size now that you are using sizeSpec?

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Missed that, thanks. )

import Diagrams.TwoD.Adjust (adjustDia2D)
import Diagrams.TwoD.Attributes (splitTextureFills)
import Diagrams.TwoD.Path (Clip (Clip))
Expand All @@ -137,11 +143,12 @@ import qualified Text.Blaze.Svg.Renderer.Pretty as Pretty

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

-- | @SVG@ is simply a token used to identify this rendering backend
-- (to aid type inference).
data SVG = SVG
deriving (Show, Typeable)
deriving (Show, Typeable)

type B = SVG

Expand All @@ -161,7 +168,7 @@ initialSvgRenderState = SvgRenderState 0 0 1 True
-- for assiging a unique clip path ID.
type SvgRenderM = State SvgRenderState S.Svg

instance Monoid (Render SVG R2) where
instance SVGFloat n => Monoid (Render SVG V2 n) where
mempty = R $ return mempty
(R r1) `mappend` (R r2_) =
R $ do
Expand All @@ -170,56 +177,57 @@ instance Monoid (Render SVG R2) where
return (svg1 `mappend` svg2)

-- Handle clip attributes.
renderSvgWithClipping :: S.Svg -- ^ Input SVG
-> Style v -- ^ Styles
renderSvgWithClipping :: forall n. SVGFloat n
=> S.Svg -- ^ Input SVG
-> Style V2 n -- ^ Styles
-> SvgRenderM -- ^ Resulting svg
renderSvgWithClipping svg s =
case (op Clip <$> getAttr s) of
Nothing -> return $ svg
case op Clip <$> getAttr s of
Nothing -> return svg
Just paths -> renderClips paths
where
renderClips :: [Path R2] -> SvgRenderM
renderClips [] = return $ svg
renderClips :: SVGFloat n => [Path V2 n] -> SvgRenderM
renderClips [] = return svg
renderClips (p:ps) = do
clipPathId += 1
id_ <- use clipPathId
R.renderClip p id_ <$> renderClips ps

-- | Create a new texture defs svg element using the style and the current
-- id number, then increment the gradient id number.
fillTextureDefs :: Style v -> SvgRenderM
fillTextureDefs :: SVGFloat n => Style v n -> SvgRenderM
fillTextureDefs s = do
id_ <- use fillGradId
fillGradId += 2 -- always even
return $ R.renderFillTextureDefs id_ s

lineTextureDefs :: Style v -> SvgRenderM
lineTextureDefs :: SVGFloat n => Style v n -> SvgRenderM
lineTextureDefs s = do
id_ <- use lineGradId
lineGradId += 2 -- always odd
return $ R.renderLineTextureDefs id_ s

instance Backend SVG R2 where
data Render SVG R2 = R SvgRenderM
type Result SVG R2 = S.Svg
data Options SVG R2 = SVGOptions
{ _size :: SizeSpec2D -- ^ The requested size.
, _svgDefinitions :: Maybe S.Svg
instance SVGFloat n => Backend SVG V2 n where
data Render SVG V2 n = R SvgRenderM
type Result SVG V2 n = S.Svg
data Options SVG V2 n = SVGOptions
{ _size :: SizeSpec2D n -- ^ The requested size.
, _svgDefinitions :: Maybe S.Svg
-- ^ Custom definitions that will be added to the @defs@
-- section of the output.
}
}

renderRTree _ opts rt = evalState svgOutput initialSvgRenderState
where
svgOutput = do
let R r = toRender rt
(w,h) = sizePair (opts^.size)
let R r = toRender rt
(w,h) = sizePair (opts^.sizeSpec)
svg <- r
return $ R.svgHeader w h (opts^.svgDefinitions) $ svg
return $ R.svgHeader w h (opts^.svgDefinitions) svg

adjustDia c opts d = adjustDia2D size c opts (d # reflectY)
adjustDia c opts d = adjustDia2D sizeSpec c opts (d # reflectY)

toRender :: RTree SVG R2 Annotation -> Render SVG R2
toRender :: forall n. SVGFloat n => RTree SVG V2 n Annotation -> Render SVG V2 n
toRender = fromRTree
. Node (RStyle (mempty # recommendFillColor (transparent :: AlphaColour Double)))
. (:[])
Expand All @@ -237,10 +245,11 @@ toRender = fromRTree

-- save current setting for local text
oldIsLocal <- use isLocalText

-- check if this style speficies a font size in Local units
case getFontSizeIsLocal <$> getAttr sty of
Nothing -> return ()
Just isLocal -> isLocalText .= isLocal
F.mapM_ (assign isLocalText)
((getFontSizeIsLocal :: FontSize n -> Bool) <$> getAttr sty)

-- render subtrees
svg <- r
-- restore the old setting for local text
Expand All @@ -256,25 +265,25 @@ toRender = fromRTree
(textureDefs `mappend` clippedSvg)
fromRTree (Node _ rs) = foldMap fromRTree rs

getSize :: Options SVG R2 -> SizeSpec2D
getSize :: SVGFloat n => Options SVG V2 n -> SizeSpec2D n
getSize (SVGOptions {_size = s}) = s

setSize :: Options SVG R2 -> SizeSpec2D -> Options SVG R2
setSize :: SVGFloat n => Options SVG V2 n -> SizeSpec2D n -> Options SVG V2 n
setSize o s = o {_size = s}

size :: Lens' (Options SVG R2) SizeSpec2D
size = lens getSize setSize
sizeSpec :: SVGFloat n => Lens' (Options SVG V2 n) (SizeSpec2D n)
sizeSpec = lens getSize setSize

getSVGDefs :: Options SVG R2 -> Maybe S.Svg
getSVGDefs :: SVGFloat n => Options SVG V2 n -> Maybe S.Svg
getSVGDefs (SVGOptions {_svgDefinitions = d}) = d

setSVGDefs :: Options SVG R2 -> Maybe S.Svg -> Options SVG R2
setSVGDefs :: SVGFloat n => Options SVG V2 n -> Maybe S.Svg -> Options SVG V2 n
setSVGDefs o d = o {_svgDefinitions = d}

svgDefinitions :: Lens' (Options SVG R2) (Maybe S.Svg)
svgDefinitions :: SVGFloat n => Lens' (Options SVG V2 n) (Maybe S.Svg)
svgDefinitions = lens getSVGDefs setSVGDefs

instance Hashable (Options SVG R2) where
instance (Hashable n, SVGFloat n) => Hashable (Options SVG V2 n) where
hashWithSalt s (SVGOptions sz defs) =
s `hashWithSalt` sz `hashWithSalt` defs

Expand Down Expand Up @@ -334,40 +343,40 @@ instance Hashable (MarkupM a) where
m
hashWithSalt s Empty = s `hashWithSalt` (8 :: Int)

instance Renderable (Path R2) SVG where
instance SVGFloat n => Renderable (Path V2 n) SVG where
render _ = R . return . R.renderPath

instance Renderable Text SVG where
instance SVGFloat n => Renderable (Text n) SVG where
render _ t = R $ do
isLocal <- use isLocalText
return $ R.renderText isLocal t

instance Renderable (DImage Embedded) SVG where
instance SVGFloat n => Renderable (DImage n Embedded) SVG where
render _ = R . return . R.renderDImageEmb

-- TODO: instance Renderable Image SVG where

-- | Render a diagram as an SVG, writing to the specified output file
-- and using the requested size.
renderSVG :: FilePath -> SizeSpec2D -> Diagram SVG R2 -> IO ()
renderSVG outFile sizeSpec
renderSVG :: SVGFloat n => FilePath -> SizeSpec2D n -> Diagram SVG V2 n -> IO ()
renderSVG outFile szSpec
= BS.writeFile outFile
. renderSvg
. renderDia SVG (SVGOptions sizeSpec Nothing)
. renderDia SVG (SVGOptions szSpec Nothing)

-- | Render a diagram as a pretty printed SVG.
renderPretty :: FilePath -> SizeSpec2D -> Diagram SVG R2 -> IO ()
renderPretty outFile sizeSpec
renderPretty :: SVGFloat n => FilePath -> SizeSpec2D n -> Diagram SVG V2 n -> IO ()
renderPretty outFile szSpec
= writeFile outFile
. Pretty.renderSvg
.renderDia SVG (SVGOptions sizeSpec Nothing)
. renderDia SVG (SVGOptions szSpec Nothing)



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

-- | Load images (JPG/PNG/...) in a SVG specific way.
loadImageSVG :: FilePath -> IO (Diagram SVG R2)
loadImageSVG :: SVGFloat n => FilePath -> IO (Diagram SVG V2 n)
loadImageSVG fp = do
raw <- SBS.readFile fp
dyn <- eIO $ decodeImage raw
Expand All @@ -377,19 +386,18 @@ loadImageSVG fp = do
if jpgHeader `SBS.isPrefixOf` raw then pic 'J' dat else do
case dyn of
(ImageYCbCr8 _) -> pic 'J' dat
_ -> pic 'P' =<< (eIO $ encodeDynamicPng dyn)
_ -> pic 'P' =<< eIO (encodeDynamicPng dyn)
where pngHeader :: SBS.ByteString
pngHeader = SBS.pack [137, 80, 78, 71, 13, 10, 26, 10]
jpgHeader :: SBS.ByteString
jpgHeader = SBS.pack [0xFF, 0xD8]
eIO :: Either String a -> IO a
eIO = either fail return

instance Renderable (DImage (Native Img)) SVG where
instance SVGFloat n => Renderable (DImage n (Native Img)) SVG where
render _ di@(DImage (ImageNative (Img t d)) _ _ _) = R $ do
mime <- case t of
'J' -> return "image/jpeg"
'P' -> return "image/png"
_ -> fail "Unknown mime type while rendering image"
return $ R.renderDImage di $ R.dataUri mime d