Skip to content

Commit

Permalink
Merge pull request #61 from diagrams/linear
Browse files Browse the repository at this point in the history 
Migrate from `vector-space` package to `linear`

Make types more polymorphic.
  • Loading branch information
@bergey
bergey committed Oct 10, 2014
2 parents 9e28b4e + c7e7366 commit 10b1bdf
Show file tree
Hide file tree
Showing 4 changed files with 191 additions and 170 deletions.
1 change: 0 additions & 1 deletion diagrams-svg.cabal
View file
Expand Up @@ -48,7 +48,6 @@ Library
, mtl >= 1 && < 2.3
, bytestring >= 0.9 && < 1.0
, base64-bytestring >= 1 && < 1.1
, vector-space >= 0.7 && < 0.9
, colour
, diagrams-core >= 1.2 && < 1.3
, diagrams-lib >= 1.2 && < 1.3
Expand Down
108 changes: 58 additions & 50 deletions src/Diagrams/Backend/SVG.hs
View file
@@ -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)
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

0 comments on commit 10b1bdf

Please sign in to comment.