Allow excluding patterns

cabal-gild.cabal

@@ -58,9 +58,9 @@ library
     Cabal-syntax ^>=3.10.1.0 || ^>=3.12.0.0,
     bytestring ^>=0.11.4.0 || ^>=0.12.0.2,
     containers ^>=0.6.7 || ^>=0.7,
-    directory ^>=1.3.8.1,
     exceptions ^>=0.10.7,
     filepath ^>=1.4.100.1 || ^>=1.5.2.0,
+    filepattern ^>=0.1.3,
     parsec ^>=3.1.16.1,
     pretty ^>=1.1.3.6,
     text ^>=2.0.2 || ^>=2.1,
@@ -145,9 +145,10 @@ test-suite cabal-gild-test-suite
   build-depends:
     bytestring,
     containers,
-    directory,
+    directory ^>=1.3.8.1,
     exceptions,
     filepath,
+    filepattern,
     hspec ^>=2.11.8,
     temporary ^>=1.3,
     transformers,

source/library/CabalGild/Unstable/Action/EvaluatePragmas.hs

@@ -13,6 +13,7 @@ import qualified Control.Monad as Monad
 import qualified Control.Monad.Catch as Exception
 import qualified Control.Monad.Trans.Class as Trans
 import qualified Control.Monad.Trans.Maybe as MaybeT
+import qualified Data.Containers.ListUtils as List
 import qualified Data.Maybe as Maybe
 import qualified Data.Set as Set
 import qualified Distribution.Compat.Lens as Lens
@@ -62,30 +63,35 @@ discover p n fls ds = do
   let (strs, args, opts, errs) =
         GetOpt.getOpt'
           GetOpt.Permute
-          [ GetOpt.Option [] ["exclude"] (GetOpt.ReqArg id "FILE") ""
+          [ GetOpt.Option [] ["exclude"] (GetOpt.ReqArg id "PATTERN") ""
           ]
           ds
   mapM_ (Exception.throwM . UnknownOption.fromString) opts
   mapM_ (Exception.throwM . InvalidOption.fromString) errs
   let root = FilePath.takeDirectory p
       directories =
-        FilePath.dropTrailingPathSeparator
-          . normalize
-          . FilePath.combine root
-          <$> if null args then ["."] else args
-  files <- Trans.lift . fmap mconcat $ traverse MonadWalk.walk directories
+        List.nubOrd
+          . fmap
+            ( FilePath.dropTrailingPathSeparator
+                . normalize
+                . FilePath.combine root
+            )
+          $ if null args then ["."] else args
+  let exclusions = List.nubOrd $ fmap (normalize . FilePath.combine root) strs
+  files <-
+    Trans.lift $
+      MonadWalk.walk
+        "."
+        (fmap (\d -> normalize $ FilePath.joinPath [d, "**"]) directories)
+        exclusions
   let comments = concatMap (snd . FieldLine.annotation) fls
       position =
         maybe (fst $ Name.annotation n) (fst . FieldLine.annotation) $
           Maybe.listToMaybe fls
-      -- Exclusion must be computed relative to the directory containing the cabal file (see #71)
-      excludedFiles = Set.fromList $ fmap (normalize . FilePath.combine root) strs
       fieldLines =
         zipWith ModuleName.toFieldLine ((,) position <$> comments : repeat [])
           . Maybe.mapMaybe (toModuleName directories)
-          . Maybe.mapMaybe (stripAnyExtension extensions)
-          . filter (`Set.notMember` excludedFiles)
-          $ fmap normalize files
+          $ Maybe.mapMaybe (stripAnyExtension extensions . normalize) files
       -- This isn't great, but the comments have to go /somewhere/.
       name =
         if null fieldLines

source/library/CabalGild/Unstable/Class/MonadWalk.hs

@@ -1,28 +1,11 @@
 module CabalGild.Unstable.Class.MonadWalk where
 
-import qualified System.Directory as Directory
-import qualified System.FilePath as FilePath
+import qualified System.FilePattern as FilePattern
+import qualified System.FilePattern.Directory as FilePattern
 
--- | A 'Monad' that can also walk the file system.
+-- | A wrapper around 'FilePattern.getDirectoryFilesIgnore'.
 class (Monad m) => MonadWalk m where
-  -- | Lists all files in the given directory and its subdirectories
-  -- recursively.
-  walk :: FilePath -> m [FilePath]
+  walk :: FilePath -> [FilePattern.FilePattern] -> [FilePattern.FilePattern] -> m [FilePath]
 
--- | Uses 'listDirectoryRecursively'.
 instance MonadWalk IO where
-  walk = listDirectoryRecursively
-
--- | Lists all files in the given directory and its subdirectories recursively.
--- The order is not guaranteed and may change between different calls. It's
--- also not specified if the results are breadth-first or depth-first.
-listDirectoryRecursively :: FilePath -> IO [FilePath]
-listDirectoryRecursively d = do
-  es <- Directory.listDirectory d
-  let f e = do
-        let p = FilePath.combine d e
-        b <- Directory.doesDirectoryExist p
-        if b
-          then listDirectoryRecursively p
-          else pure [p]
-  mconcat <$> traverse f es
+  walk = FilePattern.getDirectoryFilesIgnore