diff --git a/diagrams-postscript.cabal b/diagrams-postscript.cabal --- a/diagrams-postscript.cabal +++ b/diagrams-postscript.cabal @@ -1,5 +1,5 @@ Name: diagrams-postscript -Version: 1.4.1 +Version: 1.5 Synopsis: Postscript backend for diagrams drawing EDSL Description: This package provides a modular backend for rendering diagrams created with the diagrams EDSL using Postscript. @@ -23,7 +23,7 @@ Category: Graphics Build-type: Simple Cabal-version: 1.18 -Tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2 +Tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.3 || ==8.6.5 || ==8.8.1 Source-repository head type: git location: https://github.com/diagrams/diagrams-postscript.git @@ -34,19 +34,18 @@ Diagrams.Backend.Postscript.CmdLine Graphics.Rendering.Postscript Hs-source-dirs: src - Build-depends: base >= 4.2 && < 4.12, + Build-depends: base >= 4.8 && < 4.14, + bytestring >= 0.9 && <0.11, mtl >= 2.0 && < 2.3, - dlist >= 0.5 && < 0.9, diagrams-core >= 1.3 && < 1.5, diagrams-lib >= 1.3 && < 1.5, data-default-class < 0.2, - statestack >= 0.2 && < 0.3, + statestack >= 0.2 && < 0.4, split >= 0.1.2 && < 0.3, - monoid-extras >= 0.3 && < 0.5, - semigroups >= 0.3.4 && < 0.19, - lens >= 4.0 && < 4.17, - containers >= 0.3 && < 0.6, - hashable >= 1.1 && < 1.3 - if impl(ghc < 7.6) - build-depends: ghc-prim + monoid-extras >= 0.3 && < 0.6, + semigroups >= 0.3.4 && < 0.20, + lens >= 4.0 && < 4.19, + containers >= 0.3 && < 0.7, + hashable >= 1.1 && < 1.4 + default-language: Haskell2010 diff --git a/src/Diagrams/Backend/Postscript.hs b/src/Diagrams/Backend/Postscript.hs --- a/src/Diagrams/Backend/Postscript.hs +++ b/src/Diagrams/Backend/Postscript.hs @@ -65,6 +65,8 @@ import Control.Monad.Trans (lift) import Data.Maybe (catMaybes, isJust) +import qualified Data.ByteString.Builder as B + import qualified Data.Foldable as F import Data.Hashable (Hashable (..)) import Data.Tree @@ -133,7 +135,7 @@ instance Backend Postscript V2 Double where data Render Postscript V2 Double = C (RenderM ()) - type Result Postscript V2 Double = IO () + type Result Postscript V2 Double = B.Builder data Options Postscript V2 Double = PostscriptOptions { _psfileName :: String -- ^ the name of the file you want generated , _psSizeSpec :: SizeSpec V2 Double -- ^ the requested size of the output @@ -142,7 +144,7 @@ deriving (Show) renderRTree _ opts t = - let surfaceF surface = C.renderWith surface r + let surfaceF surface = fst (C.renderBuilder surface r) V2 w h = specToSize 100 (opts^.psSizeSpec) r = runRenderM . runC . toRender $ t in case opts^.psOutputFormat of diff --git a/src/Diagrams/Backend/Postscript/CmdLine.hs b/src/Diagrams/Backend/Postscript/CmdLine.hs --- a/src/Diagrams/Backend/Postscript/CmdLine.hs +++ b/src/Diagrams/Backend/Postscript/CmdLine.hs @@ -72,6 +72,9 @@ ) where +import qualified Data.ByteString.Builder as B +import System.IO (IOMode (..), withFile) + import Diagrams.Backend.CmdLine import Diagrams.Backend.Postscript import Diagrams.Prelude hiding (height, interval, option, @@ -165,7 +168,10 @@ renderDias' ds o = renderDias o ds >> return () renderDia' :: QDiagram Postscript V2 Double Any -> Options Postscript V2 Double -> IO () -renderDia' d o = renderDia Postscript o d >> return () +renderDia' d o = do + let b = renderDia Postscript o d + withFile (o ^. psfileName) WriteMode $ \h -> B.hPutBuilder h b + -- | @multiMain@ is like 'defaultMain', except instead of a single diff --git a/src/Graphics/Rendering/Postscript.hs b/src/Graphics/Rendering/Postscript.hs --- a/src/Graphics/Rendering/Postscript.hs +++ b/src/Graphics/Rendering/Postscript.hs @@ -1,7 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + -- for Data.Semigroup + ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Postscript @@ -28,6 +33,8 @@ , PSWriter(..) , renderWith , renderPagesWith + , renderBuilder + , renderPagesBuilder , withEPSSurface , newPath , moveTo @@ -76,21 +83,22 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative +import Data.Monoid (mconcat, mempty) #endif -import Control.Lens (Lens', makeLenses, use, (%=), (.=)) -import Control.Monad.State -import Control.Monad.Writer -import Data.Char (isPrint, ord) -import Data.DList (DList, fromList, toList) -import Data.List (intersperse) -import Diagrams.Attributes (Color (..), LineCap (..), - LineJoin (..), SomeColor (..), - colorToSRGBA) -import Diagrams.TwoD.Attributes (Texture (..)) -import Diagrams.TwoD.Path hiding (fillRule, stroke) -import Numeric (showIntAtBase) -import System.IO (IOMode (..), hClose, hPutStr, - openFile) +import Control.Lens (Lens', makeLenses, use, (%=), (.=)) +import Control.Monad.State.Strict +import qualified Data.ByteString.Builder as B +import Data.Char (isPrint, ord) +import Data.List (intersperse) +import Data.Semigroup (Semigroup (..)) +import Data.String (fromString) +import Diagrams.Attributes (Color (..), LineCap (..), + LineJoin (..), SomeColor (..), + colorToSRGBA) +import Diagrams.TwoD.Attributes (Texture (..)) +import Diagrams.TwoD.Path hiding (fillRule, stroke) +import Numeric (showIntAtBase) +import System.IO (IOMode (..), withFile) data CMYK = CMYK { _cyan :: Double @@ -129,8 +137,8 @@ -- that we have emitted into the postscript file (at least -- ones that we do not protect in other ways). data DrawState = DS - { _fillRule :: FillRule - , _font :: PostscriptFont + { _fillRule :: FillRule + , _font :: PostscriptFont } deriving (Eq) makeLenses ''DrawState @@ -140,8 +148,8 @@ emptyDS = DS Winding defaultFont data RenderState = RS - { _drawState :: DrawState -- The current state. - , _saved :: [DrawState] -- A stack of passed states pushed by save and poped with restore. + { _drawState :: !DrawState -- The current state. + , _saved :: ![DrawState] -- A stack of passed states pushed by save and poped with restore. } makeLenses ''RenderState @@ -150,17 +158,27 @@ emptyRS = RS emptyDS [] -- +-- | Type for a monad that writes Postscript using the commands we will define later. -- | Type for a monad that writes Postscript using the commands we will define later. -newtype PSWriter m = PSWriter { runPSWriter :: WriterT (DList String) IO m } - deriving (Functor, Applicative, Monad, MonadWriter (DList String)) +newtype PSWriter m = PSWriter { runPSWriter :: State B.Builder m } + deriving (Functor, Applicative, Monad, MonadState B.Builder) +tell' :: (MonadState s m, Semigroup s) => s -> m () +#if MIN_VERSION_mtl(2,2,0) +tell' x = modify' (<> x) +#else +tell' x = do + s' <- get + put $! s' <> x +#endif + -- | Type of the monad that tracks the state from side-effecting commands. newtype Render m = Render { runRender :: StateT RenderState PSWriter m } deriving (Functor, Applicative, Monad, MonadState RenderState) -- | Abstraction of the drawing surface details. -data Surface = Surface { header :: Int -> String, footer :: Int -> String, _width :: Int, _height :: Int, fileName :: String } +data Surface = Surface { header :: Int -> B.Builder, footer :: Int -> B.Builder, _width :: Int, _height :: Int, fileName :: String } doRender :: Render a -> PSWriter a doRender r = evalStateT (runRender r) emptyRS @@ -169,50 +187,57 @@ -- passed 'Surface' and renders the commands built up in the -- 'Render' argument. renderWith :: MonadIO m => Surface -> Render a -> m a -renderWith s r = liftIO $ do - (v,ss) <- runWriterT . runPSWriter . doRender $ r - h <- openFile (fileName s) WriteMode - hPutStr h (header s 1) - mapM_ (hPutStr h) (toList ss) - hPutStr h (footer s 1) - hClose h +renderWith s r = liftIO $ withFile (fileName s) WriteMode $ \h -> do + B.hPutBuilder h b return v + where + (b, v) = renderBuilder s r +-- | Pure variant of 'renderWith' +renderBuilder :: Surface -> Render a -> (B.Builder, a) +renderBuilder s r = + let (v, ss) = flip runState mempty . runPSWriter . doRender $ r + in (header s 1 <> ss <> footer s 1, v) + -- | Renders multiple pages given as a list of 'Render' actions -- to the file associated with the 'Surface' argument. renderPagesWith :: MonadIO m => Surface -> [Render a] -> m [a] -renderPagesWith s rs = liftIO $ do - h <- openFile (fileName s) WriteMode - hPutStr h (header s (length rs)) - - vs <- mapM (page h) (zip rs [1..]) - - hClose h - return vs +renderPagesWith s rs = liftIO $ withFile (fileName s) WriteMode $ \h -> do + B.hPutBuilder h b + return v where - page h (r,i) = do - (v,ss) <- runWriterT . runPSWriter . doRender $ r - mapM_ (hPutStr h) (toList ss) - hPutStr h (footer s i) - return v + (b, v) = renderPagesBuilder s rs +-- | Pure variant of 'renderPagesWith' +renderPagesBuilder :: Surface -> [Render a] -> (B.Builder, [a]) +renderPagesBuilder s rs = + let (vs, sss) = unzip . map (uncurry page) $ zip rs [1..] + in (header s (length rs) <> mconcat sss, vs) + where + page r i = + let (v, ss) = flip runState mempty . runPSWriter . doRender $ r + in (v, ss <> footer s i) + -- | Builds a surface and performs an action on that surface. -withEPSSurface :: String -> Int -> Int -> (Surface -> IO a) -> IO a +withEPSSurface :: String -> Int -> Int -> (Surface -> r) -> r withEPSSurface file w h f = f s where s = Surface (epsHeader w h) epsFooter w h file -renderPS :: String -> Render () -renderPS s = Render . lift . tell $ fromList [s, "\n"] +renderPS :: B.Builder -> Render () +renderPS b = Render . lift . tell' $ b <> "\n" +renderWordsPS :: (a -> B.Builder) -> [a] -> Render () +renderWordsPS f = renderPS . mconcat . intersperse " " . map f + -- | Clip with the current path. clip :: Render () clip = renderPS "clip" -mkPSCall :: Show a => String -> [a] -> Render() -mkPSCall n vs = renderPS . concat $ intersperse " " (map show vs) ++ [" ", n] +mkPSCall :: (a -> B.Builder) -> B.Builder -> [a] -> Render () +mkPSCall f n vs = mkPSCall' n (map f vs) -mkPSCall' :: String -> [String] -> Render() -mkPSCall' n vs = renderPS . concat $ intersperse " " vs ++ [" ", n] +mkPSCall' :: B.Builder -> [B.Builder] -> Render() +mkPSCall' n vs = renderPS $ mconcat (intersperse " " vs) <> " " <> n -- | Start a new path. newPath :: Render () @@ -229,30 +254,30 @@ -> Double -- ^ start angle in radians. -> Double -- ^ end angle in radians. -> Render () -arc a b c d e = mkPSCall "arc" [a,b,c, d * 180 / pi, e* 180 / pi] +arc a b c d e = mkPSCall B.doubleDec "arc" [a,b,c, d * 180 / pi, e* 180 / pi] -- | Move the current point. moveTo :: Double -> Double -> Render () -moveTo x y = mkPSCall "moveto" [x,y] +moveTo x y = mkPSCall B.doubleDec "moveto" [x,y] -- | Add a line to the current path from the current point to the given point. -- The current point is also moved with this command. lineTo :: Double -> Double -> Render () -lineTo x y = mkPSCall "lineto" [x,y] +lineTo x y = mkPSCall B.doubleDec "lineto" [x,y] -- | Add a cubic Bézier curve segment to the current path from the current point. -- The current point is also moved with this command. curveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Render () -curveTo ax ay bx by cx cy = mkPSCall "curveto" [ax,ay,bx,by,cx,cy] +curveTo ax ay bx by cx cy = mkPSCall B.doubleDec "curveto" [ax,ay,bx,by,cx,cy] -- | Add a line segment to the current path using relative coordinates. relLineTo :: Double -> Double -> Render () -relLineTo x y = mkPSCall "rlineto" [x,y] +relLineTo x y = mkPSCall B.doubleDec "rlineto" [x,y] -- | Add a cubic Bézier curve segment to the current path from the current point -- using relative coordinates. relCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> Render () -relCurveTo ax ay bx by cx cy = mkPSCall "rcurveto" [ax,ay,bx,by,cx,cy] +relCurveTo ax ay bx by cx cy = mkPSCall B.doubleDec "rcurveto" [ax,ay,bx,by,cx,cy] -- | Stroke the current path. stroke :: Render () @@ -290,7 +315,7 @@ showTextInBox :: (Double,Double) -> (Double,Double) -> String -> Render () showTextInBox (a,b) (c,d) s = do renderFont - renderPS . unwords . map show $ [a,b,c,d] + renderWordsPS B.doubleDec $ [a,b,c,d] stringPS s renderPS " showinbox" @@ -298,18 +323,19 @@ showTextAlign :: Double -> Double -> String -> Render () showTextAlign xt yt s = do renderFont - renderPS . unwords . map show $ [xt, yt] + renderPS " " + renderWordsPS B.doubleDec [xt, yt] stringPS s renderPS " showalign" -- | Apply a transform matrix to the current transform. transform :: Double -> Double -> Double -> Double -> Double -> Double -> Render () transform ax ay bx by tx ty = when (vs /= [1.0,0.0,0.0,1.0,0.0,0.0]) $ - renderPS (matrixPS vs ++ " concat") + renderPS (matrixPS vs <> " concat") where vs = [ax,ay,bx,by,tx,ty] -matrixPS :: Show a => [a] -> String -matrixPS vs = unwords ("[" : map show vs ++ ["]"]) +matrixPS :: Show a => [a] -> B.Builder +matrixPS vs = fromString $ unwords ("[" : map show vs ++ ["]"]) -- | Push the current state of the renderer onto the state stack. save :: Render () @@ -364,13 +390,13 @@ -- | Set the color of the stroke. Ignore gradients. strokeColor :: Texture n -> Render () -strokeColor (SC (SomeColor c)) = mkPSCall "setrgbcolor" (colorPS c) +strokeColor (SC (SomeColor c)) = mkPSCall B.doubleDec "setrgbcolor" (colorPS c) strokeColor _ = return () -- | Set the color of the fill. Ignore gradients. fillColor :: Texture n -> Render () -fillColor (SC (SomeColor c)) = mkPSCall "setrgbcolor" (colorPS c) -fillColor _ = return () +fillColor (SC (SomeColor c)) = mkPSCall B.doubleDec "setrgbcolor" (colorPS c) +fillColor _ = return () -- CMYK colors colorCMYK :: CMYK -> [Double] @@ -378,36 +404,36 @@ -- | Set the color of the stroke. strokeColorCMYK :: CMYK -> Render () -strokeColorCMYK c = mkPSCall "setcmykcolor" (colorCMYK c) +strokeColorCMYK c = mkPSCall B.doubleDec "setcmykcolor" (colorCMYK c) -- | Set the color of the fill. fillColorCMYK :: CMYK -> Render () -fillColorCMYK c = mkPSCall "setcmykcolor" (colorCMYK c) +fillColorCMYK c = mkPSCall B.doubleDec "setcmykcolor" (colorCMYK c) -- | Set the line width. lineWidth :: Double -> Render () -lineWidth w = mkPSCall "setlinewidth" [w] +lineWidth w = mkPSCall B.doubleDec "setlinewidth" [w] -- | Set the line cap style. lineCap :: LineCap -> Render () -lineCap lc = mkPSCall "setlinecap" [fromLineCap lc] +lineCap lc = mkPSCall B.intDec "setlinecap" [fromLineCap lc] -- | Set the line join method. lineJoin :: LineJoin -> Render () -lineJoin lj = mkPSCall "setlinejoin" [fromLineJoin lj] +lineJoin lj = mkPSCall B.intDec "setlinejoin" [fromLineJoin lj] -- | Set the miter limit. miterLimit :: Double -> Render () -miterLimit ml = mkPSCall "setmiterlimit" [ml] +miterLimit ml = mkPSCall B.doubleDec "setmiterlimit" [ml] -- | Set the dash style. setDash :: [Double] -- ^ Dash pattern (even indices are "on"). -> Double -- ^ Offset. -> Render () -setDash as offset = mkPSCall' "setdash" [showArray as, show offset] +setDash as offset = mkPSCall' "setdash" [showArray B.doubleDec as, B.doubleDec offset] -showArray :: Show a => [a] -> String -showArray as = concat ["[", concat $ intersperse " " (map show as), "]"] +showArray :: (a -> B.Builder) -> [a] -> B.Builder +showArray f as = "[" <> mconcat (intersperse " " (map f as)) <> "]" fromLineCap :: LineCap -> Int fromLineCap LineCapRound = 1 @@ -421,18 +447,21 @@ -- | Translate the current transform matrix. translate :: Double -> Double -> Render () -translate x y = mkPSCall "translate" [x,y] +translate x y = mkPSCall B.doubleDec "translate" [x,y] -- | Scale the current transform matrix. scale :: Double -> Double -> Render () -scale x y = mkPSCall "scale" [x,y] +scale x y = mkPSCall B.doubleDec "scale" [x,y] -- | Rotate the current transform matrix. rotate :: Double -> Render () -rotate t = mkPSCall "rotate" [t] +rotate t = mkPSCall B.doubleDec "rotate" [t] stringPS :: String -> Render () -stringPS ss = Render $ lift (tell (fromList ("(" : map escape ss)) >> tell (fromList [")"])) +stringPS ss = Render $ lift $ do + tell' "(" + tell' (fromString $ concatMap escape ss) + tell' ")" where escape '\n' = "\\n" escape '\r' = "\\r" escape '\t' = "\\t" @@ -444,12 +473,12 @@ escape c | isPrint c = [c] | otherwise = '\\' : showIntAtBase 7 ("01234567"!!) (ord c) "" -epsHeader :: Int -> Int -> Int -> String -epsHeader w h pages = concat +epsHeader :: Int -> Int -> Int -> B.Builder +epsHeader w h pages = mconcat [ "%!PS-Adobe-3.0", if pages == 1 then " EPSF-3.0\n" else "\n" , "%%Creator: diagrams-postscript 0.1\n" - , "%%BoundingBox: 0 0 ", show w, " ", show h, "\n" - , "%%Pages: ", show pages, "\n" + , "%%BoundingBox: 0 0 ", B.intDec w, " ", B.intDec h, "\n" + , "%%Pages: ", B.intDec pages, "\n" , "%%EndComments\n\n" , "%%BeginProlog\n" , "%%BeginResource: procset diagrams-postscript 0 0\n" @@ -475,11 +504,11 @@ , "%%Page: 1 1\n" ] -epsFooter :: Int -> String -epsFooter page = concat +epsFooter :: Int -> B.Builder +epsFooter page = mconcat [ "showpage\n" , "%%PageTrailer\n" - , "%%EndPage: ", show page, "\n" + , "%%EndPage: ", B.intDec page, "\n" ] --------------------------- @@ -488,8 +517,8 @@ renderFont :: Render () renderFont = do n <- fontFromName <$> f face <*> f slant <*> f weight - s <- show <$> f size - renderPS $ concat ["/", n, " ", s, " selectfont"] + s <- f size + renderPS $ mconcat ["/", fromString n, " ", B.doubleDec s, " selectfont"] where f :: Lens' PostscriptFont a -> Render a f x = use $ drawState . font . x @@ -505,7 +534,7 @@ bold FontWeightNormal = "" bold FontWeightBold = "Bold" - italic FontSlantNormal = "" - italic FontSlantItalic = "Italic" + italic FontSlantNormal = "" + italic FontSlantItalic = "Italic" italic FontSlantOblique = "Oblique" italic _ = ""