Added a test that renders a font using diagrams/cairo and cairo side …

…by side to compare their sizes.

chart-tests/Chart-tests.cabal

@@ -179,4 +179,32 @@ Executable ChartsTestDrawingDiagramsCairo
   Main-is: DiagramsCairo.hs
   Hs-Source-Dirs: tests/drawing
   Ghc-Options: -threaded
+  default-language:    Haskell2010
+
+Executable ChartsTestCompareFonts
+  if flag(cairo) && flag(diagrams)
+    Build-Depends: 
+      base >= 3 && < 5, 
+      old-locale, 
+      array,
+      time, 
+      mtl, 
+      colour          >= 2.2.1,
+      data-accessor   == 0.2.*,
+      data-default-class < 0.1,
+      random          >= 1.0,
+      containers      >= 0.5,
+      old-time        >= 1.0,
+      cairo           >= 0.9.11,
+      Chart           >= 0.17,
+      Chart-diagrams  >= 0.1,
+      Chart-cairo     >= 0.1,
+      diagrams-cairo  >= 0.6.1,
+      diagrams-lib    >= 0.6.1,
+      diagrams-core   >= 0.6.1
+  if !flag(cairo) || !flag(diagrams)
+    Buildable: False
+  Main-is: Compare.hs
+  Hs-Source-Dirs: tests/compare-font
+  Ghc-Options: -threaded
   default-language:    Haskell2010

chart-tests/tests/compare-font/Compare.hs

@@ -0,0 +1,96 @@
+
+import Data.Colour
+import Data.Colour.Names
+import Data.Monoid
+import Data.Default.Class
+
+import Graphics.Rendering.Chart.Backend
+import Graphics.Rendering.Chart.Geometry
+import Graphics.Rendering.Chart.Drawing
+import qualified Graphics.Rendering.Chart.Backend.Diagrams as BD
+import qualified Graphics.Rendering.Chart.Backend.Cairo as BC
+
+import Diagrams.Core.Types ( renderDia )
+import Diagrams.TwoD ( SizeSpec2D(..) )
+import Diagrams.Backend.Cairo hiding ( renderCairo )
+import Diagrams.Backend.Cairo.Internal
+
+import qualified Graphics.Rendering.Cairo as C
+import qualified Graphics.Rendering.Cairo.Matrix as CM
+
+markLineStyle :: LineStyle
+markLineStyle = def 
+  { line_color_ = opaque red
+  , line_width_ = 1
+  }
+
+-- Render a few lines and mark them appropriatly.
+main :: IO ()
+main = render ("test.png") 1000 500 $ do
+  withTranslation (Point 10 10) $ do
+    (flip mapM_) [0 .. 5] $ \i -> do
+      let d = fromIntegral i
+      withTranslation (Point 0 (d * 70)) $ testDrawText (i * 10 + 10)
+    return ()
+
+testDrawText :: Int -> ChartBackend ()
+testDrawText fontSize = 
+  withFontStyle (def { font_size_ = fromIntegral fontSize, font_name_ = "Source Sans Pro" }) $ do
+    let text = "ÄÖÜ Testing " ++ show fontSize ++ "px"
+    -- Text metrics
+    ts <- textSize text
+    let a = textSizeAscent ts
+        d = textSizeDescent ts
+    -- Baseline and descent line: Red
+    withLineStyle markLineStyle $ do
+      p <- alignStrokePath $ moveTo' 0 a
+                          <> lineTo' 500 a
+                          <> moveTo' 0 (a + d)
+                          <> lineTo' 500 (a + d)
+      strokePath p
+    -- Bounding lines: Green
+    withLineStyle (markLineStyle { line_color_ = opaque green }) $ do
+      p <- alignStrokePath $ moveTo' 0 0
+                          <> lineTo' 500 0
+                          <> moveTo' 0 (fromIntegral fontSize)
+                          <> lineTo' 500 (fromIntegral fontSize)
+                          <> moveTo' 0 0
+                          <> lineTo' 0 (fromIntegral fontSize)
+
+      strokePath p
+    drawText (Point 0 a) text
+
+-- Render it side by side using cairo and diagrams cairo with SVGFonts.
+render :: FilePath -> Int -> Int -> ChartBackend () -> IO ()
+render f w h m = do
+  rc <- renderCairo (w,h) m
+  rd <- renderDiagramsCairo (w,h) m
+  s <- C.createImageSurface C.FormatARGB32 w h
+  C.renderWith s $ do
+    C.setSourceRGB 1 1 1
+    C.paint
+    C.setSourceRGB 0 0 0
+    C.newPath
+    C.moveTo (fromIntegral w / 2) 0
+    C.lineTo (fromIntegral w / 2) (fromIntegral h)
+    C.stroke
+  C.renderWith s $ do
+    C.rectangle 0 0 500 500
+    C.clip
+    rc
+  C.renderWith s $ do
+    C.setMatrix (CM.translate (fromIntegral w/2) 0 CM.identity)
+    C.rectangle 0 0 500 500
+    C.clip
+    rd
+  C.surfaceWriteToPNG s f
+
+renderCairo :: (Int, Int) -> ChartBackend () -> IO (C.Render ())
+renderCairo (w,h) m = do
+  return $ BC.runBackend (BC.defaultEnv bitmapAlignmentFns) m
+
+renderDiagramsCairo :: (Int, Int) -> ChartBackend () -> IO (C.Render ())
+renderDiagramsCairo (w,h) m = do
+  env <- BD.defaultEnv bitmapAlignmentFns
+  let (d, _) = BD.runBackend env m
+  return $ snd $ renderDia Cairo (CairoOptions "" (Dims (fromIntegral w) (fromIntegral h)) PNG True) d