diagrams-postscript 1.4.1 → 1.5

raw patch · 4 files changed

+137/−101 lines, 4 filesdep +bytestringdep −dlistdep −ghc-primdep ~basedep ~diagrams-coredep ~hashablePVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring

Dependencies removed: dlist, ghc-prim

Dependency ranges changed: base, diagrams-core, hashable, lens, monoid-extras, semigroups, statestack

API changes (from Hackage documentation)

Files

• diagrams-postscript.cabal +11/−12
• src/Diagrams/Backend/Postscript.hs +4/−2
• src/Diagrams/Backend/Postscript/CmdLine.hs +7/−1
• src/Graphics/Rendering/Postscript.hs +115/−86

@@ -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

@@ -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

@@ -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

@@ -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 _                = ""