Merge pull request #47 from haskell-hvr/drop-process-extras

Drop process-extras dependency

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

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

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'