From 08d8a1195f4c0cf320cb0603764ad6f8a8ff22e3 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Wed, 24 Dec 2014 23:52:14 +0000 Subject: [PATCH] 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 ()