diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,33 @@ +## [v1.5.1](https://github.com/diagrams/diagrams-lib/tree/v1.5.1) (2025-12-02) + +- New `Semigroup` instance for located lines (i.e. `Located (Trail' + Line v n)`), which adds an extra segment from the end of the first + to the start of the second. + +## [v1.5.0.1](https://github.com/diagrams/diagrams-lib/tree/v1.5.0.1) (2025-08-25) + +- Fix bug in `bezierFindRoot` that caused diagrams to hang when + computing the trace of certain degenerate Bezier curves. See + https://github.com/diagrams/diagrams-contrib/issues/91 . + +## [v1.5-r2](https://github.com/diagrams/diagrams-lib/tree/v1.5-r2) (2025-06-12) + +- Allow `optparse-applicative-0.19` + +## [v1.5-r1](https://github.com/diagrams/diagrams-lib/tree/v1.5-r1) (2025-05-17) + +- Allow `monoid-extras-0.7` + +## [v1.5](https://github.com/diagrams/diagrams-lib/tree/v1.5) (2025-02-13) + +- Allow `base-4.21` and test on GHC 9.12 +- Remove looped compilation mode options ([#372](https://github.com/diagrams/diagrams-lib/pull/372)) + - This allows us to remove the `fsnotify` dependency, which in + turn allows compiling diagrams to Wasm. + - To recover similar functionality (automatically recompiling + every time a source file changes), try an external tool like + `ghcid` or `ghciwatch`, or, more generically, `entr`. + ## [v1.4.7](https://github.com/diagrams/diagrams-lib/tree/v1.4.7) (2024-10-26) - Switch to `data-default-0.8` instead of `data-default-class` diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -1,5 +1,5 @@ Name: diagrams-lib -Version: 1.4.7 +Version: 1.5.1 Synopsis: Embedded domain-specific language for declarative graphics Description: Diagrams is a flexible, extensible EDSL for creating graphics of many types. Graphics can be created @@ -21,7 +21,7 @@ Cabal-version: 1.18 Extra-source-files: diagrams/*.svg Extra-doc-files: CHANGELOG.md, README.markdown, diagrams/*.svg -Tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 || ==9.10.1 +Tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1 || ==9.12.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-lib.git @@ -101,11 +101,11 @@ Diagrams.TwoD.Vector, Diagrams.Util other-modules: Linear.Vector.Compat - Build-depends: base >= 4.9 && < 4.21, + Build-depends: base >= 4.9 && < 4.22, containers >= 0.3 && < 0.8, array >= 0.3 && < 0.6, semigroups >= 0.3.4 && < 0.21, - monoid-extras >= 0.6 && < 0.7, + monoid-extras >= 0.6 && < 0.8, dual-tree >= 0.2 && < 0.3, diagrams-core >= 1.4 && < 1.6, diagrams-solve >= 0.1 && < 0.2, @@ -116,7 +116,7 @@ intervals >= 0.7 && < 0.10, lens >= 5.1 && < 5.4, tagged >= 0.7 && < 0.9, - optparse-applicative >= 0.11 && < 0.19, + optparse-applicative >= 0.11 && < 0.20, filepath >= 1.4 && < 1.6, JuicyPixels >= 3.3.4 && < 3.4, hashable >= 1.1 && < 1.6, @@ -124,7 +124,6 @@ adjunctions >= 4.0 && < 5.0, distributive >=0.2.2 && < 1.0, process >= 1.1 && < 1.7, - fsnotify >= 0.4 && < 0.5, directory >= 1.2 && < 1.4, unordered-containers >= 0.2 && < 0.3, text >= 0.7.1 && < 2.2, diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -50,12 +50,6 @@ , diagramAnimOpts , fpu - -- ** Loop options - , DiagramLoopOpts(..) - , diagramLoopOpts - , loop - , src - -- * Parsing , Parseable(..) , readHexColor @@ -70,19 +64,17 @@ -- ** helper functions for implementing @mainRender@ , defaultAnimMainRender , defaultMultiMainRender - , defaultLoopRender ) where import Control.Lens (Lens', makeLenses, (&), (.~), (^.)) import Diagrams.Animation import Diagrams.Attributes import Diagrams.Core hiding (output) -import Diagrams.Util import Options.Applicative import Options.Applicative.Types (readerAsk) -import Control.Monad (forM_, forever, unless, when) +import Control.Monad (forM_) -- MonadFail comes from Prelude in base-4.13 and up #if !MIN_VERSION_base(4,13,0) @@ -96,27 +88,12 @@ import Data.Colour.SRGB import Data.Data import Data.Functor.Identity -import Data.IORef import Data.Kind (Type) -import Data.List (delete) -import Data.Maybe (fromMaybe) import Data.Monoid import Numeric -import Control.Concurrent (threadDelay) -import System.Directory (canonicalizePath) -import System.Environment (getArgs, getProgName) -import System.Exit (ExitCode (..)) -import System.FilePath (addExtension, dropExtension, - replaceExtension, splitExtension, - takeDirectory, takeFileName, ()) -import System.FSNotify (defaultConfig, - eventTime, watchDir, - withManagerConf, confWatchMode, WatchMode(..)) -import System.FSNotify.Devel (existsEvents) -import System.Info (os) -import System.IO (hFlush, stdout) -import System.Process (readProcessWithExitCode) +import System.Environment (getProgName) +import System.FilePath (addExtension, splitExtension) import Text.Printf @@ -149,14 +126,6 @@ makeLenses ''DiagramAnimOpts --- | Extra options for command-line looping. -data DiagramLoopOpts = DiagramLoopOpts - { _loop :: Bool -- ^ Flag to indicate that the program should loop creation. - , _src :: Maybe FilePath -- ^ File path for the source file to recompile. - } - -makeLenses ''DiagramLoopOpts - -- | Command line parser for 'DiagramOpts'. -- Width is option @--width@ or @-w@. -- Height is option @--height@ or @-h@ (note we change help to be @-?@ due to this). @@ -199,16 +168,6 @@ <> value 30.0 <> help "Frames per unit time (for animations)") --- | CommandLine parser for 'DiagramLoopOpts' --- Loop is @--loop@ or @-l@. --- Source is @--src@ or @-s@. -diagramLoopOpts :: Parser DiagramLoopOpts -diagramLoopOpts = DiagramLoopOpts - <$> switch (long "loop" <> short 'l' <> help "Run in a self-recompiling loop") - <*> (optional . strOption) - ( long "src" <> short 's' - <> help "Source file to watch") - -- | A hidden \"helper\" option which always fails. -- Taken from Options.Applicative.Extra but without the -- short option 'h'. We want the 'h' for Height. @@ -277,11 +236,6 @@ instance Parseable DiagramAnimOpts where parser = diagramAnimOpts --- | Parse 'DiagramLoopOpts' using the 'diagramLoopOpts' parser. -instance Parseable DiagramLoopOpts where - parser = diagramLoopOpts - - -- | Parse @'Colour' Double@ as either a named color from "Data.Colour.Names" -- or a hexadecimal color. instance Parseable (Colour Double) where @@ -529,9 +483,8 @@ -- be output for each second (unit time) of animation. -- -- This function requires a lens into the structure that the particular backend --- uses for it's diagram base case. If @MainOpts (QDiagram b v n Any) ~ DiagramOpts@ --- then this lens will simply be 'output'. For a backend supporting looping --- it will most likely be @_1 . output@. This lens is required because the +-- uses for its diagram base case. If @MainOpts (QDiagram b v n Any) ~ DiagramOpts@ +-- then this lens will simply be 'output'. This lens is required because the -- implementation works by modifying the output field and running the base @mainRender@. -- Typically a backend can write its @Animation B V@ instance as -- @@ -563,86 +516,3 @@ where fmt = "%0" ++ show nDigits ++ "d" output' = addExtension (base ++ printf fmt i) ext (base, ext) = splitExtension (opts^.out) - -putStrF :: String -> IO () -putStrF s = putStr s >> hFlush stdout - -defaultLoopRender :: DiagramLoopOpts -> IO () -defaultLoopRender opts = when (opts ^. loop) $ do - putStrLn "Looping turned on" - prog <- getProgName - args <- getArgs - - srcPath <- case opts ^. src of - Just path -> return path - Nothing -> fromMaybe (error nosrc) <$> findHsFile prog - where - nosrc = "Unable to find Haskell source file.\n" - ++ "Specify source file with '-s' or '--src'" - srcPath' <- canonicalizePath srcPath - - sandbox <- findSandbox [] - sandboxArgs <- case sandbox of - Nothing -> return [] - Just sb -> do - putStrLn ("Using sandbox " ++ takeDirectory sb) - return ["-package-db", sb] - - let args' = delete "-l" . delete "--loop" $ args - newProg = newProgName (takeFileName srcPath) prog - timeOfDay = take 8 . drop 11 . show . eventTime - - withManagerConf defaultConfig $ - \mgr -> do - lock <- newIORef False - - _ <- watchDir mgr (takeDirectory srcPath') (existsEvents (== srcPath')) - $ \ev -> do - running <- atomicModifyIORef lock ((,) True) - unless running $ do - putStrF ("Modified " ++ timeOfDay ev ++ " ... ") - exitCode <- recompile srcPath' newProg sandboxArgs - -- Call the new program without the looping option - run newProg args' exitCode - atomicWriteIORef lock False - - putStrLn $ "Watching source file " ++ srcPath - putStrLn $ "Compiling target: " ++ newProg - putStrLn $ "Program args: " ++ unwords args' - forever . threadDelay $ case os of - -- https://ghc.haskell.org/trac/ghc/ticket/7325 - "darwin" -> 2000000000 - _ -> maxBound - -recompile :: FilePath -> FilePath -> [String] -> IO ExitCode -recompile srcFile outFile args = do - let ghcArgs = ["--make", srcFile, "-o", outFile] ++ args - putStrF "compiling ... " - (exit, _, stderr) <- readProcessWithExitCode "ghc" ghcArgs "" - when (exit /= ExitSuccess) $ putStrLn ('\n':stderr) - return exit - --- | On Windows, the next compilation must have a different output --- than the currently running program. -newProgName :: FilePath -> String -> String -newProgName srcFile oldName = case os of - "mingw32" -> - if oldName == replaceExtension srcFile "exe" - then replaceExtension srcFile ".1.exe" - else replaceExtension srcFile "exe" - _ -> dropExtension srcFile - --- | Run the given program with specified arguments, if and only if --- the previous command returned ExitSuccess. -run :: String -> [String] -> ExitCode -> IO () -run prog args ExitSuccess = do - let path = "." prog - putStrF "running ... " - (exit, stdOut, stdErr) <- readProcessWithExitCode path args "" - case exit of - ExitSuccess -> putStrLn "done." - ExitFailure r -> do - putStrLn $ prog ++ " failed with exit code " ++ show r - unless (null stdOut) $ putStrLn "stdout:" >> putStrLn stdOut - unless (null stdErr) $ putStrLn "stderr:" >> putStrLn stdErr -run _ _ _ = return () diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -539,6 +539,17 @@ _Snoc = _Wrapped . _Snoc . bimapping _Unwrapped id {-# INLINE _Snoc #-} +-- | Compose two Located trails by adding a segment joining the endpoint +-- of the first to the starting point of the second. Note, if you have +-- two located trails such that the end of the first coincides with the +-- start of the second, this will still add a trivial zero-length segment +-- between them; in that case you are probably better off with something +-- like @mapLoc (<> unLoc t2) t1@. +instance (Real n, Floating n, Metric v) + => Semigroup (Located (Trail' Line v n)) where + a@(Loc aLoc aLine) <> b@(Loc _ bLine) = + Loc aLoc (aLine <> lineFromOffsets [atStart b .-. atEnd a] <> bLine) + -------------------------------------------------- -- Extracting segments diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -209,22 +209,32 @@ -> n -- ^ The upper bound of the interval -> [n] -- ^ The roots found bezierFindRoot eps p tmin tmax - | isNothing chopInterval = [] - | clip > 0.8 = let (p1, p2) = splitAtParam newP 0.5 - tmid = tmin' + (tmax' - tmin') / 2 - in bezierFindRoot eps p1 tmin' tmid ++ - bezierFindRoot eps p2 tmid tmax' - | tmax' - tmin' < eps = [avg tmin' tmax'] - | otherwise = bezierFindRoot eps newP tmin' tmax' - where - chopInterval = chopYs (bernsteinCoeffs p) - Just (tminChop, tmaxChop) = chopInterval - newP = section p tminChop tmaxChop - clip = tmaxChop - tminChop - tmin' = tmax * tminChop + tmin * (1 - tminChop) - tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) - - + -- If we generated the max number of roots and tmax is also a root + -- (which is not among the generated ones), there must in fact be an + -- infinite number of roots, so just include tmax. + | length roots == bernsteinDegree p && last roots /= tmax && abs (evaluateBernstein p tmax) <= eps + = roots ++ [tmax] + | otherwise = roots + where + -- Lazily take a number of roots at most the degree of the bernstein + -- polynomial, to avoid generating a ton of roots in the case of a + -- straight Bezier segment along the x-axis. See https://github.com/diagrams/diagrams-contrib/issues/91 . + roots = take (bernsteinDegree p) $ go p tmin tmax + go p tmin tmax + | isNothing chopInterval = [] + | tmax' - tmin' < eps = [avg tmin' tmax'] + | clip > 0.8 = let (p1, p2) = splitAtParam newP 0.5 + tmid = tmin' + (tmax' - tmin') / 2 + in go p1 tmin' tmid ++ + go p2 tmid tmax' + | otherwise = bezierFindRoot eps newP tmin' tmax' + where + chopInterval = chopYs (bernsteinCoeffs p) + Just (tminChop, tmaxChop) = chopInterval + newP = section p tminChop tmaxChop + clip = tmaxChop - tminChop + tmin' = tmax * tminChop + tmin * (1 - tminChop) + tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) ------------------------------------------------------------------------ -- Internal