Chart-diagrams 1.0 → 1.1
raw patch · 2 files changed
+382/−123 lines, 2 filesdep +lensdep +textdep ~Chartdep ~SVGFontsdep ~colour
Dependencies added: lens, text
Dependency ranges changed: Chart, SVGFonts, colour, diagrams-core, diagrams-lib, diagrams-postscript, diagrams-svg, operational
Files
- Chart-diagrams.cabal +12/−10
- Graphics/Rendering/Chart/Backend/Diagrams.hs +370/−113
Chart-diagrams.cabal view
@@ -1,5 +1,5 @@ Name: Chart-diagrams-Version: 1.0+Version: 1.1 License: BSD3 License-file: LICENSE Copyright: Jan Bracker, 2006-2010@@ -28,18 +28,20 @@ Build-depends: base >= 3 && < 5 , old-locale , time, mtl- , diagrams-core >= 0.7- , diagrams-lib >= 0.7- , diagrams-svg >= 0.7- , diagrams-postscript >= 0.7- , SVGFonts >= 1.3- , colour >= 2.2.1+ , diagrams-core >= 0.7 && < 0.8+ , diagrams-lib >= 0.7 && < 0.8+ , diagrams-svg >= 0.8 && < 0.9+ , diagrams-postscript >= 0.7 && < 0.8+ , SVGFonts >= 1.4 && < 1.5+ , colour >= 2.2.1 && < 2.4 , blaze-svg >= 0.3.3- , bytestring >= 0.9 && < 1.0- , operational >= 0.2.2+ , bytestring >= 0.9 && < 1.0+ , operational >= 0.2.2 && < 0.3 , containers >= 0.4 && < 0.6 , data-default-class < 0.1- , Chart >= 1.0+ , lens >= 3.9 && < 3.11+ , Chart >= 1.1 && < 1.2+ , text other-modules: Paths_Chart_diagrams Exposed-modules: Graphics.Rendering.Chart.Backend.Diagrams
Graphics/Rendering/Chart/Backend/Diagrams.hs view
@@ -1,6 +1,6 @@- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-} -- | The backend to render charts with the diagrams library. module Graphics.Rendering.Chart.Backend.Diagrams@@ -9,14 +9,36 @@ , defaultEnv , customFontEnv , DEnv(..), DFont- , renderableToEPSFile- , renderableToEPSFile'++ -- * File Output Functons+ , FileFormat(..)+ , FileOptions(..)+ , fo_size+ , fo_format+ , fo_customFonts+ , renderableToFile+ , cBackendToFile++ -- * EPS Utility Functions+ , cBackendToEPSFile+ , renderableToEPSFile -- deprecated+ , renderableToEPSFile' -- deprecated+ + -- * SVG Utility Functions+ , cBackendToSVG+ , cBackendToEmbeddedFontSVG , renderableToSVG , renderableToSVG'- , renderableToSVGFile- , renderableToSVGFile'+ , renderableToSVGFile -- deprecated+ , renderableToSVGFile' -- deprecated , renderableToSVGString , renderableToSVGString'+ + -- * SVG Embedded Font Utility Functions+ , renderableToEmbeddedFontSVG+ , renderableToEmbeddedFontSVG'+ , renderableToEmbeddedFontSVGFile -- deprecated+ , renderableToEmbeddedFontSVGFile' -- deprecated ) where import Data.Default.Class@@ -26,9 +48,13 @@ import Data.Monoid import Data.Traversable import qualified Data.Map as M+import qualified Data.Set as S import qualified Data.ByteString.Lazy as BS+import qualified Data.Text as T +import Control.Lens(makeLenses) import Control.Monad.Operational+import Control.Monad.State.Lazy import Diagrams.Core.Transform ( Transformation(..) ) import Diagrams.Prelude @@ -42,13 +68,16 @@ import qualified Diagrams.Prelude as D import qualified Diagrams.TwoD as D2 import qualified Diagrams.TwoD.Arc as D2+import qualified Diagrams.TwoD.Text as D2 import qualified Diagrams.Backend.Postscript as DEPS import qualified Diagrams.Backend.SVG as DSVG import Text.Blaze.Svg.Renderer.Utf8 ( renderSvg )-import qualified Text.Blaze.Svg11 as S+import qualified Text.Blaze.Svg11 as Svg +import qualified Graphics.SVGFonts.CharReference as F import qualified Graphics.SVGFonts.ReadFont as F+import Graphics.SVGFonts.WriteFont ( makeSvgFont ) import Graphics.Rendering.Chart.Backend as G import Graphics.Rendering.Chart.Backend.Impl@@ -60,11 +89,57 @@ import Paths_Chart_diagrams ( getDataFileName ) -- -------------------------------------------------------------------------- General Utility Functions+-- General purpose file output function -- ----------------------------------------------------------------------- ++-- | The file output format:+-- EPS -> Embedded Postscript+-- SVG -> SVG with text rendered as stroked paths+-- SVG -> SVG with embedded font information and text rendered as text operations+data FileFormat = EPS+ | SVG+ | SVG_EMBEDDED++data FileOptions = FileOptions {+ _fo_size :: (Double,Double),+ _fo_format :: FileFormat,+ _fo_customFonts :: M.Map (String, FontSlant, FontWeight) FilePath+}++-- | Generate an image file for the given renderable, at the specified path. Size, format,+-- and text rendering mode are all set through the `FileOptions` parameter.+renderableToFile :: FileOptions -> Renderable a -> FilePath -> IO (PickFn a)+renderableToFile fo r path = cBackendToFile fo cb path+ where+ cb = render r (_fo_size fo)++-- | Generate an image file for the given drawing instructions, at the specified path. Size and+-- format are set through the `FileOptions` parameter.+cBackendToFile :: FileOptions -> ChartBackend a -> FilePath -> IO a+cBackendToFile fo cb path = do+ env <- customFontEnv vectorAlignmentFns w h (_fo_customFonts fo)+ case _fo_format fo of+ EPS -> do+ cBackendToEPSFile cb env path+ SVG -> do+ let (svg, a) = cBackendToSVG cb env+ BS.writeFile path (renderSvg svg)+ return a+ SVG_EMBEDDED -> do+ let (svg,a) = cBackendToEmbeddedFontSVG cb env+ BS.writeFile path (renderSvg svg)+ return a+ where+ (w,h) = _fo_size fo++-- -----------------------------------------------------------------------+-- SVG Utility Functions+-- -----------------------------------------------------------------------+ -- | Output the given renderable to a SVG file of the specifed size -- (in points), to the specified file using the default environment.+{-# DEPRECATED renderableToSVGFile "use renderToFile" #-} renderableToSVGFile :: Renderable a -> Double -> Double -> FilePath -> IO (PickFn a) renderableToSVGFile r w h file = do (svg, x) <- renderableToSVGString r w h@@ -72,6 +147,7 @@ return x -- | Output the given renderable to a SVG file using the given environment.+{-# DEPRECATED renderableToSVGFile' "use renderToFile" #-} renderableToSVGFile' :: Renderable a -> DEnv -> FilePath -> IO (PickFn a) renderableToSVGFile' r env file = do let (svg, x) = renderableToSVGString' r env@@ -93,26 +169,102 @@ -- | Output the given renderable as a SVG of the specifed size -- (in points) using the default environment.-renderableToSVG :: Renderable a -> Double -> Double -> IO (S.Svg, PickFn a)++renderableToSVG :: Renderable a -> Double -> Double -> IO (Svg.Svg, PickFn a) renderableToSVG r w h = do- env <- defaultEnv vectorAlignmentFns w h- return $ renderableToSVG' r env+ env <- defaultEnv vectorAlignmentFns w h+ return $ renderableToSVG' r env -- | Output the given renderable as a SVG using the given environment.-renderableToSVG' :: Renderable a -> DEnv -> (S.Svg, PickFn a)+renderableToSVG' :: Renderable a -> DEnv -> (Svg.Svg, PickFn a) renderableToSVG' r env = let (w, h) = envOutputSize env (d, x) = runBackendR env r- svg = D.renderDia DSVG.SVG (DSVG.SVGOptions $ D2.Dims w h) d+ svg = D.renderDia DSVG.SVG (DSVG.SVGOptions (D2.Dims w h) Nothing) d in (svg, x) +-- -----------------------------------------------------------------------+-- SVG Embedded Font Utility Functions+-- -----------------------------------------------------------------------++-- | Output the given renderable to a SVG file of the specifed size+-- (in points), to the specified file using the default environment.+-- Font are embedded to save space.+{-# DEPRECATED renderableToEmbeddedFontSVGFile "use renderToFile" #-}+renderableToEmbeddedFontSVGFile :: Renderable a -> Double -> Double -> FilePath -> IO (PickFn a)+renderableToEmbeddedFontSVGFile r w h file = do+ (svg, x) <- renderableToEmbeddedFontSVG r w h+ BS.writeFile file $ renderSvg svg+ return x++-- | Output the given renderable to a SVG file using the given environment.+-- Font are embedded to save space.+{-# DEPRECATED renderableToEmbeddedFontSVGFile' "use renderToFile" #-}+renderableToEmbeddedFontSVGFile' :: Renderable a -> DEnv -> FilePath -> IO (PickFn a)+renderableToEmbeddedFontSVGFile' r env file = do+ let (svg, x) = renderableToEmbeddedFontSVG' r env+ BS.writeFile file $ renderSvg svg+ return x++-- | Output the given renderable as a SVG of the specifed size+-- (in points) using the default environment.+-- Font are embedded to save space.+renderableToEmbeddedFontSVG :: Renderable a -> Double -> Double -> IO (Svg.Svg, PickFn a)+renderableToEmbeddedFontSVG r w h = do+ env <- defaultEnv vectorAlignmentFns w h+ return $ renderableToEmbeddedFontSVG' r env++-- | Output the given renderable as a SVG using the given environment.+-- Font are embedded to save space.+renderableToEmbeddedFontSVG' :: Renderable a -> DEnv -> (Svg.Svg,PickFn a)+renderableToEmbeddedFontSVG' r env = cBackendToEmbeddedFontSVG (render r size) env+ where+ size = envOutputSize env++cBackendToEPSFile :: ChartBackend a -> DEnv -> FilePath -> IO a+cBackendToEPSFile cb env path = do+ let (w, h) = envOutputSize env+ (d, a) = runBackend env cb+ psOpts = DEPS.PostscriptOptions path (D2.Dims w h) DEPS.EPS+ D.renderDia DEPS.Postscript psOpts d+ return a+ +cBackendToSVG :: ChartBackend a -> DEnv -> (Svg.Svg,a)+cBackendToSVG cb env = (svg,a)+ where+ (w, h) = envOutputSize env+ (d, a) = runBackend env cb+ svg = D.renderDia DSVG.SVG (DSVG.SVGOptions (D2.Dims w h) Nothing) d++cBackendToEmbeddedFontSVG :: ChartBackend a -> DEnv -> (Svg.Svg,a)+cBackendToEmbeddedFontSVG cb env = (svg, x)+ where+ (w, h) = envOutputSize env+ (d, x, gs) = runBackendWithGlyphs env cb+ fontDefs = Just $ forM_ (M.toList gs) $ \((fFam, fSlant, fWeight), usedGs) -> do+ let fs = envFontStyle env+ let font = envSelectFont env $ fs { _font_name = fFam+ , _font_slant = fSlant+ , _font_weight = fWeight + }+ makeSvgFont font usedGs+ -- M.Map (String, FontSlant, FontWeight) (S.Set String)+ -- makeSvgFont :: (FontData, OutlineMap) -> Set.Set String -> S.Svg+ svg = D.renderDia DSVG.SVG (DSVG.SVGOptions (D2.Dims w h) fontDefs) d++-- -----------------------------------------------------------------------+-- EPS Utility Functions+-- -----------------------------------------------------------------------+ -- | Output the given renderable to a EPS file using the default environment.+{-# DEPRECATED renderableToEPSFile "use renderToFile" #-} renderableToEPSFile :: Renderable a -> Double -> Double -> FilePath -> IO (PickFn a) renderableToEPSFile r w h file = do env <- defaultEnv vectorAlignmentFns w h renderableToEPSFile' r env file -- | Output the given renderable to a EPS file using the given environment.+{-# DEPRECATED renderableToEPSFile' "use renderToFile" #-} renderableToEPSFile' :: Renderable a -> DEnv -> FilePath -> IO (PickFn a) renderableToEPSFile' r env file = do let (w, h) = envOutputSize env@@ -135,11 +287,15 @@ , envFontStyle :: FontStyle -- ^ The current/initial font style. , envSelectFont :: FontStyle -> DFont -- ^ The font selection function. , envOutputSize :: (Double, Double) -- ^ The size of the rendered output.+ , envUsedGlyphs :: M.Map (String, FontSlant, FontWeight) (S.Set String)+ -- ^ The map of all glyphs that are used from a specific font. } -- | A font a delivered by SVGFonts. type DFont = (F.FontData, F.OutlineMap) +type DState a = State DEnv a+ defaultFonts :: IO (FontStyle -> DFont) defaultFonts = do serifR <- loadDefaultFont "fonts/LinLibertine_R.svg"@@ -155,26 +311,49 @@ let selectFont :: FontStyle -> DFont selectFont fs = case (_font_name fs, _font_slant fs, _font_weight fs) of- ("serif", FontSlantNormal , FontWeightNormal) -> serifR- ("serif", FontSlantNormal , FontWeightBold ) -> serifRB- ("serif", FontSlantItalic , FontWeightNormal) -> serifRI- ("serif", FontSlantOblique, FontWeightNormal) -> serifRI- ("serif", FontSlantItalic , FontWeightBold ) -> serifRBI- ("serif", FontSlantOblique, FontWeightBold ) -> serifRBI+ ("serif", FontSlantNormal , FontWeightNormal) -> alterFontFamily "serif" serifR+ ("serif", FontSlantNormal , FontWeightBold ) -> alterFontFamily "serif" serifRB+ ("serif", FontSlantItalic , FontWeightNormal) -> alterFontFamily "serif" serifRI+ ("serif", FontSlantOblique, FontWeightNormal) -> alterFontFamily "serif" serifRI+ ("serif", FontSlantItalic , FontWeightBold ) -> alterFontFamily "serif" serifRBI+ ("serif", FontSlantOblique, FontWeightBold ) -> alterFontFamily "serif" serifRBI - ("sans-serif", FontSlantNormal , FontWeightNormal) -> sansR- ("sans-serif", FontSlantNormal , FontWeightBold ) -> sansRB- ("sans-serif", FontSlantItalic , FontWeightNormal) -> sansRI- ("sans-serif", FontSlantOblique, FontWeightNormal) -> sansRI- ("sans-serif", FontSlantItalic , FontWeightBold ) -> sansRBI- ("sans-serif", FontSlantOblique, FontWeightBold ) -> sansRBI+ ("sans-serif", FontSlantNormal , FontWeightNormal) -> alterFontFamily "sans-serif" sansR+ ("sans-serif", FontSlantNormal , FontWeightBold ) -> alterFontFamily "sans-serif" sansRB+ ("sans-serif", FontSlantItalic , FontWeightNormal) -> alterFontFamily "sans-serif" sansRI+ ("sans-serif", FontSlantOblique, FontWeightNormal) -> alterFontFamily "sans-serif" sansRI+ ("sans-serif", FontSlantItalic , FontWeightBold ) -> alterFontFamily "sans-serif" sansRBI+ ("sans-serif", FontSlantOblique, FontWeightBold ) -> alterFontFamily "sans-serif" sansRBI - ("monospace", _, FontWeightNormal) -> monoR- ("monospace", _, FontWeightBold ) -> monoRB+ ("monospace", _, FontWeightNormal) -> alterFontFamily "monospace" monoR+ ("monospace", _, FontWeightBold ) -> alterFontFamily "monospace" monoRB + (fam, FontSlantNormal , FontWeightNormal) | fam `isFontFamily` serifR -> serifR+ (fam, FontSlantNormal , FontWeightBold ) | fam `isFontFamily` serifRB -> serifRB+ (fam, FontSlantItalic , FontWeightNormal) | fam `isFontFamily` serifRI -> serifRI+ (fam, FontSlantOblique, FontWeightNormal) | fam `isFontFamily` serifRI -> serifRI+ (fam, FontSlantItalic , FontWeightBold ) | fam `isFontFamily` serifRBI -> serifRBI+ (fam, FontSlantOblique, FontWeightBold ) | fam `isFontFamily` serifRBI -> serifRBI+ + (fam, FontSlantNormal , FontWeightNormal) | fam `isFontFamily` sansR -> sansR+ (fam, FontSlantNormal , FontWeightBold ) | fam `isFontFamily` sansRB -> sansRB+ (fam, FontSlantItalic , FontWeightNormal) | fam `isFontFamily` sansRI -> sansRI+ (fam, FontSlantOblique, FontWeightNormal) | fam `isFontFamily` sansRI -> sansRI+ (fam, FontSlantItalic , FontWeightBold ) | fam `isFontFamily` sansRBI -> sansRBI+ (fam, FontSlantOblique, FontWeightBold ) | fam `isFontFamily` sansRBI -> sansRBI+ + (fam, _, FontWeightNormal) | fam `isFontFamily` monoR -> monoR+ (fam, _, FontWeightBold ) | fam `isFontFamily` monoRB -> monoRB+ (_, slant, weight) -> selectFont (fs { _font_name = "sans-serif" }) return selectFont++alterFontFamily :: String -> DFont -> DFont+alterFontFamily n (fd, om) = (fd { F.fontDataFamily = n }, om)++isFontFamily :: String -> DFont -> Bool+isFontFamily n (fd, _) = n == F.fontDataFamily fd loadDefaultFont :: FilePath -> IO DFont loadDefaultFont file = getDataFileName file >>= return . F.outlMap@@ -199,6 +378,7 @@ Just font -> font Nothing -> selectFont fs , envOutputSize = (w,h)+ , envUsedGlyphs = M.empty } -- | Produce a default environment with the default fonts.@@ -214,8 +394,8 @@ -> Renderable a -- ^ Chart render code. -> (Diagram b R2, PickFn a) -- ^ The diagram. runBackendR env r = - let cr = render r (envOutputSize env)- in runBackend env cr+ let cb = render r (envOutputSize env)+ in runBackend env cb -- | Run this backends renderer. runBackend :: (D.Backend b R2, D.Renderable (D.Path R2) b)@@ -223,105 +403,174 @@ -> ChartBackend a -- ^ Chart render code. -> (Diagram b R2, a) -- ^ The diagram. runBackend env m = - let (d, x) = runBackend' env (withDefaultStyle m)- in (D2.reflectY $ D2.view (p2 (0,0)) (r2 (envOutputSize env)) d, x)+ let (d, x) = evalState (runBackend' TextRenderSvg $ withDefaultStyle m) env+ in (adjustOutputDiagram env d, x) -runBackend' :: (D.Renderable (D.Path R2) b) => DEnv- -> ChartBackend a -> (Diagram b R2, a)-runBackend' env m = eval env (view m)+-- | Run this backends renderer.+runBackendWithGlyphs :: ( D.Backend b R2+ , D.Renderable (D.Path R2) b+ , D.Renderable (D2.Text) b)+ => DEnv -- ^ Environment to start rendering with.+ -> ChartBackend a -- ^ Chart render code.+ -> ( Diagram b R2, a+ , M.Map (String, FontSlant, FontWeight) (S.Set String))+runBackendWithGlyphs env m = + let ((d, x), env') = runState (runBackend' TextRenderNative $ withDefaultStyle m) env+ in (adjustOutputDiagram env d, x, envUsedGlyphs env')++-- | Flag to decide which technique should ne used to render text.+-- The type parameter is the primitive that has to be supported by +-- a backend when rendering text using this technique.+data TextRender a where+ TextRenderNative :: TextRender (D2.Text)+ TextRenderSvg :: TextRender (D.Path R2)++runBackend' :: (D.Renderable (D.Path R2) b, D.Renderable t b) + => TextRender t -> ChartBackend a -> DState (Diagram b R2, a)+runBackend' tr m = eval tr $ view $ m where- eval :: (D.Renderable (D.Path R2) b)- => DEnv -> ProgramView ChartBackendInstr a -> (Diagram b R2, a)- eval env (Return v) = (mempty, v)- eval env (StrokePath p :>>= f) = dStrokePath env p <># step env f- eval env (FillPath p :>>= f) = dFillPath env p <># step env f- eval env (DrawText p s :>>= f) = dDrawText env p s <># step env f- eval env (GetTextSize s :>>= f) = dTextSize env s <>= step env f- eval env (GetAlignments :>>= f) = dAlignmentFns env <>= step env f- eval env (WithTransform m p :>>= f) = dWithTransform env m p <>= step env f- eval env (WithFontStyle fs p :>>= f) = dWithFontStyle env fs p <>= step env f- eval env (WithFillStyle fs p :>>= f) = dWithFillStyle env fs p <>= step env f- eval env (WithLineStyle ls p :>>= f) = dWithLineStyle env ls p <>= step env f- eval env (WithClipRegion r p :>>= f) = dWithClipRegion env r p <>= step env f+ eval :: (D.Renderable (D.Path R2) b, D.Renderable t b)+ => TextRender t -> ProgramView ChartBackendInstr a -> DState (Diagram b R2, a)+ eval tr (Return v) = return (mempty, v)+ eval tr (StrokePath p :>>= f) = dStrokePath p <># step tr f+ eval tr (FillPath p :>>= f) = dFillPath p <># step tr f+ eval tr@TextRenderSvg (DrawText p s :>>= f) = dDrawTextSvg p s <># step tr f+ eval tr@TextRenderNative (DrawText p s :>>= f) = dDrawTextNative p s <># step tr f+ eval tr (GetTextSize s :>>= f) = dTextSize s <>= step tr f+ eval tr (GetAlignments :>>= f) = dAlignmentFns <>= step tr f+ eval tr (WithTransform m p :>>= f) = dWithTransform tr m p <>= step tr f+ eval tr (WithFontStyle fs p :>>= f) = dWithFontStyle tr fs p <>= step tr f+ eval tr (WithFillStyle fs p :>>= f) = dWithFillStyle tr fs p <>= step tr f+ eval tr (WithLineStyle ls p :>>= f) = dWithLineStyle tr ls p <>= step tr f+ eval tr (WithClipRegion r p :>>= f) = dWithClipRegion tr r p <>= step tr f - step :: (D.Renderable (D.Path R2) b)- => DEnv -> (v -> ChartBackend a) -> v -> (Diagram b R2, a)- step env f = \v -> runBackend' env (f v)+ step :: (D.Renderable (D.Path R2) b, D.Renderable t b)+ => TextRender t -> (v -> ChartBackend a) -> v -> DState (Diagram b R2, a)+ step tr f v = runBackend' tr (f v) - (<>#) :: (Monoid m) => m -> (() -> (m, a)) -> (m, a)- (<>#) m f = (m, ()) <>= f+ (<>#) :: (Monad s, Monoid m) => s m -> (() -> s (m, a)) -> s (m, a)+ (<>#) m f = do+ ma <- m+ return (ma, ()) <>= f - (<>=) :: (Monoid m) => (m, a) -> (a -> (m, b)) -> (m, b)- (<>=) (ma, a) f = let (mb, b) = f a- in (mb <> ma, b)+ (<>=) :: (Monad s, Monoid m) => s (m, a) -> (a -> s (m, b)) -> s (m, b)+ (<>=) m f = do+ (ma, a) <- m+ (mb, b) <- f a+ return (mb <> ma, b) +-- | Executes the given state locally, but preserves the changes to the 'envUsedGlyphs'+-- map. Assumes that values are never removed from the map inbetween.+dLocal :: DState a -> DState a+dLocal m = do+ env <- get+ x <- m+ env' <- get+ put $ env { envUsedGlyphs = envUsedGlyphs env' }+ return x+ dStrokePath :: (D.Renderable (D.Path R2) b)- => DEnv -> Path -> Diagram b R2-dStrokePath env p = applyFillStyle noFillStyle $ D.stroke $ convertPath False p+ => Path -> DState (Diagram b R2)+dStrokePath p = return $ applyFillStyle noFillStyle $ D.stroke $ convertPath False p dFillPath :: (D.Renderable (D.Path R2) b)- => DEnv -> Path -> Diagram b R2-dFillPath env p = applyLineStyle noLineStyle $ D.stroke $ convertPath True p+ => Path -> DState (Diagram b R2)+dFillPath p = return $ applyLineStyle noLineStyle $ D.stroke $ convertPath True p dTextSize :: (D.Renderable (D.Path R2) b)- => DEnv -> String -> (Diagram b R2, TextSize)-dTextSize env text = {-# SCC "dTextSize" #-}+ => String -> DState (Diagram b R2, TextSize)+dTextSize text = do+ env <- get let fs = envFontStyle env- (scaledH, scaledA, scaledD, scaledYB) = calcFontMetrics env- in (mempty, TextSize { textSizeWidth = {-# SCC "D2.width" #-} D2.width $ - {-# SCC "F.textSVG'" #-} F.textSVG' $ - {-# SCC "fontStyleToTextOpts" #-} fontStyleToTextOpts env text- , textSizeAscent = scaledA -- scaledH * (a' / h') -- ascent- , textSizeDescent = scaledD -- scaledH * (d' / h') -- descent- , textSizeYBearing = scaledYB -- -scaledH * (capHeight / h)- , textSizeHeight = _font_size $ fs- })+ let (scaledH, scaledA, scaledD, scaledYB) = calcFontMetrics env+ return (mempty, TextSize + { textSizeWidth = D2.width $ F.textSVG' + $ fontStyleToTextOpts env text+ , textSizeAscent = scaledA -- scaledH * (a' / h') -- ascent+ , textSizeDescent = scaledD -- scaledH * (d' / h') -- descent+ , textSizeYBearing = scaledYB -- -scaledH * (capHeight / h)+ , textSizeHeight = _font_size $ fs+ }) dAlignmentFns :: (D.Renderable (D.Path R2) b)- => DEnv -> (Diagram b R2, AlignmentFns)-dAlignmentFns env = (mempty, envAlignmentFns env) -- TODO+ => DState (Diagram b R2, AlignmentFns)+dAlignmentFns = do+ env <- get+ return (mempty, envAlignmentFns env) -dDrawText :: (D.Renderable (D.Path R2) b)- => DEnv -> Point -> String -> Diagram b R2-dDrawText env (Point x y) text - = {-# SCC "dDrawText" #-} D.transform (toTransformation $ translate (Vector x y) 1)- $ applyFontStyle (envFontStyle env)- $ D2.scaleY (-1)- $ F.textSVG_ (fontStyleToTextOpts env text)+dDrawTextSvg :: (D.Renderable (D.Path R2) b)+ => Point -> String -> DState (Diagram b R2)+dDrawTextSvg (Point x y) text = do+ env <- get+ return $ D.transform (toTransformation $ translate (Vector x y) 1)+ $ applyFontStyleSVG (envFontStyle env)+ $ D2.scaleY (-1)+ $ F.textSVG_ (fontStyleToTextOpts env text) -dWith :: (D.Renderable (D.Path R2) b)- => DEnv -> (DEnv -> DEnv) -> (Diagram b R2 -> Diagram b R2) - -> ChartBackend a -> (Diagram b R2, a)-dWith env envF dF m = let (ma, a) = runBackend' (envF env) m- in (dF ma, a)+dDrawTextNative :: (D.Renderable D2.Text b)+ => Point -> String -> DState (Diagram b R2)+dDrawTextNative (Point x y) text = do+ env <- get+ addGlyphsOfString text+ return $ D.transform (toTransformation $ translate (Vector x y) 1)+ $ applyFontStyleText (envFontStyle env) + $ D2.scaleY (-1)+ $ D2.baselineText text -dWithTransform :: (D.Renderable (D.Path R2) b)- => DEnv -> Matrix -> ChartBackend a -> (Diagram b R2, a)-dWithTransform env t = dWith env id $ D.transform (toTransformation t)+dWith :: (D.Renderable (D.Path R2) b, D.Renderable t b)+ => TextRender t -> (DEnv -> DEnv) -> (Diagram b R2 -> Diagram b R2) + -> ChartBackend a -> DState (Diagram b R2, a)+dWith tr envF dF m = dLocal $ do+ modify envF+ (ma, a) <- runBackend' tr m+ return (dF ma, a) -dWithLineStyle :: (D.Renderable (D.Path R2) b)- => DEnv -> LineStyle -> ChartBackend a -> (Diagram b R2, a)-dWithLineStyle env ls = dWith env id $ applyLineStyle ls+dWithTransform :: (D.Renderable (D.Path R2) b, D.Renderable t b)+ => TextRender t -> Matrix -> ChartBackend a -> DState (Diagram b R2, a)+dWithTransform tr t = dWith tr id $ D.transform (toTransformation t) -dWithFillStyle :: (D.Renderable (D.Path R2) b)- => DEnv -> FillStyle -> ChartBackend a -> (Diagram b R2, a)-dWithFillStyle env fs = dWith env id $ applyFillStyle fs+dWithLineStyle :: (D.Renderable (D.Path R2) b, D.Renderable t b)+ => TextRender t -> LineStyle -> ChartBackend a -> DState (Diagram b R2, a)+dWithLineStyle tr ls = dWith tr id $ applyLineStyle ls -dWithFontStyle :: (D.Renderable (D.Path R2) b)- => DEnv -> FontStyle -> ChartBackend a -> (Diagram b R2, a)-dWithFontStyle env fs = dWith env (\e -> e { envFontStyle = fs }) $ id -- TODO+dWithFillStyle :: (D.Renderable (D.Path R2) b, D.Renderable t b)+ => TextRender t -> FillStyle -> ChartBackend a -> DState (Diagram b R2, a)+dWithFillStyle tr fs = dWith tr id $ applyFillStyle fs -dWithClipRegion :: (D.Renderable (D.Path R2) b)- => DEnv -> Rect -> ChartBackend a -> (Diagram b R2, a)-dWithClipRegion env clip = dWith env id $ D2.clipBy (convertPath True $ rectPath clip)+dWithFontStyle :: (D.Renderable (D.Path R2) b, D.Renderable t b)+ => TextRender t -> FontStyle -> ChartBackend a -> DState (Diagram b R2, a)+dWithFontStyle tr fs = dWith tr (\e -> e { envFontStyle = fs }) $ id +dWithClipRegion :: (D.Renderable (D.Path R2) b, D.Renderable t b)+ => TextRender t -> Rect -> ChartBackend a -> DState (Diagram b R2, a)+dWithClipRegion tr clip = dWith tr id $ D2.clipBy (convertPath True $ rectPath clip)+ -- ----------------------------------------------------------------------- -- Converions Helpers -- ----------------------------------------------------------------------- +addGlyphsOfString :: String -> DState ()+addGlyphsOfString s = do+ env <- get+ let fs = envFontStyle env+ let fontData = fst $ envSelectFont env fs+ let ligatures = ((filter ((>1) . length)) . (M.keys) . F.fontDataGlyphs) fontData+ let glyphs = fmap T.unpack $ F.characterStrings s ligatures+ modify $ \env -> + let gKey = (_font_name fs, _font_slant fs, _font_weight fs)+ gMap = envUsedGlyphs env+ entry = case M.lookup gKey gMap of+ Nothing -> S.fromList glyphs+ Just gs -> gs `S.union` S.fromList glyphs+ in env { envUsedGlyphs = M.insert gKey entry gMap }+ return ()+ pointToP2 :: Point -> P2 pointToP2 (Point x y) = p2 (x,y) +adjustOutputDiagram :: (D.Backend b R2) => DEnv -> Diagram b R2 -> Diagram b R2+adjustOutputDiagram env d = D2.reflectY $ D2.view (p2 (0,0)) (r2 (envOutputSize env)) d+ noLineStyle :: LineStyle noLineStyle = def { _line_width = 0@@ -370,10 +619,17 @@ FillStyleSolid cl -> D.fillColor cl -- | Apply all pure diagrams properties from the font style.-applyFontStyle :: (D.HasStyle a) => FontStyle -> a -> a-applyFontStyle fs = applyLineStyle noLineStyle - . applyFillStyle (solidFillStyle $ _font_color fs)+applyFontStyleSVG :: (D.HasStyle a) => FontStyle -> a -> a+applyFontStyleSVG fs = applyLineStyle noLineStyle + . applyFillStyle (solidFillStyle $ _font_color fs) +applyFontStyleText :: (D.HasStyle a) => FontStyle -> a -> a+applyFontStyleText fs = D2.font (_font_name fs)+ . D2.fontSize (_font_size fs)+ . D2.fontSlant (convertFontSlant $ _font_slant fs)+ . D2.fontWeight (convertFontWeight $ _font_weight fs)+ . D.fillColor (_font_color fs)+ -- | Calculate the font metrics for the currently set font style. -- The returned value will be @(height, ascent, descent, ybearing)@. calcFontMetrics :: DEnv -> (Double, Double, Double, Double)@@ -430,6 +686,17 @@ LineJoinRound -> D.LineJoinRound LineJoinBevel -> D.LineJoinBevel +convertFontSlant :: FontSlant -> D2.FontSlant+convertFontSlant fs = case fs of+ FontSlantNormal -> D2.FontSlantNormal+ FontSlantItalic -> D2.FontSlantItalic+ FontSlantOblique -> D2.FontSlantOblique++convertFontWeight :: FontWeight -> D2.FontWeight+convertFontWeight fw = case fw of+ FontWeightBold -> D2.FontWeightBold+ FontWeightNormal -> D2.FontWeightNormal+ -- | Convert paths. The boolean says wether all trails -- of the path shall be closed or remain open. convertPath :: Bool -> Path -> D.Path R2@@ -478,16 +745,6 @@ pathToTrail' closeAll End _ = (mempty, False || closeAll, Nothing) pathToTrail' closeAll Close _ = (mempty, True || closeAll, Nothing) ------------+---------------------------------------------------------------------- +$( makeLenses ''FileOptions )