diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index a129c323..275d65cb 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -33,6 +33,7 @@ Library Diagrams.Attributes, Diagrams.Attributes.Compile, Diagrams.Backend.CmdLine, + Diagrams.Backend.Build, Diagrams.BoundingBox, Diagrams.Combinators, Diagrams.Coordinates, @@ -121,7 +122,9 @@ Library unordered-containers >= 0.2 && < 0.2.6, system-filepath >= 0.2 && < 0.5, text >= 0.7.1 && < 1.3, - mtl >= 2.0 && < 2.3 + mtl >= 2.0 && < 2.3, + transformers >= 0.3.0 && < 0.5.0, + exceptions >= 0.6 && < 1.0 if impl(ghc < 7.6) Build-depends: ghc-prim Hs-source-dirs: src diff --git a/src/Diagrams/Backend/Build.hs b/src/Diagrams/Backend/Build.hs new file mode 100644 index 00000000..872a6281 --- /dev/null +++ b/src/Diagrams/Backend/Build.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Builder.Class +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- General class for building diagrams to files. +-- +----------------------------------------------------------------------------- +module Diagrams.Backend.Build where + +import Diagrams.Core +import Diagrams.Size +import Data.Monoid (Any) +import Linear.V2 +import Control.Lens (Lens') + +-- | Generic class for building diagrams whose output is a file with a +-- 2D size. +class Backend b v n => BackendBuild b v n where + -- | Lens onto the size of the output file. + outputSize :: Lens' (Options b v n) (SizeSpec V2 n) + + -- | Build a diagram of the given format to the path using the + -- backend's options. The @Maybe String@ returns any errors. + saveDia :: FilePath -> Options b v n -> QDiagram b v n Any -> IO () + diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs index bf4d7ec7..39844bdf 100644 --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -13,12 +13,12 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- Convenient creation of command-line-driven executables for --- rendering diagrams. This module provides a general framework --- and default behaviors for parsing command-line arguments, --- records for diagram creation options in various forms, and --- classes and instances for a unified entry point to command-line-driven --- diagram creation executables. +-- Convenient creation of command-line-driven executables for rendering +-- diagrams. This module provides a general framework and default +-- behaviors for parsing command-line arguments, records for diagram +-- creation options in various forms, and classes and instances for a +-- unified entry point to command-line-driven diagram creation +-- executables. -- -- For a tutorial on command-line diagram creation see -- . @@ -26,104 +26,100 @@ ----------------------------------------------------------------------------- module Diagrams.Backend.CmdLine - ( - - -- * Options - - -- ** Standard options - DiagramOpts(..) - , diagramOpts - , width - , height - , output - - -- ** Multi-diagram options - , DiagramMultiOpts(..) - , diagramMultiOpts - , selection - , list - - -- ** Animation options - , DiagramAnimOpts(..) - , diagramAnimOpts - , fpu - - -- ** Loop options - , DiagramLoopOpts(..) - , diagramLoopOpts - , loop - , src - , interval - - -- * Parsing - , Parseable(..) - , readHexColor - - -- * Command-line programs (@Mainable@) - -- ** Arguments, rendering, and entry point - , Mainable(..) - - -- ** General currying - , ToResult(..) - - -- ** helper functions for implementing @mainRender@ - , defaultAnimMainRender - , defaultMultiMainRender - , defaultLoopRender - ) where + ( + + -- * Options + + -- ** Standard options + DiagramOpts(..) + , diagramOpts + , width + , height + , output + + -- ** Multi-diagram options + , DiagramMultiOpts(..) + , diagramMultiOpts + , selection + , list + + -- ** Animation options + , DiagramAnimOpts(..) + , diagramAnimOpts + , fpu + + -- ** Loop options + , DiagramLoopOpts(..) + , diagramLoopOpts + , loop + , src + , interval + + -- * Parsing + , Parseable(..) + , readHexColor + + -- * Command-line programs (@Mainable@) + -- ** Arguments, rendering, and entry point + , Mainable(..) + + -- ** General currying + , ToResult(..) + + -- ** helper functions for implementing @mainRender@ + , defaultAnimMainRender + , defaultMultiMainRender + , defaultLoopRender + ) where import Control.Lens (Lens', makeLenses, (&), (.~), (^.)) import Diagrams.Animation import Diagrams.Attributes -import Diagrams.Core hiding (value, output) +import Diagrams.Core hiding (output, value) +import Diagrams.Util import Options.Applicative import Options.Applicative.Types (readerAsk) -import Prelude - -import Control.Monad (forM_, forever, when) +import Control.Monad (forM_, forever, unless, when) import Data.Active hiding (interval) -import Data.Char (isDigit, isSpace) +import Data.Char (isDigit) import Data.Colour import Data.Colour.Names import Data.Colour.SRGB import Data.Data -import Data.List (intercalate) +import Data.IORef +import Data.List (delete) import Data.Maybe (fromMaybe) import Data.Monoid import qualified Data.Text as T import Numeric import Control.Concurrent (threadDelay) -import Control.Exception (bracket) import Filesystem.Path.CurrentOS (directory, fromText) -import System.Directory (canonicalizePath, - doesDirectoryExist, - getCurrentDirectory) +import System.Directory (canonicalizePath) import System.Environment (getArgs, getProgName) import System.Exit (ExitCode (..)) import System.FilePath (addExtension, dropExtension, - dropExtensions, replaceExtension, - splitExtension, takeFileName, ()) + replaceExtension, splitExtension, + takeDirectory, takeFileName, ()) import System.FSNotify (WatchConfig (..), defaultConfig, - watchDir, withManagerConf) + eventTime, watchDir, + withManagerConf) import System.FSNotify.Devel (existsEvents) import System.Info (os) -import System.IO (IOMode (..), hClose, openFile) -import System.Process (readProcess, - readProcessWithExitCode, runProcess, - waitForProcess) +import System.IO (hFlush, stdout) +import System.Process (readProcessWithExitCode) import Text.Printf -- | Standard options most diagrams are likely to have. data DiagramOpts = DiagramOpts - { _width :: Maybe Int -- ^ Final output width of diagram. - , _height :: Maybe Int -- ^ Final output height of diagram. - , _output :: FilePath -- ^ Output file path, format is typically chosen by extension. - } + { _width :: Maybe Int -- ^ Final output width of diagram. + , _height :: Maybe Int -- ^ Final output height of diagram. + , _output :: FilePath -- ^ Output file path, format is typically chosen by extension. + } deriving (Show, Data, Typeable) makeLenses ''DiagramOpts @@ -131,28 +127,28 @@ makeLenses ''DiagramOpts -- | Extra options for a program that can offer a choice -- between multiple diagrams. data DiagramMultiOpts = DiagramMultiOpts - { _selection :: Maybe String -- ^ Selected diagram to render. - , _list :: Bool -- ^ Flag to indicate that a list of available diagrams should - -- be printed to standard out. - } + { _selection :: Maybe String -- ^ Selected diagram to render. + , _list :: Bool -- ^ Flag to indicate that a list of available diagrams should + -- be printed to standard out. + } deriving (Show, Data, Typeable) makeLenses ''DiagramMultiOpts -- | Extra options for animations. data DiagramAnimOpts = DiagramAnimOpts - { _fpu :: Double -- ^ Number of frames per unit time to generate for the animation. - } + { _fpu :: Double -- ^ Number of frames per unit time to generate for the animation. + } deriving (Show, Data, Typeable) 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. - , _interval :: Int -- ^ Interval in seconds at which to check for recompilation. - } + { _loop :: Bool -- ^ Flag to indicate that the program should loop creation. + , _src :: Maybe FilePath -- ^ File path for the source file to recompile. + , _interval :: Int -- ^ Interval in seconds at which to check for recompilation. + } makeLenses ''DiagramLoopOpts @@ -162,41 +158,41 @@ makeLenses ''DiagramLoopOpts -- Output is option @--output@ or @-o@. diagramOpts :: Parser DiagramOpts diagramOpts = DiagramOpts - <$> (optional . option auto) - ( long "width" <> short 'w' - <> metavar "WIDTH" - <> help "Desired WIDTH of the output image") - <*> (optional . option auto) - ( long "height" <> short 'h' - <> metavar "HEIGHT" - <> help "Desired HEIGHT of the output image") - <*> strOption - ( long "output" <> short 'o' - <> value "" - <> metavar "OUTPUT" - <> help "OUTPUT file") + <$> (optional . option auto) + ( long "width" <> short 'w' + <> metavar "WIDTH" + <> help "Desired WIDTH of the output image") + <*> (optional . option auto) + ( long "height" <> short 'h' + <> metavar "HEIGHT" + <> help "Desired HEIGHT of the output image") + <*> strOption + ( long "output" <> short 'o' + <> value "" + <> metavar "OUTPUT" + <> help "OUTPUT file") -- | Command line parser for 'DiagramMultiOpts'. -- Selection is option @--selection@ or @-S@. -- List is @--list@ or @-L@. diagramMultiOpts :: Parser DiagramMultiOpts diagramMultiOpts = DiagramMultiOpts - <$> (optional . strOption) - ( long "selection" <> short 'S' - <> metavar "NAME" - <> help "NAME of the diagram to render") - <*> switch - ( long "list" <> short 'L' - <> help "List all available diagrams") + <$> (optional . strOption) + ( long "selection" <> short 'S' + <> metavar "NAME" + <> help "NAME of the diagram to render") + <*> switch + ( long "list" <> short 'L' + <> help "List all available diagrams") -- | Command line parser for 'DiagramAnimOpts' -- Frames per unit is @--fpu@ or @-f@. diagramAnimOpts :: Parser DiagramAnimOpts diagramAnimOpts = DiagramAnimOpts - <$> option auto - ( long "fpu" <> short 'f' - <> value 30.0 - <> help "Frames per unit time (for animations)") + <$> option auto + ( long "fpu" <> short 'f' + <> value 30.0 + <> help "Frames per unit time (for animations)") -- | CommandLine parser for 'DiagramLoopOpts' -- Loop is @--loop@ or @-l@. @@ -204,15 +200,15 @@ diagramAnimOpts = DiagramAnimOpts -- Interval is @-i@ defaulting to one second. 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") - <*> option auto - ( long "interval" <> short 'i' - <> value 1 - <> metavar "INTERVAL" - <> help "When running in a loop, check for changes every INTERVAL seconds.") + <$> switch (long "loop" <> short 'l' <> help "Run in a self-recompiling loop") + <*> (optional . strOption) + ( long "src" <> short 's' + <> help "Source file to watch") + <*> option auto + ( long "interval" <> short 'i' + <> value 1 + <> metavar "INTERVAL" + <> help "When running in a loop, check for changes every INTERVAL seconds.") -- | A hidden \"helper\" option which always fails. -- Taken from Options.Applicative.Extra but without the @@ -229,12 +225,12 @@ helper' = abortOption ShowHelpText $ mconcat -- or fails with a help message. defaultOpts :: Parser a -> IO a defaultOpts optsParser = do - prog <- getProgName - let p = info (helper' <*> optsParser) - ( fullDesc - <> progDesc "Command-line diagram generation." - <> header prog) - execParser p + prog <- getProgName + let p = info (helper' <*> optsParser) + ( fullDesc + <> progDesc "Command-line diagram generation." + <> header prog) + execParser p -- | Parseable instances give a command line parser for a type. If a custom -- parser for a common type is wanted a newtype wrapper could be used to make @@ -242,7 +238,7 @@ defaultOpts optsParser = do -- instances as 'Read' because we want to limit ourselves to things that make -- sense to parse from the command line. class Parseable a where - parser :: Parser a + parser :: Parser a -- The following instance would overlap with the product instance for -- Parseable. We can't tell if one wants to parse (a,b) as one argument or a @@ -254,51 +250,51 @@ class Parseable a where -- | Parse 'Int' according to its 'Read' instance. instance Parseable Int where - parser = argument auto mempty + parser = argument auto mempty -- | Parse 'Double' according to its 'Read' instance. instance Parseable Double where - parser = argument auto mempty + parser = argument auto mempty -- | Parse a string by just accepting the given string. instance Parseable String where - parser = argument str mempty + parser = argument str mempty -- | Parse 'DiagramOpts' using the 'diagramOpts' parser. instance Parseable DiagramOpts where - parser = diagramOpts + parser = diagramOpts -- | Parse 'DiagramMultiOpts' using the 'diagramMultiOpts' parser. instance Parseable DiagramMultiOpts where - parser = diagramMultiOpts + parser = diagramMultiOpts -- | Parse 'DiagramAnimOpts' using the 'diagramAnimOpts' parser. instance Parseable DiagramAnimOpts where - parser = diagramAnimOpts + parser = diagramAnimOpts -- | Parse 'DiagramLoopOpts' using the 'diagramLoopOpts' parser. instance Parseable DiagramLoopOpts where - parser = diagramLoopOpts + parser = diagramLoopOpts -- | Parse @'Colour' Double@ as either a named color from "Data.Colour.Names" -- or a hexadecimal color. instance Parseable (Colour Double) where - parser = argument (rc <|> rh) mempty - where - rh, rc :: ReadM (Colour Double) - rh = f . colorToSRGBA <$> (readerAsk >>= readHexColor) - rc = readerAsk >>= readColourName - f (r,g,b,_) = sRGB r g b -- TODO: this seems unfortunate. Should the alpha - -- value be applied to the r g b values? + parser = argument (rc <|> rh) mempty + where + rh, rc :: ReadM (Colour Double) + rh = f . colorToSRGBA <$> (readerAsk >>= readHexColor) + rc = readerAsk >>= readColourName + f (r,g,b,_) = sRGB r g b -- TODO: this seems unfortunate. Should the alpha + -- value be applied to the r g b values? -- | Parse @'AlphaColour' Double@ as either a named color from "Data.Colour.Names" -- or a hexadecimal color. instance Parseable (AlphaColour Double) where - parser = argument (rc <|> rh) mempty - where - rh = readerAsk >>= readHexColor - rc = opaque <$> (readerAsk >>= readColourName) + parser = argument (rc <|> rh) mempty + where + rh = readerAsk >>= readHexColor + rc = opaque <$> (readerAsk >>= readColourName) -- Addapted from the Clay.Color module of the clay package @@ -310,9 +306,9 @@ instance Parseable (AlphaColour Double) where -- order being red, green, blue, alpha. readHexColor :: (Applicative m, Monad m) => String -> m (AlphaColour Double) readHexColor cs = case cs of - ('0':'x':hs) -> handle hs - ('#':hs) -> handle hs - hs -> handle hs + ('0':'x':hs) -> handle hs + ('#':hs) -> handle hs + hs -> handle hs where handle hs | length hs <= 8 && all isHexDigit hs = case hs of @@ -323,27 +319,29 @@ readHexColor cs = case cs of _ -> fail $ "could not parse as a colour" ++ cs handle _ = fail $ "could not parse as a colour: " ++ cs - isHexDigit c = isDigit c|| c `elem` "abcdef" + isHexDigit c = isDigit c || c `elem` "abcdef" hex a b = (/ 255) <$> case readHex [a,b] of [(h,"")] -> return h - _ -> fail $ "could not parse as a hex value" ++ (a:b:[]) + _ -> fail $ "could not parse as a hex value" ++ [a,b] -- | This instance is needed to signal the end of a chain of -- nested tuples, it always just results in the unit value -- without consuming anything. instance Parseable () where - parser = pure () + parser = pure () -- | Allow 'Parseable' things to be combined. instance (Parseable a, Parseable b) => Parseable (a,b) where - parser = (,) <$> parser <*> parser + parser = (,) <$> parser <*> parser -- | Triples of Parsebales should also be Parseable. -instance (Parseable a, Parseable b, Parseable c) => Parseable (a, b, c) - where - parser = (,,) <$> parser <*> parser <*> parser +instance (Parseable a, Parseable b, Parseable c) => Parseable (a, b, c) where + parser = (,,) <$> parser <*> parser <*> parser + +instance (Parseable a, Parseable b, Parseable c, Parseable d) => Parseable (a, b, c, d) where + parser = (,,,) <$> parser <*> parser <*> parser <*> parser -- | This class allows us to abstract over functions that take some arguments -- and produce a final value. When some @d@ is an instance of @@ -351,46 +349,46 @@ instance (Parseable a, Parseable b, Parseable c) => Parseable (a, b, c) -- at once, and a type @'ResultOf' d@ that is the type of the final result from -- some base case instance. class ToResult d where - type Args d :: * - type ResultOf d :: * + type Args d :: * + type ResultOf d :: * - toResult :: d -> Args d -> ResultOf d + toResult :: d -> Args d -> ResultOf d -- | A diagram can always produce a diagram when given @()@ as an argument. -- This is our base case. instance ToResult (QDiagram b v n Any) where - type Args (QDiagram b v n Any) = () - type ResultOf (QDiagram b v n Any) = QDiagram b v n Any + type Args (QDiagram b v n Any) = () + type ResultOf (QDiagram b v n Any) = QDiagram b v n Any - toResult d _ = d + toResult d _ = d -- | A list of diagrams can produce pages. instance ToResult [QDiagram b v n Any] where - type Args [QDiagram b v n Any] = () - type ResultOf [QDiagram b v n Any] = [QDiagram b v n Any] + type Args [QDiagram b v n Any] = () + type ResultOf [QDiagram b v n Any] = [QDiagram b v n Any] - toResult ds _ = ds + toResult ds _ = ds -- | A list of named diagrams can give the multi-diagram interface. instance ToResult [(String, QDiagram b v n Any)] where - type Args [(String,QDiagram b v n Any)] = () - type ResultOf [(String,QDiagram b v n Any)] = [(String,QDiagram b v n Any)] + type Args [(String,QDiagram b v n Any)] = () + type ResultOf [(String,QDiagram b v n Any)] = [(String,QDiagram b v n Any)] - toResult ds _ = ds + toResult ds _ = ds -- | An animation is another suitable base case. instance ToResult (Animation b v n) where - type Args (Animation b v n) = () - type ResultOf (Animation b v n) = Animation b v n + type Args (Animation b v n) = () + type ResultOf (Animation b v n) = Animation b v n - toResult a _ = a + toResult a _ = a -- | Diagrams that require IO to build are a base case. instance ToResult d => ToResult (IO d) where - type Args (IO d) = Args d - type ResultOf (IO d) = IO (ResultOf d) + type Args (IO d) = Args d + type ResultOf (IO d) = IO (ResultOf d) - toResult d args = flip toResult args <$> d + toResult d args = flip toResult args <$> d -- | An instance for a function that, given some 'a', can produce a 'd' that is -- also an instance of 'ToResult'. For this to work we need both the @@ -402,10 +400,10 @@ instance ToResult d => ToResult (IO d) where -- is clearer and easier to understand then paragraphs in English written by -- me. instance ToResult d => ToResult (a -> d) where - type Args (a -> d) = (a, Args d) - type ResultOf (a -> d) = ResultOf d + type Args (a -> d) = (a, Args d) + type ResultOf (a -> d) = ResultOf d - toResult f (a,args) = toResult (f a) args + toResult f (a,args) = toResult (f a) args -- | This class represents the various ways we want to support diagram creation @@ -424,62 +422,62 @@ instance ToResult d => ToResult (a -> d) where -- The associated type 'MainOpts' describes the options which need to be parsed -- from the command-line and passed to @mainRender@. class Mainable d where - -- | Associated type that describes the options which need to be parsed - -- from the command-line and passed to @mainRender@. - type MainOpts d :: * - - -- | This method invokes the command-line parser resulting in an options - -- value or ending the program with an error or help message. - -- Typically the default instance will work. If a different help message - -- or parsing behavior is desired a new implementation is appropriate. - -- - -- Note the @d@ argument should only be needed to fix the type @d@. Its - -- value should not be relied on as a parameter. - mainArgs :: Parseable (MainOpts d) => d -> IO (MainOpts d) - mainArgs _ = defaultOpts parser - - -- | Backend specific work of rendering with the given options and mainable - -- value is done here. All backend instances should implement this method. - mainRender :: MainOpts d -> d -> IO () - - -- | Main entry point for command-line diagram creation. This is the method - -- that users will call from their program @main@. For instance an expected - -- user program would take the following form. - -- - -- @ - -- import Diagrams.Prelude - -- import Diagrams.Backend.TheBestBackend.CmdLine - -- - -- d :: Diagram B R2 - -- d = ... - -- - -- main = mainWith d - -- @ - -- - -- Most backends should be able to use the default implementation. A different - -- implementation should be used to handle more complex interactions with the user. - mainWith :: Parseable (MainOpts d) => d -> IO () - mainWith d = do - opts <- mainArgs d - mainRender opts d + -- | Associated type that describes the options which need to be parsed + -- from the command-line and passed to @mainRender@. + type MainOpts d :: * + + -- | This method invokes the command-line parser resulting in an options + -- value or ending the program with an error or help message. + -- Typically the default instance will work. If a different help message + -- or parsing behavior is desired a new implementation is appropriate. + -- + -- Note the @d@ argument should only be needed to fix the type @d@. Its + -- value should not be relied on as a parameter. + mainArgs :: Parseable (MainOpts d) => d -> IO (MainOpts d) + mainArgs _ = defaultOpts parser + + -- | Backend specific work of rendering with the given options and mainable + -- value is done here. All backend instances should implement this method. + mainRender :: MainOpts d -> d -> IO () + + -- | Main entry point for command-line diagram creation. This is the method + -- that users will call from their program @main@. For instance an expected + -- user program would take the following form. + -- + -- @ + -- import Diagrams.Prelude + -- import Diagrams.Backend.TheBestBackend.CmdLine + -- + -- d :: Diagram B R2 + -- d = ... + -- + -- main = mainWith d + -- @ + -- + -- Most backends should be able to use the default implementation. A different + -- implementation should be used to handle more complex interactions with the user. + mainWith :: Parseable (MainOpts d) => d -> IO () + mainWith d = do + opts <- mainArgs d + mainRender opts d -- | This instance allows functions resulting in something that is 'Mainable' to -- be 'Mainable'. It takes a parse of collected arguments and applies them to -- the given function producing the 'Mainable' result. instance (Parseable (Args (a -> d)), ToResult d, Mainable (ResultOf d)) => Mainable (a -> d) where - type MainOpts (a -> d) = (MainOpts (ResultOf (a -> d)), Args (a -> d)) + type MainOpts (a -> d) = (MainOpts (ResultOf (a -> d)), Args (a -> d)) - mainRender (opts, a) f = mainRender opts (toResult f a) + mainRender (opts, a) f = mainRender opts (toResult f a) -- TODO: why can't we get away with: instance (Parseable (Args (a -> d)), Mainable (ResultOf d)) => ... -- Doesn't `Args (a -> d)` imply `ToResult (a -> d)` which implies `ToResult d` ? -- | With this instance we can perform IO to produce something -- 'Mainable' before rendering. instance Mainable d => Mainable (IO d) where - type MainOpts (IO d) = MainOpts d + type MainOpts (IO d) = MainOpts d - mainRender opts dio = dio >>= mainRender opts + mainRender opts dio = dio >>= mainRender opts -- | @defaultMultiMainRender@ is an implementation of 'mainRender' where -- instead of a single diagram it takes a list of diagrams paired with names @@ -499,13 +497,13 @@ instance Mainable d => Mainable (IO d) where -- opt-in to this form or provide a different instance that makes more sense. defaultMultiMainRender :: Mainable d => (MainOpts d, DiagramMultiOpts) -> [(String, d)] -> IO () defaultMultiMainRender (opts,multi) ds = - if multi^.list - then showDiaList (map fst ds) - else case multi^.selection of - Nothing -> putStrLn "No diagram selected." >> showDiaList (map fst ds) - Just sel -> case lookup sel ds of - Nothing -> putStrLn $ "Unknown diagram: " ++ sel - Just d -> mainRender opts d + if multi^.list + then showDiaList (map fst ds) + else case multi^.selection of + Nothing -> putStrLn "No diagram selected." >> showDiaList (map fst ds) + Just sel -> case lookup sel ds of + Nothing -> putStrLn $ "Unknown diagram: " ++ sel + Just d -> mainRender opts d -- | Display the list of diagrams available for rendering. showDiaList :: [String] -> IO () @@ -546,15 +544,14 @@ showDiaList ds = do defaultAnimMainRender :: (opts -> QDiagram b v n Any -> IO ()) - -> (Lens' opts FilePath) -- ^ A lens into the output path. - -> (opts ,DiagramAnimOpts) + -> Lens' opts FilePath -- ^ A lens into the output path. + -> (opts, DiagramAnimOpts) -> Animation b v n -> IO () defaultAnimMainRender renderF out (opts,animOpts) anim = do - let - frames = simulate (toRational $ animOpts^.fpu) anim - nDigits = length . show . length $ frames - forM_ (zip [1..] frames) $ \(i,d) -> renderF (indexize out nDigits i opts) d + let frames = simulate (toRational $ animOpts^.fpu) anim + nDigits = length . show . length $ frames + forM_ (zip [1..] frames) $ \(i,d) -> renderF (indexize out nDigits i opts) d -- | @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 @@ -562,99 +559,92 @@ defaultAnimMainRender renderF out (opts,animOpts) anim = do indexize :: Lens' s FilePath -> Int -> Integer -> s -> s indexize out nDigits i opts = opts & out .~ output' where fmt = "%0" ++ show nDigits ++ "d" - output' = addExtension (base ++ printf fmt (i::Integer)) ext + 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 is turned on." - prog <- getProgName - putStrLn $ "program is named: " ++ prog - args <- getArgs - srcPath <- canonicalizePath $ - fromMaybe (addExtension (dropExtensions prog) ".hs") (opts ^. src) - let newProg = newProgName (takeFileName srcPath) prog - putStrLn $ "canonical name is: " ++ srcPath - -- Polling is only used on Windows - withManagerConf defaultConfig { confPollInterval = (opts ^. interval) } $ - \mgr -> do - _stop <- watchDir - mgr - (directory . fromText . T.pack $ srcPath) - (existsEvents $ \fp -> (fromText $ T.pack srcPath) == fp) - -- Call the new program without the looping option - (\ev -> print ev >> recompile srcPath newProg >>= run newProg (filter (/= "-l") args)) - putStrLn "entering infinite loop" - forever . threadDelay $ case os of - -- https://ghc.haskell.org/trac/ghc/ticket/7325 - "darwin" -> 1000000000000 - _ -> maxBound - -recompile :: FilePath -> FilePath -> IO ExitCode -recompile srcFile outFile = do - let errFile = srcFile ++ ".errors" - putStr "Recompiling..." - status <- do - bracket (openFile errFile WriteMode) hClose $ \h -> do - sargs <- sandboxArgs - let ghcArgs = ["--make", srcFile, "-o", outFile] ++ sargs - print $ "passing ghc args: " ++ intercalate " " ghcArgs - p <- runProcess "ghc" ghcArgs - Nothing Nothing Nothing Nothing (Just h) - waitForProcess p - if (status /= ExitSuccess) - then putStrLn "" >> putStrLn (replicate 75 '-') >> readFile errFile >>= putStr - else putStrLn "done." - return status - -sandboxArgs :: IO [String] -sandboxArgs = do - cur <- getCurrentDirectory - let sandbox = cur ".cabal-sandbox" - exists <- doesDirectoryExist sandbox - if exists - then do - let strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace - ghcV <- strip <$> readProcess "ghc" ["--numeric-version"] "" - uname <- case os of - "linux" -> strip <$> readProcess "uname" ["-m"] "" - _ -> return "" - let pdb = case os of - "linux" -> sandbox (uname ++ "-linux-ghc-" ++ ghcV ++ "-packages.conf.d") - "mingw32" -> sandbox "i386-windows-ghc-" ++ ghcV ++ "-packages.conf.d" - "darwin" -> sandbox "x86_64-osx-ghc-" ++ ghcV ++ "-packages.conf.d" - _ -> error "I don't know how to handle cabal sandbox on this OS" - return ["-no-user-package-db", "-package-db", pdb] - else return [] + putStrLn "Looping turned on" + prog <- getProgName + args <- getArgs + + srcPath <- do + let p1 = fromMaybe prog (opts ^. src) + mPath <- findHsFile p1 + case mPath of + Just path -> pure path + Nothing -> error ("Unable to guess source file. " + ++ "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 srcFilePath = fromText $ T.pack srcPath' + args' = delete "-l" . delete "--loop" $ args + newProg = newProgName (takeFileName srcPath) prog + timeOfDay = take 8 . drop 11 . show . eventTime + + -- Polling is only used on Windows + withManagerConf defaultConfig { confPollInterval = opts ^. interval } $ + \mgr -> do + lock <- newIORef False + + _ <- watchDir mgr (directory srcFilePath) (existsEvents (== srcFilePath)) + $ \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" -> 5000000000000 + _ -> 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. +-- than the currently running program. newProgName :: FilePath -> String -> String newProgName srcFile oldName = case os of - "mingw32" -> - if oldName == replaceExtension srcFile "exe" + "mingw32" -> + if oldName == replaceExtension srcFile "exe" then replaceExtension srcFile ".1.exe" else replaceExtension srcFile "exe" - _ -> dropExtension srcFile + _ -> dropExtension srcFile -- | Run the given program with specified arguments, if and only if --- the previous command returned ExitSuccess. +-- the previous command returned ExitSuccess. run :: String -> [String] -> ExitCode -> IO () run prog args ExitSuccess = do - let path = "." prog - putStrLn $ intercalate " " $ ["calling as", path] ++ args - (exit, stdout, stderr) <- readProcessWithExitCode path args "" - case exit of - ExitSuccess -> return () - ExitFailure r -> do - putStr $ prog ++ " failed with exit code: " - print r - when (stdout /= "") $ do - putStrLn "---------------------------------------- STDOUT" - putStrLn stdout - when (stderr /= "") $ do - putStrLn "---------------------------------------- STDERR" - putStrLn stderr - when ((stdout ++ stderr) /= "") $ do - putStrLn "----------------------------------------" + 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/TwoD.hs b/src/Diagrams/TwoD.hs index 931fc029..b5e6ed3a 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -73,7 +73,9 @@ module Diagrams.TwoD -- * Paths -- ** Stroking - , stroke, stroke', strokeTrail, strokeT, strokeTrail', strokeT' + , stroke, stroke' + , strokePath, strokeP, strokePath', strokeP' + , strokeTrail, strokeT, strokeTrail', strokeT' , strokeLine, strokeLoop , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop , FillRule(..), fillRule diff --git a/src/Diagrams/Util.hs b/src/Diagrams/Util.hs index 8c922356..96ad1030 100644 --- a/src/Diagrams/Util.hs +++ b/src/Diagrams/Util.hs @@ -10,24 +10,46 @@ ----------------------------------------------------------------------------- module Diagrams.Util - ( -- * Utilities for users + ( -- * Utilities for users - with - , applyAll - , (#) + with + , applyAll + , (#) - , iterateN + , iterateN - , tau + , tau - -- * Internal utilities - , foldB + -- * Files + , findHsFile - ) where + -- * Finding sandboxes + , findSandbox + , globalPackage + + -- * Internal utilities + , foldB + + ) where import Data.Default.Class import Data.Monoid +import Control.Applicative +import Control.Lens hiding (( # )) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Trans +import Control.Monad.Trans.Maybe +import Data.List +import Data.List.Lens +import Data.Maybe +import System.Directory +import System.Environment +import System.FilePath +import System.FilePath.Lens +import System.Process + -- | Several functions exported by the diagrams library take a number -- of arguments giving the user control to \"tweak\" various aspects -- of their behavior. Rather than give such functions a long list @@ -102,3 +124,124 @@ foldB f _ as = foldB' as go [] = [] go [x] = [x] go (x1:x2:xs) = f x1 x2 : go xs + +------------------------------------------------------------------------ +-- Files +------------------------------------------------------------------------ + +-- | Given some file (no extension or otherwise) try to find a haskell +-- source file. +findHsFile :: FilePath -> IO (Maybe FilePath) +findHsFile file = runMaybeT $ self <|> hs <|> lhs + where + self = guard (hasExtension file) >> check file + hs = check (addExtension file "hs") + lhs = check (addExtension file "lhs") + check f = do + lift (doesFileExist f) >>= guard + pure f + +------------------------------------------------------------------------ +-- Sandbox +------------------------------------------------------------------------ + +-- | Parse cabal config file to find the location of the package +-- database. +parseConfig :: FilePath -> MaybeT IO FilePath +parseConfig file = do + config <- maybeIO $ readFile file + hoistMaybe $ config ^? lined . prefixed "package-db: " + +-- | Seach the given directory and all parent directories until a cabal +-- config file is found. First search for \"cabal.config\", then +-- \"cabal.sandbox.config\". Return the location of the package +-- database in the config file. +configSearch :: FilePath -> MaybeT IO FilePath +configSearch p0 = do + p0' <- maybeIO $ canonicalizePath p0 + + let mkPaths p + | all isPathSeparator p || p == "." + = [] + | otherwise = map (p ) ["cabal.config", "cabal.sandbox.config"] + ++ mkPaths (p ^. directory) + + foldMaybeT parseConfig (mkPaths p0') + +-- | Check if the folder is a database, or if it contains a database. +-- Returns the database location if it's found. +isDB :: FilePath -> MaybeT IO FilePath +isDB path = + if isConf path + then return path + else maybeIO (getDirectoryContents path) >>= hoistMaybe . find isConf + where + isConf = isSuffixOf ".conf.d" + +-- | Search for a sandbox in the following order: +-- +-- * Test given FilePaths if they point directly to a database or +-- contain a cabal config file (or any parent directory containing a +-- config file). +-- +-- * Same test for @DIAGRAMS_SANDBOX@ environment value +-- +-- * Environment values of @GHC_PACKAGE_PATH@, @HSENV@ and +-- @PACKAGE_DB_FOR_GHC@ that point to a database. +-- +-- * Test for config file in current directory (or any parents). +-- +findSandbox :: [FilePath] -> IO (Maybe FilePath) +findSandbox paths = runMaybeT $ pathsTest <|> diaSB <|> envDB <|> wdConfig + where + -- first path in environment + lookEnv = MaybeT . (fmap . fmap) (head . splitSearchPath) . lookupEnv + envDB = foldMaybeT lookEnv ["GHC_PACKAGE_PATH", "HSENV", "PACKAGE_DB_FOR_GHC"] + + -- test if path points directly to db or contains a config file + test x = isDB x <|> configSearch x + pathsTest = foldMaybeT test paths + diaSB = lookEnv "DIAGRAMS_SANDBOX" >>= test + wdConfig = maybeIO getCurrentDirectory >>= configSearch + +-- | Use the given path for the sandbox in the @GHC_PACKAGE_PATH@ +-- environment (appending the ghc global package database from @ghc +-- --info@. @GHC_PACKAGE_PATH@ if the variable ghc and other tools use +-- to find the package database. (This is what @cabal exec@ sets) +-- ghcPackagePath :: FilePath -> IO () +-- ghcPackagePath db = do +-- gdb <- globalPackage +-- let dbs = intercalate [searchPathSeparator] [db,gdb] +-- setEnv "GHC_PACKAGE_PATH" dbs +-- +-- setEnv is only in base > 4.7, either need to use setenv package or +-- -package-db flag + +-- | Find ghc's global package database. Throws an error if it isn't +-- found. +globalPackage :: IO FilePath +globalPackage = do + info <- read <$> readProcess "ghc" ["--info"] "" + return $ fromMaybe (error "Unable to parse ghc --info.") + (lookup "Global Package DB" info) + +-- MaybeT utilities + +-- | Lift an 'IO' action. If any exceptions are raised, return Nothing. +maybeIO :: (MonadCatch m, MonadIO m) => IO a -> MaybeT m a +maybeIO io = liftIO io `catchAll` const mzero + +-- | Lift a maybe value to a MaybeT of any monad. +hoistMaybe :: Monad m => Maybe a -> MaybeT m a +hoistMaybe = MaybeT . return + +-- | Fold a list of 'MaybeT's that short-circuits as soon as a Just value +-- is found (instead going through the whole list). +foldMaybeT :: Monad m => (a -> MaybeT m b) -> [a] -> MaybeT m b +foldMaybeT _ [] = mzero +foldMaybeT f (a:as) = MaybeT $ do + x <- runMaybeT (f a) + if isJust x + then return x + else runMaybeT (foldMaybeT f as) +