diff --git a/cabal-plan.cabal b/cabal-plan.cabal index ea431ae..14c5b85 100644 --- a/cabal-plan.cabal +++ b/cabal-plan.cabal @@ -96,31 +96,33 @@ executable cabal-plan hs-source-dirs: src-exe main-is: cabal-plan.hs - other-modules: Paths_cabal_plan LicenseReport Flag + other-modules: Paths_cabal_plan LicenseReport Flag ProcessLazyByteString autogen-modules: Paths_cabal_plan if flag(exe) -- dependencies w/ inherited version ranges via 'cabal-plan' library + -- Note: exe is installable only with GHC-8.0+ build-depends: cabal-plan - , base + , base >=4.9 , text , containers , bytestring , directory -- dependencies which require version bounds - build-depends: mtl ^>= 2.2.1 - , ansi-terminal ^>= 0.9 || ^>=0.10 - , base-compat ^>= 0.10.5 || ^>=0.11 - , optics-core ^>= 0.1 || ^>= 0.2 + build-depends: mtl ^>= 2.2.2 + , async ^>= 2.2.2 + , ansi-terminal ^>=0.10 + , base-compat ^>=0.11 + , optics-core ^>= 0.2 , optparse-applicative ^>= 0.15.0.0 - , parsec ^>= 3.1.11 - , process-extras ^>= 0.7.4 - , semialign ^>= 1 || ^>=1.1 - , singleton-bool ^>= 0.1.4 + , parsec ^>= 3.1.13 + , process ^>= 1.4.3.0 || ^>=1.6.3.0 + , semialign ^>= 1.1 + , singleton-bool ^>= 0.1.5 , these ^>= 1 , topograph ^>= 1 - , transformers ^>= 0.3.0.0 || ^>= 0.4.2.0 || ^>= 0.5.2.0 + , transformers ^>= 0.5.2.0 , vector ^>= 0.12.0.1 if flag(license-report) @@ -129,10 +131,6 @@ executable cabal-plan , zlib ^>= 0.6.2 , filepath ^>= 1.4.1.1 - if !impl(ghc >= 8.0) - build-depends: - semigroups ^>= 0.18.3 || ^>=0.19 - if flag(_) cpp-options: -DUNDERLINE_SUPPORT else diff --git a/src-exe/ProcessLazyByteString.hs b/src-exe/ProcessLazyByteString.hs new file mode 100644 index 0000000..ca1aedc --- /dev/null +++ b/src-exe/ProcessLazyByteString.hs @@ -0,0 +1,73 @@ +module ProcessLazyByteString (readProcessWithExitCode) where + +import Control.Concurrent.Async (wait, withAsync) +import qualified Control.Exception as E +import Control.Monad (unless) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Internal as LBS (ByteString (..), + defaultChunkSize) +import Foreign.C.Error (Errno (..), ePIPE) +import qualified GHC.IO.Exception as GHC +import System.Exit (ExitCode) +import System.IO (Handle, hClose) +import qualified System.Process as Proc + +readProcessWithExitCode + :: String -- ^ Command + -> [String] -- ^ Arguments + -> BS.ByteString -- ^ Stdin + -> IO (ExitCode, LBS.ByteString, LBS.ByteString) +readProcessWithExitCode cmd args = readProcessImpl (Proc.proc cmd args) + +readProcessImpl + :: Proc.CreateProcess + -> BS.ByteString + -> IO (ExitCode, LBS.ByteString, LBS.ByteString) +readProcessImpl cp input = + Proc.withCreateProcess cp' $ \mi mo me ph -> case (mi, mo, me) of + (Just inh, Just outh, Just errh) -> + -- spawn workers to read stdout and stderr + withAsync (getLBSContents outh) $ \outA -> + withAsync (getLBSContents errh) $ \errA -> do + -- write the input + unless (BS.null input) $ BS.hPutStr inh input + ignoreSigPipe $ hClose inh + + -- wait for the output + out <- wait outA + err <- wait errA + + -- wait for the process + ec <- Proc.waitForProcess ph + + return (ec, out, err) + + (Nothing,_,_) -> fail "readProcessWithExitCode: Failed to get a stdin handle." + (_,Nothing,_) -> fail "readProcessWithExitCode: Failed to get a stdout handle." + (_,_,Nothing) -> fail "readProcessWithExitCode: Failed to get a stderr handle." + + where + cp' :: Proc.CreateProcess + cp' = cp + { Proc.std_in = Proc.CreatePipe + , Proc.std_out = Proc.CreatePipe + , Proc.std_err = Proc.CreatePipe + } + +ignoreSigPipe :: IO () -> IO () +ignoreSigPipe = E.handle $ \e -> case e of + GHC.IOError { GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + _ -> E.throwIO e + +getLBSContents :: Handle -> IO LBS.ByteString +getLBSContents = hGetContentsN LBS.defaultChunkSize + +-- No unsafeInterleaveIO +hGetContentsN :: Int -> Handle -> IO LBS.ByteString +hGetContentsN k h = loop `E.finally` hClose h where + loop = do + c <- BS.hGetSome h k -- only blocks if there is no data available + if BS.null c + then return LBS.Empty + else LBS.Chunk c <$> loop diff --git a/src-exe/cabal-plan.hs b/src-exe/cabal-plan.hs index a927bb2..f24a561 100644 --- a/src-exe/cabal-plan.hs +++ b/src-exe/cabal-plan.hs @@ -18,6 +18,7 @@ import Control.Monad.Trans.Class (lift) import Data.Align (align) import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS import Data.Char (isAlphaNum) import Data.Foldable (for_, toList) import qualified Data.Graph as G @@ -46,7 +47,7 @@ import System.Console.ANSI import System.Directory (getCurrentDirectory) import System.Exit (ExitCode (..), exitFailure) import System.IO (hPutStrLn, stderr, stdout) -import System.Process.ByteString (readProcessWithExitCode) +import ProcessLazyByteString (readProcessWithExitCode) import qualified Text.Parsec as P import qualified Text.Parsec.String as P import qualified Topograph as TG @@ -1068,19 +1069,19 @@ doDot showBuiltin showGlobal plan tred tredWeights highlights rootPatterns outpu ] -- run dot - let readProcess :: FilePath -> [String] -> ByteString -> IO ByteString + let readProcess :: FilePath -> [String] -> ByteString -> IO LBS.ByteString readProcess cmd args input = do (ec, out, err) <- readProcessWithExitCode cmd args input case ec of ExitSuccess -> return out ExitFailure _ -> do - BS.putStr err + LBS.putStr err exitFailure contents' <- case mdot of Nothing -> return contents - Just PNG -> readProcess "dot" ["-Tpng"] contents - Just PDF -> readProcess "dot" ["-Tpdf"] contents + Just PNG -> LBS.toStrict <$> readProcess "dot" ["-Tpng"] contents + Just PDF -> LBS.toStrict <$> readProcess "dot" ["-Tpdf"] contents if output == "-" then BS.putStr contents'