module Diagrams.Backend.Cairo.Internal where
import Diagrams.Core.Transform
import Diagrams.Located (viewLoc)
import Diagrams.Prelude
import Diagrams.Trail
import Diagrams.TwoD.Adjust (adjustDia2D,
setDefault2DAttributes)
import Diagrams.TwoD.Image
import Diagrams.TwoD.Path (Clip (..), getFillRule)
import Diagrams.TwoD.Size (requiredScaleT)
import Diagrams.TwoD.Text
import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Cairo.Matrix as CM
import Control.Monad.State
import Data.List (isSuffixOf)
import Data.Maybe (catMaybes, fromMaybe)
import Control.Exception (try)
import qualified Data.Foldable as F
import Data.Typeable
data Cairo = Cairo
deriving (Eq,Ord,Read,Show,Typeable)
data OutputType =
PNG
| PS
| PDF
| SVG
| RenderOnly
deriving (Eq, Ord, Read, Show, Bounded, Enum, Typeable)
instance Monoid (Render Cairo R2) where
mempty = C $ return ()
(C rd1) `mappend` (C rd2) = C (rd1 >> rd2)
type RenderM a = StateT Bool C.Render a
save :: RenderM ()
save = lift C.save
restore :: RenderM ()
restore = lift C.restore
instance Backend Cairo R2 where
data Render Cairo R2 = C (RenderM ())
type Result Cairo R2 = (IO (), C.Render ())
data Options Cairo R2 = CairoOptions
{ cairoFileName :: String
, cairoSizeSpec :: SizeSpec2D
, cairoOutputType :: OutputType
, cairoBypassAdjust :: Bool
}
deriving Show
withStyle _ s t (C r) = C $ do
save
cairoMiscStyle s
put False
r
ignoreFill <- get
lift $ do
cairoTransf t
cairoStrokeStyle ignoreFill s
C.stroke
restore
doRender _ (CairoOptions file size out _) (C r) = (renderIO, r')
where r' = evalStateT r False
renderIO = do
let surfaceF s = C.renderWith s r'
(w,h) = case size of
Width w' -> (w',w')
Height h' -> (h',h')
Dims w' h' -> (w',h')
Absolute -> (100,100)
case out of
PNG ->
C.withImageSurface C.FormatARGB32 (round w) (round h) $ \surface -> do
surfaceF surface
C.surfaceWriteToPNG surface file
PS -> C.withPSSurface file w h surfaceF
PDF -> C.withPDFSurface file w h surfaceF
SVG -> C.withSVGSurface file w h surfaceF
RenderOnly -> return ()
adjustDia c opts d = if cairoBypassAdjust opts
then (opts, d # setDefault2DAttributes)
else adjustDia2D cairoSizeSpec
setCairoSizeSpec
c opts (d # reflectY)
where setCairoSizeSpec sz o = o { cairoSizeSpec = sz }
renderC :: (Renderable a Cairo, V a ~ R2) => a -> RenderM ()
renderC a = case (render Cairo a) of C r -> r
cairoMiscStyle :: Style v -> RenderM ()
cairoMiscStyle s =
sequence_
. catMaybes $ [ handle clip
, handle fSize
, handleFontFace
, handle fColor
, handle lFillRule
]
where handle :: AttributeClass a => (a -> RenderM ()) -> Maybe (RenderM ())
handle f = f `fmap` getAttr s
clip = mapM_ (\p -> renderC p >> lift C.clip) . getClip
fSize = lift . C.setFontSize . getFontSize
fFace = fromMaybe "" $ getFont <$> getAttr s
fSlant = fromFontSlant . fromMaybe FontSlantNormal
$ getFontSlant <$> getAttr s
fWeight = fromFontWeight . fromMaybe FontWeightNormal
$ getFontWeight <$> getAttr s
handleFontFace = Just . lift $ C.selectFontFace fFace fSlant fWeight
fColor c = lift $ setSource (getFillColor c) s
lFillRule = lift . C.setFillRule . fromFillRule . getFillRule
fromFontSlant :: FontSlant -> C.FontSlant
fromFontSlant FontSlantNormal = C.FontSlantNormal
fromFontSlant FontSlantItalic = C.FontSlantItalic
fromFontSlant FontSlantOblique = C.FontSlantOblique
fromFontWeight :: FontWeight -> C.FontWeight
fromFontWeight FontWeightNormal = C.FontWeightNormal
fromFontWeight FontWeightBold = C.FontWeightBold
cairoStrokeStyle :: Bool -> Style v -> C.Render ()
cairoStrokeStyle ignoreFill s =
sequence_
. catMaybes $ [ if ignoreFill then Nothing else handle fColor
, handle lColor
, handle lWidth
, handle lCap
, handle lJoin
, handle lDashing
]
where handle :: (AttributeClass a) => (a -> C.Render ()) -> Maybe (C.Render ())
handle f = f `fmap` getAttr s
fColor c = setSource (getFillColor c) s >> C.fillPreserve
lColor c = setSource (getLineColor c) s
lWidth = C.setLineWidth . getLineWidth
lCap = C.setLineCap . fromLineCap . getLineCap
lJoin = C.setLineJoin . fromLineJoin . getLineJoin
lDashing (getDashing -> Dashing ds offs) =
C.setDash ds offs
setSource :: Color c => c -> Style v -> C.Render ()
setSource c s = C.setSourceRGBA r g b a'
where (r,g,b,a) = colorToSRGBA c
a' = case getOpacity <$> getAttr s of
Nothing -> a
Just d -> a * d
cairoTransf :: T2 -> C.Render ()
cairoTransf t = C.transform m
where m = CM.Matrix a1 a2 b1 b2 c1 c2
(unr2 -> (a1,a2)) = apply t unitX
(unr2 -> (b1,b2)) = apply t unitY
(unr2 -> (c1,c2)) = transl t
fromLineCap :: LineCap -> C.LineCap
fromLineCap LineCapButt = C.LineCapButt
fromLineCap LineCapRound = C.LineCapRound
fromLineCap LineCapSquare = C.LineCapSquare
fromLineJoin :: LineJoin -> C.LineJoin
fromLineJoin LineJoinMiter = C.LineJoinMiter
fromLineJoin LineJoinRound = C.LineJoinRound
fromLineJoin LineJoinBevel = C.LineJoinBevel
fromFillRule :: FillRule -> C.FillRule
fromFillRule Winding = C.FillRuleWinding
fromFillRule EvenOdd = C.FillRuleEvenOdd
instance Renderable (Segment Closed R2) Cairo where
render _ (Linear (OffsetClosed v)) = C . lift $ uncurry C.relLineTo (unr2 v)
render _ (Cubic (unr2 -> (x1,y1))
(unr2 -> (x2,y2))
(OffsetClosed (unr2 -> (x3,y3))))
= C . lift $ C.relCurveTo x1 y1 x2 y2 x3 y3
instance Renderable (Trail R2) Cairo where
render _ t = flip withLine t $ renderT . lineSegments
where
renderT segs =
C $ do
mapM_ renderC segs
lift $ when (isLoop t) C.closePath
when (isLine t) (put True)
instance Renderable (Path R2) Cairo where
render _ (Path trs) = C $ lift C.newPath >> F.mapM_ renderTrail trs
where renderTrail (viewLoc -> (unp2 -> p, tr)) = do
lift $ uncurry C.moveTo p
renderC tr
instance Renderable Image Cairo where
render _ (Image file sz tr) = C . lift $ do
if ".png" `isSuffixOf` file
then do
C.save
cairoTransf (tr <> reflectionY)
pngSurfChk <- liftIO (try $ C.imageSurfaceCreateFromPNG file
:: IO (Either IOError C.Surface))
case pngSurfChk of
Right pngSurf -> do
w <- C.imageSurfaceGetWidth pngSurf
h <- C.imageSurfaceGetHeight pngSurf
cairoTransf $ requiredScaleT sz (fromIntegral w, fromIntegral h)
C.setSourceSurface pngSurf (fromIntegral w / 2)
(fromIntegral h / 2)
Left _ ->
liftIO . putStrLn $
"Warning: can't read image file <" ++ file ++ ">"
C.paint
C.restore
else
liftIO . putStr . unlines $
[ "Warning: Cairo backend can currently only render embedded"
, " images in .png format. Ignoring <" ++ file ++ ">."
]
instance Renderable Text Cairo where
render _ (Text tr al str) = C $ do
lift $ do
C.save
cairoTransf (tr <> reflectionY)
(refX, refY) <- case al of
BoxAlignedText xt yt -> do
tExt <- C.textExtents str
fExt <- C.fontExtents
let l = C.textExtentsXbearing tExt
r = C.textExtentsXadvance tExt
b = C.fontExtentsDescent fExt
t = C.fontExtentsAscent fExt
return (lerp l r xt, lerp (b) t yt)
BaselineText -> return (0, 0)
cairoTransf (moveOriginBy (r2 (refX, refY)) mempty)
C.showText str
C.restore