directory-ospath-streaming 0.1.0.3 → 0.2

raw patch · 10 files changed

+692/−111 lines, 10 filesdep +deepseqdep ~atomic-counterdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq

Dependency ranges changed: atomic-counter, base

API changes (from Hackage documentation)

Files

• Changelog.md +9/−1
• Readme.md +2/−0
• directory-ospath-streaming.cabal +12/−5
• src/System/Directory/OsPath/Contents.hs +169/−0
• src/System/Directory/OsPath/FileType.hs +42/−29
• src/System/Directory/OsPath/Streaming.hs +30/−66
• src/System/Directory/OsPath/Streaming/Internal.hs +71/−0
• src/System/Directory/OsPath/Streaming/Internal/Raw.hs +300/−0
• src/System/Directory/OsPath/Types.hs +42/−0
• test/TestMain.hs +15/−10

@@ -1,7 +1,15 @@+# 0.2++– New function for listing directory contents recursively ‘getDirectoryContentsRecursive’+- New function for defining custom recursive directory traversals ‘listContentsRecFold’+- ‘readDirStream’ now returns file type in addition to basename+- ‘DirStream’ is now safe to close multiple times and it will be automatically closed by GC when it becomes unreachable+- The ‘FileType’ type now has only 3 constructors, symlink status is now field of some of them+ # 0.1.0.3  - Lower `base` minimum required base to 4.12 (GHC 8.6). Minimum-  supported `unix` is still 2.8 because of `OsString`.+  supported `unix` is still 2.8 because of `OsString`  # 0.1.0.2 

@@ -7,4 +7,6 @@ perspective, this reading interface allows stopping at any point without loading every directory element. +Also defines general-purpose recursive directory traversals.+ Both Windows and Unix systems are supported.

@@ -5,7 +5,7 @@ name:   directory-ospath-streaming version:-  0.1.0.3+  0.2 synopsis:   Stream directory entries in constant memory in vanilla IO description:@@ -14,6 +14,8 @@   perspective, this reading interface allows stopping at any point   without loading every directory element. +  Also defines general-purpose recursive directory traversals.+   Both Windows and Unix systems are supported. copyright:   (c) Sergey Vinokurov 2023@@ -97,7 +99,6 @@       -Wno-missing-role-annotations       -Wno-missing-poly-kind-signatures - common depends-on-filepath   if flag(os-string)     build-depends:@@ -110,21 +111,27 @@ library   import: ghc-options, depends-on-filepath   exposed-modules:-    System.Directory.OsPath.FileType     System.Directory.OsPath.Streaming+    System.Directory.OsPath.Streaming.Internal+    System.Directory.OsPath.Streaming.Internal.Raw+    System.Directory.OsPath.Types+  other-modules:+    System.Directory.OsPath.Contents+    System.Directory.OsPath.FileType   hs-source-dirs:     src   build-depends:+    , atomic-counter     , base >= 4.12 && < 5+    , deepseq >= 1.4    if os(windows)     build-depends:-      , atomic-counter       , directory >= 1.3.8       , Win32 >= 2.13.3   else-    -- Cannot use lower version because it doesn’t support OsStrings     build-depends:+      -- Cannot use lower version because it doesn’t support OsStrings       , unix >= 2.8  test-suite test

@@ -0,0 +1,169 @@+-- |+-- Module:     System.Directory.OsPath.Contents+-- Copyright:  (c) Sergey Vinokurov 2024+-- License:    Apache-2.0 (see LICENSE)+-- Maintainer: serg.foo@gmail.com++{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module System.Directory.OsPath.Contents+  ( getDirectoryContentsRecursive++  , listContentsRecFold+  ) where++import Control.Exception (mask, onException)+import Data.Coerce (coerce, Coercible)+import System.IO.Unsafe (unsafeInterleaveIO)+import System.OsPath++import System.Directory.OsPath.Streaming.Internal (DirStream)+import qualified System.Directory.OsPath.Streaming.Internal as Streaming+import qualified System.Directory.OsPath.Streaming.Internal.Raw as Raw+import System.Directory.OsPath.Types++-- | Recursively list all the files and directories in a directory and all subdirectories.+--+-- The directory structure is traversed depth-first.+--+-- The result is generated lazily so is not well defined if the source+-- directory structure changes before the list is fully consumed.+--+-- Symlinks within directory structure may cause result to be infinitely long.+getDirectoryContentsRecursive+  :: OsPath+  -> IO [(OsPath, FileType)]+getDirectoryContentsRecursive root =+  listContentsRecFold'+    Nothing+    (\_ _ (Relative path) _ ft _ cons prependSubdir rest -> cons (path, ft) $ prependSubdir rest)+    (\_ _ (Relative path) _ ft -> pure (Just (path, ft)))+    (Just root)++{-# INLINE listContentsRecFold #-}+-- | The most general form of gathering directory contents.+--+-- Treats symlinks the same as regular files and directories. Folding functions can+-- decide how to handle symlinks.+--+-- Both directory and file actions can throw exceptions and this function+-- will try to close finished directory streams promptly (they’ll be closed+-- by GC in the worst case).+listContentsRecFold+  :: forall f a b. (Foldable f, Coercible b OsPath)+  => Maybe Int+  -- ^ Depth limit if specified, negative values treated the same as positive ones.+  -> (forall c. OsPath -> b -> Relative OsPath -> Basename OsPath -> SymlinkType -> (a -> IO c -> IO c) -> (IO c -> IO c) -> IO c -> IO c)+  -- ^ Decide how to fold directory and its children given its path.+  --+  -- Can do IO actions to plan what to do and typically should derive its+  -- result from last @IO c@ argument.+  --+  -- Returns @IO c@ where @c@ is hidden from the user so the only way+  -- to make it is to construct from the passed @IO c@ action.+  --+  -- Arguments:+  --+  -- * @OsPath@              - absolute path to the visited directory+  -- * @b@                   - root of the visited directory as passed originally in @f b@ to the bigger fold function+  -- * @Relative OsPath@     - path to the visited directory relative to the previous @b@ argument+  -- * @Basename OsPath@     - name of the visited directory without slashes+  -- * @SymlinkType@         - symlink status of the visited directory+  -- * @(a -> IO c -> IO c)@ - can be used to record some output (@a@) about the directory itself+  -- * @(IO c -> IO c)@      - traverse inside this directory, can be ignored to skip its children+  -- * @IO c@                - continue scanning not yet visited parts, must be used to construct return value (otherwise it won’t typecheck!)+  --+  -- The passed @(IO c -> IO c)@ argument function should (but is not required to)+  -- be applied in the returned function and it will prepend results for subdirectories+  -- of the directory being analyzed. If not applied these subdirectories will be skipped,+  -- this way ignoring particular directory and all its children can be achieved.+  -> (OsPath -> b -> Relative OsPath -> Basename OsPath -> FileType -> IO (Maybe a))+  -- ^ What to do with file+  -> f b+  -- ^ Roots to search in, either absolute or relative+  -> IO [a]+listContentsRecFold = \depthLimit foldDir filePred input ->+  listContentsRecFold' depthLimit (\a b c d _f g h i j -> foldDir a b c d g h i j) filePred input++{-# INLINE listContentsRecFold' #-}+-- Actual worker with slightly worse type signature that we don’t want to expose to the users.+-- But it’s better candidate for implementing getDirectoryContentsRecursive here that+-- listContentsRecFold.+listContentsRecFold'+  :: forall f a b. (Foldable f, Coercible b OsPath)+  => Maybe Int+  -> (forall c. OsPath -> b -> Relative OsPath -> Basename OsPath -> FileType -> SymlinkType -> (a -> IO c -> IO c) -> (IO c -> IO c) -> IO c -> IO c)+  -> (OsPath -> b -> Relative OsPath -> Basename OsPath -> FileType -> IO (Maybe a))+  -> f b+  -> IO [a]+listContentsRecFold' depthLimit foldDir filePred input =+  goCache =<< Raw.allocateDirReadCache+  where+    goCache cache =+      foldr (goNewDir initLimit) (Raw.releaseDirReadCache cache *> pure []) input+      where+        !initLimit = case depthLimit of+          Nothing -> -1 -- Loop until overflow, basically infinitely+          Just x  -> abs x++        goNewDir :: Int -> b -> IO [a] -> IO [a]+        goNewDir !d root rest =+          mask $ \restore -> do+            stream <- Streaming.openDirStream $ coerce root+            (restore+              (goDirStream root d (Streaming.closeDirStream stream *> rest) stream))++        goDirStream :: b -> Int -> IO [a] -> DirStream -> IO [a]+        goDirStream _    0     rest _      = rest+        goDirStream root depth rest stream = go+          where+            go :: IO [a]+            go = (`onException` Streaming.closeDirStream stream) $ do+              x <- Streaming.readDirStreamWithCache cache stream+              case x of+                Nothing                -> rest+                Just (yAbs, yBase, ft) -> do+                  let yRel :: Relative OsPath+                      yRel = coerce yBase+                  case ft of+                    Other _       -> addLazy (filePred yAbs root yRel yBase ft) go+                    File _        -> addLazy (filePred yAbs root yRel yBase ft) go+                    Directory ft' -> foldDir yAbs root yRel yBase ft ft' cons (goNewDirAcc yRel (depth - 1) yAbs) go++            goNewDirAcc :: Relative OsPath -> Int -> OsPath -> IO [a] -> IO [a]+            goNewDirAcc rootAcc !d dir rest1 =+              mask $ \restore -> do+                stream1 <- Streaming.openDirStream dir+                (restore+                  (goDirStreamAcc rootAcc d (Streaming.closeDirStream stream1 *> rest1) stream1))++            goDirStreamAcc :: Relative OsPath -> Int -> IO [a] -> DirStream -> IO [a]+            goDirStreamAcc _       0      rest1 _       = rest1+            goDirStreamAcc rootAcc depth1 rest1 stream1 = go1+              where+                go1 :: IO [a]+                go1 = (`onException` Streaming.closeDirStream stream1) $ do+                  x <- Streaming.readDirStreamWithCache cache stream1+                  case x of+                    Nothing                -> rest1+                    Just (yAbs, yBase, ft) -> do+                      let yRel :: Relative OsPath+                          yRel = coerce (</>) rootAcc yBase+                      case ft of+                        Other _       -> addLazy (filePred yAbs root yRel yBase ft) go1+                        File _        -> addLazy (filePred yAbs root yRel yBase ft) go1+                        Directory ft' -> foldDir yAbs root yRel yBase ft ft' cons (goNewDirAcc yRel (depth1 - 1) yAbs) go1++        addLazy :: IO (Maybe a) -> IO [a] -> IO [a]+        addLazy x y = do+          x' <- x+          case x' of+            Nothing  -> y+            Just x'' -> cons x'' y++        cons :: a -> IO [a] -> IO [a]+        cons x y =+          (x :) <$> unsafeInterleaveIO y

@@ -1,6 +1,6 @@ -- | -- Module:     System.Directory.OsPath.FileType--- Copyright:  (c) Sergey Vinokurov 2023+-- Copyright:  (c) Sergey Vinokurov 2024 -- License:    Apache-2.0 (see LICENSE) -- Maintainer: serg.foo@gmail.com @@ -8,53 +8,66 @@ {-# LANGUAGE ScopedTypeVariables #-}  module System.Directory.OsPath.FileType-  ( FileType(..)-  , getFileType+  ( getFileType++  , regularFile+  , regularDirectory+  , regularOther+  , symlinkFile+  , symlinkDirectory+  , symlinkOther   ) where  import System.OsPath.Types (OsPath)+import System.Directory.OsPath.Types  #ifdef mingw32_HOST_OS- import System.Directory.OsPath (doesFileExist, doesDirectoryExist)+#endif+#ifndef mingw32_HOST_OS+import Control.Exception (try, IOException)+import System.OsString.Internal.Types (getOsString)+import qualified System.Posix.Files.PosixString as PosixF+#endif  getFileType :: OsPath -> IO FileType+#ifdef mingw32_HOST_OS getFileType fp = do   isFile <- doesFileExist fp   if isFile-  then pure File+  then pure regularFile   else do     isDir <- doesDirectoryExist fp-    pure $ if isDir then Directory else Other--#else--import Control.Exception (try, IOException)-import System.OsString.Internal.Types (getOsString)-import qualified System.Posix.Files.PosixString as PosixF--getFileType :: OsPath -> IO FileType+    pure $ if isDir then regularDirectory else regularOther+#endif+#ifndef mingw32_HOST_OS getFileType fp = do   s <- PosixF.getSymbolicLinkStatus $ getOsString fp   case () of-    _ | PosixF.isRegularFile s  -> pure File-      | PosixF.isDirectory s    -> pure Directory+    _ | PosixF.isRegularFile s  -> pure regularFile+      | PosixF.isDirectory s    -> pure regularDirectory       | PosixF.isSymbolicLink s -> do         es' <- try $ PosixF.getFileStatus $ getOsString fp         case es' of-          Left (_ :: IOException) -> pure Other+          Left (_ :: IOException) -> pure symlinkOther           Right s'-            | PosixF.isRegularFile s' -> pure FileSym-            | PosixF.isDirectory s'   -> pure DirectorySym-            | otherwise               -> pure Other-      | otherwise -> pure Other-+            | PosixF.isRegularFile s' -> pure symlinkFile+            | PosixF.isDirectory s'   -> pure symlinkDirectory+            | otherwise               -> pure symlinkOther+      | otherwise -> pure regularOther #endif -data FileType-  = File-  | FileSym -- ^ Symlink to a file.-  | Directory-  | DirectorySym -- ^ Symlink to a directory.-  | Other-  deriving (Show, Read, Eq, Ord)+-- Avoid allocations with this one weird trick.+{-# NOINLINE regularFile #-}+{-# NOINLINE regularDirectory #-}+{-# NOINLINE symlinkFile #-}+{-# NOINLINE symlinkDirectory #-}+-- | Auxiliary constants to refer to different file types without+-- allocations.+regularFile, regularDirectory, regularOther, symlinkFile, symlinkDirectory, symlinkOther :: FileType+regularFile      = File Regular+regularDirectory = Directory Regular+regularOther     = Other Regular+symlinkFile      = File Symlink+symlinkDirectory = Directory Symlink+symlinkOther     = Other Symlink

@@ -1,78 +1,42 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE QuasiQuotes         #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | Streaming functions for interacting with the filesystem.+-- |+-- Module:     System.Directory.OsPath.SafeStreaming+-- Copyright:  (c) Sergey Vinokurov 2024+-- License:    Apache-2.0 (see LICENSE)+-- Maintainer: serg.foo@gmail.com+--+-- You’ll most likely be interested in either+--+-- * 'getDirectoryContentsRecursive' to search directory hierarchy recursively+-- * 'DirStream', 'openDirStream', 'readDirStream', and 'closeDirStream' to traverse single directory efficiently  module System.Directory.OsPath.Streaming   ( DirStream   , openDirStream   , readDirStream   , closeDirStream-  ) where -import System.OsPath (osp)--#ifdef mingw32_HOST_OS--import Control.Concurrent.Counter (Counter)-import qualified Control.Concurrent.Counter as Counter-import Control.Monad (unless)-import System.OsPath.Types (OsPath)-import System.OsString.Internal.Types (OsString(OsString), getOsString)-import System.OsString.Windows (pstr)-import qualified System.Win32.Types as Win32-import qualified System.Win32.WindowsString.File as Win32--data DirStream = DirStream !Win32.HANDLE !Win32.FindData !Counter--openDirStream :: OsPath -> IO DirStream-openDirStream fp = do-  (h, fdat) <- Win32.findFirstFile $ getOsString fp <> [pstr|\*|]-  hasMore <- Counter.new 1 -- always at least two records, "." and ".."-  pure $! DirStream h fdat hasMore--closeDirStream :: DirStream -> IO ()-closeDirStream (DirStream h _ _) = Win32.findClose h--readDirStream :: DirStream -> IO (Maybe OsPath)-readDirStream (DirStream h fdat hasMore) = go-  where-    go = do-      hasMore' <- Counter.get hasMore-      if hasMore' /= 0-      then do-        filename  <- Win32.getFindDataFileName fdat-        hasMore'' <- Win32.findNextFile h fdat-        unless hasMore'' $-          Counter.set hasMore 0-        if filename == getOsString [osp|.|] || filename == getOsString [osp|..|]-        then go-        else pure $ Just $ OsString filename-      else pure Nothing+  -- * File types+  , SymlinkType(..)+  , FileType(..)+  , Basename(..)+  , getFileType -#else+  -- * Get directory contents+  , getDirectoryContentsRecursive -import System.OsPath.Types (OsPath)-import System.OsString.Internal.Types (OsString(OsString), getOsString)-import System.Posix.Directory.PosixPath (DirStream, closeDirStream)-import qualified System.Posix.Directory.PosixPath as Posix+  , listContentsRecFold -openDirStream :: OsPath -> IO DirStream-openDirStream = Posix.openDirStream . getOsString+  -- * Utilities+  , regularFile+  , regularDirectory+  , regularOther+  , symlinkFile+  , symlinkDirectory+  , symlinkOther+  ) where -{-# INLINE readDirStream #-}-readDirStream :: DirStream -> IO (Maybe OsPath)-readDirStream ds = go-  where-    go = do-      fp <- Posix.readDirStream ds-      case () of-        _ | fp == mempty-          -> pure Nothing-          | fp == getOsString [osp|.|] || fp == getOsString [osp|..|]-          -> go-          | otherwise-          -> pure $ Just $ OsString fp+import System.Directory.OsPath.Contents+import System.Directory.OsPath.FileType+import System.Directory.OsPath.Streaming.Internal as Streaming+import System.Directory.OsPath.Types -#endif

@@ -0,0 +1,71 @@+-- |+-- Module:     System.Directory.OsPath.Streaming.Internal+-- Copyright:  (c) Sergey Vinokurov 2024+-- License:    Apache-2.0 (see LICENSE)+-- Maintainer: serg.foo@gmail.com++{-# LANGUAGE BangPatterns   #-}+{-# LANGUAGE MagicHash      #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecursiveDo    #-}+{-# LANGUAGE UnboxedTuples  #-}++module System.Directory.OsPath.Streaming.Internal+  ( DirStream(..)+  , openDirStream+  , readDirStream+  , closeDirStream++  , readDirStreamWithCache+  ) where++import Control.Concurrent.Counter (Counter)+import qualified Control.Concurrent.Counter as Counter+import Control.Monad (when)+import System.Mem.Weak (Weak, mkWeak, finalize)+import System.OsPath (OsPath)++import qualified System.Directory.OsPath.Streaming.Internal.Raw as Raw+import System.Directory.OsPath.Types++-- | Abstract handle to directory contents.+--+-- May be closed multiple times and will be automatically closed by GC+-- when it goes out of scope.+data DirStream = DirStream+  { dsHandle   :: !Raw.RawDirStream+  , dsIsClosed :: {-# UNPACK #-} !Counter+  , dsFin      :: {-# UNPACK #-} !(Weak DirStream)+  }++openDirStream :: OsPath -> IO DirStream+openDirStream root = mdo+  dsHandle   <- Raw.openRawDirStream root+  dsIsClosed <- Counter.new 0+  let result = DirStream{dsHandle, dsIsClosed, dsFin}+  dsFin <- mkWeak result result (Just (closeDirStreamInternal result))+  pure result++-- | Deallocate directory handle. It’s safe to close 'DirStream' multiple times,+-- unlike the underlying OS-specific directory stream handle.+closeDirStream :: DirStream -> IO ()+closeDirStream stream =+  -- Finalize ourselves to do it only once instead of running finalizer+  -- in GC afterwards once more.+  finalize (dsFin stream)++closeDirStreamInternal :: DirStream -> IO ()+closeDirStreamInternal DirStream{dsHandle, dsIsClosed} = do+  !oldVal <- Counter.cas dsIsClosed 0 1+  when (oldVal == 0) $+    Raw.closeRawDirStream dsHandle++readDirStream :: DirStream -> IO (Maybe (OsPath, FileType))+readDirStream = Raw.readRawDirStream . dsHandle++readDirStreamWithCache+  :: Raw.DirReadCache+  -> DirStream+  -> IO (Maybe (OsPath, Basename OsPath, FileType))+readDirStreamWithCache cache =+  Raw.readRawDirStreamWithCache cache . dsHandle

@@ -0,0 +1,300 @@+-- |+-- Module:     System.Directory.OsPath.Streaming.Internal.Raw+-- Copyright:  (c) Sergey Vinokurov 2024+-- License:    Apache-2.0 (see LICENSE)+-- Maintainer: serg.foo@gmail.com+--+-- Streaming functions for interacting with the filesystem.+--+-- These do the basic job of reading directory entries but care must+-- be taken to not close these streams more than once.++{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE UnboxedTuples       #-}++#ifndef mingw32_HOST_OS+# if MIN_VERSION_unix(2, 8, 6) && __GLASGOW_HASKELL__ >= 902+#  define HAVE_UNIX_CACHE 1+# endif+#endif++module System.Directory.OsPath.Streaming.Internal.Raw+  ( RawDirStream(..)+  , openRawDirStream+  , readRawDirStream+  , closeRawDirStream++  , DirReadCache(..)+  , allocateDirReadCache+  , releaseDirReadCache+  , readRawDirStreamWithCache+  ) where++import System.OsPath (osp, (</>))++import System.Directory.OsPath.FileType+import System.Directory.OsPath.Types++#ifdef mingw32_HOST_OS+import Control.Concurrent.Counter (Counter)+import qualified Control.Concurrent.Counter as Counter+import Control.Monad (unless)+import System.OsPath.Types (OsPath)+import System.OsString.Internal.Types (OsString(OsString), getOsString)+import System.OsString.Windows (pstr)+import qualified System.Win32.Types as Win32+import qualified System.Win32.WindowsString.File as Win32+#endif++-- Don’t use #else to make treesitter do better job - it parses #else part as comments.+#ifndef mingw32_HOST_OS+import System.OsPath.Types (OsPath)+import System.OsString.Internal.Types (OsString(OsString), getOsString)+import qualified System.Posix.Directory.PosixPath as Posix++# ifdef HAVE_UNIX_CACHE+import Data.Coerce (coerce)+import Foreign.C (CString, CChar)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.Storable (sizeOf, alignment, peekElemOff)+import qualified System.Posix.Directory.Internals as DirInternals+import System.Posix.PosixPath.FilePath (peekFilePath)++import GHC.Exts (MutableByteArray#, newAlignedPinnedByteArray#, touch#, mutableByteArrayContents#, RealWorld)+import GHC.IO (IO(..))+import GHC.Int (Int(..))+import GHC.Ptr (Ptr(..))+# endif+#endif++-- | Abstract handle to directory contents.+--+-- Not thread safe and shouldn't be closed more than once.++#ifdef mingw32_HOST_OS+data RawDirStream = RawDirStream !Win32.HANDLE !Win32.FindData !Counter !OsPath+#endif+#ifndef mingw32_HOST_OS+data RawDirStream = RawDirStream !Posix.DirStream !OsPath+#endif++openRawDirStream :: OsPath -> IO RawDirStream+#ifdef mingw32_HOST_OS+openRawDirStream fp = do+  (h, fdat) <- Win32.findFirstFile $ getOsString fp <> [pstr|\*|]+  hasMore <- Counter.new 1 -- always at least two records, "." and ".."+  pure $! RawDirStream h fdat hasMore fp+#endif++#ifndef mingw32_HOST_OS+openRawDirStream root = do+  stream <- Posix.openDirStream (getOsString root)+  pure $ RawDirStream stream root+#endif++-- | Deallocate directory handle. It’s not safe to call multiple times+-- on the same handle.+closeRawDirStream :: RawDirStream -> IO ()++#ifdef mingw32_HOST_OS+closeRawDirStream (RawDirStream h _ _ _) = Win32.findClose h+#endif+#ifndef mingw32_HOST_OS+closeRawDirStream (RawDirStream stream _) = Posix.closeDirStream stream+#endif++readRawDirStream :: RawDirStream -> IO (Maybe (OsPath, FileType))+readRawDirStream stream = do+  cache <- allocateDirReadCache+  res   <- readRawDirStreamWithCache cache stream+  -- Safe to don’t care about exceptions because we know that cache is+  -- just a byte vector so just touch# it for now.+  releaseDirReadCache cache+  pure $ (\(_, Basename x, typ) -> (x, typ)) <$> res++#ifdef mingw32_HOST_OS+-- No state on Windows+newtype DirReadCache = DirReadCache ()+#endif++#ifndef mingw32_HOST_OS++# ifndef HAVE_UNIX_CACHE+-- No state in early unix package+newtype DirReadCache = DirReadCache ()+# endif++# ifdef HAVE_UNIX_CACHE+data DirReadCache = DirReadCache (MutableByteArray# RealWorld)+# endif++#endif+++allocateDirReadCache :: IO DirReadCache+#ifdef mingw32_HOST_OS+allocateDirReadCache = pure $ DirReadCache ()+#endif++#ifndef mingw32_HOST_OS+# ifndef HAVE_UNIX_CACHE+allocateDirReadCache = pure $ DirReadCache ()+# endif+# ifdef HAVE_UNIX_CACHE+allocateDirReadCache = IO $ \s0 ->+  case newAlignedPinnedByteArray# size align s0 of+    (# s1, mbarr# #) ->+      (# s1, DirReadCache mbarr# #)+  where+    !(I# size)  = sizeOf    (undefined :: Ptr DirInternals.DirEnt)+    !(I# align) = alignment (undefined :: Ptr DirInternals.DirEnt)+# endif+#endif+++releaseDirReadCache :: DirReadCache -> IO ()+#ifdef mingw32_HOST_OS+releaseDirReadCache _ = pure ()+#endif+#ifndef mingw32_HOST_OS++# ifndef HAVE_UNIX_CACHE+releaseDirReadCache _ = pure ()+# endif+# ifdef HAVE_UNIX_CACHE+releaseDirReadCache (DirReadCache barr#) =+  IO $ \s0 -> case touch# barr# s0 of s1 -> (# s1, () #)+# endif+#endif+++readRawDirStreamWithCache+  :: DirReadCache+  -> RawDirStream+  -> IO (Maybe (OsPath, Basename OsPath, FileType))+#ifdef mingw32_HOST_OS+readRawDirStreamWithCache _ stream@(RawDirStream _ _ _ root) = do+  traverse (\x -> let full = root </> x in (full, Basename x,) <$> getFileType full) =<< _readRawDirStreamSimple stream+#endif+#ifndef mingw32_HOST_OS++# ifndef HAVE_UNIX_CACHE+readRawDirStreamWithCache _ stream@(RawDirStream _ root) = do+  traverse (\x -> let full = root </> x in (full, Basename x,) <$> getFileType full) =<< _readRawDirStreamSimple stream+# endif+# ifdef HAVE_UNIX_CACHE+readRawDirStreamWithCache (DirReadCache barr#) (RawDirStream stream root) = go+  where+    cache :: Ptr DirInternals.DirEnt+    cache = Ptr (mutableByteArrayContents# barr#)++    shouldSkipDirEntry :: CString -> IO Bool+    shouldSkipDirEntry ptr+      | ptr == nullPtr = pure True+    shouldSkipDirEntry ptr = do+      (x1 :: CChar) <- peekElemOff ptr 0+      case x1 of+        0  -> pure False+        46 -> do -- ASCII for ‘.’+          (x2 :: CChar) <- peekElemOff ptr 1+          case x2 of+            0  -> pure True+            46 -> do -- ASCII for ‘.’+              (x3 :: CChar) <- peekElemOff ptr 2+              pure $! x3 == 0+            _  -> pure False+        _  -> pure False++    go :: IO (Maybe (OsPath, Basename OsPath, FileType))+    go = do+      x <- DirInternals.readDirStreamWithPtr+        cache+        (\dirEnt -> do+          (namePtr :: CString) <- DirInternals.dirEntName dirEnt++          shouldSkip <- shouldSkipDirEntry namePtr++          if shouldSkip+          then+            pure Nothing+          else do+            !path <- peekFilePath namePtr++            let fullPath = root </> coerce path++            !typ  <- DirInternals.dirEntType dirEnt++            typ' <- case typ of+              DirInternals.UnknownType         -> getFileType fullPath+              DirInternals.NamedPipeType       -> pure regularOther+              DirInternals.CharacterDeviceType -> pure regularOther+              DirInternals.DirectoryType       -> pure regularDirectory+              DirInternals.BlockDeviceType     -> pure regularOther+              DirInternals.RegularFileType     -> pure regularFile+              DirInternals.SymbolicLinkType    -> getFileType fullPath+              DirInternals.SocketType          -> pure regularOther+              DirInternals.WhiteoutType        -> pure regularOther+              -- Unaccounted type, probably should not happeen since the+              -- list above is exhaustive.+              _                                -> getFileType fullPath++            pure (Just (fullPath, Basename $ coerce path, typ')))+        stream++      case x of+        Nothing           -> pure Nothing+        Just Nothing      -> go+        Just res@(Just _) -> pure res+# endif+#endif++_readRawDirStreamSimple :: RawDirStream -> IO (Maybe OsPath)++#ifdef mingw32_HOST_OS+_readRawDirStreamSimple (RawDirStream h fdat hasMore _) = go+  where+    go = do+      hasMore' <- Counter.get hasMore+      if hasMore' /= 0+      then do+        filename  <- Win32.getFindDataFileName fdat+        hasMore'' <- Win32.findNextFile h fdat+        unless hasMore'' $+          Counter.set hasMore 0+        if filename == getOsString [osp|.|] || filename == getOsString [osp|..|]+        then go+        else pure $ Just $ OsString filename+      else pure Nothing+#endif+#ifndef mingw32_HOST_OS+_readRawDirStreamSimple (RawDirStream stream _) = go+  where+# ifndef HAVE_UNIX_CACHE+    go = do+      fp <- Posix.readDirStream stream+      case () of+        _ | fp == mempty+          -> pure Nothing+          | fp == getOsString [osp|.|] || fp == getOsString [osp|..|]+          -> go+          | otherwise+          -> pure $ Just $ OsString fp+# endif+# ifdef HAVE_UNIX_CACHE+    go = do+      fp <- Posix.readDirStreamMaybe stream+      case fp of+        Nothing -> pure Nothing+        Just fp'+          | fp' == getOsString [osp|.|] || fp' == getOsString [osp|..|]+          -> go+          | otherwise+          -> pure $ Just $ OsString fp'+# endif+#endif+

@@ -0,0 +1,42 @@+-- |+-- Module:     System.Directory.OsPath.Types+-- Copyright:  (c) Sergey Vinokurov 2024+-- License:    Apache-2.0 (see LICENSE)+-- Maintainer: serg.foo@gmail.com++{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module System.Directory.OsPath.Types+  ( SymlinkType(..)+  , FileType(..)+  , Basename(..)+  , Relative(..)+  ) where++import Control.DeepSeq (NFData)+import GHC.Generics (Generic, Generic1)++data SymlinkType = Regular | Symlink+  deriving (Show, Read, Eq, Ord, Generic)++instance NFData SymlinkType++data FileType+  = File {-# UNPACK #-} !SymlinkType+  | Directory {-# UNPACK #-} !SymlinkType+  | Other {-# UNPACK #-} !SymlinkType+  deriving (Show, Read, Eq, Ord, Generic)++instance NFData FileType++-- | Basename part of filename, without directory separators.+newtype Basename a = Basename { unBasename :: a }+  deriving (Eq, Ord, Show, Generic, Generic1, NFData, Functor, Foldable, Traversable)++-- | Filename relative to some other path.+newtype Relative a = Relative { unRelative :: a }+  deriving (Eq, Ord, Show, Generic, Generic1, NFData, Functor, Foldable, Traversable)

@@ -17,7 +17,6 @@ import qualified Data.List as L import System.OsPath -import System.Directory.OsPath.FileType import System.Directory.OsPath.Streaming  import Test.Tasty@@ -44,13 +43,19 @@         Just y <- readDirStream ds         Just z <- readDirStream ds         return $ L.sort [w, x, y, z]-      res @?= [[osp|bar.txt|], [osp|baz.txt|], [osp|bin|], [osp|foo.txt|]]+      res @?= [([osp|bar.txt|], File Regular), ([osp|baz.txt|], File Regular), ([osp|bin|], Directory Regular), ([osp|foo.txt|], File Regular)]+   , testGroup "getFileType general"       [ testCase "file" $ do-          getFileType [osp|directory-ospath-streaming.cabal|] >>= (@?= File)+          getFileType [osp|directory-ospath-streaming.cabal|] >>= (@?= File Regular)       , testCase "directory" $ do-          getFileType [osp|test|] >>= (@?= Directory)+          getFileType [osp|test|] >>= (@?= Directory Regular)       ]++  , testCase "getDirectoryContentsRecursive" $ do+    res <- L.sort <$> getDirectoryContentsRecursive [osp|test/filesystem|]+    res @?= [([osp|bar.txt|], File Regular), ([osp|baz.txt|], File Regular), ([osp|bin|], Directory Regular), ([osp|bin|] </> [osp|bin.txt|], File Regular), ([osp|foo.txt|], File Regular)]+ #ifndef mingw32_HOST_OS   , withResource       (do@@ -66,7 +71,7 @@               (getOsString (currDir </> [osp|directory-ospath-streaming.cabal|]))               (getOsString dest)             ft <- getFileType dest-            ft @?= FileSym+            ft @?= File Symlink         , testCase "directory symlink" $ do             tmp     <- mkTmpDir             currDir <- getCurrentDirectory@@ -75,17 +80,17 @@               (getOsString (currDir </> [osp|src|]))               (getOsString dest)             ft <- getFileType dest-            ft @?= DirectorySym+            ft @?= Directory Symlink         , testCase "other" $ do             tmp <- mkTmpDir             let dest = tmp </> [osp|tmp3|]-            res    <- tryIO $ Posix.createNamedPipe (getOsString dest) 0+            res <- tryIO $ Posix.createNamedPipe (getOsString dest) 0             case res of               -- Creating named pipe might fail on some filesystems               Left _  -> pure ()               Right _ -> do                 ft <- getFileType dest-                ft @?= Other+                ft @?= Other Regular         , testCase "recursive symlink is other" $ do             tmp <- mkTmpDir             let dest = tmp </> [osp|tmp4|]@@ -93,7 +98,7 @@               (getOsString dest)               (getOsString dest)             ft <- getFileType dest-            ft @?= Other+            ft @?= Other Symlink         , testCase "dangling symlink is other" $ do             tmp <- mkTmpDir             let dest = tmp </> [osp|tmp5|]@@ -101,7 +106,7 @@               (getOsString (tmp </> [osp|does-not-exist|]))               (getOsString dest)             ft <- getFileType dest-            ft @?= Other+            ft @?= Other Symlink         ] #endif   ]