Font embedding changes

src/Diagrams/Backend/SVG.hs

@@ -97,6 +97,7 @@ import           Data.Monoid.Split            (Split (..))
 import           Text.Blaze.Svg.Renderer.Utf8 (renderSvg)
 import           Text.Blaze.Svg11             ((!))
 import qualified Text.Blaze.Svg11             as S
+import qualified Text.Blaze.Svg.Renderer.String as StringSvg
 
 -- from this package
 import qualified Graphics.Rendering.SVG       as R
@@ -136,20 +137,29 @@ renderStyledGroup ignFill s = S.g ! R.renderStyles ignFill s
 
 renderSvgWithClipping :: S.Svg             -- ^ Input SVG
                       -> Style v           -- ^ Styles
-                      -> Int               -- ^ Clip Path ID
                       -> Transformation R2 -- ^ Freeze transform
-                      -> S.Svg             -- ^ Resulting svg
-renderSvgWithClipping svg s id_ t = do
-  R.renderClip (transform (inv t) <$> getClip <$> getAttr s) id_  -- Clipping if any
-  svg                                       -- The diagram
+                      -> SvgRenderM        -- ^ Resulting svg
+renderSvgWithClipping svg s t =
+  case (transform (inv t) <$> getClip <$> getAttr s) of
+    Nothing -> return $ svg
+    Just paths -> renderClips paths
+  where
+    renderClips :: [Path R2] -> SvgRenderM
+    renderClips [] = return $ svg
+    renderClips (p:ps) = do
+      incrementClipPath
+      id_ <- gets clipPathId
+      R.renderClip p id_ <$> renderClips ps
 
 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
+                          -- ^ Custom definitions that will be added to the @defs@ 
+                          --   section of the output.
                         }
-                        deriving Show
 
   -- | Here the SVG backend is different from the other backends.  We
   --   give a different definition of renderDia, where only the
@@ -159,27 +169,25 @@ instance Backend SVG R2 where
   --   primitives.
   withStyle _ s t (R r) =
     R $ do
-      incrementClipPath
       setIgnoreFill False
-      clipPathId_ <- gets clipPathId
       svg <- r
       ign <- gets ignoreFill
-      let styledSvg = renderStyledGroup ign s ! (R.renderClipPathId s clipPathId_) $
-                        renderSvgWithClipping svg s clipPathId_ t
+      clippedSvg <- renderSvgWithClipping svg s t
+      let styledSvg = renderStyledGroup ign s clippedSvg
       -- This is where the frozen transformation is applied.
       return (R.renderTransform t styledSvg)
 
-  doRender _ (SVGOptions sz) (R r) =
+  doRender _ opts (R r) =
     evalState svgOutput initialSvgRenderState
    where
     svgOutput = do
       svg <- r
-      let (w,h) = case sz of
+      let (w,h) = case size opts of
                     Width w'   -> (w',w')
                     Height h'  -> (h',h')
                     Dims w' h' -> (w',h')
                     Absolute   -> (100,100)
-      return $ R.svgHeader w h $ svg
+      return $ R.svgHeader w h (svgDefinitions opts) $ svg
 
   adjustDia c opts d = adjustDia2D size setSvgSize c opts
                          (d # reflectY
@@ -204,6 +212,19 @@ instance Backend SVG R2 where
               -- implementation: "t2" instead of "t1 <> t2".
               = withStyle SVG s t1 (render SVG (transform t2 p))
 
+instance Show (Options SVG R2) where
+  show opts = concat $
+            [ "SVGOptions { "
+            , "size = "
+            , show $ size opts
+            , " , "
+            , "svgDefinitions = "
+            , case svgDefinitions opts of
+                Nothing -> "Nothing"
+                Just svg -> "Just " ++ StringSvg.renderSvg svg
+            , " }"
+            ]
+
 instance Renderable (Segment Closed R2) SVG where
   render c = render c . (fromSegments :: [Segment Closed R2] -> Path R2) . (:[])
 
@@ -229,4 +250,4 @@ renderSVG :: FilePath -> SizeSpec2D -> Diagram SVG R2 -> IO ()
 renderSVG outFile sizeSpec
   = BS.writeFile outFile
   . renderSvg
-  . renderDia SVG (SVGOptions sizeSpec)
+  . renderDia SVG (SVGOptions sizeSpec Nothing)

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) 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

@@ -20,33 +20,38 @@ module Graphics.Rendering.SVG
     ( svgHeader
     , renderPath
     , renderClip
-    , renderClipPathId
     , renderText
     , renderStyles
     , renderTransform
+    , renderMiterLimit
     ) where
 
 -- from base
 import           Data.List                   (intercalate, intersperse)
 
 -- from diagrams-lib
 import           Diagrams.Prelude            hiding (Attribute, Render, e, (<>))
-import           Diagrams.TwoD.Path          (getClip, getFillRule)
+import           Diagrams.TwoD.Path          (getFillRule)
 import           Diagrams.TwoD.Text
 
 -- from blaze-svg
 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 :: Double -> Double -> S.Svg -> S.Svg
-svgHeader w h_ s =  S.docTypeSvg
+-- | @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
   ! A.version "1.1"
   ! A.width    (S.toValue w)
   ! A.height   (S.toValue h_)
   ! A.fontSize "1"
-  ! A.viewbox (S.toValue $ concat . intersperse " " $ map show ([0, 0, round w, round h_] :: [Int])) $
-     S.g $ s
+  ! A.viewbox (S.toValue $ concat . intersperse " " $ map show ([0, 0, round w, round h_] :: [Int])) 
+  $ do case defines of 
+         Nothing -> return ()
+         Just defs -> S.defs $ defs
+       S.g $ s
 
 renderPath :: Path R2 -> S.Svg
 renderPath (Path trs)  = S.path ! A.d makePath
@@ -68,11 +73,12 @@ renderSeg (Cubic  (unr2 -> (x0,y0))
                   (OffsetClosed (unr2 -> (x2,y2))))
   = cr x0 y0 x1 y1 x2 y2
 
-renderClip :: Maybe [Path R2] -> Int -> S.Svg
-renderClip Nothing _       = mempty
-renderClip (Just pths) id_ = S.clippath ! A.id_ clipPathId $ renderClipPaths
-  where renderClipPaths = mapM_ renderPath pths
-        clipPathId      = S.toValue $ "myClip" ++ show id_
+renderClip :: Path R2 -> Int -> S.Svg -> S.Svg
+renderClip p id_ svg = do 
+  S.g ! A.clipPath (S.toValue $ "url(#" ++ clipPathId id_ ++ ")") $ do 
+    S.clippath ! A.id_ (S.toValue $ clipPathId id_) $ renderPath p
+    svg
+  where clipPathId i = "myClip" ++ show i
 
 renderText :: Text -> S.Svg
 renderText (Text tr tAlign str) =
@@ -127,7 +133,12 @@ renderStyles ignoreFill s = mconcat . map ($ s) $
   , renderFontSlant
   , renderFontWeight
   , renderFontFamily
+  , renderMiterLimit
   ]
+
+renderMiterLimit :: Style v -> S.Attribute
+renderMiterLimit s = renderAttr A.strokeMiterlimit miterLimit
+ where miterLimit = getLineMiterLimit <$> getAttr s
 
 renderLineColor :: Style v -> S.Attribute
 renderLineColor s =
@@ -216,14 +227,6 @@ renderFontFamily s = renderAttr A.fontFamily fontFamily_
  where
   fontFamily_ = getFont <$> getAttr s
 
-renderClipPathId :: Style v -> Int -> S.Attribute
-renderClipPathId s id_ = renderAttr A.clipPath clipPathId
- where
-  clipPathId :: Maybe String
-  clipPathId = case getClip <$> getAttr s of
-                 Nothing -> Nothing
-                 Just _ -> Just ("url(#myClip" ++ show id_ ++ ")")
-
 -- | Render a style attribute if available, empty otherwise.
 renderAttr :: S.ToValue s => (S.AttributeValue -> S.Attribute)
            -> Maybe s