From 067451d9d9df08a426c77c5f8257edb9a24d4ec4 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Fri, 19 Dec 2014 17:23:32 +0000 Subject: [PATCH 01/11] Add BackendBuild class. --- diagrams-lib.cabal | 1 + src/Diagrams/Backend/Build.hs | 30 ++++++++++++++++++++++++++++++ 2 files changed, 31 insertions(+) create mode 100644 src/Diagrams/Backend/Build.hs diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index a129c323..6c723849 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, 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 () + From e8067402270c19bfa0f469a3be3280b260d46a18 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Wed, 24 Dec 2014 23:52:14 +0000 Subject: [PATCH 02/11] Formatting and hlint. --- src/Diagrams/Backend/CmdLine.hs | 542 ++++++++++++++++---------------- 1 file changed, 270 insertions(+), 272 deletions(-) diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs index bf4d7ec7..bd540e79 100644 --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -26,51 +26,51 @@ ----------------------------------------------------------------------------- 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 @@ -90,14 +90,12 @@ import Data.Colour import Data.Colour.Names import Data.Colour.SRGB import Data.Data -import Data.List (intercalate) 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, @@ -111,7 +109,7 @@ import System.FSNotify (WatchConfig (..), defaultConfig, watchDir, withManagerConf) import System.FSNotify.Devel (existsEvents) import System.Info (os) -import System.IO (IOMode (..), hClose, openFile) +import System.IO (IOMode (..), withFile) import System.Process (readProcess, readProcessWithExitCode, runProcess, waitForProcess) @@ -120,10 +118,10 @@ 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 +129,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 +160,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 +202,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 +227,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 +240,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 +252,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 +308,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 @@ -327,23 +325,22 @@ readHexColor cs = case cs of 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 -- | 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 +348,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 +399,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 +421,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 +496,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,7 +543,7 @@ showDiaList ds = do defaultAnimMainRender :: (opts -> QDiagram b v n Any -> IO ()) - -> (Lens' opts FilePath) -- ^ A lens into the output path. + -> Lens' opts FilePath -- ^ A lens into the output path. -> (opts ,DiagramAnimOpts) -> Animation b v n -> IO () @@ -562,73 +559,74 @@ 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) 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 + 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 + let errFile = srcFile ++ ".errors" + putStr "Recompiling..." + + status <- withFile errFile WriteMode $ \h -> do + sargs <- sandboxArgs + let ghcArgs = ["--make", srcFile, "-o", outFile] ++ sargs + print $ "passing ghc args: " ++ unwords 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 [] + 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 [] -- | 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" -> @@ -638,23 +636,23 @@ newProgName srcFile oldName = case os of _ -> 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 + putStrLn $ unwords $ ["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) /= "") $ + putStrLn "----------------------------------------" run _ _ _ = return () From 07569121ec229fca98e13447f087ef0e9219cb81 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 28 Dec 2014 00:32:28 +0000 Subject: [PATCH 03/11] Add sandbox finding function. --- diagrams-lib.cabal | 4 +- src/Diagrams/Util.hs | 141 ++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 135 insertions(+), 10 deletions(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 6c723849..ec59df38 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -122,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, + exceptions if impl(ghc < 7.6) Build-depends: ghc-prim Hs-source-dirs: src diff --git a/src/Diagrams/Util.hs b/src/Diagrams/Util.hs index 8c922356..177dbae6 100644 --- a/src/Diagrams/Util.hs +++ b/src/Diagrams/Util.hs @@ -10,24 +10,43 @@ ----------------------------------------------------------------------------- module Diagrams.Util - ( -- * Utilities for users + ( -- * Utilities for users - with - , applyAll - , (#) + with + , applyAll + , (#) - , iterateN + , iterateN - , tau + , tau - -- * Internal utilities - , foldB + -- * Finding sandboxes + , findSandbox + , ghcPackagePath - ) where + -- * 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 +121,107 @@ foldB f _ as = foldB' as go [] = [] go [x] = [x] go (x1:x2:xs) = f x1 x2 : go xs + +------------------------------------------------------------------------ +-- 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 + lookEnv = MaybeT . lookupEnv + ghcPkg = lookEnv "GHC_PACKAGE_PATH" + hsenv = lookEnv "HSENV" + pkgDB = lookEnv "PACKAGE_DB_FOR_GHC" + envDB = ghcPkg <|> hsenv <|> pkgDB + + -- 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 + +-- 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) + +-- | Find ghc's global package database. Throws in 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) + From 4857193b0e06352d60e5477cab7378237a5955c9 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 28 Dec 2014 00:40:16 +0000 Subject: [PATCH 04/11] CmdLine loop changes. --- src/Diagrams/Backend/CmdLine.hs | 171 +++++++++++++++----------------- 1 file changed, 78 insertions(+), 93 deletions(-) diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs index bd540e79..4858a05f 100644 --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -75,44 +75,40 @@ module Diagrams.Backend.CmdLine 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.Maybe (fromMaybe) +import Data.List (delete) import Data.Monoid import qualified Data.Text as T import Numeric import Control.Concurrent (threadDelay) import Filesystem.Path.CurrentOS (directory, fromText) -import System.Directory (canonicalizePath, - doesDirectoryExist, - getCurrentDirectory) +import System.Directory (canonicalizePath, doesFileExist) 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 (..), withFile) -import System.Process (readProcess, - readProcessWithExitCode, runProcess, - waitForProcess) +import System.IO (hFlush, stdout) +import System.Process (readProcessWithExitCode) import Text.Printf @@ -321,7 +317,7 @@ 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 @@ -370,7 +366,7 @@ instance ToResult [QDiagram b v n Any] where -- | 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 Args [(String,QDiagram b v n Any)] = () type ResultOf [(String,QDiagram b v n Any)] = [(String,QDiagram b v n Any)] toResult ds _ = ds @@ -544,14 +540,13 @@ showDiaList ds = do defaultAnimMainRender :: (opts -> QDiagram b v n Any -> IO ()) -> Lens' opts FilePath -- ^ A lens into the output path. - -> (opts ,DiagramAnimOpts) + -> (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,97 +557,87 @@ indexize out nDigits i opts = opts & out .~ output' 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." + putStrLn "Looping 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 + + srcPath <- case opts ^. src of + Just path -> return path + Nothing -> do + let hsFile = replaceExtension prog "hs" + lhsFile = replaceExtension prog "lhs" + hsExists <- doesFileExist hsFile + if hsExists then return hsFile + else do + lhsExists <- doesFileExist lhsFile + if lhsExists then return lhsFile + else error ("Unable to guess source file\n " + ++ "Specify source file with '-s' or '--src'") + srcPath' <- canonicalizePath srcPath + + sandbox <- findSandbox [] + case sandbox of + Nothing -> return () + Just sb -> do + ghcPackagePath sb + putStrLn ("Using sandbox " ++ takeDirectory sb) + + let srcFilePath = fromText $ T.pack srcPath' + args' = delete "-l" . delete "--loop" $ args + newProg = newProgName (takeFileName srcPath) prog + -- 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 + \mgr -> do + _ <- watchDir + mgr + (directory srcFilePath) + (existsEvents (== srcFilePath)) + -- Call the new program without the looping option + (\ev -> putStrF ("Modified " ++ show (eventTime ev) ++ " ... ") + >> recompile srcPath newProg >>= run newProg args') + 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 -> IO ExitCode recompile srcFile outFile = do - let errFile = srcFile ++ ".errors" - putStr "Recompiling..." - - status <- withFile errFile WriteMode $ \h -> do - sargs <- sandboxArgs - let ghcArgs = ["--make", srcFile, "-o", outFile] ++ sargs - print $ "passing ghc args: " ++ unwords 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 [] + let ghcArgs = ["--make", srcFile, "-o", outFile] + 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" + "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. run :: String -> [String] -> ExitCode -> IO () run prog args ExitSuccess = do let path = "." prog - putStrLn $ unwords $ ["calling as", path] ++ args - (exit, stdout, stderr) <- readProcessWithExitCode path args "" + putStrF "running ... " + (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) /= "") $ - putStrLn "----------------------------------------" + 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 () From de6d6ebfdb56882e0d7c8e34eb3297619ba4b546 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 29 Dec 2014 01:23:13 +0000 Subject: [PATCH 05/11] Use -package-db instead of package path env. --- src/Diagrams/Backend/CmdLine.hs | 16 +++++++------- src/Diagrams/Util.hs | 39 +++++++++++++++++---------------- 2 files changed, 28 insertions(+), 27 deletions(-) diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs index 4858a05f..1f47d3f0 100644 --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -580,12 +580,12 @@ defaultLoopRender opts = when (opts ^. loop) $ do ++ "Specify source file with '-s' or '--src'") srcPath' <- canonicalizePath srcPath - sandbox <- findSandbox [] - case sandbox of - Nothing -> return () + sandbox <- findSandbox [] + sandboxArgs <- case sandbox of + Nothing -> return [] Just sb -> do - ghcPackagePath sb putStrLn ("Using sandbox " ++ takeDirectory sb) + return ["-package-db", sb] let srcFilePath = fromText $ T.pack srcPath' args' = delete "-l" . delete "--loop" $ args @@ -600,7 +600,7 @@ defaultLoopRender opts = when (opts ^. loop) $ do (existsEvents (== srcFilePath)) -- Call the new program without the looping option (\ev -> putStrF ("Modified " ++ show (eventTime ev) ++ " ... ") - >> recompile srcPath newProg >>= run newProg args') + >> recompile srcPath newProg sandboxArgs >>= run newProg args') putStrLn $ "Watching source file " ++ srcPath putStrLn $ "Compiling target: " ++ newProg putStrLn $ "Program args: " ++ unwords args' @@ -609,9 +609,9 @@ defaultLoopRender opts = when (opts ^. loop) $ do "darwin" -> 5000000000000 _ -> maxBound -recompile :: FilePath -> FilePath -> IO ExitCode -recompile srcFile outFile = do - let ghcArgs = ["--make", srcFile, "-o", outFile] +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) diff --git a/src/Diagrams/Util.hs b/src/Diagrams/Util.hs index 177dbae6..987d17be 100644 --- a/src/Diagrams/Util.hs +++ b/src/Diagrams/Util.hs @@ -22,7 +22,7 @@ module Diagrams.Util -- * Finding sandboxes , findSandbox - , ghcPackagePath + , globalPackage -- * Internal utilities , foldB @@ -175,11 +175,9 @@ isDB path = findSandbox :: [FilePath] -> IO (Maybe FilePath) findSandbox paths = runMaybeT $ pathsTest <|> diaSB <|> envDB <|> wdConfig where - lookEnv = MaybeT . lookupEnv - ghcPkg = lookEnv "GHC_PACKAGE_PATH" - hsenv = lookEnv "HSENV" - pkgDB = lookEnv "PACKAGE_DB_FOR_GHC" - envDB = ghcPkg <|> hsenv <|> pkgDB + -- 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 @@ -191,11 +189,22 @@ findSandbox paths = runMaybeT $ pathsTest <|> diaSB <|> envDB <|> wdConfig -- 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 +-- 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 @@ -217,11 +226,3 @@ foldMaybeT f (a:as) = MaybeT $ do then return x else runMaybeT (foldMaybeT f as) --- | Find ghc's global package database. Throws in 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) - From 125db8b02acce68486b2ad3845c1148cd59d7a9a Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sat, 3 Jan 2015 16:41:49 +0000 Subject: [PATCH 06/11] Better CmdLine messages. --- src/Diagrams/Backend/CmdLine.hs | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs index 1f47d3f0..b0c107f1 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 -- . @@ -338,6 +338,9 @@ instance (Parseable a, Parseable b) => Parseable (a,b) where 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 -- 'ToResult' we get a type @'Args' d@ that is a type of /all/ the arguments @@ -576,7 +579,7 @@ defaultLoopRender opts = when (opts ^. loop) $ do else do lhsExists <- doesFileExist lhsFile if lhsExists then return lhsFile - else error ("Unable to guess source file\n " + else error ("Unable to guess source file. " ++ "Specify source file with '-s' or '--src'") srcPath' <- canonicalizePath srcPath @@ -590,16 +593,14 @@ defaultLoopRender opts = when (opts ^. loop) $ do 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 - _ <- watchDir - mgr - (directory srcFilePath) - (existsEvents (== srcFilePath)) + _ <- watchDir mgr (directory srcFilePath) (existsEvents (== srcFilePath)) -- Call the new program without the looping option - (\ev -> putStrF ("Modified " ++ show (eventTime ev) ++ " ... ") + (\ev -> putStrF ("Modified " ++ timeOfDay ev ++ " ... ") >> recompile srcPath newProg sandboxArgs >>= run newProg args') putStrLn $ "Watching source file " ++ srcPath putStrLn $ "Compiling target: " ++ newProg From 2c15fcb7dae4762405b26736f1f71930a1773157 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 19 Jan 2015 08:28:45 +0000 Subject: [PATCH 07/11] Package constaints. --- diagrams-lib.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index ec59df38..beaad035 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -123,8 +123,8 @@ Library system-filepath >= 0.2 && < 0.5, text >= 0.7.1 && < 1.3, mtl >= 2.0 && < 2.3, - transformers, - exceptions + transformers >= 3.0 && < 5.0, + exceptions >= 0.6 && < 1.0 if impl(ghc < 7.6) Build-depends: ghc-prim Hs-source-dirs: src From 7b534dc5d7b0ecd9cfddcb6e8dbf8a182eb8e791 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 25 Jan 2015 19:45:11 +0000 Subject: [PATCH 08/11] Add strokePath and friends. --- src/Diagrams/TwoD.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) 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 From edccd912474f36b5f2994769e607d0dcdfcdbd89 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Wed, 28 Jan 2015 18:18:24 +0000 Subject: [PATCH 09/11] Fix transformers bounds. --- diagrams-lib.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index beaad035..275d65cb 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -123,7 +123,7 @@ Library system-filepath >= 0.2 && < 0.5, text >= 0.7.1 && < 1.3, mtl >= 2.0 && < 2.3, - transformers >= 3.0 && < 5.0, + transformers >= 0.3.0 && < 0.5.0, exceptions >= 0.6 && < 1.0 if impl(ghc < 7.6) Build-depends: ghc-prim From a60925bf5273a3067e993ee9b64c1eb6f391f096 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Wed, 28 Jan 2015 23:36:53 +0000 Subject: [PATCH 10/11] Added findHsFile function. --- src/Diagrams/Backend/CmdLine.hs | 23 ++++++++++------------- src/Diagrams/Util.hs | 19 +++++++++++++++++++ 2 files changed, 29 insertions(+), 13 deletions(-) diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs index b0c107f1..cba41e61 100644 --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -90,13 +90,14 @@ import Data.Colour.Names import Data.Colour.SRGB import Data.Data import Data.List (delete) +import Data.Maybe (fromMaybe) import Data.Monoid import qualified Data.Text as T import Numeric import Control.Concurrent (threadDelay) import Filesystem.Path.CurrentOS (directory, fromText) -import System.Directory (canonicalizePath, doesFileExist) +import System.Directory (canonicalizePath) import System.Environment (getArgs, getProgName) import System.Exit (ExitCode (..)) import System.FilePath (addExtension, dropExtension, @@ -569,18 +570,13 @@ defaultLoopRender opts = when (opts ^. loop) $ do prog <- getProgName args <- getArgs - srcPath <- case opts ^. src of - Just path -> return path - Nothing -> do - let hsFile = replaceExtension prog "hs" - lhsFile = replaceExtension prog "lhs" - hsExists <- doesFileExist hsFile - if hsExists then return hsFile - else do - lhsExists <- doesFileExist lhsFile - if lhsExists then return lhsFile - else error ("Unable to guess source file. " - ++ "Specify source file with '-s' or '--src'") + 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 [] @@ -642,3 +638,4 @@ run prog args ExitSuccess = do unless (null stdOut) $ putStrLn "stdout:" >> putStrLn stdOut unless (null stdErr) $ putStrLn "stderr:" >> putStrLn stdErr run _ _ _ = return () + diff --git a/src/Diagrams/Util.hs b/src/Diagrams/Util.hs index 987d17be..96ad1030 100644 --- a/src/Diagrams/Util.hs +++ b/src/Diagrams/Util.hs @@ -20,6 +20,9 @@ module Diagrams.Util , tau + -- * Files + , findHsFile + -- * Finding sandboxes , findSandbox , globalPackage @@ -122,6 +125,22 @@ foldB f _ as = foldB' as 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 ------------------------------------------------------------------------ From 51c25009de6fa9fbccfabc696b5158abe18606dc Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Thu, 29 Jan 2015 04:03:03 +0000 Subject: [PATCH 11/11] Impliment locking for cmdline loop. --- src/Diagrams/Backend/CmdLine.hs | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src/Diagrams/Backend/CmdLine.hs b/src/Diagrams/Backend/CmdLine.hs index cba41e61..39844bdf 100644 --- a/src/Diagrams/Backend/CmdLine.hs +++ b/src/Diagrams/Backend/CmdLine.hs @@ -89,6 +89,7 @@ import Data.Colour import Data.Colour.Names import Data.Colour.SRGB import Data.Data +import Data.IORef import Data.List (delete) import Data.Maybe (fromMaybe) import Data.Monoid @@ -594,10 +595,18 @@ defaultLoopRender opts = when (opts ^. loop) $ do -- Polling is only used on Windows withManagerConf defaultConfig { confPollInterval = opts ^. interval } $ \mgr -> do + lock <- newIORef False + _ <- watchDir mgr (directory srcFilePath) (existsEvents (== srcFilePath)) - -- Call the new program without the looping option - (\ev -> putStrF ("Modified " ++ timeOfDay ev ++ " ... ") - >> recompile srcPath newProg sandboxArgs >>= run newProg args') + $ \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'