Initial attempts at embedded image support for SVG backend

See #11.  Does not actually work yet.

Note this means the SVG render monad now has to involve IO (in order
to read in the external image data), which makes me a little sad.

diagrams-svg.cabal

@@ -47,6 +47,7 @@ Library
                      , filepath
                      , mtl           >= 1     && < 2.2
                      , bytestring    >= 0.9   && < 1.0
+                     , base64-bytestring >= 1 && < 1.1
                      , vector-space  >= 0.7   && < 0.9
                      , colour
                      , diagrams-core >= 0.7   && < 0.8

examples/Image.hs

@@ -0,0 +1,10 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+
+import           Diagrams.Backend.SVG.CmdLine
+import           Diagrams.Prelude
+
+no = (circle 1 <> hrule 2 # rotateBy (1/8))
+   # lw 0.2 # lc red
+example = no <> image "phone.png" 1.5 1.5
+
+main = defaultMain (example # centerXY # pad 1.1)

src/Diagrams/Backend/SVG.hs

@@ -121,12 +121,12 @@ initialSvgRenderState = SvgRenderState 0 False
 -- | Monad to keep track of state when rendering an SVG.
 --   Currently just keeps a monotonically increasing counter
 --   for assiging a unique clip path ID.
-type SvgRenderM = State SvgRenderState S.Svg
+type SvgRenderM = StateT SvgRenderState IO S.Svg
 
-incrementClipPath :: State SvgRenderState ()
+incrementClipPath :: StateT SvgRenderState IO ()
 incrementClipPath = modify (\st -> st { clipPathId = clipPathId st + 1 })
 
-setIgnoreFill :: Bool -> State SvgRenderState ()
+setIgnoreFill :: Bool -> StateT SvgRenderState IO ()
 setIgnoreFill b = modify (\st -> st { ignoreFill = b })
 
 instance Monoid (Render SVG R2) where
@@ -159,7 +159,7 @@ renderSvgWithClipping svg s t =
 
 instance Backend SVG R2 where
   data Render  SVG R2 = R SvgRenderM
-  type Result  SVG R2 = S.Svg
+  type Result  SVG R2 = IO S.Svg
   data Options SVG R2 = SVGOptions
                         { size :: SizeSpec2D   -- ^ The requested size.
                         , svgDefinitions :: Maybe S.Svg
@@ -184,7 +184,7 @@ instance Backend SVG R2 where
       return (R.renderTransform t styledSvg)
 
   doRender _ opts (R r) =
-    evalState svgOutput initialSvgRenderState
+    evalStateT svgOutput initialSvgRenderState
    where
     svgOutput = do
       svg <- r
@@ -247,13 +247,12 @@ instance Renderable (Path R2) SVG where
 instance Renderable Text SVG where
   render _ = R . return . R.renderText
 
--- TODO: instance Renderable Image SVG where
-
+instance Renderable Image SVG where
+  render _ = R . liftIO . R.renderImage
 
 -- | 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
-  = BS.writeFile outFile
-  . renderSvg
-  . renderDia SVG (SVGOptions sizeSpec Nothing)
+renderSVG outFile sizeSpec dia = do
+  svg <- renderDia SVG (SVGOptions sizeSpec Nothing) dia
+  BS.writeFile outFile (renderSvg svg)

src/Diagrams/Backend/SVG/CmdLine.hs

@@ -156,7 +156,7 @@ chooseRender opts d =
                             (Just w, Just h)   -> Dims (fromIntegral w)
                                                        (fromIntegral h)
 
-               build = renderDia SVG (SVGOptions sizeSpec Nothing) d
+           build <- renderDia SVG (SVGOptions sizeSpec Nothing) d
            BS.writeFile (output opts) (renderSvg build)
        | otherwise -> putStrLn $ "Unknown file type: " ++ last ps
 

src/Graphics/Rendering/SVG.hs

@@ -21,6 +21,7 @@ module Graphics.Rendering.SVG
     , renderPath
     , renderClip
     , renderText
+    , renderImage
     , renderStyles
     , renderTransform
     , renderMiterLimit
@@ -34,6 +35,7 @@ import           Control.Lens
 
 -- from diagrams-lib
 import           Diagrams.Prelude            hiding (Attribute, Render, e, (<>))
+import           Diagrams.TwoD.Image
 import           Diagrams.TwoD.Path          (getFillRule)
 import           Diagrams.TwoD.Text
 
@@ -42,7 +44,11 @@ import           Text.Blaze.Svg11            (cr, hr, lr, m, mkPath, vr, z, (!))
 import qualified Text.Blaze.Svg11            as S
 import qualified Text.Blaze.Svg11.Attributes as A
 
--- | @svgHeader w h defs s@: @w@ width, @h@ height, 
+import qualified Data.ByteString.Base64.Lazy as BS64
+import qualified Data.ByteString.Lazy        as BS
+import qualified Data.ByteString.Lazy.Char8  as BS8
+
+-- | @svgHeader w h defs s@: @w@ width, @h@ height,
 --   @defs@ global definitions for defs sections, @s@ actual SVG content.
 svgHeader :: Double -> Double -> Maybe S.Svg -> S.Svg -> S.Svg
 svgHeader w h_ defines s =  S.docTypeSvg
@@ -108,6 +114,21 @@ renderText (Text tr tAlign str) =
   (a,b,c,d,e,f)       = getMatrix t
   transformMatrix     =  S.matrix a b c d e f
 
+renderImage :: Image -> IO S.Svg
+renderImage (Image file sz tr) = do
+  img <- BS.readFile file  -- XXX need to catch exceptions
+  return $
+    S.image
+      ! A.transform transformMatrix
+--    ! A.width  -- XXX
+--    ! A.height -- XXX
+      ! A.xlinkHref (S.preEscapedToValue (mkDataURI img))
+  where
+    (a,b,c,d,e,f)       = getMatrix tr
+    transformMatrix     =  S.matrix a b c d e f
+    mkDataURI dat       = "data:image/png;base64," ++ BS8.unpack (BS64.encode dat)
+      -- XXX allow things other than png
+
 getMatrix :: Transformation R2 -> (Double, Double, Double, Double, Double, Double)
 getMatrix t = (a1,a2,b1,b2,c1,c2)
  where