diagrams-postscript 1.0.2.4 → 1.1
raw patch · 4 files changed
+80/−70 lines, 4 filesdep +containersdep ~diagrams-coredep ~diagrams-libdep ~lens
Dependencies added: containers
Dependency ranges changed: diagrams-core, diagrams-lib, lens, mtl, semigroups
Files
- diagrams-postscript.cabal +7/−7
- src/Diagrams/Backend/Postscript.hs +54/−48
- src/Diagrams/Backend/Postscript/CmdLine.hs +6/−6
- src/Graphics/Rendering/Postscript.hs +13/−9
diagrams-postscript.cabal view
@@ -1,5 +1,5 @@ Name: diagrams-postscript-Version: 1.0.2.4+Version: 1.1 Synopsis: Postscript backend for diagrams drawing EDSL Description: This package provides a modular backend for rendering diagrams created with the diagrams EDSL using Postscript.@@ -32,19 +32,19 @@ Graphics.Rendering.Postscript Hs-source-dirs: src Build-depends: base >= 4.2 && < 4.8,- mtl >= 2.0 && < 2.2,+ mtl >= 2.0 && < 2.3, filepath, dlist >= 0.5 && < 0.8, vector-space >= 0.7.7 && < 0.9,- diagrams-core >= 1.0 && < 1.2,- diagrams-lib >= 1.0.1 && < 1.2,+ diagrams-core >= 1.0 && < 1.3,+ diagrams-lib >= 1.0.1 && < 1.3, data-default-class < 0.1, split >= 0.1.2 && < 0.3, monoid-extras >= 0.3 && < 0.4,- semigroups >= 0.3.4 && < 0.14,- lens >= 3.8 && < 4.2,+ semigroups >= 0.3.4 && < 0.16,+ lens >= 3.8 && < 4.3,+ containers >= 0.3 && < 0.6, hashable >= 1.1 && < 1.3 if impl(ghc < 7.6) build-depends: ghc-prim default-language: Haskell2010-
src/Diagrams/Backend/Postscript.hs view
@@ -44,13 +44,15 @@ -- * Postscript-supported output formats , OutputFormat(..)- ) where + , renderDias+ ) where +import Diagrams.Core.Compile import qualified Graphics.Rendering.Postscript as C import Diagrams.Backend.Postscript.CMYK -import Diagrams.Prelude hiding (view)+import Diagrams.Prelude hiding (view, fillColor) import Diagrams.TwoD.Adjust (adjustDia2D) import Diagrams.TwoD.Path (Clip (Clip), getFillRule)@@ -64,7 +66,7 @@ import qualified Data.Foldable as F import Data.Hashable (Hashable (..)) import qualified Data.List.NonEmpty as N-import Data.Monoid.Split+import Data.Tree import Data.Typeable import GHC.Generics (Generic) @@ -96,29 +98,29 @@ } deriving (Show) - withStyle _ s t (C r) = C $ do- C.save- postscriptMiscStyle s- r- postscriptTransf t- postscriptStyle s- C.stroke- C.restore-- doRender _ (PostscriptOptions file size out) (C r) =+ renderRTree _ opts t = let surfaceF surface = C.renderWith surface r- -- Everything except Dims is arbitrary. The backend- -- should have first run 'adjustDia' to update the- -- final size of the diagram with explicit dimensions,- -- so normally we would only expect to get Dims anyway.- (w,h) = sizeFromSpec size+ (w,h) = sizeFromSpec (opts^.psSizeSpec)+ r = runC . toRender $ t+ in case opts^.psOutputFormat of+ EPS -> C.withEPSSurface (opts^.psfileName) (round w) (round h) surfaceF - in case out of- EPS -> C.withEPSSurface file (round w) (round h) surfaceF+ adjustDia c opts d = adjustDia2D psSizeSpec c opts d - adjustDia c opts d = adjustDia2D _psSizeSpec setPsSize c opts d- where setPsSize sz o = o { _psSizeSpec = sz }+runC :: Render Postscript R2 -> C.Render ()+runC (C r) = r +toRender :: RTree Postscript R2 a -> Render Postscript R2+toRender (Node (RPrim p) _) = render Postscript p+toRender (Node (RStyle sty) rs) = C $ do+ C.save+ postscriptMiscStyle sty+ runC $ F.foldMap toRender rs+ postscriptStyle sty+ C.stroke+ C.restore+toRender (Node _ rs) = F.foldMap toRender rs+ instance Hashable (Options Postscript R2) where hashWithSalt s (PostscriptOptions fn sz out) = s `hashWithSalt` fn@@ -144,28 +146,28 @@ psOutputFormat = lens (\(PostscriptOptions {_psOutputFormat = t}) -> t) (\o t -> o {_psOutputFormat = t}) -instance MultiBackend Postscript R2 where- renderDias b opts ds = doRenderPages b (combineSizes (map fst rs)) (map snd rs) >> return ()- where- mkMax (x,y) = (Max x, Max y)- fromMaxPair (Max x, Max y) = (x,y)+renderDias :: (Semigroup m, Monoid m) =>+ Options Postscript R2 -> [QDiagram Postscript R2 m] -> IO [()]+renderDias opts ds = case opts^.psOutputFormat of+ EPS -> C.withEPSSurface (opts^.psfileName) (round w) (round h) surfaceF+ where+ surfaceF surface = C.renderPagesWith surface (map (\(C r) -> r) rs)+ (w,h) = sizeFromSpec (cSize^.psSizeSpec) - rs = map mkRender ds- mkRender d = (opts', mconcat . map renderOne . prims $ d')- where- (opts', d') = adjustDia b opts d- renderOne (p, (M t, s)) = withStyle b s mempty (render b (transform t p))- renderOne (p, (t1 :| t2, s)) = withStyle b s t1 (render b (transform (t1 <> t2) p))+ dropMid (x, _, z) = (x,z) - combineSizes [] = PostscriptOptions "" (Dims 100 100) EPS -- arbitrary- combineSizes (o:os) = o { _psSizeSpec = uncurry Dims . fromMaxPair . sconcat $ f o N.:| fmap f os }- where f = mkMax . sizeFromSpec . _psSizeSpec+ optsdss = map (dropMid . adjustDia Postscript opts) ds+ cSize = (combineSizes $ map fst optsdss)+ g2o = scaling (sqrt (w * h))+ rs = map (toRender . toRTree g2o . snd) optsdss - doRenderPages _ (PostscriptOptions file size out) pages =- let surfaceF surface = C.renderPagesWith surface (map (\(C r) -> r) pages)- (w,h) = sizeFromSpec size- in case out of- EPS -> C.withEPSSurface file (round w) (round h) surfaceF+ combineSizes [] = PostscriptOptions "" (Dims 100 100) EPS+ combineSizes (o:os) =+ o { _psSizeSpec = uncurry Dims . fromMaxPair . sconcat $ f o N.:| fmap f os }+ where+ f = mkMax . sizeFromSpec . _psSizeSpec+ fromMaxPair (Max x, Max y) = (x,y)+ mkMax (x,y) = (Max x, Max y) renderC :: (Renderable a Postscript, V a ~ R2) => a -> C.Render () renderC a = case render Postscript a of C r -> r@@ -180,6 +182,7 @@ , handle fSlant , handle fWeight , handle fSize+ , handle fLocal , handle fColor , handle fColorCMYK , handle lFillRule@@ -188,11 +191,12 @@ handle :: AttributeClass a => (a -> C.Render ()) -> Maybe (C.Render ()) handle f = f `fmap` getAttr s clip = mapM_ (\p -> renderC p >> C.clip) . op Clip- fSize = assign (C.drawState . C.font . C.size) <$> getFontSize+ fSize = assign (C.drawState . C.font . C.size) <$> (fromOutput . getFontSize)+ fLocal = assign (C.drawState . C.font . C.isLocal) <$> getFontSizeIsLocal fFace = assign (C.drawState . C.font . C.face) <$> getFont fSlant = assign (C.drawState . C.font . C.slant) .fromFontSlant <$> getFontSlant fWeight = assign (C.drawState . C.font . C.weight) . fromFontWeight <$> getFontWeight- fColor c = C.fillColor (getFillColor c)+ fColor = C.fillColor . getFillTexture fColorCMYK c = C.fillColorCMYK (getFillColorCMYK c) lFillRule = assign (C.drawState . C.fillRule) . getFillRule @@ -219,16 +223,16 @@ ] where handle :: (AttributeClass a) => (a -> C.Render ()) -> Maybe (C.Render ()) handle f = f `fmap` getAttr s- lColor = C.strokeColor . getLineColor+ lColor = C.strokeColor . getLineTexture lColorCMYK = C.strokeColorCMYK . getLineColorCMYK- fColor c = C.fillColor (getFillColor c) >> C.fillPreserve+ fColor c = C.fillColor (getFillTexture c) >> C.fillPreserve fColorCMYK c = C.fillColorCMYK (getFillColorCMYK c) >> C.fillPreserve- lWidth = C.lineWidth . getLineWidth+ lWidth = C.lineWidth . fromOutput . getLineWidth lCap = C.lineCap . getLineCap lJoin = C.lineJoin . getLineJoin lMiter = C.miterLimit . getLineMiterLimit lDashing (getDashing -> Dashing ds offs) =- C.setDash ds offs+ C.setDash (map fromOutput ds) (fromOutput offs) postscriptTransf :: Transformation R2 -> C.Render () postscriptTransf t = C.transform a1 a2 b1 b2 c1 c2@@ -264,7 +268,9 @@ renderC tr instance Renderable Text Postscript where- render _ (Text tr al str) = C $ do+ render _ (Text tt tn al str) = C $ do+ isLocal <- use (C.drawState . C.font . C.isLocal)+ let tr = if isLocal then tt else tn C.save postscriptTransf tr case al of
src/Diagrams/Backend/Postscript/CmdLine.hs view
@@ -48,11 +48,11 @@ -- -- For a tutorial on command-line diagram creation see -- <http://projects.haskell.org/diagrams/doc/cmdline.html>.--- +-- ----------------------------------------------------------------------------- module Diagrams.Backend.Postscript.CmdLine- ( + ( -- * General form of @main@ -- $mainwith @@ -156,7 +156,7 @@ chooseRender opts renderer = case splitOn "." (opts^.output) of [""] -> putStrLn "No output file given."- ps | last ps `elem` ["eps"] + ps | last ps `elem` ["eps"] || last ps `elem` ["ps"] -> do let outfmt = case last ps of _ -> EPS@@ -169,13 +169,13 @@ renderer (PostscriptOptions (opts^.output) sizeSpec outfmt) | otherwise -> putStrLn $ "Unknown file type: " ++ last ps- + renderDias' :: [Diagram Postscript R2] -> Options Postscript R2 -> IO ()-renderDias' ds o = renderDias Postscript o ds >> return ()+renderDias' ds o = renderDias o ds >> return () renderDia' :: Diagram Postscript R2 -> Options Postscript R2 -> IO () renderDia' d o = renderDia Postscript o d >> return ()- + -- | @multiMain@ is like 'defaultMain', except instead of a single -- diagram it takes a list of diagrams paired with names as input.
src/Graphics/Rendering/Postscript.hs view
@@ -65,14 +65,15 @@ , FontSlant(..) , FontWeight(..)- , face, slant, weight, size+ , face, slant, weight, size, isLocal , fillRule, ignoreFill, font , CMYK(..), cyan, magenta, yellow, blacK ) where -import Diagrams.Attributes(Color(..),LineCap(..),LineJoin(..),colorToSRGBA)+import Diagrams.Attributes(Color(..),LineCap(..),LineJoin(..),colorToSRGBA,SomeColor(..))+import Diagrams.TwoD.Attributes (Texture(..)) import Diagrams.TwoD.Path hiding (stroke, fillRule) import Control.Applicative import Control.Monad.Writer@@ -109,12 +110,13 @@ , _slant :: FontSlant , _weight :: FontWeight , _size :: Double+ , _isLocal :: Bool } deriving (Eq, Show) makeLenses '' PostscriptFont defaultFont :: PostscriptFont-defaultFont = PostscriptFont "Helvetica" FontSlantNormal FontWeightNormal 1+defaultFont = PostscriptFont "Helvetica" FontSlantNormal FontWeightNormal 1 True -- Here we want to mirror the state of side-effecting calls -- that we have emitted into the postscript file (at least@@ -358,13 +360,15 @@ colorPS c = [ r, g, b ] where (r,g,b,_) = colorToSRGBA c --- | Set the color of the stroke.-strokeColor :: (Color c) => c -> Render ()-strokeColor c = mkPSCall "setrgbcolor" (colorPS c)+-- | Set the color of the stroke. Ignore gradients.+strokeColor :: Texture -> Render ()+strokeColor (SC (SomeColor c)) = mkPSCall "setrgbcolor" (colorPS c)+strokeColor _ = return () --- | Set the color of the fill.-fillColor :: (Color c) => c -> Render ()-fillColor c = mkPSCall "setrgbcolor" (colorPS c)+-- | Set the color of the fill. Ignore gradients.+fillColor :: Texture -> Render ()+fillColor (SC (SomeColor c)) = mkPSCall "setrgbcolor" (colorPS c)+fillColor _ = return () -- CMYK colors colorCMYK :: CMYK -> [Double]