diff --git a/ghcup.cabal b/ghcup.cabal index f27822ed..2f75d842 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -97,7 +97,7 @@ common app-common-depends , utf8-string ^>=1.0 , vector >=0.12 && <0.14 , versions >=6.0.5 && <6.1 - , yaml-streamly ^>=0.12.0 + , yaml-streamly >=0.12.5 && <0.13 if flag(tar) cpp-options: -DTAR @@ -202,7 +202,7 @@ library , safe ^>=0.3.18 , safe-exceptions ^>=0.1 , split ^>=0.2.3.4 - , streamly ^>=0.8.2 + , streamly-core >=0.2.0 && <0.3.0 , strict-base ^>=0.4 , template-haskell >=2.7 && <2.22 , temporary ^>=1.3 @@ -403,7 +403,7 @@ test-suite ghcup-test , hspec-golden-aeson ^>=0.9 , QuickCheck ^>=2.14.1 , quickcheck-arbitrary-adt ^>=0.3.1.0 - , streamly ^>=0.8.2 + , streamly-core >=0.2.0 && <0.3.0 , text ^>=2.0 , time >=1.9.3 && <1.12 , uri-bytestring ^>=0.3.2.2 diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 780a9c10..82e0352d 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -77,7 +77,7 @@ import System.IO.Temp import Text.Regex.Posix import qualified Data.Text as T -import qualified Streamly.Prelude as S +import qualified Streamly.Data.Stream as S @@ -673,5 +673,3 @@ rmTmp = do forM_ ghcup_dirs $ \f -> do logDebug $ "rm -rf " <> T.pack (fromGHCupPath f) rmPathForcibly f - - diff --git a/lib/GHCup/Prelude/File.hs b/lib/GHCup/Prelude/File.hs index c397b79c..46f66cc9 100644 --- a/lib/GHCup/Prelude/File.hs +++ b/lib/GHCup/Prelude/File.hs @@ -73,7 +73,8 @@ import System.FilePath import Text.PrettyPrint.HughesPJClass (prettyShow) import qualified Data.Text as T -import qualified Streamly.Prelude as S +import qualified Streamly.Data.Stream as S +import qualified Streamly.Data.Fold as F import Control.DeepSeq (force) import Control.Exception (evaluate) import GHC.IO.Exception @@ -88,7 +89,7 @@ import System.IO.Error -- If any copy operation fails, the record file is deleted, as well -- as the partially installed files. mergeFileTree :: ( MonadMask m - , S.MonadAsync m + , MonadIO m , MonadReader env m , HasDirs env , HasLog env @@ -127,7 +128,7 @@ mergeFileTree sourceBase destBase tool v' copyOp = do -- we want the cleanup action to leak through in case of exception onE_ (cleanupOnPartialInstall recFile) $ wrapInExcepts $ do logDebug "Starting merge" - lift $ flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do + lift $ flip S.fold (getDirectoryContentsRecursive sourceBase) $ F.drainMapM $ \f -> do copy f logDebug $ T.pack "Recording installed file: " <> T.pack f recordInstalledFile f recFile @@ -189,26 +190,26 @@ copyFileE from to = handleIO (throwE . CopyError . show) . liftIO . copyFile fro -- the source directory structure changes before the list is used. -- -- depth first -getDirectoryContentsRecursiveDFS :: (MonadCatch m, S.MonadAsync m, MonadMask m) +getDirectoryContentsRecursiveDFS :: (MonadCatch m, MonadIO m, MonadMask m) => GHCupPath - -> S.SerialT m FilePath + -> S.Stream m FilePath getDirectoryContentsRecursiveDFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveDFSUnsafe fp -- breadth first -getDirectoryContentsRecursiveBFS :: (MonadCatch m, S.MonadAsync m, MonadMask m) +getDirectoryContentsRecursiveBFS :: (MonadCatch m, MonadIO m, MonadMask m) => GHCupPath - -> S.SerialT m FilePath + -> S.Stream m FilePath getDirectoryContentsRecursiveBFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveBFSUnsafe fp -getDirectoryContentsRecursive :: (MonadCatch m, S.MonadAsync m, MonadMask m) +getDirectoryContentsRecursive :: (MonadCatch m, MonadIO m, MonadMask m) => GHCupPath - -> S.SerialT m FilePath + -> S.Stream m FilePath getDirectoryContentsRecursive = getDirectoryContentsRecursiveBFS -getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m) +getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, MonadIO m, MonadMask m) => FilePath - -> S.SerialT m FilePath + -> S.Stream m FilePath getDirectoryContentsRecursiveUnsafe = getDirectoryContentsRecursiveBFSUnsafe findFilesDeep :: GHCupPath -> Regex -> IO [FilePath] diff --git a/lib/GHCup/Prelude/File/Posix.hs b/lib/GHCup/Prelude/File/Posix.hs index dbd3655c..b2e32155 100644 --- a/lib/GHCup/Prelude/File/Posix.hs +++ b/lib/GHCup/Prelude/File/Posix.hs @@ -26,7 +26,6 @@ import System.IO ( hClose, hSetBinaryMode ) import System.IO.Error hiding ( catchIOError ) import System.FilePath import System.Directory ( removeFile, pathIsSymbolicLink, getSymbolicLinkTarget, doesPathExist ) -import System.Posix.Directory import System.Posix.Error ( throwErrnoPathIfMinus1Retry ) import System.Posix.Internals ( withFilePath ) import System.Posix.Files @@ -40,13 +39,13 @@ import qualified System.Posix as Posix import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.Internal.FileSystem.Handle as IFH -import qualified Streamly.Prelude as S +import qualified Streamly.Data.Stream as S import qualified GHCup.Prelude.File.Posix.Foreign as FD -import qualified Streamly.Internal.Data.Stream.StreamD.Type - as D -import Streamly.Internal.Data.Unfold.Type +import qualified Streamly.Internal.Data.Stream as D + +import Streamly.Internal.Data.Unfold (Unfold(..)) import qualified Streamly.Internal.Data.Unfold as U -import Streamly.Internal.Control.Concurrent ( withRunInIO ) + import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer ) import GHC.IO.Exception (IOException(ioe_type), IOErrorType (..)) @@ -140,7 +139,7 @@ copyFile from to fail' = do handle' <- SPI.fdToHandle fd pure (fd, handle') streamlyCopy (fH, tH) = - S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH + S.fold (FH.writeChunks tH) $ IFH.readChunksWith (256 * 1024) fH foreign import capi unsafe "fcntl.h open" c_open :: CString -> CInt -> Posix.CMode -> IO CInt @@ -278,8 +277,8 @@ removeEmptyDirectory = PD.removeDirectory -- | Create an 'Unfold' of directory contents. -unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath) -unfoldDirContents = U.bracket (liftIO . openDirStreamPortable) (liftIO . closeDirStreamPortable) (Unfold step return) +unfoldDirContents :: (MonadIO m, MonadCatch m) => Unfold m FilePath (FD.DirType, FilePath) +unfoldDirContents = U.bracketIO openDirStreamPortable closeDirStreamPortable (Unfold step return) where {-# INLINE [0] step #-} step dirstream = do @@ -291,17 +290,17 @@ unfoldDirContents = U.bracket (liftIO . openDirStreamPortable) (liftIO . closeDi | otherwise -> D.Yield (typ, e) dirstream -getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) +getDirectoryContentsRecursiveDFSUnsafe :: (MonadIO m, MonadCatch m) => FilePath - -> S.SerialT m FilePath + -> S.Stream m FilePath getDirectoryContentsRecursiveDFSUnsafe fp = go "" where go cd = flip S.concatMap (S.unfold unfoldDirContents (fp cd)) $ \(t, f) -> if | t == FD.dtDir -> go (cd f) - | otherwise -> pure (cd f) + | otherwise -> S.fromPure (cd f) -getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath +getDirectoryContentsRecursiveUnfold :: (MonadIO m, MonadMask m) => Unfold m FilePath FilePath getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""])) where {-# INLINE [0] step #-} @@ -321,15 +320,12 @@ getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, ["" (s, f) <- acquire (topdir dir) return $ D.Skip (topdir, Just (dir, s, f), dirs) - acquire dir = - withRunInIO $ \run -> mask_ $ run $ do + acquire dir = do dirstream <- liftIO $ openDirStreamPortable dir ref <- newIOFinalizer (liftIO $ closeDirStreamPortable dirstream) return (dirstream, ref) -getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) +getDirectoryContentsRecursiveBFSUnsafe :: (MonadIO m, MonadMask m) => FilePath - -> S.SerialT m FilePath + -> S.Stream m FilePath getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold - - diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 3cdcbe83..ed9b6fd1 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -87,7 +87,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Text.Megaparsec as MP import qualified Data.List.NonEmpty as NE -import qualified Streamly.Prelude as S +import qualified Streamly.Data.Stream as S +import qualified Streamly.Data.Fold as F import Control.DeepSeq (force) import GHC.IO (evaluate) @@ -1174,7 +1175,7 @@ installDestSanityCheck :: ( MonadIO m Excepts '[DirNotEmpty] m () installDestSanityCheck (IsolateDirResolved isoDir) = do hideErrorDef [doesNotExistErrorType] () $ do - empty' <- liftIO $ S.null $ getDirectoryContentsRecursiveUnsafe isoDir + empty' <- liftIO $ S.fold F.null $ getDirectoryContentsRecursiveUnsafe isoDir when (not empty') (throwE $ DirNotEmpty isoDir) installDestSanityCheck _ = pure () @@ -1284,4 +1285,3 @@ expandVersionPattern cabalVer gitHashS gitHashL gitDescribe gitBranch go (GitDescribe:xs) = gitDescribe <> go xs go (GitBranchName:xs) = gitBranch <> go xs go (S str:xs) = str <> go xs - diff --git a/test/ghcup-test/GHCup/Utils/FileSpec.hs b/test/ghcup-test/GHCup/Utils/FileSpec.hs index aac4e3d5..0742e33e 100644 --- a/test/ghcup-test/GHCup/Utils/FileSpec.hs +++ b/test/ghcup-test/GHCup/Utils/FileSpec.hs @@ -6,8 +6,8 @@ import Data.List import System.Directory import System.FilePath import System.IO.Unsafe -import qualified Streamly.Prelude as S - +import qualified Streamly.Data.Stream as S +import qualified Streamly.Data.Fold as F import Test.Hspec @@ -16,13 +16,13 @@ spec :: Spec spec = do describe "GHCup.Utils.File" $ do it "getDirectoryContentsRecursiveBFS" $ do - l1 <- sort <$> S.toList (getDirectoryContentsRecursiveBFSUnsafe "lib") + l1 <- sort <$> S.fold F.toList (getDirectoryContentsRecursiveBFSUnsafe "lib") l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib" not (null l1) `shouldBe` True not (null l2) `shouldBe` True l1 `shouldBe` l2 it "getDirectoryContentsRecursiveDFS" $ do - l1 <- sort <$> S.toList (getDirectoryContentsRecursiveDFSUnsafe "lib") + l1 <- sort <$> S.fold F.toList (getDirectoryContentsRecursiveDFSUnsafe "lib") l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib" not (null l1) `shouldBe` True not (null l2) `shouldBe` True @@ -54,5 +54,3 @@ getDirectoryContentsRecursiveLazy topdir = recurseDirectories [""] ignore ['.'] = True ignore ['.', '.'] = True ignore _ = False - -