module Diagrams.Backend.Cairo.Text
(
queryCairo, unsafeCairo
, StyleParam, cairoWithStyle
, TextExtents(..), FontExtents(..)
, getTextExtents, getFontExtents, getExtents
, kerningCorrectionIO
, textLineBoundedIO, textVisualBoundedIO
, kerningCorrection, textLineBounded, textVisualBounded
) where
import Diagrams.Backend.Cairo.Internal
import Diagrams.Prelude
import Control.Monad.State
import System.IO.Unsafe
import qualified Graphics.Rendering.Cairo as C
queryCairo :: C.Render a -> IO a
queryCairo c = C.withImageSurface C.FormatA1 0 0 (`C.renderWith` c)
unsafeCairo :: C.Render a -> a
unsafeCairo = unsafePerformIO . queryCairo
type StyleParam = forall a. HasStyle a => a -> a
cairoWithStyle :: C.Render a -> StyleParam -> C.Render a
cairoWithStyle f style = do
C.save
evalStateT (cairoMiscStyle (style mempty)) ()
result <- f
C.restore
return result
data TextExtents = TextExtents
{ bearing, textSize, advance :: R2 }
processTextExtents :: C.TextExtents -> TextExtents
processTextExtents (C.TextExtents xb yb w h xa ya)
= TextExtents (r2 (xb,yb)) (r2 (w,h)) (r2 (xa,ya))
getTextExtents :: StyleParam -> String -> C.Render TextExtents
getTextExtents style txt
= cairoWithStyle (processTextExtents <$> C.textExtents txt) style
data FontExtents = FontExtents
{ ascent, descent, height :: Double
, maxAdvance :: R2
}
processFontExtents :: C.FontExtents -> FontExtents
processFontExtents (C.FontExtents a d h mx my)
= FontExtents a d h (r2 (mx,my))
getFontExtents :: StyleParam -> C.Render FontExtents
getFontExtents style
= cairoWithStyle (processFontExtents <$> C.fontExtents) style
getExtents :: StyleParam -> String -> C.Render (FontExtents, TextExtents)
getExtents style str = cairoWithStyle (do
fe <- processFontExtents <$> C.fontExtents
te <- processTextExtents <$> C.textExtents str
return (fe, te)
) style
kerningCorrectionIO :: StyleParam -> Char -> Char -> IO Double
kerningCorrectionIO style a b = do
let ax t = fst . unr2 . advance <$> queryCairo (getTextExtents style t)
l <- ax [a, b]
la <- ax [a]
lb <- ax [b]
return $ l la lb
textLineBoundedIO :: StyleParam -> String -> IO (Diagram Cairo R2)
textLineBoundedIO style str = do
(fe, te) <- queryCairo $ getExtents style str
let box = fromCorners (p2 (0, negate $ descent fe))
(p2 (fst . unr2 $ advance te, ascent fe))
return . setEnvelope (getEnvelope box) $ style (baselineText str)
textVisualBoundedIO :: StyleParam -> String -> IO (Diagram Cairo R2)
textVisualBoundedIO style str = do
te <- queryCairo $ getTextExtents style str
let box = fromCorners (origin .+^ bearing te)
(origin .+^ bearing te ^+^ (textSize te))
return . setEnvelope (getEnvelope box) $ style (baselineText str)
kerningCorrection :: StyleParam -> Char -> Char -> Double
kerningCorrection style a = unsafePerformIO . kerningCorrectionIO style a
textLineBounded, textVisualBounded :: StyleParam -> String -> Diagram Cairo R2
textLineBounded style = unsafePerformIO . textLineBoundedIO style
textVisualBounded style = unsafePerformIO . textVisualBoundedIO style