diagrams-cairo 0.7 → 1.0
raw patch · 10 files changed
+366/−288 lines, 10 filesdep +containersdep +data-default-classdep +lensdep −cmdargsdep ~basedep ~diagrams-coredep ~diagrams-lib
Dependencies added: containers, data-default-class, lens, statestack
Dependencies removed: cmdargs
Dependency ranges changed: base, diagrams-core, diagrams-lib
Files
- CHANGES.markdown +8/−2
- LICENSE +2/−0
- README.markdown +14/−9
- diagrams-cairo.cabal +9/−6
- src/Diagrams/Backend/Cairo.hs +8/−7
- src/Diagrams/Backend/Cairo/CmdLine.hs +124/−125
- src/Diagrams/Backend/Cairo/Internal.hs +165/−107
- src/Diagrams/Backend/Cairo/List.hs +11/−11
- src/Diagrams/Backend/Cairo/Ptr.hs +4/−4
- src/Diagrams/Backend/Cairo/Text.hs +21/−17
CHANGES.markdown view
@@ -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-
LICENSE view
@@ -1,8 +1,10 @@ Copyright 2011-2013 diagrams-cairo team: + Daniel Bergey <bergey@alum.mit.edu> Sam Griffin <sam.griffin@gmail.com> Niklas Haas <nand@lavabit.com> John Lato <jwlato@gmail.com>+ Jeffrey Rosenbluth <Jeffrey.Rosenbluth@gmail.com> Ian Ross <ian@skybluetrades.net> Michael Sloan <mgsloan@gmail.com> Luite Stegeman <stegeman@gmail.com>
README.markdown view
@@ -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
diagrams-cairo.cabal view
@@ -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)
src/Diagrams/Backend/Cairo.hs view
@@ -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
src/Diagrams/Backend/Cairo/CmdLine.hs view
@@ -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+-- <http://projects.haskell.org/diagrams/doc/cmdline.html>.+-- ----------------------------------------------------------------------------- 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
src/Diagrams/Backend/Cairo/Internal.hs view
@@ -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
src/Diagrams/Backend/Cairo/List.hs view
@@ -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
src/Diagrams/Backend/Cairo/Ptr.hs view
@@ -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
src/Diagrams/Backend/Cairo/Text.hs view
@@ -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