diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,10 @@ +1.0: 25 November 2013 +--------------------- + + - Re-implement via new backend `RTree` interface. + - Use new command-line interface from `diagrams-lib`. + - Export `B` as an alias for `Cairo` token. + 0.7: 9 August 2013 ------------------ @@ -59,7 +66,7 @@ - Add dependency on `colour` - Lower bound on `cairo` raised to 0.12.4 - + * **Bug fixes** - Fixed looped compile mode, which was repeatedly trying to compile @@ -158,4 +165,3 @@ ---------------- * initial preview release - diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,8 +1,10 @@ Copyright 2011-2013 diagrams-cairo team: + Daniel Bergey Sam Griffin Niklas Haas John Lato + Jeffrey Rosenbluth Ian Ross Michael Sloan Luite Stegeman diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -28,7 +28,7 @@ d = circle 1 # fc blue -main = defaultMain (pad 1.1 d) +main = mainWith (pad 1.1 d) ``` Save this to file named `Circle.hs` and compile it: @@ -43,16 +43,21 @@ ``` $ ./Circle --help -Command-line diagram generation. +./Circle -Circle [OPTIONS] +Usage: ./Circle [-w|--width WIDTH] [-h|--height HEIGHT] [-o|--output OUTPUT] + [--loop] [-s|--src ARG] [-i|--interval INTERVAL] + Command-line diagram generation. -Common flags: - -w --width=INT Desired width of the output image - -h --height=INT Desired height of the output image - -o --output=FILE Output file - -? --help Display help message - -V --version Print version information +Available options: + -?,--help Show this help text + -w,--width WIDTH Desired WIDTH of the output image + -h,--height HEIGHT Desired HEIGHT of the output image + -o,--output OUTPUT OUTPUT file + -l,--loop Run in a self-recompiling loop + -s,--src ARG Source file to watch + -i,--interval INTERVAL When running in a loop, check for changes every INTERVAL seconds. +ommand-line diagram generation. ``` The output type will be automatically determined from the file diff --git a/diagrams-cairo.cabal b/diagrams-cairo.cabal --- a/diagrams-cairo.cabal +++ b/diagrams-cairo.cabal @@ -1,5 +1,5 @@ Name: diagrams-cairo -Version: 0.7 +Version: 1.0 Synopsis: Cairo backend for diagrams drawing EDSL Description: A full-featured backend for rendering diagrams using the cairo rendering engine. @@ -48,19 +48,22 @@ Diagrams.Backend.Cairo.Ptr Diagrams.Backend.Cairo.Text Hs-source-dirs: src - Build-depends: base >= 4.2 && < 4.7, + Build-depends: base >= 4.2 && < 4.8, mtl >= 2.0 && < 2.2, process, directory, filepath, old-time, time, - diagrams-core >= 0.7 && < 0.8, - diagrams-lib >= 0.7 && < 0.8, + diagrams-core >= 1.0 && < 1.1, + diagrams-lib >= 1.0 && < 1.1, cairo >= 0.12.4 && < 0.13, - cmdargs >= 0.6 && < 0.11, colour, - split >= 0.1.2 && < 0.3 + split >= 0.1.2 && < 0.3, + containers >= 0.3 && < 0.6, + lens >= 3.8 && < 4, + data-default-class >= 0.0.1 && < 0.1, + statestack >= 0.2 && < 0.3 default-language: Haskell2010 if !os(windows) diff --git a/src/Diagrams/Backend/Cairo.hs b/src/Diagrams/Backend/Cairo.hs --- a/src/Diagrams/Backend/Cairo.hs +++ b/src/Diagrams/Backend/Cairo.hs @@ -36,10 +36,10 @@ -- particular backend. For @b ~ Cairo@ and @v ~ R2@, we have -- -- > data family Options Cairo R2 = CairoOptions --- > { cairoFileName :: String -- ^ The name of the file you want generated --- > , cairoSizeSpec :: SizeSpec2D -- ^ The requested size of the output --- > , cairoOutputType :: OutputType -- ^ the output format and associated options --- > , cairoBypassAdjust :: Bool -- ^ Should the 'adjustDia' step be bypassed during rendering? +-- > { _cairoFileName :: String -- ^ The name of the file you want generated +-- > , _cairoSizeSpec :: SizeSpec2D -- ^ The requested size of the output +-- > , _cairoOutputType :: OutputType -- ^ the output format and associated options +-- > , _cairoBypassAdjust :: Bool -- ^ Should the 'adjustDia' step be bypassed during rendering? -- > } -- -- @ @@ -92,6 +92,7 @@ -- * Backend token , Cairo(..) + , B ) where import System.FilePath (takeExtension) @@ -106,9 +107,9 @@ -- This module defines -- -- > data family Options Cairo R2 = CairoOptions --- > { cairoFileName :: String -- ^ The name of the file you want generated --- > , cairoSizeSpec :: SizeSpec2D -- ^ The requested size of the output --- > , cairoOutputType :: OutputType -- ^ the output format and associated options +-- > { _cairoFileName :: String -- ^ The name of the file you want generated +-- > , _cairoSizeSpec :: SizeSpec2D -- ^ The requested size of the output +-- > , _cairoOutputType :: OutputType -- ^ the output format and associated options -- > } -- -- See the documentation at the top of "Diagrams.Backend.Cairo" for diff --git a/src/Diagrams/Backend/Cairo/CmdLine.hs b/src/Diagrams/Backend/Cairo/CmdLine.hs --- a/src/Diagrams/Backend/Cairo/CmdLine.hs +++ b/src/Diagrams/Backend/Cairo/CmdLine.hs @@ -1,8 +1,13 @@ -{-# LANGUAGE DeriveDataTypeable, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.Cairo.CmdLine --- Copyright : (c) 2011 Diagrams-cairo team (see LICENSE) +-- Copyright : (c) 2013 Diagrams-cairo team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -18,14 +23,26 @@ -- * 'animMain' is like 'defaultMain' but for animations instead of -- diagrams. -- +-- * 'mainWith' is a generic form that does all of the above but with +-- a slightly scarier type. See "Diagrams.Backend.CmdLine". This +-- form can also take a function type that has a subtable final result +-- (any of arguments to the above types) and 'Parseable' arguments. +-- -- If you want to generate diagrams programmatically---/i.e./ if you -- want to do anything more complex than what the below functions -- provide---you have several options. -- --- * A simple but somewhat inflexible approach is to wrap up --- 'defaultMain' (or 'multiMain', or 'animMain') in a call to --- 'System.Environment.withArgs'. +-- * Use a function with 'mainWith'. This may require making +-- 'Parseable' instances for custom argument types. -- +-- * Make a new 'Mainable' instance. This may require a newtype +-- wrapper on your diagram type to avoid the existing instances. +-- This gives you more control over argument parsing, intervening +-- steps, and diagram creation. +-- +-- * Build option records and pass them along with a diagram to 'mainRender' +-- from "Diagrams.Backend.CmdLine". +-- -- * A more flexible approach is to use the 'renderCairo' function -- provided in the "Diagrams.Backend.Cairo" module. -- @@ -33,19 +50,35 @@ -- function directly; see "Diagrams.Backend.Cairo" for more -- information. -- +-- For a tutorial on command-line diagram creation see +-- . +-- ----------------------------------------------------------------------------- module Diagrams.Backend.Cairo.CmdLine - ( defaultMain + ( + -- * General form of @main@ + -- $mainwith + + mainWith + + -- * Supported forms of @main@ + + , defaultMain , multiMain , animMain + -- * Backend tokens + , Cairo + , B ) where -import Data.List (intercalate) +import Control.Lens ((^.),Lens') + import Diagrams.Prelude hiding (width, height, interval) import Diagrams.Backend.Cairo +import Diagrams.Backend.CmdLine -- Below hack is needed because GHC 7.0.x has a bug regarding export -- of data family constructors; see comments in Diagrams.Backend.Cairo @@ -53,19 +86,21 @@ import Diagrams.Backend.Cairo.Internal #endif -import System.Console.CmdArgs.Implicit hiding (args) - +#if __GLASGOW_HASKELL__ < 706 import Prelude hiding (catch) +#else +import Prelude +#endif -import Data.Maybe (fromMaybe) -import Control.Monad (when, forM_, mplus) import Data.List.Split -import Text.Printf +#ifdef CMDLINELOOP +import Data.Maybe (fromMaybe) +import Control.Monad (when, mplus) +import Control.Lens (_1) import System.Environment (getArgs, getProgName) import System.Directory (getModificationTime) -import System.FilePath (addExtension, splitExtension) import System.Process (runProcess, waitForProcess) import System.IO (openFile, hClose, IOMode(..), hSetBuffering, BufferMode(..), stdout) @@ -73,7 +108,6 @@ import Control.Concurrent (threadDelay) import Control.Exception (catch, SomeException(..), bracket) -#ifdef CMDLINELOOP import System.Posix.Process (executeFile) #if MIN_VERSION_directory(1,2,0) import Data.Time.Clock (UTCTime,getCurrentTime) @@ -88,58 +122,28 @@ #endif #endif -data DiagramOpts = DiagramOpts - { width :: Maybe Int - , height :: Maybe Int - , output :: FilePath - , list :: Bool - , selection :: Maybe String - , fpu :: Double -#ifdef CMDLINELOOP - , loop :: Bool - , src :: Maybe String - , interval :: Int -#endif - } - deriving (Show, Data, Typeable) +-- $mainwith +-- The 'mainWith' method unifies all of the other forms of @main@ and is now +-- the recommended way to build a command-line diagrams program. It works as a +-- direct replacement for 'defaultMain', 'multiMain', or 'animMain' as well as +-- allowing more general arguments. For example, given a function that +-- produces a diagram when given an @Int@ and a @'Colour' Double@, 'mainWith' +-- will produce a program that looks for additional number and color arguments. +-- +-- > ... definitions ... +-- > f :: Int -> Colour Double -> Diagram Cairo R2 +-- > f i c = ... +-- > +-- > main = mainWith f +-- +-- We can run this program as follows: +-- +-- > $ ghc --make MyDiagram +-- > +-- > # output image.png built by `f 20 red` +-- > $ ./MyDiagram -o image.png -w 200 20 red -diagramOpts :: String -> Bool -> DiagramOpts -diagramOpts prog sel = DiagramOpts - { width = def - &= typ "INT" - &= help "Desired width of the output image" - , height = def - &= typ "INT" - &= help "Desired height of the output image" - - , output = def - &= typFile - &= help "Output file" - - , selection = def - &= help "Name of the diagram to render" - &= (if sel then typ "NAME" else ignore) - - , list = def - &= (if sel then help "List all available diagrams" else ignore) - - , fpu = 30 - &= typ "FLOAT" - &= help "Frames per unit time (for animations)" -#ifdef CMDLINELOOP - , loop = False - &= help "Run in a self-recompiling loop" - , src = def - &= typFile - &= help "Source file to watch" - , interval = 1 &= typ "SECONDS" - &= help "When running in a loop, check for changes every n seconds." -#endif - } - &= summary "Command-line diagram generation." - &= program prog - -- | This is the simplest way to render diagrams, and is intended to -- be used like so: -- @@ -161,21 +165,20 @@ -- options. Currently it looks something like -- -- @ --- Command-line diagram generation. +-- ./Program -- --- Foo [OPTIONS] +-- Usage: ./Program [-w|--width WIDTH] [-h|--height HEIGHT] [-o|--output OUTPUT] +-- [--loop] [-s|--src ARG] [-i|--interval INTERVAL] +-- Command-line diagram generation. -- --- Common flags: --- -w --width=INT Desired width of the output image --- -h --height=INT Desired height of the output image --- -o --output=FILE Output file --- -f --fpu=FLOAT Frames per unit time (for animations) --- -l --loop Run in a self-recompiling loop --- -s --src=FILE Source file to watch --- -i --interval=SECONDS When running in a loop, check for changes every n --- seconds. --- -? --help Display help message --- -V --version Print version information +-- Available options: +-- -?,--help Show this help text +-- -w,--width WIDTH Desired WIDTH of the output image +-- -h,--height HEIGHT Desired HEIGHT of the output image +-- -o,--output OUTPUT OUTPUT file +-- -l,--loop Run in a self-recompiling loop +-- -s,--src ARG Source file to watch +-- -i,--interval INTERVAL When running in a loop, check for changes every INTERVAL seconds. -- @ -- -- For example, a couple common scenarios include @@ -191,18 +194,31 @@ -- @ defaultMain :: Diagram Cairo R2 -> IO () -defaultMain d = do - prog <- getProgName - args <- getArgs - opts <- cmdArgs (diagramOpts prog False) - chooseRender opts d +defaultMain = mainWith + #ifdef CMDLINELOOP - when (loop opts) (waitForChange Nothing opts prog args) +output' :: Lens' (MainOpts (Diagram Cairo R2)) FilePath +output' = _1 . output + +instance Mainable (Diagram Cairo R2) where + type MainOpts (Diagram Cairo R2) = (DiagramOpts, DiagramLoopOpts) + + mainRender (opts,loopOpts) d = do + chooseRender opts d + when (loopOpts^.loop) (waitForChange Nothing loopOpts) +#else +output' :: Lens' (MainOpts (Diagram Cairo R2)) FilePath +output' = output + +instance Mainable (Diagram Cairo R2) where + type MainOpts (Diagram Cairo R2) = DiagramOpts + + mainRender opts d = chooseRender opts d #endif chooseRender :: DiagramOpts -> Diagram Cairo R2 -> IO () chooseRender opts d = - case splitOn "." (output opts) of + case splitOn "." (opts ^. output) of [""] -> putStrLn "No output file given." ps | last ps `elem` ["png", "ps", "pdf", "svg"] -> do let outTy = case last ps of @@ -214,10 +230,10 @@ fst $ renderDia Cairo ( CairoOptions - (output opts) + (opts^.output) (mkSizeSpec - (fromIntegral <$> width opts) - (fromIntegral <$> height opts) + (fromIntegral <$> opts ^. width ) + (fromIntegral <$> opts ^. height) ) outTy False @@ -245,24 +261,14 @@ -- @ multiMain :: [(String, Diagram Cairo R2)] -> IO () -multiMain ds = do - prog <- getProgName - opts <- cmdArgs (diagramOpts prog True) - if list opts - then showDiaList (map fst ds) - else - case selection opts of - Nothing -> putStrLn "No diagram selected." >> showDiaList (map fst ds) - Just sel -> case lookup sel ds of - Nothing -> putStrLn $ "Unknown diagram: " ++ sel - Just d -> chooseRender opts d +multiMain = mainWith --- | Display the list of diagrams available for rendering. -showDiaList :: [String] -> IO () -showDiaList ds = do - putStrLn "Available diagrams:" - putStrLn $ " " ++ intercalate " " ds +instance Mainable [(String, Diagram Cairo R2)] where + type MainOpts [(String, Diagram Cairo R2)] + = (MainOpts (Diagram Cairo R2), DiagramMultiOpts) + mainRender = defaultMultiMainRender + -- | @animMain@ is like 'defaultMain', but renders an animation -- instead of a diagram. It takes as input an animation and produces -- a command-line program which will crudely \"render\" the animation @@ -280,35 +286,28 @@ -- The @--fpu@ option can be used to control how many frames will be -- output for each second (unit time) of animation. animMain :: Animation Cairo R2 -> IO () -animMain anim = do - prog <- getProgName - opts <- cmdArgs (diagramOpts prog False) - let frames = simulate (toRational $ fpu opts) anim - nDigits = length . show . length $ frames - forM_ (zip [1..] frames) $ \(i,d) -> - chooseRender (indexize nDigits i opts) d +animMain = mainWith --- | @indexize d n@ adds the integer index @n@ to the end of the --- output file name, padding with zeros if necessary so that it uses --- at least @d@ digits. -indexize :: Int -> Integer -> DiagramOpts -> DiagramOpts -indexize nDigits i opts = opts { output = output' } - where fmt = "%0" ++ show nDigits ++ "d" - output' = addExtension (base ++ printf fmt (i::Integer)) ext - (base, ext) = splitExtension (output opts) +instance Mainable (Animation Cairo R2) where + type MainOpts (Animation Cairo R2) = (MainOpts (Diagram Cairo R2), DiagramAnimOpts) + mainRender = defaultAnimMainRender output' + + #ifdef CMDLINELOOP -waitForChange :: Maybe ModuleTime -> DiagramOpts -> String -> [String] -> IO () -waitForChange lastAttempt opts prog args = do +waitForChange :: Maybe ModuleTime -> DiagramLoopOpts -> IO () +waitForChange lastAttempt opts = do + prog <- getProgName + args <- getArgs hSetBuffering stdout NoBuffering - go lastAttempt - where go lastAtt = do - threadDelay (1000000 * interval opts) + go prog args lastAttempt + where go prog args lastAtt = do + threadDelay (1000000 * opts^.interval) -- putStrLn $ "Checking... (last attempt = " ++ show lastAttempt ++ ")" - (newBin, newAttempt) <- recompile lastAtt prog (src opts) + (newBin, newAttempt) <- recompile lastAtt prog (opts^.src) if newBin then executeFile prog False args Nothing - else go $ newAttempt `mplus` lastAtt + else go prog args $ newAttempt `mplus` lastAtt -- | @recompile t prog@ attempts to recompile @prog@, assuming the -- last attempt was made at time @t@. If @t@ is @Nothing@ assume diff --git a/src/Diagrams/Backend/Cairo/Internal.hs b/src/Diagrams/Backend/Cairo/Internal.hs --- a/src/Diagrams/Backend/Cairo/Internal.hs +++ b/src/Diagrams/Backend/Cairo/Internal.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -36,25 +37,30 @@ ----------------------------------------------------------------------------- module Diagrams.Backend.Cairo.Internal where +import Diagrams.Core.Compile (RNode (..), RTree, toRTree) import Diagrams.Core.Transform -import Diagrams.Located (viewLoc) -import Diagrams.Prelude -import Diagrams.Trail +import Diagrams.Prelude hiding (opacity, view) import Diagrams.TwoD.Adjust (adjustDia2D, setDefault2DAttributes) import Diagrams.TwoD.Image -import Diagrams.TwoD.Path (Clip (..), getFillRule) +import Diagrams.TwoD.Path (Clip (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 Control.Monad (when) +import qualified Control.Monad.StateStack as SS +import Control.Monad.Trans (lift, liftIO) +import Data.Default.Class import Data.List (isSuffixOf) -import Data.Maybe (catMaybes, fromMaybe) +import Data.Maybe (catMaybes, fromMaybe, isJust) +import Data.Tree +import Control.Lens hiding (transform, ( # )) + import Control.Exception (try) import qualified Data.Foldable as F @@ -69,6 +75,8 @@ data Cairo = Cairo deriving (Eq,Ord,Read,Show,Typeable) +type B = Cairo + -- | Output types supported by cairo, including four different file -- types (PNG, PS, PDF, SVG). If you want to output directly to GTK -- windows, see the @diagrams-gtk@ package. @@ -83,58 +91,60 @@ -- window; see the @diagrams-gtk@ package). 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) +-- | Custom state tracked in the 'RenderM' monad. +data CairoState + = CairoState { _accumStyle :: Style R2 + -- ^ The current accumulated style. + , _ignoreFill :: Bool + -- ^ Whether or not we saw any lines in the most + -- recent path (as opposed to loops). If we did, + -- we should ignore any fill attribute. + -- diagrams-lib separates lines and loops into + -- separate path primitives so we don't have to + -- worry about seeing them together in the same + -- path. + } +$(makeLenses ''CairoState) + +instance Default CairoState where + def = CairoState + { _accumStyle = mempty + , _ignoreFill = False + } + -- | The custom monad in which intermediate drawing options take -- place; 'Graphics.Rendering.Cairo.Render' is cairo's own rendering --- monad. Right now we simply maintain a Bool state to track --- whether or not we saw any lines in the most recent path (as --- opposed to loops). If we did, we should ignore any fill --- attribute. diagrams-lib separates lines and loops into separate --- path primitives so we don't have to worry about seeing them --- together in the same path. -type RenderM a = StateT Bool C.Render a -- no state for now +-- monad. +type RenderM a = SS.StateStackT CairoState C.Render a --- Simple, stupid implementations of save and restore for now. If --- need be we could switch to a more sophisticated implementation --- using an "undoable state" monad which lets you save (push state --- onto a stack) and restore (pop from the stack). +liftC :: C.Render a -> RenderM a +liftC = lift +runRenderM :: RenderM a -> C.Render a +runRenderM = flip SS.evalStateStackT def + -- | Push the current context onto a stack. save :: RenderM () -save = lift C.save +save = SS.save >> liftC C.save -- | Restore the context from a stack. restore :: RenderM () -restore = lift C.restore +restore = liftC C.restore >> SS.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 -- ^ The name of the file you want generated - , cairoSizeSpec :: SizeSpec2D -- ^ The requested size of the output - , cairoOutputType :: OutputType -- ^ the output format and associated options - , cairoBypassAdjust :: Bool -- ^ Should the 'adjustDia' step be bypassed during rendering? + { _cairoFileName :: String -- ^ The name of the file you want generated + , _cairoSizeSpec :: SizeSpec2D -- ^ The requested size of the output + , _cairoOutputType :: OutputType -- ^ the output format and associated options + , _cairoBypassAdjust :: Bool -- ^ Should the 'adjustDia' step be bypassed during rendering? } 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 + where r' = runRenderM r renderIO = do let surfaceF s = C.renderWith s r' @@ -158,40 +168,88 @@ SVG -> C.withSVGSurface file w h surfaceF RenderOnly -> return () - adjustDia c opts d = if cairoBypassAdjust opts + -- renderData :: Monoid' m => b -> QDiagram b v m -> Render b v + renderData _ = renderRTree . toRTree + + adjustDia c opts d = if _cairoBypassAdjust opts then (opts, d # setDefault2DAttributes) - else adjustDia2D cairoSizeSpec + else adjustDia2D _cairoSizeSpec setCairoSizeSpec c opts (d # reflectY) - where setCairoSizeSpec sz o = o { cairoSizeSpec = sz } + where setCairoSizeSpec sz o = o { _cairoSizeSpec = sz } +runC :: Render Cairo R2 -> RenderM () +runC (C r) = r + +instance Monoid (Render Cairo R2) where + mempty = C $ return () + (C rd1) `mappend` (C rd2) = C (rd1 >> rd2) + +renderRTree :: RTree Cairo R2 a -> Render Cairo R2 +renderRTree (Node (RPrim accTr p) _) = render Cairo (transform accTr p) +renderRTree (Node (RStyle sty) ts) = C $ do + save + cairoStyle sty + accumStyle %= (<> sty) + runC $ F.foldMap renderRTree ts + restore +renderRTree (Node (RFrozenTr tr) ts) = C $ do + save + liftC $ cairoTransf tr + runC $ F.foldMap renderRTree ts + restore +renderRTree (Node _ ts) = F.foldMap renderRTree ts + +cairoFileName :: Lens' (Options Cairo R2) String +cairoFileName = lens (\(CairoOptions {_cairoFileName = f}) -> f) + (\o f -> o {_cairoFileName = f}) + +cairoSizeSpec :: Lens' (Options Cairo R2) SizeSpec2D +cairoSizeSpec = lens (\(CairoOptions {_cairoSizeSpec = s}) -> s) + (\o s -> o {_cairoSizeSpec = s}) + +cairoOutputType :: Lens' (Options Cairo R2) OutputType +cairoOutputType = lens (\(CairoOptions {_cairoOutputType = t}) -> t) + (\o t -> o {_cairoOutputType = t}) + +cairoBypassAdjust :: Lens' (Options Cairo R2) Bool +cairoBypassAdjust = lens (\(CairoOptions {_cairoBypassAdjust = b}) -> b) + (\o b -> o {_cairoBypassAdjust = b}) + -- | Render an object that the cairo backend knows how to render. renderC :: (Renderable a Cairo, V a ~ R2) => a -> RenderM () -renderC a = case (render Cairo a) of C r -> r +renderC = runC . render Cairo --- | Handle \"miscellaneous\" style attributes (clip, font stuff, fill --- color and fill rule). -cairoMiscStyle :: Style v -> RenderM () -cairoMiscStyle s = +-- | Get an accumulated style attribute from the render monad state. +getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM (Maybe b) +getStyleAttrib f = (fmap f . getAttr) <$> use accumStyle + +-- | Handle those style attributes for which we can immediately emit +-- cairo instructions as we encounter them in the tree (clip, font +-- size, fill rule, line width, cap, join, and dashing). Other +-- attributes (font face, slant, weight; fill color, stroke color, +-- opacity) must be accumulated. +cairoStyle :: Style v -> RenderM () +cairoStyle s = sequence_ . catMaybes $ [ handle clip , handle fSize - , handleFontFace - , handle fColor , handle lFillRule + , handle lWidth + , handle lCap + , handle lJoin + , handle lDashing ] 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 + clip = mapM_ (\p -> cairoPath p >> liftC C.clip) . op Clip + fSize = liftC . C.setFontSize . getFontSize + lFillRule = liftC . C.setFillRule . fromFillRule . getFillRule + lWidth = liftC . C.setLineWidth . getLineWidth + lCap = liftC . C.setLineCap . fromLineCap . getLineCap + lJoin = liftC . C.setLineJoin . fromLineJoin . getLineJoin + lDashing (getDashing -> Dashing ds offs) = + liftC $ C.setDash ds offs fromFontSlant :: FontSlant -> C.FontSlant fromFontSlant FontSlantNormal = C.FontSlantNormal @@ -202,35 +260,9 @@ fromFontWeight FontWeightNormal = C.FontWeightNormal fromFontWeight FontWeightBold = C.FontWeightBold --- | Handle style attributes having to do with stroke. -cairoStrokeStyle :: Bool -> Style v -> C.Render () -cairoStrokeStyle ignoreFill s = - sequence_ - . catMaybes $ [ if ignoreFill then Nothing else handle fColor - , handle lColor -- see Note [color order] - , 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 - --- | Set the source color. -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 - +-- | Apply the opacity from a style to a given color. +applyOpacity :: Color c => c -> Style v -> AlphaColour Double +applyOpacity c s = dissolve (fromMaybe 1 $ getOpacity <$> getAttr s) (toAlphaColour c) -- | Multiply the current transformation matrix by the given 2D -- transformation. @@ -241,13 +273,6 @@ (unr2 -> (b1,b2)) = apply t unitY (unr2 -> (c1,c2)) = transl t -{- ~~~~ Note [color order] - - It's important for the line and fill colors to be handled in the - given order (fill color first, then line color) because of the way - Cairo handles them (both are taken from the sourceRGBA). --} - fromLineCap :: LineCap -> C.LineCap fromLineCap LineCapButt = C.LineCapButt fromLineCap LineCapRound = C.LineCapRound @@ -263,11 +288,11 @@ fromFillRule EvenOdd = C.FillRuleEvenOdd instance Renderable (Segment Closed R2) Cairo where - render _ (Linear (OffsetClosed v)) = C . lift $ uncurry C.relLineTo (unr2 v) + render _ (Linear (OffsetClosed v)) = C . liftC $ 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 + = C . liftC $ C.relCurveTo x1 y1 x2 y2 x3 y3 instance Renderable (Trail R2) Cairo where render _ t = flip withLine t $ renderT . lineSegments @@ -275,21 +300,47 @@ renderT segs = C $ do mapM_ renderC segs - lift $ when (isLoop t) C.closePath + liftC $ when (isLoop t) C.closePath - when (isLine t) (put True) + when (isLine t) (ignoreFill .= True) -- remember that we saw a Line, so we will ignore fill attribute 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 + render _ p = C $ do + cairoPath p + f <- getStyleAttrib (toAlphaColour . getFillColor) + s <- getStyleAttrib (toAlphaColour . getLineColor) + ign <- use ignoreFill + setSourceColor f + when (isJust f && not ign) $ liftC C.fillPreserve + setSourceColor s + liftC C.stroke +-- Add a path to the Cairo context, without stroking or filling it. +cairoPath :: Path R2 -> RenderM () +cairoPath (Path trs) = do + liftC C.newPath + ignoreFill .= False + F.mapM_ renderTrail trs + where + renderTrail (viewLoc -> (unp2 -> p, tr)) = do + liftC $ uncurry C.moveTo p + renderC tr + +-- XXX should handle opacity in a more straightforward way, using +-- cairo's built-in support for transparency? See also +-- https://github.com/diagrams/diagrams-cairo/issues/15 . +setSourceColor :: Maybe (AlphaColour Double) -> RenderM () +setSourceColor Nothing = return () +setSourceColor (Just c) = do + o <- fromMaybe 1 <$> getStyleAttrib getOpacity + liftC (C.setSourceRGBA r g b (o*a)) + where (r,g,b,a) = colorToSRGBA c + -- Can only do PNG files at the moment... instance Renderable Image Cairo where - render _ (Image file sz tr) = C . lift $ do + render _ (Image file sz tr) = C . liftC $ do if ".png" `isSuffixOf` file then do C.save @@ -317,8 +368,14 @@ -- see http://www.cairographics.org/tutorial/#L1understandingtext instance Renderable Text Cairo where render _ (Text tr al str) = C $ do - lift $ do - C.save + ff <- fromMaybe "" <$> getStyleAttrib getFont + fs <- fromMaybe C.FontSlantNormal <$> getStyleAttrib (fromFontSlant . getFontSlant) + fw <- fromMaybe C.FontWeightNormal <$> getStyleAttrib (fromFontWeight . getFontWeight) + f <- getStyleAttrib (toAlphaColour . getFillColor) + save + setSourceColor f + liftC $ do + C.selectFontFace ff fs fw -- XXX should use reflection font matrix here instead? cairoTransf (tr <> reflectionY) (refX, refY) <- case al of @@ -333,4 +390,5 @@ BaselineText -> return (0, 0) cairoTransf (moveOriginBy (r2 (refX, -refY)) mempty) C.showText str - C.restore + C.newPath + restore diff --git a/src/Diagrams/Backend/Cairo/List.hs b/src/Diagrams/Backend/Cairo/List.hs --- a/src/Diagrams/Backend/Cairo/List.hs +++ b/src/Diagrams/Backend/Cairo/List.hs @@ -13,19 +13,19 @@ module Diagrams.Backend.Cairo.List where -import Control.Applicative ((<$>)) -import Control.Exception (bracket) +import Control.Applicative ((<$>)) +import Control.Exception (bracket) -import Data.Colour -import Data.Colour.SRGB (sRGB) -import Data.Word (Word8) +import Data.Colour +import Data.Colour.SRGB (sRGB) +import Data.Word (Word8) -import Diagrams.Prelude (Diagram, R2) -import Diagrams.Backend.Cairo (Cairo) -import Diagrams.Backend.Cairo.Ptr (renderPtr) +import Diagrams.Backend.Cairo (Cairo) +import Diagrams.Backend.Cairo.Ptr (renderPtr) +import Diagrams.Prelude (Diagram, R2) -import Foreign.Marshal.Alloc (free) -import Foreign.Marshal.Array (peekArray) +import Foreign.Marshal.Alloc (free) +import Foreign.Marshal.Array (peekArray) -- | Render to a regular list of Colour values. @@ -38,7 +38,7 @@ f _ [] = [] f n xs | n >= w = [] : f 0 xs f n (g:b:r:a:xs) = - let l n = fromIntegral n / fromIntegral a + let l x = fromIntegral x / fromIntegral a c = sRGB (l r) (l g) (l b) `withOpacity` (fromIntegral a / 255) in case f (n+1) xs of diff --git a/src/Diagrams/Backend/Cairo/Ptr.hs b/src/Diagrams/Backend/Cairo/Ptr.hs --- a/src/Diagrams/Backend/Cairo/Ptr.hs +++ b/src/Diagrams/Backend/Cairo/Ptr.hs @@ -36,10 +36,10 @@ let stride = formatStrideForWidth FormatARGB32 w size = stride * h opt = CairoOptions - { cairoSizeSpec = Dims (fromIntegral w) (fromIntegral h) - , cairoOutputType = RenderOnly - , cairoBypassAdjust = False - , cairoFileName = "" + { _cairoSizeSpec = Dims (fromIntegral w) (fromIntegral h) + , _cairoOutputType = RenderOnly + , _cairoBypassAdjust = False + , _cairoFileName = "" } (_, r) = renderDia Cairo opt d diff --git a/src/Diagrams/Backend/Cairo/Text.hs b/src/Diagrams/Backend/Cairo/Text.hs --- a/src/Diagrams/Backend/Cairo/Text.hs +++ b/src/Diagrams/Backend/Cairo/Text.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Backend.Cairo.Text @@ -42,7 +43,8 @@ -- * Extents -- ** Data Structures - , TextExtents(..), FontExtents(..) + , TextExtents(TextExtents), bearing, textSize, advance + , FontExtents(FontExtents), ascent, descent, height, maxAdvance -- ** Queries @@ -55,9 +57,10 @@ ) where import Diagrams.Backend.Cairo.Internal -import Diagrams.Prelude +import Diagrams.BoundingBox +import Diagrams.Prelude hiding (height, view) -import Control.Monad.State +import Control.Lens (makeLenses, view) import System.IO.Unsafe import qualified Graphics.Rendering.Cairo as C @@ -71,22 +74,21 @@ unsafeCairo :: C.Render a -> a unsafeCairo = unsafePerformIO . queryCairo --- | Executes the given cairo action, with styling applied. This does --- not do all styling, only attributes that are processed by --- 'cairoMiscStyle', which does clip, fill color, fill rule, and, --- importantly for this module, font face, style, and weight. +-- | Executes the given cairo action, with styling applied. cairoWithStyle :: C.Render a -> Style R2 -> C.Render a cairoWithStyle f style = do C.save - evalStateT (cairoMiscStyle style) False + runRenderM (cairoStyle style) result <- f C.restore return result -- | A more convenient data structure for the results of a text-extents query. data TextExtents = TextExtents - { bearing, textSize, advance :: R2 } + { _bearing, _textSize, _advance :: R2 } +makeLenses ''TextExtents + processTextExtents :: C.TextExtents -> TextExtents processTextExtents (C.TextExtents xb yb w h xa ya) = TextExtents (r2 (xb,yb)) (r2 (w,h)) (r2 (xa,ya)) @@ -98,10 +100,12 @@ -- | A more convenient data structure for the results of a font-extents query. data FontExtents = FontExtents - { ascent, descent, height :: Double - , maxAdvance :: R2 + { _ascent, _descent, _height :: Double + , _maxAdvance :: R2 } +makeLenses ''FontExtents + processFontExtents :: C.FontExtents -> FontExtents processFontExtents (C.FontExtents a d h mx my) = FontExtents a d h (r2 (mx,my)) @@ -126,7 +130,7 @@ -- 'baselineText'. kerningCorrectionIO :: Style R2 -> Char -> Char -> IO Double kerningCorrectionIO style a b = do - let ax t = fst . unr2 . advance <$> queryCairo (getTextExtents style t) + let ax t = fst . unr2 . view advance <$> queryCairo (getTextExtents style t) l <- ax [a, b] la <- ax [a] lb <- ax [b] @@ -138,8 +142,8 @@ textLineBoundedIO :: Style R2 -> 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)) + let box = fromCorners (p2 (0, negate $ view descent fe)) + (p2 (fst . unr2 $ view advance te, view ascent fe)) return . setEnvelope (getEnvelope box) . applyStyle style $ baselineText str -- | Creates a text diagram with its envelope set to enclose the glyphs of the text, @@ -147,8 +151,8 @@ textVisualBoundedIO :: Style R2 -> 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) + let box = fromCorners (origin .+^ view bearing te) + ((origin .+^ view bearing te) .+^ view textSize te) return . setEnvelope (getEnvelope box) . applyStyle style $ baselineText str -- | Queries the amount of horizontal offset that needs to be applied