From 90367a398cf48cb3649fb969ed5cc4647df6806a Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 28 Dec 2014 00:40:16 +0000 Subject: [PATCH] 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 ()