vcs-ignore 0.0.2.0 → 0.1.0.0
raw patch · 27 files changed
+2308/−1233 lines, 27 filesdep +criteriondep +processdep +temporarydep −doctestdep −exceptionsdep ~Globdep ~basedep ~containers
Dependencies added: criterion, process, temporary
Dependencies removed: doctest, exceptions
Dependency ranges changed: Glob, base, containers, directory, filepath, optparse-applicative, text
Files
- CHANGELOG.md +17/−1
- LICENSE +1/−1
- README.md +166/−68
- RELEASING.md +48/−0
- app/Main.hs +87/−67
- app/Main/Options.hs +49/−49
- app/Main/Vendor.hs +25/−33
- benchmark/Main.hs +80/−0
- doctest/Main.hs +0/−6
- src/Data/VCS/Ignore.hs +17/−88
- src/Data/VCS/Ignore/Core.hs +0/−81
- src/Data/VCS/Ignore/FileSystem.hs +0/−99
- src/Data/VCS/Ignore/Git.hs +45/−0
- src/Data/VCS/Ignore/Git/Internal/Pattern.hs +266/−0
- src/Data/VCS/Ignore/Git/Internal/Repository.hs +391/−0
- src/Data/VCS/Ignore/Git/Internal/Traversal.hs +159/−0
- src/Data/VCS/Ignore/Repo.hs +0/−75
- src/Data/VCS/Ignore/Repo/Git.hs +0/−272
- src/Data/VCS/Ignore/Types.hs +65/−48
- test/Data/VCS/Ignore/CoreSpec.hs +0/−87
- test/Data/VCS/Ignore/FileSystemSpec.hs +0/−65
- test/Data/VCS/Ignore/Git/CompatibilitySpec.hs +161/−0
- test/Data/VCS/Ignore/Git/Internal/PatternSpec.hs +115/−0
- test/Data/VCS/Ignore/Git/Internal/RepositorySpec.hs +296/−0
- test/Data/VCS/Ignore/Git/Internal/TraversalSpec.hs +250/−0
- test/Data/VCS/Ignore/Repo/GitSpec.hs +0/−139
- vcs-ignore.cabal +70/−54
CHANGELOG.md view
@@ -1,9 +1,25 @@ # Changelog for vcs-ignore +## v0.1.0.0 (2026-08-31)++- Replace the eager repository scan and separate lazy matcher with one opaque,+ lazy `GitRepository` session+- Add kind-aware ignore queries with consistent Git last-match and+ ignored-parent semantics+- Add a constant-result-memory repository fold with caller pruning and global+ early termination+- Never follow symbolic links during traversal and expose each entry's kind+- Support Git directories, gitfiles, linked worktrees, and common directories+- Hide pattern and raw filesystem implementation details from the public API+- Remove the `Repo` type class, `scanRepo`, eager `Git`, and the separate+ `GitIgnoreMatcher` API+- Update the executable, documentation, tests, and benchmarks for the new API+- Document intentionally unsupported Git configuration (`core.excludesFile`,+ `core.ignoreCase`, and conditional includes) and sparse-checkout index rules+ ## v0.0.2.0 (2021-12-29) - minor fixes and improvements - Bump _LTS Haskell_ to `18.20` ## v0.0.1.0 (2021-05-10) - initial release-
LICENSE view
@@ -1,6 +1,6 @@ BSD 3-Clause License -Copyright (c) 2020-2022, Vaclav Svejcar+Copyright (c) 2020-2026, Vaclav Svejcar All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,104 +1,202 @@--[](https://hackage.haskell.org/package/vcs-ignore)-[](https://www.stackage.org/package/vcs-ignore)- # vcs-ignore-`vcs-ignore` is small Haskell library used to find, check and process files ignored by selected _VCS_. -## 1. Table of Contents-<!-- TOC -->+[](https://github.com/xwinus/vcs-ignore/actions/workflows/ci.yml)+[](https://hackage.haskell.org/package/vcs-ignore)+[](https://www.stackage.org/package/vcs-ignore) -- [1. Table of Contents](#1-table-of-contents)-- [2. Use as Library](#2-use-as-library)- - [2.1. Listing all files/directories ignored by VCS](#21-listing-all-filesdirectories-ignored-by-vcs)- - [2.2. Walking files/directories ignored by VCS](#22-walking-filesdirectories-ignored-by-vcs)- - [2.3. Checking if path is ignored by VCS](#23-checking-if-path-is-ignored-by-vcs)-- [3. Use as Executable](#3-use-as-executable)- - [3.1. Checking if path is ignored by VCS](#31-checking-if-path-is-ignored-by-vcs)+`vcs-ignore` is a Haskell library for querying Git ignore rules and traversing+the visible part of a working tree. It uses one lazy repository session for+both operations: opening a repository never scans its working tree, and+per-directory `.gitignore` files are loaded only when a visible branch needs+them. -<!-- /TOC -->+## Contents +- [Opening a repository](#opening-a-repository)+- [Checking a path](#checking-a-path)+- [Listing visible entries](#listing-visible-entries)+- [Processing without building a list](#processing-without-building-a-list)+- [Pruning and stopping early](#pruning-and-stopping-early)+- [Traversal and cache semantics](#traversal-and-cache-semantics)+- [Migrating from 0.0.x](#migrating-from-00x)+- [Using the executable](#using-the-executable) -## 2. Use as Library-Because this library is really simple to use, following example should be enough to understand how to use it for your project.+## Opening a repository -### 2.1. Listing all files/directories ignored by VCS+Use `openGitRepository` when the working-tree root is already known:+ ```haskell-{-# LANGUAGE TypeApplications #-}+import Data.VCS.Ignore -module Data.VCS.Test where+openProject :: IO GitRepository+openProject = openGitRepository "/path/to/project"+``` -import Data.VCS.Ignore ( Git, Repo(..), listRepo )+Use `findGitRepository` to search from a file or directory towards its+parents. It returns `Nothing` when no enclosing Git worktree exists. -example :: IO [FilePath]-example = do- repo <- scanRepo @Git "path/to/repo"- listRepo repo+```haskell+import Data.VCS.Ignore++findProject :: IO (Maybe GitRepository)+findProject = findGitRepository "/path/to/project/src/Main.hs" ``` -### 2.2. Walking files/directories ignored by VCS-```haskell-{-# LANGUAGE TypeApplications #-}+Both regular `.git` directories and gitfiles used by linked worktrees and+submodules are supported. -module Data.VCS.Test where+## Checking a path -import Data.Maybe ( catMaybes )-import System.Directory ( doesFileExist )-import Data.VCS.Ignore ( Git, Repo(..), walkRepo )+Queries take a repository-relative path and an explicit `PathKind`. The path+does not need to exist, and the library never guesses its kind from the+filesystem or a trailing slash. -onlyFiles :: IO [FilePath]-onlyFiles = do- repo <- scanRepo @Git "path/to/repo"- catMaybes <$> walkRepo repo walkFn- where- walkFn path = do- file <- doesFileExist path- pure (if file then Just path else Nothing)+```haskell+import Data.VCS.Ignore +checkBuildDirectory :: IO Bool+checkBuildDirectory = do+ repo <- openGitRepository "/path/to/project"+ isIgnored repo Directory "dist"++checkGeneratedFile :: IO Bool+checkGeneratedFile = do+ repo <- openGitRepository "/path/to/project"+ isIgnored repo RegularFile "generated/output.log" ``` -### 2.3. Checking if path is ignored by VCS+Absolute paths and paths containing a `..` component are rejected. `.` denotes+the repository root and is never ignored.++## Listing visible entries++`listRepo` returns non-ignored files and directories. Each path is relative to+the repository root, and the root itself is not included.+ ```haskell-{-# LANGUAGE TypeApplications #-}+import Data.VCS.Ignore -module Data.VCS.Test where+listVisibleFiles :: IO [FilePath]+listVisibleFiles = do+ repo <- openGitRepository "/path/to/project"+ entries <- listRepo repo+ pure+ [ entryPath entry+ | entry <- entries+ , entryKind entry == RegularFile+ ]+``` -import Data.VCS.Ignore ( Git, Repo(..) )+`listRepo` intentionally materializes its result. Use `forRepo_` or `foldRepo`+for large repositories when a complete list is unnecessary. -checkIgnored :: IO Bool-checkIgnored = do- repo <- scanRepo @Git "path/to/repo"- isIgnored repo "/some/path/.DS_Store"+## Processing without building a list++`forRepo_` performs an action for every non-ignored entry without accumulating+the results.++```haskell+import Data.VCS.Ignore+import System.FilePath ((</>))++printVisiblePaths :: IO ()+printVisiblePaths = do+ repo <- openGitRepository "/path/to/project"+ forRepo_ repo $ \entry ->+ putStrLn (repositoryRoot repo </> entryPath entry) ``` -## 3. Use as Executable-While `vcs-ignore` is mainly intended to be used as a library, it also comes with small executable called `ignore` that can be used standalone to verify whether given path is ignored or not.+The callback receives the kind already discovered by the walker. Directory+symlinks are reported as `SymbolicLink` and are never followed. +## Pruning and stopping early++`foldRepo` is the underlying traversal primitive. `Prune` skips a visible+directory for caller-specific reasons, while `Stop` terminates the entire+traversal immediately.++```haskell+import Data.VCS.Ignore+import System.FilePath (takeFileName)++countAtMost :: Int -> GitRepository -> IO (WalkResult Int)+countAtMost limit repo =+ foldRepo repo 0 $ \count entry ->+ if entryKind entry == Directory+ && takeFileName (entryPath entry) == ".cache"+ then pure (count, Prune)+ else+ if count >= limit+ then pure (count, Stop)+ else pure (count + 1, Continue) ```++Traversal is depth-first and pre-order. Sibling order is intentionally+unspecified. `Prune` on a non-directory is equivalent to `Continue`.++## Traversal and cache semantics++- Ignored entries are not passed to callbacks.+- Ignored directories are never opened or scanned.+- Git metadata belonging to the opened repository is never emitted.+- The default XDG global ignore file and `info/exclude` are loaded when the+ repository is opened.+- A visible directory's `.gitignore` is loaded on first use and at most once+ per repository session.+- A nested `.gitignore` is never loaded below an ignored or caller-pruned+ directory.+- Later rule changes become visible after opening a new `GitRepository`.+- Missing, symlinked, and non-regular `.gitignore` files are treated as empty.+ Other I/O failures are reported instead of being silently ignored.++These rules ensure that individual queries and traversal use the same Git+precedence and ignored-parent behavior.++The current matcher intentionally does not evaluate Git configuration. In+particular, `core.excludesFile`, `core.ignoreCase`, conditional config includes,+and index-backed ignore files in sparse checkouts are not supported. It reads+the default `$XDG_CONFIG_HOME/git/ignore` (or its platform equivalent) and uses+case-sensitive matching. Paths use Haskell `FilePath`; exact round-tripping of+arbitrary byte-string filenames is not guaranteed.++## Migrating from 0.0.x++Version `0.1.0.0` replaces the eager and lazy APIs with one repository session:++| Before | Now |+|---|---|+| `scanRepo @Git root` | `openGitRepository root` |+| `openGitIgnoreMatcher root` | `openGitRepository root` |+| `isIgnored repo path` | `isIgnored repo kind path` |+| `isIgnoredPath matcher kind path` | `isIgnored repo kind path` |+| `repoRoot repo` | `repositoryRoot repo` |+| `listRepo :: IO [FilePath]` | `listRepo :: IO [Entry]` |+| list-returning callback traversal | `foldRepo`, `walkRepo`, or `forRepo_` |++The `Repo` type class, eager `Git` value, `scanRepo`, and public pattern and+filesystem helpers have been removed. Paths returned in `Entry` remain+repository-relative.++## Using the executable++The package includes an executable named `ignore`. Run it from inside a Git+working tree to check a path:++```console $ ignore --help-vcs-ignore, v0.0.2.0 :: https://github.com/vaclavsvejcar/vcs-ignore+vcs-ignore, v0.1.0.0 :: https://github.com/xwinus/vcs-ignore Usage: ignore (-p|--path PATH) [--debug] [-v|--version] [--numeric-version]- library for handling files ignored by VCS systems--Available options:- -p,--path PATH path to check- --debug produce more verbose output- -v,--version show version info- --numeric-version show only version number- -h,--help Show this help text ``` -### 3.1. Checking if path is ignored by VCS-To verify if path is ignored by _VCS_, just call the `ignore` executable with `-p` parameter inside the _VCS_ repository like this:+The command exits with status `0` when the path is ignored and status `1` when+it is visible or no repository is found. -```-$ ignore -p .stack-work/some-file-Found repository at: /path/to/repo-Path '.stack-work/some-file' IS NOT ignored+```console+$ ignore -p generated/output.log+Found repository at: /path/to/project+Path 'generated/output.log' IS ignored $ echo $?-1+0 ```--As you can see, `ignore` executable prints result in human readable form as well as it sets the exit code to `1` if the file is __not__ ignored.
+ RELEASING.md view
@@ -0,0 +1,48 @@+# Releasing vcs-ignore++Releases use an annotated `vVERSION` tag. The tag workflow builds the Cabal+source distribution and executable archives for Linux, macOS, and Windows,+then creates a draft GitHub release.++## Prepare++1. Set the version in `package.yaml` and regenerate `vcs-ignore.cabal`.+2. Replace the changelog's development marker with the release date.+3. Merge the preparation pull request and wait for CI on `master`.+4. Confirm that `cabal check`, tests, Haddock, and `cabal sdist` pass.++## Build the draft release++Create and push the release tag from the tested `master` commit:++```console+git switch master+git pull --ff-only+git tag -a vVERSION -m "Release vVERSION"+git push origin vVERSION+```++The release workflow verifies that the tag matches the package version. After+all artifacts build successfully, it creates a draft GitHub release containing+the Hackage-ready source distribution, platform binaries, and checksums.++## Publish++1. Download the source distribution from the draft GitHub release.+2. Upload it as a Hackage candidate and inspect the generated package page:++ ```console+ cabal upload vcs-ignore-VERSION.tar.gz+ ```++3. Publish the same archive after the candidate is verified:++ ```console+ cabal upload --publish vcs-ignore-VERSION.tar.gz+ ```++4. Review the generated release notes and publish the GitHub draft.+5. Verify the public Hackage documentation and the downloadable binaries.++Never move or recreate a published release tag. Prepare a new package version+when a released artifact needs correction.
app/Main.hs view
@@ -1,78 +1,98 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ViewPatterns #-}--{-|-Module : Main-Description : Simple application using the /vcs-ignore/ library-Copyright : (c) 2020-2022 Vaclav Svejcar-License : BSD-3-Clause-Maintainer : vaclav.svejcar@gmail.com-Stability : experimental-Portability : POSIX--This simple application demonstrates the use of "vcs-ignore" library. It allows-to check whether path given as argument is ignored within existing /GIT/ repo.--}--module Main- ( main- )-where+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-} -import Control.Monad ( when )-import Data.VCS.Ignore.Core ( findRepo )-import Data.VCS.Ignore.Repo ( Repo(..) )-import Data.VCS.Ignore.Repo.Git ( Git )-import Main.Options ( Mode(..)- , Options(..)- , optionsParser- )-import Options.Applicative ( execParser )-import System.Directory ( canonicalizePath- , getCurrentDirectory- )-import System.Exit ( exitFailure- , exitSuccess- )-import System.FilePath ( makeRelative )+-- |+-- Module : Main+-- Description : Simple application using the /vcs-ignore/ library+-- Copyright : (c) 2020-2026 Vaclav Svejcar+-- License : BSD-3-Clause+-- Maintainer : vaclav.svejcar@gmail.com+-- Stability : experimental+-- Portability : POSIX+--+-- This simple application demonstrates the use of "vcs-ignore" library. It allows+-- to check whether path given as argument is ignored within existing /GIT/ repo.+module Main (+ main,+) where +import Control.Monad (when)+import Data.VCS.Ignore (+ GitRepository,+ PathKind (..),+ findGitRepository,+ isIgnored,+ repositoryRoot,+ )+import Main.Options (+ Mode (..),+ Options (..),+ optionsParser,+ )+import Options.Applicative (execParser)+import System.Directory (+ doesDirectoryExist,+ doesFileExist,+ getCurrentDirectory,+ makeAbsolute,+ pathIsSymbolicLink,+ )+import System.Exit (+ exitFailure,+ exitSuccess,+ )+import System.FilePath (makeRelative, normalise)+import System.IO.Error (+ isDoesNotExistError,+ tryIOError,+ ) main :: IO () main = do- options <- execParser optionsParser- repo <- findRepoOrFail @Git options- executeMode repo options---findRepoOrFail :: (Repo r, Show r) => Options -> IO r-findRepoOrFail Options {..} = do- repoDir <- getCurrentDirectory- maybeRepo <- findRepo repoDir- case maybeRepo of- Just repo -> do- putStrLn $ "Found repository at: " <> repoRoot repo- when oDebug (putStrLn $ "Repository details: " <> show repo)- pure repo- Nothing -> do- putStrLn $ "No repository found for path: " <> repoDir- exitFailure+ options <- execParser optionsParser+ repo <- findRepoOrFail options+ executeMode repo options +findRepoOrFail :: Options -> IO GitRepository+findRepoOrFail Options{..} = do+ repoDir <- getCurrentDirectory+ maybeRepo <- findGitRepository repoDir+ case maybeRepo of+ Just repo -> do+ putStrLn $ "Found repository at: " <> repositoryRoot repo+ when oDebug (putStrLn $ "Repository root: " <> repositoryRoot repo)+ pure repo+ Nothing -> do+ putStrLn $ "No repository found for path: " <> repoDir+ exitFailure -executeMode :: Repo r => r -> Options -> IO ()+executeMode :: GitRepository -> Options -> IO () executeMode repo (oMode -> Path path) = checkPath repo path --checkPath :: Repo r => r -> FilePath -> IO ()+checkPath :: GitRepository -> FilePath -> IO () checkPath repo path = do- relative <- makeRelative (repoRoot repo) <$> canonicalizePath path- excluded <- isIgnored repo relative- if excluded then reportIgnored else reportNotIgnored- where- reportIgnored = do- putStrLn $ "Path '" <> path <> "' IS ignored"- exitSuccess- reportNotIgnored = do- putStrLn $ "Path '" <> path <> "' IS NOT ignored"- exitFailure+ absolute <- normalise <$> makeAbsolute path+ kind <- classifyPath absolute+ let relative = makeRelative (repositoryRoot repo) absolute+ excluded <- isIgnored repo kind relative+ if excluded then reportIgnored else reportNotIgnored+ where+ reportIgnored = do+ putStrLn $ "Path '" <> path <> "' IS ignored"+ exitSuccess+ reportNotIgnored = do+ putStrLn $ "Path '" <> path <> "' IS NOT ignored"+ exitFailure +classifyPath :: FilePath -> IO PathKind+classifyPath path = do+ symbolicLinkResult <- tryIOError $ pathIsSymbolicLink path+ case symbolicLinkResult of+ Left error'+ | isDoesNotExistError error' -> pure Other+ | otherwise -> ioError error'+ Right True -> pure SymbolicLink+ Right False -> do+ directory <- doesDirectoryExist path+ regularFile <- doesFileExist path+ pure $ if directory then Directory else if regularFile then RegularFile else Other
app/Main/Options.hs view
@@ -1,62 +1,62 @@ {-# LANGUAGE StrictData #-} -{-|-Module : Main.Options-Description : Options definitions for "optparse-applicative"-Copyright : (c) 2020-2022 Vaclav Svejcar-License : BSD-3-Clause-Maintainer : vaclav.svejcar@gmail.com-Stability : experimental-Portability : POSIX--Options definitions for "optparse-applicative".--}--module Main.Options- ( Options(..)- , Mode(..)- , optionsParser- )-where--import Main.Vendor ( buildVersion- , productDesc- , productInfo- )-import Options.Applicative+-- |+-- Module : Main.Options+-- Description : Options definitions for "optparse-applicative"+-- Copyright : (c) 2020-2026 Vaclav Svejcar+-- License : BSD-3-Clause+-- Maintainer : vaclav.svejcar@gmail.com+-- Stability : experimental+-- Portability : POSIX+--+-- Options definitions for "optparse-applicative".+module Main.Options (+ Options (..),+ Mode (..),+ optionsParser,+) where +import Main.Vendor (+ buildVersion,+ productDesc,+ productInfo,+ )+import Options.Applicative data Options = Options- { oMode :: Mode- , oDebug :: Bool- }- deriving (Eq, Show)+ { oMode :: Mode+ , oDebug :: Bool+ }+ deriving (Eq, Show) data Mode = Path FilePath- deriving (Eq, Show)-+ deriving (Eq, Show) optionsParser :: ParserInfo Options-optionsParser = info (options <**> versionP <**> helper)- (fullDesc <> progDesc productDesc <> header productInfo)- where- options =- Options- <$> ( Path- <$> strOption- (long "path" <> short 'p' <> metavar "PATH" <> help- "path to check"+optionsParser =+ info+ (options <**> versionP <**> helper)+ (fullDesc <> progDesc productDesc <> header productInfo)+ where+ options =+ Options . Path+ <$> strOption+ ( long "path"+ <> short 'p'+ <> metavar "PATH"+ <> help+ "path to check" )- )- <*> switch (long "debug" <> help "produce more verbose output")-+ <*> switch (long "debug" <> help "produce more verbose output") versionP :: Parser (a -> a) versionP = versionInfoP <*> versionNumP- where- versionInfoP = infoOption- productInfo- (long "version" <> short 'v' <> help "show version info")- versionNumP = infoOption- buildVersion- (long "numeric-version" <> help "show only version number")+ where+ versionInfoP =+ infoOption+ productInfo+ (long "version" <> short 'v' <> help "show version info")+ versionNumP =+ infoOption+ buildVersion+ (long "numeric-version" <> help "show only version number")
app/Main/Vendor.hs view
@@ -1,50 +1,42 @@ {-# LANGUAGE OverloadedStrings #-} -{-|-Module : Main.Vendor-Description : Details about the application.-Copyright : (c) 2020-2022 Vaclav Svejcar-License : BSD-3-Clause-Maintainer : vaclav.svejcar@gmail.com-Stability : experimental-Portability : POSIX--Module providing info about this application.--}--module Main.Vendor- ( buildVersion- , productDesc- , productInfo- , productName- , webRepo- )-where--import Data.String ( IsString(..) )-import Data.Version ( showVersion )-import Paths_vcs_ignore ( version )+-- |+-- Module : Main.Vendor+-- Description : Details about the application.+-- Copyright : (c) 2020-2026 Vaclav Svejcar+-- License : BSD-3-Clause+-- Maintainer : vaclav.svejcar@gmail.com+-- Stability : experimental+-- Portability : POSIX+--+-- Module providing info about this application.+module Main.Vendor (+ buildVersion,+ productDesc,+ productInfo,+ productName,+ webRepo,+) where +import Data.String (IsString (..))+import Data.Version (showVersion)+import Paths_vcs_ignore (version) -- | Product version.-buildVersion :: IsString a => a+buildVersion :: (IsString a) => a buildVersion = fromString . showVersion $ version --productDesc :: IsString a => a+productDesc :: (IsString a) => a productDesc = "library for handling files ignored by VCS systems" - -- | Product info. productInfo :: (IsString a, Monoid a) => a productInfo = mconcat [productName, ", v", buildVersion, " :: ", webRepo] - -- | Product full name.-productName :: IsString a => a+productName :: (IsString a) => a productName = "vcs-ignore" - -- | Product source code repository.-webRepo :: IsString a => a-webRepo = "https://github.com/vaclavsvejcar/vcs-ignore"+webRepo :: (IsString a) => a+webRepo = "https://github.com/xwinus/vcs-ignore"
+ benchmark/Main.hs view
@@ -0,0 +1,80 @@+module Main (main) where++import Control.Monad (forM_)+import Criterion.Main (+ bench,+ bgroup,+ defaultMain,+ envWithCleanup,+ nfIO,+ whnfIO,+ )+import Data.VCS.Ignore (+ PathKind (Directory),+ WalkAction (Continue, Stop),+ entryPath,+ foldRepo,+ isIgnored,+ listRepo,+ openGitRepository,+ )+import System.Directory (+ createDirectoryIfMissing,+ getTemporaryDirectory,+ removePathForcibly,+ )+import System.FilePath (+ takeDirectory,+ (</>),+ )+import System.IO.Temp (createTempDirectory)++main :: IO ()+main =+ defaultMain+ [ envWithCleanup setupEnvironment cleanupEnvironment $ \root ->+ bgroup+ "repository"+ [ bench "open" $ whnfIO (openGitRepository root)+ , bench "cold-directory-query" . whnfIO $ do+ repo <- openGitRepository root+ isIgnored repo Directory "ignored"+ , bench "fold-visible-tree" . whnfIO $ do+ repo <- openGitRepository root+ foldRepo repo (0 :: Int) countEntry+ , bench "list-visible-tree" . nfIO $ do+ repo <- openGitRepository root+ fmap entryPath <$> listRepo repo+ , bench "stop-after-ten" . whnfIO $ do+ repo <- openGitRepository root+ foldRepo repo (0 :: Int) stopAfterTen+ ]+ ]+ where+ countEntry count _ = pure (count + 1, Continue)+ stopAfterTen count _+ | count >= 10 = pure (count, Stop)+ | otherwise = pure (count + 1, Continue)++setupEnvironment :: IO FilePath+setupEnvironment = do+ temporary <- getTemporaryDirectory+ sandbox <- createTempDirectory temporary "vcs-ignore-benchmark"+ let root = sandbox </> "repo"+ createDirectoryIfMissing True $ root </> ".git" </> "info"+ writeFile (root </> ".gitignore") "ignored/\n"+ createTree $ root </> "ignored"+ createTree $ root </> "visible"+ pure root+ where+ createTree base =+ forM_ [1 .. directoryCount] $ \directoryIndex -> do+ let directory = base </> show directoryIndex+ createDirectoryIfMissing True directory+ forM_ [1 .. filesPerDirectory] $ \fileIndex ->+ writeFile (directory </> show fileIndex <> ".generated") "benchmark"+ directoryCount = 20 :: Int+ filesPerDirectory = 200 :: Int++cleanupEnvironment :: FilePath -> IO ()+cleanupEnvironment = removePathForcibly . takeDirectory
− doctest/Main.hs
@@ -1,6 +0,0 @@-module Main (main) where--import Test.DocTest- -main :: IO ()-main = doctest ["-XOverloadedStrings", "src"]
src/Data/VCS/Ignore.hs view
@@ -1,89 +1,18 @@-{-|-Module : Data.VCS.Ignore-Description : Reexported modules for convenience-Copyright : (c) 2020-2022 Vaclav Svejcar-License : BSD-3-Clause-Maintainer : vaclav.svejcar@gmail.com-Stability : experimental-Portability : POSIX--@vcs-ignore@ is small Haskell library used to find, check and process files-ignored by selected /VCS/.--= Example of Use-Because this library is really simple to use, following example should be-enough to understand how to use it for your project.--== Listing all files/directories ignored by VCS-@-{-# LANGUAGE TypeApplications #-}--module Data.VCS.Test where--import Data.VCS.Ignore ( Git, Repo(..), listRepo )--example :: IO [FilePath]-example = do- repo <- scanRepo @Git "path/to/repo"- listRepo repo-@--== Walking files/directories ignored by VCS-@-{-# LANGUAGE TypeApplications #-}--module Data.VCS.Test where--import Data.Maybe ( catMaybes )-import System.Directory ( doesFileExist )-import Data.VCS.Ignore ( Git, Repo(..), walkRepo )--onlyFiles :: IO [FilePath]-onlyFiles = do- repo <- scanRepo @Git "path/to/repo"- catMaybes <$> walkRepo repo walkFn- where- walkFn path = do- file <- doesFileExist path- pure (if file then Just path else Nothing)-@--== Checking if path is ignored by VCS-@-{-# LANGUAGE TypeApplications #-}--module Data.VCS.Test where--import Data.VCS.Ignore ( Git, Repo(..) )--checkIgnored :: IO Bool-checkIgnored = do- repo <- scanRepo @Git "path/to/repo"- isIgnored repo "/some/path/.DS_Store"-@--}--module Data.VCS.Ignore- ( -- Working with ignored files- findRepo- , listRepo- , walkRepo- -- * Repo /type class/- , Repo(..)- , RepoError(..)- -- * /GIT/ implementation- , Git(..)- -- * Common data types- , VCSIgnoreError(..)- )-where+-- |+-- Module : Data.VCS.Ignore+-- Description : Git ignore queries and controllable repository traversal+-- Copyright : (c) 2020-2026 Vaclav Svejcar+-- License : BSD-3-Clause+-- Maintainer : vaclav.svejcar@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- The library uses one lazy repository session for both individual ignore+-- queries and recursive traversal. Opening a repository does not scan its+-- working tree; per-directory rules are loaded only when a visible branch is+-- queried or traversed.+module Data.VCS.Ignore (+ module Data.VCS.Ignore.Git,+) where -import Data.VCS.Ignore.Core ( findRepo- , listRepo- , walkRepo- )-import Data.VCS.Ignore.Repo ( Repo(..)- , RepoError(..)- )-import Data.VCS.Ignore.Repo.Git ( Git(..) )-import Data.VCS.Ignore.Types ( VCSIgnoreError(..) )+import Data.VCS.Ignore.Git
− src/Data/VCS/Ignore/Core.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TypeApplications #-}--{-|-Module : Data.VCS.Ignore.Core-Description : Core operations over the repository-Copyright : (c) 2020-2022 Vaclav Svejcar-License : BSD-3-Clause-Maintainer : vaclav.svejcar@gmail.com-Stability : experimental-Portability : POSIX--This module contains core operations you can perform over the scanned 'Repo'.--}--module Data.VCS.Ignore.Core- ( findRepo- , listRepo- , walkRepo- )-where--import Control.Exception ( try )-import Control.Monad.IO.Class ( MonadIO- , liftIO- )-import qualified Data.List as L-import Data.Maybe ( catMaybes- , fromMaybe- )-import Data.VCS.Ignore.FileSystem ( walkPaths )-import Data.VCS.Ignore.Repo ( Repo(..) )-import Data.VCS.Ignore.Types ( VCSIgnoreError )-import System.FilePath ( pathSeparator- , takeDirectory- )----- | Attempts to find (and scan via 'scanRepo') repository at given path.--- If given path doesn't contain valid repository, it recursively tries in every--- parent directory until the root directory (e.g. @C:@ or @/@) is reached.-findRepo :: (MonadIO m, Repo r)- => FilePath -- ^ path where to start scanning- -> m (Maybe r) -- ^ scanned 'Repo' (if found)-findRepo = liftIO . go- where- go dir = do- let parent = takeDirectory dir- maybeRepo <- try @VCSIgnoreError (scanRepo dir)- case maybeRepo of- Left _ | parent == dir -> pure Nothing- Left _ -> go parent- Right repo -> pure . Just $ repo----- | Resursively lists all non-ignored paths withing the given repository--- (both files and directories).-listRepo :: (MonadIO m, Repo r)- => r -- ^ repository to list- -> m [FilePath] -- ^ list of non-ignored paths within the repository-listRepo repo = walkRepo repo pure----- | Similar to 'listRepo', but allows to perform any action on every--- non-ignored path within the repository.-walkRepo :: (MonadIO m, Repo r)- => r -- ^ repository to walk- -> (FilePath -> m a) -- ^ action to do on every non-excluded filepath- -> m [a] -- ^ list of transformed paths-walkRepo repo fn = do- let search path | L.null path = pure Nothing- | otherwise = doSearch path- catMaybes <$> walkPaths root' (search . relativePath)- where- ps = [pathSeparator]- root = repoRoot repo- root' = if ps `L.isSuffixOf` root then root else root <> ps- relativePath = dropPrefix root'- dropPrefix = \prefix t -> fromMaybe t (L.stripPrefix prefix t)- doSearch = \path -> isIgnored repo path >>= process path- process = \path x -> if x then pure Nothing else Just <$> fn path
− src/Data/VCS/Ignore/FileSystem.hs
@@ -1,99 +0,0 @@-{-# LANGUAGE MultiWayIf #-}--{-|-Module : Data.VCS.Ignore.FileSystem-Description : Helper functions for working with file system-Copyright : (c) 2020-2022 Vaclav Svejcar-License : BSD-3-Clause-Maintainer : vaclav.svejcar@gmail.com-Stability : experimental-Portability : POSIX--This module contains mainly helper functions, that are internally used by this-library.--}--module Data.VCS.Ignore.FileSystem- ( findPaths- , listPaths- , walkPaths- , toPosixPath- )-where---import Control.Monad ( forM- , mfilter- )-import Control.Monad.IO.Class ( MonadIO- , liftIO- )-import Data.Maybe ( catMaybes- , fromMaybe- )-import System.Directory ( doesDirectoryExist- , doesFileExist- , getDirectoryContents- )-import System.FilePath ( (</>) )----- | Recursively finds paths on given path whose filename matches the predicate.-findPaths :: MonadIO m- => FilePath -- ^ path to traverse- -> (FilePath -> m Bool) -- ^ predicate to match filename- -> m [FilePath] -- ^ list of found paths-findPaths entryPath predicate = catMaybes <$> walkPaths entryPath process- where- process path = (\p -> if p then Just path else Nothing) <$> predicate path----- | Recursively finds all paths on given path. If file reference is passed--- instead of directory, such path is returned.-listPaths :: MonadIO m- => FilePath -- ^ path to traverse- -> m [FilePath] -- ^ list of found paths-listPaths entryPath = walkPaths entryPath pure----- | Recursively walks the given path and performs selected action for each--- found file. Output of this function is:------ * If the given __path is file__, only this single path is processed and--- returned.--- * If the given __path is directory__, all subdirectories and files are--- recursively processed and returned.--- * If the given __path doesn't exist__, empy list will be returned.-walkPaths :: MonadIO m- => FilePath -- ^ path to traverse- -> (FilePath -> m a) -- ^ function to process path- -> m [a] -- ^ result of traversed & processed paths-walkPaths entryPath fn = do- isDir <- liftIO $ doesDirectoryExist entryPath- isFile <- liftIO $ doesFileExist entryPath- if- | isDir -> fn entryPath >>= (\p -> (p :) <$> listDirectory entryPath)- | isFile -> pure <$> fn entryPath- | otherwise -> pure []- where- listDirectory dir = do- names <- liftIO $ getDirectoryContents dir- paths <- forM (filter (`notElem` [".", ".."]) names) $ \name -> do- let path = dir </> name- isDirectory <- liftIO $ doesDirectoryExist path- if isDirectory then walkPaths path fn else pure <$> fn path- pure $ concat paths----- | If the given path contains backward slashes (Windows style), converts them--- into forward ones (Unix style).------ >>> toPosixPath "foo\\bar\\x.txt"--- "foo/bar/x.txt"------ >>> toPosixPath "foo/bar/x.txt"--- "foo/bar/x.txt"-toPosixPath :: FilePath -- ^ input filepath to convert- -> FilePath -- ^ output filepath-toPosixPath = replace '\\' '/'- where replace a b = fmap $ fromMaybe b . mfilter (/= a) . Just
+ src/Data/VCS/Ignore/Git.hs view
@@ -0,0 +1,45 @@+-- |+-- Module : Data.VCS.Ignore.Git+-- Description : Lazy Git ignore queries and repository traversal+-- Copyright : (c) 2020-2026 Vaclav Svejcar+-- License : BSD-3-Clause+-- Maintainer : vaclavsvejcar@gmail.com+-- Stability : experimental+-- Portability : portable+module Data.VCS.Ignore.Git (+ GitRepository,+ PathKind (..),+ Entry (..),+ WalkAction (..),+ WalkResult (..),+ GitError (..),+ openGitRepository,+ findGitRepository,+ repositoryRoot,+ isIgnored,+ foldRepo,+ walkRepo,+ forRepo_,+ listRepo,+) where++import Data.VCS.Ignore.Git.Internal.Repository (+ GitRepository,+ findGitRepository,+ isIgnored,+ openGitRepository,+ repositoryRoot,+ )+import Data.VCS.Ignore.Git.Internal.Traversal (+ foldRepo,+ forRepo_,+ listRepo,+ walkRepo,+ )+import Data.VCS.Ignore.Types (+ Entry (..),+ GitError (..),+ PathKind (..),+ WalkAction (..),+ WalkResult (..),+ )
+ src/Data/VCS/Ignore/Git/Internal/Pattern.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}++-- |+-- Module : Data.VCS.Ignore.Git.Internal.Pattern+-- Description : Parsing and evaluation of Git ignore patterns+-- Copyright : (c) 2020-2026 Vaclav Svejcar+-- License : BSD-3-Clause+-- Maintainer : vaclav.svejcar@gmail.com+-- Stability : experimental+-- Portability : portable+module Data.VCS.Ignore.Git.Internal.Pattern (+ Pattern,+ PatternGroup (..),+ parsePatterns,+ loadPatternsFile,+ evaluatePatternGroups,+) where++import Control.Exception (IOException, catch, throwIO)+import qualified Data.List as L+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.VCS.Ignore.Types (PathKind (..))+import System.Directory (+ doesDirectoryExist,+ doesFileExist,+ pathIsSymbolicLink,+ )+import System.FilePath (pathSeparator)+import qualified System.FilePath.Glob as G+import System.IO.Error (+ isDoesNotExistError,+ tryIOError,+ )++-- | A compiled Git ignore rule. Its representation is deliberately private so+-- callers cannot construct rules that bypass Git's line parsing semantics.+data Pattern = Pattern+ { patternMatchers :: [G.Pattern]+ , patternNegated :: Bool+ , patternDirectoryOnly :: Bool+ }+ deriving (Eq, Show)++-- | Patterns from one ignore source, scoped to a repository-relative prefix.+-- Prefixes use POSIX separators and are conventionally written as @/@ for the+-- repository root or @/directory/@ for a nested ignore file.+data PatternGroup = PatternGroup+ { patternGroupPrefix :: FilePath+ , patternGroupPatterns :: [Pattern]+ }+ deriving (Eq, Show)++-- | Parses the contents of an ignore file. Blank lines and comments are+-- discarded. CRLF, escaped leading hash/bang characters and Git's trailing+-- space rules are handled before compiling each pattern.+parsePatterns :: T.Text -> [Pattern]+parsePatterns = foldr parseLine [] . T.lines+ where+ parseLine raw patterns =+ case prepareLine raw of+ Nothing -> patterns+ Just line -> compilePattern line : patterns++-- | Loads and parses an ignore file. The flag controls whether a symbolic link+-- may be followed: global and repository exclude files use 'True', while a+-- working-tree @.gitignore@ uses 'False' to match Git's behaviour.+--+-- A missing file is an empty source. Other I/O failures are propagated.+loadPatternsFile :: Bool -> FilePath -> IO [Pattern]+loadPatternsFile followSymbolicLink path = do+ symbolicLinkResult <- tryIOError $ pathIsSymbolicLink path+ case symbolicLinkResult of+ Left error'+ | isDoesNotExistError error' -> pure []+ | otherwise -> ioError error'+ Right True+ | not followSymbolicLink -> pure []+ | otherwise -> do+ isRegularFile <- doesFileExist path+ if isRegularFile then parsePatterns <$> readPatterns else pure []+ Right False -> do+ isDirectory <- doesDirectoryExist path+ if isDirectory+ then pure []+ else do+ isRegularFile <- doesFileExist path+ if isRegularFile then parsePatterns <$> readPatterns else pure []+ where+ readPatterns = T.readFile path `catch` handleMissing+ handleMissing error'+ | isDoesNotExistError error' = pure T.empty+ | otherwise = throwIO (error' :: IOException)++-- | Evaluates groups ordered from lowest to highest precedence. Within each+-- group, patterns retain file order. Consequently, the last matching rule is+-- authoritative. The result is 'True' when the path is ignored.+evaluatePatternGroups :: PathKind -> [PatternGroup] -> FilePath -> Bool+evaluatePatternGroups kind groups path =+ fromMaybe False $ L.foldl' applyGroup Nothing groups+ where+ candidate = addLeadingSlash . toPosix $ path+ applyGroup result group+ | groupApplies prefix candidate =+ L.foldl' (applyPattern prefix) result $ patternGroupPatterns group+ | otherwise = result+ where+ prefix = normalizePrefix $ patternGroupPrefix group+ applyPattern prefix result pattern'+ | matchesPattern kind pattern' (pathForGroup prefix candidate) =+ Just . not $ patternNegated pattern'+ | otherwise = result++prepareLine :: T.Text -> Maybe T.Text+prepareLine raw+ | T.null line = Nothing+ | "#" `T.isPrefixOf` line = Nothing+ | otherwise = Just line+ where+ line = stripUnescapedTrailingSpaces . T.dropWhileEnd (== '\r') $ raw++compilePattern :: T.Text -> Pattern+compilePattern line =+ Pattern+ { patternMatchers =+ if hasDanglingEscape body+ then []+ else compileGlob . T.unpack <$> matcherSources patternBody directoryOnly+ , patternNegated = negated+ , patternDirectoryOnly = directoryOnly+ }+ where+ (negated, body) = case T.uncons line of+ Just ('!', rest) -> (True, rest)+ _ -> (False, line)+ directoryOnly = "/" `T.isSuffixOf` body+ withoutDirectoryMarker = fromMaybe body $ T.stripSuffix "/" body+ patternBody = unescapePattern withoutDirectoryMarker++matcherSources :: T.Text -> Bool -> [T.Text]+matcherSources raw directoryOnly+ | T.null raw = []+ | directoryOnly = [expandTrailingRecursive scoped]+ | "/**" `T.isSuffixOf` scoped = [expandTrailingRecursive scoped]+ | otherwise = [scoped]+ where+ scoped = case T.stripPrefix "/" raw of+ Just anchored -> "/" <> anchored+ Nothing+ | "**/" `T.isPrefixOf` raw -> raw+ | "/" `T.isInfixOf` raw -> "/" <> raw+ | otherwise -> "**/" <> raw++-- Glob recognizes recursive wildcards in the @**/@ form. Git also gives a+-- trailing @/**@ recursive meaning, so append a final wildcard component to+-- preserve that behaviour at arbitrary depth.+expandTrailingRecursive :: T.Text -> T.Text+expandTrailingRecursive source+ | "/**" `T.isSuffixOf` source = source <> "/*"+ | otherwise = source++compileGlob :: String -> G.Pattern+compileGlob =+ G.compileWith+ G.compDefault+ { G.numberRanges = False+ , G.pathSepInRanges = False+ }++matchesPattern :: PathKind -> Pattern -> FilePath -> Bool+matchesPattern kind pattern' candidate =+ (not (patternDirectoryOnly pattern') || kind == Directory)+ && any (`G.match` candidate) (patternMatchers pattern')++pathForGroup :: FilePath -> FilePath -> FilePath+pathForGroup "/" candidate = candidate+pathForGroup prefix candidate =+ addLeadingSlash . fromMaybe candidate $ L.stripPrefix prefix candidate++groupApplies :: FilePath -> FilePath -> Bool+groupApplies "/" _ = True+groupApplies prefix candidate =+ prefix `L.isPrefixOf` addTrailingSlash candidate+ && prefix /= addTrailingSlash candidate++normalizePrefix :: FilePath -> FilePath+normalizePrefix prefix+ | stripped == "" = "/"+ | otherwise = addTrailingSlash . addLeadingSlash $ stripped+ where+ stripped = dropWhile (== '/') . L.dropWhileEnd (== '/') . toPosix $ prefix++stripUnescapedTrailingSpaces :: T.Text -> T.Text+stripUnescapedTrailingSpaces text = case T.unsnoc text of+ Just (prefix, ' ') ->+ let slashes = T.takeWhileEnd (== '\\') prefix+ beforeSlashes = T.dropEnd (T.length slashes) prefix+ in if odd (T.length slashes)+ then beforeSlashes <> T.dropEnd 1 slashes <> " "+ else stripUnescapedTrailingSpaces prefix+ _ -> text++hasDanglingEscape :: T.Text -> Bool+hasDanglingEscape = odd . T.length . T.takeWhileEnd (== '\\')++unescapePattern :: T.Text -> T.Text+unescapePattern = T.pack . go . T.unpack+ where+ go [] = []+ go ['\\'] = ['\\']+ go ('[' : rest) =+ case takeCharacterClass [] rest of+ Nothing -> "[[]" <> go rest+ Just (body, remaining) ->+ '[' : (unescapeClass body <> (']' : go remaining))+ go ('\\' : char : rest) = escapeGlobLiteral char <> go rest+ go (char : rest) = char : go rest++ takeCharacterClass _ [] = Nothing+ takeCharacterClass prefix ('\\' : char : rest) =+ takeCharacterClass (char : '\\' : prefix) rest+ takeCharacterClass prefix (']' : rest) = Just (reverse prefix, rest)+ takeCharacterClass prefix (char : rest) =+ takeCharacterClass (char : prefix) rest++ unescapeClass body =+ case unescapeClassBody body of+ (False, characters) -> characters+ (True, '!' : characters) -> '!' : '-' : characters+ (True, '^' : characters) -> '^' : '-' : characters+ (True, characters) -> '-' : characters++ unescapeClassBody [] = (False, [])+ unescapeClassBody ('\\' : '-' : rest) =+ let (_, characters) = unescapeClassBody rest+ in (True, characters)+ unescapeClassBody ('\\' : char : rest) =+ let (hasLiteralHyphen, characters) = unescapeClassBody rest+ in (hasLiteralHyphen, escapeGlobLiteral char <> characters)+ unescapeClassBody (char : rest) =+ let (hasLiteralHyphen, characters) = unescapeClassBody rest+ in (hasLiteralHyphen, char : characters)++ escapeGlobLiteral '*' = "[*]"+ escapeGlobLiteral '?' = "[?]"+ escapeGlobLiteral '[' = "[[]"+ escapeGlobLiteral char = [char]++addLeadingSlash :: FilePath -> FilePath+addLeadingSlash path+ | "/" `L.isPrefixOf` path = path+ | otherwise = '/' : path++addTrailingSlash :: FilePath -> FilePath+addTrailingSlash path+ | "/" `L.isSuffixOf` path = path+ | otherwise = path <> "/"++toPosix :: FilePath -> FilePath+toPosix = fmap replaceSeparator+ where+ replaceSeparator char+ | char == pathSeparator = '/'+ | otherwise = char
+ src/Data/VCS/Ignore/Git/Internal/Repository.hs view
@@ -0,0 +1,391 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}++-- |+-- Module : Data.VCS.Ignore.Git.Internal.Repository+-- Description : Lazy Git repository session and ignore queries+-- Copyright : (c) 2020-2026 Vaclav Svejcar+-- License : BSD-3-Clause+-- Maintainer : vaclav.svejcar@gmail.com+-- Stability : experimental+-- Portability : portable+module Data.VCS.Ignore.Git.Internal.Repository (+ GitRepository (..),+ openGitRepository,+ findGitRepository,+ repositoryRoot,+ isIgnored,+ rootRuleContext,+ loadDirectoryRules,+ loadDirectoryRulesWith,+ isRepositoryMetadata,+ validateRepositoryPath,+ groupPrefix,+) where++import Control.Concurrent.MVar (+ MVar,+ modifyMVar,+ modifyMVar_,+ newEmptyMVar,+ newMVar,+ putMVar,+ readMVar,+ )+import Control.Exception (+ AsyncException,+ SomeException,+ fromException,+ mask,+ throwIO,+ try,+ )+import Control.Monad (unless)+import qualified Data.Char as Char+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, isJust)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.VCS.Ignore.Git.Internal.Pattern (+ Pattern,+ PatternGroup (..),+ evaluatePatternGroups,+ loadPatternsFile,+ )+import Data.VCS.Ignore.Types (+ GitError (..),+ PathKind (..),+ )+import System.Directory (+ XdgDirectory (XdgConfig),+ canonicalizePath,+ doesDirectoryExist,+ doesFileExist,+ getXdgDirectory,+ makeAbsolute,+ )+import System.FilePath (+ isAbsolute,+ makeRelative,+ pathSeparator,+ takeDirectory,+ (</>),+ )+import qualified System.FilePath.Posix as Posix++-- | An opened Git working tree. Repository-level rules are captured when the+-- session is opened, while working-tree @.gitignore@ files are loaded and+-- cached on first use.+data GitRepository = GitRepository+ { gitRepositoryRoot :: FilePath+ , gitRepositoryGitDirectory :: FilePath+ , gitRepositoryCommonDirectory :: FilePath+ , gitRepositoryBasePatterns :: [Pattern]+ , gitRepositoryRuleCache :: MVar (Map.Map FilePath RulePromise)+ }++data RuleLoadResult+ = RuleLoadFinished (Either SomeException PatternGroup)+ | RuleLoadCancelled++type RulePromise = MVar RuleLoadResult++-- | Open a Git working tree without scanning its contents.+openGitRepository :: FilePath -> IO GitRepository+openGitRepository path = do+ root <- makeAbsolute path >>= canonicalizePath+ isDirectory <- doesDirectoryExist root+ unless isDirectory (throwIO $ NotGitRepository root)+ gitDirectory <- resolveGitDirectory root+ commonDirectory <- resolveCommonDirectory gitDirectory+ globalIgnore <- getXdgDirectory XdgConfig ("git" </> "ignore")+ globalPatterns <- loadPatternsFile True globalIgnore+ repositoryPatterns <-+ loadPatternsFile True (commonDirectory </> "info" </> "exclude")+ cache <- newMVar Map.empty+ pure+ GitRepository+ { gitRepositoryRoot = root+ , gitRepositoryGitDirectory = gitDirectory+ , gitRepositoryCommonDirectory = commonDirectory+ , gitRepositoryBasePatterns = globalPatterns <> repositoryPatterns+ , gitRepositoryRuleCache = cache+ }++-- | Find and open the nearest enclosing Git working tree.+findGitRepository :: FilePath -> IO (Maybe GitRepository)+findGitRepository path = do+ absolute <- makeAbsolute path+ isDirectory <- doesDirectoryExist absolute+ start <- canonicalizePath $ if isDirectory then absolute else takeDirectory absolute+ go start+ where+ go directory = do+ hasMetadata <- gitMetadataExists directory+ let parent = takeDirectory directory+ if hasMetadata+ then Just <$> openGitRepository directory+ else+ if parent == directory+ then pure Nothing+ else go parent++-- | Return the canonical absolute root of the working tree.+repositoryRoot :: GitRepository -> FilePath+repositoryRoot = gitRepositoryRoot++-- | Check a repository-relative path against Git ignore rules. The supplied+-- kind is authoritative; the candidate itself is never inspected.+isIgnored :: GitRepository -> PathKind -> FilePath -> IO Bool+isIgnored repository kind rawPath =+ case validateRepositoryPath rawPath of+ Left err -> throwIO err+ Right relative+ | relative == "." -> pure False+ | isRepositoryMetadata repository relative -> pure True+ | otherwise -> do+ initialGroups <- rootRuleContext repository+ evaluateAncestors initialGroups (ancestorDirectories relative)+ where+ evaluateAncestors groups [] =+ pure $ evaluatePatternGroups kind groups relative+ evaluateAncestors groups (directory : directories)+ | evaluatePatternGroups Directory groups directory = pure True+ | otherwise = do+ directoryGroup <- loadDirectoryRules repository directory+ evaluateAncestors (groups <> [directoryGroup]) directories++-- | Rules applicable to entries directly under the repository root. Base+-- rules precede the lazily loaded root @.gitignore@ group.+rootRuleContext :: GitRepository -> IO [PatternGroup]+rootRuleContext repository = do+ rootRules <- loadDirectoryRules repository "."+ pure+ [ PatternGroup+ { patternGroupPrefix = "/"+ , patternGroupPatterns = gitRepositoryBasePatterns repository+ }+ , rootRules+ ]++-- | Load and cache the @.gitignore@ belonging to a repository-relative+-- directory. Symlinked ignore files are deliberately not followed.+loadDirectoryRules :: GitRepository -> FilePath -> IO PatternGroup+loadDirectoryRules repository =+ loadDirectoryRulesWith repository $ \directory ->+ loadPatternsFile False $+ repositoryRoot repository+ </> fromPosix directory+ </> ".gitignore"++-- | Variant with an injectable loader for concurrency tests.+loadDirectoryRulesWith ::+ GitRepository ->+ (FilePath -> IO [Pattern]) ->+ FilePath ->+ IO PatternGroup+loadDirectoryRulesWith repository loadPatterns rawDirectory = do+ directory <-+ case validateRepositoryPath rawDirectory of+ Left err -> throwIO err+ Right validDirectory -> pure validDirectory+ mask $ \restore -> do+ (promise, ownsLoad) <-+ modifyMVar (gitRepositoryRuleCache repository) $ \cache ->+ case Map.lookup directory cache of+ Just existing -> pure (cache, (existing, False))+ Nothing -> do+ created <- newEmptyMVar+ pure (Map.insert directory created cache, (created, True))+ if ownsLoad+ then do+ result <- try . restore $ loadRules directory+ if either isAsyncException (const False) result+ then do+ modifyMVar_+ (gitRepositoryRuleCache repository)+ (pure . Map.delete directory)+ putMVar promise RuleLoadCancelled+ either throwIO pure result+ else do+ putMVar promise $ RuleLoadFinished result+ either throwIO pure result+ else do+ cached <- restore $ readMVar promise+ case cached of+ RuleLoadFinished result -> either throwIO pure result+ RuleLoadCancelled ->+ loadDirectoryRulesWith repository loadPatterns directory+ where+ loadRules directory = do+ patterns <- loadPatterns directory+ pure+ PatternGroup+ { patternGroupPrefix = groupPrefix directory+ , patternGroupPatterns = patterns+ }++ isAsyncException exception =+ isJust (fromException exception :: Maybe AsyncException)++-- | Whether a repository-relative path names the working tree's own Git+-- metadata. Nested @.git@ names belong to nested working trees and are not+-- classified as this repository's metadata.+isRepositoryMetadata :: GitRepository -> FilePath -> Bool+isRepositoryMetadata repository path =+ any (`containsPath` candidate) metadataPaths+ where+ candidate = Posix.normalise $ toPosix path+ metadataPaths =+ ".git"+ : foldr+ addInternalMetadata+ []+ [ gitRepositoryGitDirectory repository+ , gitRepositoryCommonDirectory repository+ ]+ addInternalMetadata absolutePath paths =+ let relative = toPosix $ makeRelative (repositoryRoot repository) absolutePath+ in if isOutside relative || relative == "."+ then paths+ else Posix.normalise relative : paths+ containsPath metadata candidatePath =+ candidatePath == metadata+ || (metadata <> "/") `List.isPrefixOf` candidatePath++-- | Validate and normalize a repository-relative lexical path.+validateRepositoryPath :: FilePath -> Either GitError FilePath+validateRepositoryPath rawPath+ | invalid = Left $ InvalidRepositoryPath rawPath+ | otherwise = Right normalized+ where+ posixPath = toPosix rawPath+ components = Posix.splitDirectories posixPath+ invalid =+ isAbsolute rawPath+ || Posix.isAbsolute posixPath+ || (pathSeparator == '\\' && hasWindowsDrive posixPath)+ || '\NUL' `elem` rawPath+ || ".." `elem` components+ normalized =+ case Posix.normalise posixPath of+ "" -> "."+ value -> value++-- | Convert a repository-relative directory to a normalized pattern-group+-- prefix.+groupPrefix :: FilePath -> FilePath+groupPrefix directory+ | normalized `elem` ["", ".", "/"] = "/"+ | otherwise = "/" <> stripSlashes normalized <> "/"+ where+ normalized = Posix.normalise $ toPosix directory++resolveGitDirectory :: FilePath -> IO FilePath+resolveGitDirectory root = do+ let metadata = root </> ".git"+ isDirectory <- doesDirectoryExist metadata+ if isDirectory+ then canonicalizePath metadata+ else do+ isFile <- doesFileExist metadata+ if isFile+ then resolveGitFile root metadata+ else throwIO $ NotGitRepository root++resolveGitFile :: FilePath -> FilePath -> IO FilePath+resolveGitFile root metadata = do+ firstLine <- readFirstLine metadata+ case Text.stripPrefix "gitdir:" firstLine of+ Nothing ->+ throwIO $+ InvalidGitMetadata metadata "expected a 'gitdir:' declaration"+ Just rawGitDirectory -> do+ let declared = Text.unpack $ Text.strip rawGitDirectory+ if null declared+ then throwIO $ InvalidGitMetadata metadata "empty gitdir path"+ else do+ let resolved =+ if isAbsolute declared+ then declared+ else root </> declared+ exists <- doesDirectoryExist resolved+ unless exists $+ throwIO (InvalidGitMetadata metadata "gitdir does not exist")+ canonicalizePath resolved++resolveCommonDirectory :: FilePath -> IO FilePath+resolveCommonDirectory gitDirectory = do+ let commonFile = gitDirectory </> "commondir"+ exists <- doesFileExist commonFile+ if not exists+ then pure gitDirectory+ else do+ rawCommonDirectory <- Text.unpack . Text.strip <$> readFirstLine commonFile+ if null rawCommonDirectory+ then throwIO $ InvalidGitMetadata commonFile "empty commondir path"+ else do+ let resolved =+ if isAbsolute rawCommonDirectory+ then rawCommonDirectory+ else gitDirectory </> rawCommonDirectory+ isDirectory <- doesDirectoryExist resolved+ unless isDirectory $+ throwIO (InvalidGitMetadata commonFile "commondir does not exist")+ canonicalizePath resolved++readFirstLine :: FilePath -> IO Text.Text+readFirstLine path = do+ content <- Text.readFile path+ pure . fromMaybe Text.empty . safeHead $ Text.lines content++safeHead :: [a] -> Maybe a+safeHead [] = Nothing+safeHead (value : _) = Just value++gitMetadataExists :: FilePath -> IO Bool+gitMetadataExists root = do+ let metadata = root </> ".git"+ isDirectory <- doesDirectoryExist metadata+ isFile <- doesFileExist metadata+ pure $ isDirectory || isFile++ancestorDirectories :: FilePath -> [FilePath]+ancestorDirectories relative =+ case directoryComponents of+ [] -> []+ first : rest -> scanl (Posix.</>) first rest+ where+ directory = Posix.takeDirectory relative+ directoryComponents =+ filter (`notElem` ["", ".", "/"]) $+ Posix.splitDirectories directory++hasWindowsDrive :: FilePath -> Bool+hasWindowsDrive (letter : ':' : _) = Char.isAlpha letter+hasWindowsDrive _ = False++isOutside :: FilePath -> Bool+isOutside path =+ Posix.isAbsolute path+ || case Posix.splitDirectories path of+ ".." : _ -> True+ _ -> False++toPosix :: FilePath -> FilePath+toPosix = fmap replaceSeparator+ where+ replaceSeparator character+ | character == pathSeparator = '/'+ | otherwise = character++fromPosix :: FilePath -> FilePath+fromPosix "." = ""+fromPosix path = fmap replaceSeparator path+ where+ replaceSeparator '/' = pathSeparator+ replaceSeparator character = character++stripSlashes :: FilePath -> FilePath+stripSlashes = List.dropWhileEnd (== '/') . dropWhile (== '/')
+ src/Data/VCS/Ignore/Git/Internal/Traversal.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE BangPatterns #-}++-- |+-- Module : Data.VCS.Ignore.Git.Internal.Traversal+-- Description : Pruning, early-stopping traversal of a Git working tree+-- Copyright : (c) 2020-2026 Vaclav Svejcar+-- License : BSD-3-Clause+-- Maintainer : vaclav.svejcar@gmail.com+-- Stability : experimental+-- Portability : portable+module Data.VCS.Ignore.Git.Internal.Traversal (+ foldRepo,+ walkRepo,+ forRepo_,+ listRepo,+) where++import Control.Monad (void)+import Data.VCS.Ignore.Git.Internal.Pattern (+ PatternGroup,+ evaluatePatternGroups,+ )+import Data.VCS.Ignore.Git.Internal.Repository (+ GitRepository,+ isRepositoryMetadata,+ loadDirectoryRules,+ repositoryRoot,+ rootRuleContext,+ )+import Data.VCS.Ignore.Types (+ Entry (..),+ PathKind (..),+ WalkAction (..),+ WalkResult (..),+ )+import System.Directory (+ doesDirectoryExist,+ doesFileExist,+ doesPathExist,+ listDirectory,+ pathIsSymbolicLink,+ )+import System.FilePath ((</>))+import System.IO.Error (+ isDoesNotExistError,+ tryIOError,+ )++data WorkItem+ = VisitDirectory [PatternGroup] FilePath+ | VisitEntry [PatternGroup] FilePath++-- | Folds visible repository entries in depth-first preorder.+--+-- The repository root is not passed to the callback. Ignored directories and+-- repository metadata are pruned before the callback is invoked. A callback+-- can prune any other directory or stop the complete traversal. Symbolic links+-- are emitted as links and are never followed. Sibling order is the order+-- supplied by the filesystem and is intentionally unspecified.+foldRepo ::+ GitRepository ->+ state ->+ (state -> Entry -> IO (state, WalkAction)) ->+ IO (WalkResult state)+foldRepo repository initialState step = do+ initialState `seq` pure ()+ rules <- rootRuleContext repository+ loop initialState [VisitDirectory rules ""]+ where+ loop !state [] = pure $ WalkCompleted state+ loop !state (VisitDirectory rules relativeDirectory : pending) = do+ namesResult <- tryIOError . listDirectory $ absolutePath relativeDirectory+ case namesResult of+ Left error'+ | isDoesNotExistError error' -> loop state pending+ | otherwise -> ioError error'+ Right names -> do+ let entries = VisitEntry rules . childPath relativeDirectory <$> names+ loop state (entries <> pending)+ loop !state (VisitEntry rules relative : pending) =+ if isRepositoryMetadata repository relative+ then loop state pending+ else do+ maybeKind <- classifyPath $ absolutePath relative+ case maybeKind of+ Nothing -> loop state pending+ Just kind ->+ if evaluatePatternGroups kind rules relative+ then loop state pending+ else do+ (!nextState, action) <- step state $ Entry relative kind+ continueFrom rules pending relative kind nextState action++ continueFrom _ _ _ _ !state Stop = pure $ WalkStopped state+ continueFrom rules pending relative Directory !state Continue = do+ currentKind <- classifyPath $ absolutePath relative+ case currentKind of+ Just Directory -> do+ directoryRules <- loadDirectoryRules repository relative+ loop state $ VisitDirectory (rules <> [directoryRules]) relative : pending+ _ -> loop state pending+ continueFrom _ pending _ _ !state _ = loop state pending++ absolutePath "" = repositoryRoot repository+ absolutePath relative = repositoryRoot repository </> relative++-- | Walks visible entries for their effects and traversal control.+walkRepo ::+ GitRepository ->+ (Entry -> IO WalkAction) ->+ IO (WalkResult ())+walkRepo repository action = foldRepo repository () step+ where+ step () entry = do+ nextAction <- action entry+ pure ((), nextAction)++-- | Performs an action for every visible entry.+forRepo_ :: GitRepository -> (Entry -> IO ()) -> IO ()+forRepo_ repository action =+ void (walkRepo repository $ \entry -> action entry >> pure Continue)++-- | Lists all visible repository entries in traversal order.+listRepo :: GitRepository -> IO [Entry]+listRepo repository = do+ result <- foldRepo repository [] collect+ pure . reverse $ case result of+ WalkCompleted entries -> entries+ WalkStopped entries -> entries+ where+ collect entries entry = pure (entry : entries, Continue)++childPath :: FilePath -> FilePath -> FilePath+childPath "" name = name+childPath parent name = parent </> name++-- A path may disappear after its name was returned by 'listDirectory'. Such an+-- entry is skipped, while all other I/O errors retain their original failure.+classifyPath :: FilePath -> IO (Maybe PathKind)+classifyPath path = do+ symbolicLinkResult <- tryIOError $ pathIsSymbolicLink path+ case symbolicLinkResult of+ Left error'+ | isDoesNotExistError error' -> pure Nothing+ | otherwise -> ioError error'+ Right True -> pure $ Just SymbolicLink+ Right False -> classifyNonLink+ where+ classifyNonLink = do+ isDirectory <- doesDirectoryExist path+ if isDirectory+ then pure $ Just Directory+ else do+ isFile <- doesFileExist path+ if isFile+ then pure $ Just RegularFile+ else do+ exists <- doesPathExist path+ pure $ if exists then Just Other else Nothing
− src/Data/VCS/Ignore/Repo.hs
@@ -1,75 +0,0 @@-{-# LANGUAGE StrictData #-}--{-|-Module : Data.VCS.Ignore.Repo-Description : Type class representing the VCS repository-Copyright : (c) 2020-2022 Vaclav Svejcar-License : BSD-3-Clause-Maintainer : vaclav.svejcar@gmail.com-Stability : experimental-Portability : POSIX--This module contains /type class/ representing the selected type of /VCS/-repository.--}--module Data.VCS.Ignore.Repo- ( Repo(..)- , RepoError(..)- )-where--import Control.Exception ( Exception(..) )-import Control.Monad.Catch ( MonadThrow )-import Control.Monad.IO.Class ( MonadIO )-import Data.Text ( Text )-import qualified Data.Text as T-import Data.VCS.Ignore.Types ( fromVCSIgnoreError- , toVCSIgnoreError- )----- | /Type class/ representing instance of /VCS/ repository of selected type.--- In order to obtain instance, the physical repository needs to be scanned--- first by the 'scanRepo' method. Then absolute path to the repository root is--- provided by 'repoRoot' method. To check if any path (relative to the repo--- root) is ignored or not, use the 'isIgnored' method.-class Repo r where-- -- | Returns name of the repository (e.g. @GIT@).- repoName :: r -- ^ /VCS/ repository instance- -> Text -- ^ name of the repository-- -- | Returns absolute path to the root of the /VCS/ repository.- repoRoot :: r -- ^ /VCS/ repository instance- -> FilePath -- ^ absolute path to the repository-- -- | Scans repository at given path. If the given path doesn't contain valid- -- repository, 'RepoError' may be thrown.- scanRepo :: (MonadIO m, MonadThrow m)- => FilePath -- ^ path to the /VCS/ repository root- -> m r -- ^ scanned repository (or failure)-- -- | Checks whether the given path is ignored. The input path is expected to- -- be relative to the repository root, it might or might not point to existing- -- file or directory.- isIgnored :: MonadIO m- => r -- ^ /VCS/ repository instance- -> FilePath -- ^ path to check, relative to the repository root- -> m Bool -- ^ whether the path is ignored or not----- | Represents error related to operations over the /VCS/ repository.-data RepoError = InvalidRepo FilePath Text- -- ^ Given 'FilePath' doesn't contain valid /VCS/ repository root.- deriving (Eq, Show)--instance Exception RepoError where- displayException = displayException'- fromException = fromVCSIgnoreError- toException = toVCSIgnoreError---displayException' :: RepoError -> String-displayException' (InvalidRepo path reason) =- mconcat ["Path '", path, "' is not a valid repository: ", T.unpack reason]
− src/Data/VCS/Ignore/Repo/Git.hs
@@ -1,272 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TupleSections #-}--{-|-Module : Data.VCS.Ignore.Repo.Git-Description : Implementation of 'Repo' for /GIT/-Copyright : (c) 2020-2022 Vaclav Svejcar-License : BSD-3-Clause-Maintainer : vaclav.svejcar@gmail.com-Stability : experimental-Portability : POSIX--This module contains implementation of 'Repo' /type class/ for the /GIT/ content-versioning system. Most of the public functions is exported only to make them-visible for tests, end user of this library really shouldn't need to use them.--}--module Data.VCS.Ignore.Repo.Git- ( Git(..)- , Pattern(..)- , compilePattern- , matchesPattern- , parsePatterns- , loadPatterns- , findGitIgnores- , gitIgnorePatterns- , repoPatterns- , globalPatterns- , scanRepo'- , isIgnored'- , isGitRepo- )-where--import Control.Exception ( SomeException- , catch- )-import Control.Monad.Catch ( MonadThrow- , throwM- )-import Control.Monad.IO.Class ( MonadIO- , liftIO- )-import qualified Data.List as L-import Data.Maybe ( fromMaybe- , maybeToList- )-import Data.String ( IsString(..) )-import Data.Text ( Text )-import qualified Data.Text as T-import qualified Data.Text.IO as T-import Data.VCS.Ignore.FileSystem ( findPaths- , toPosixPath- )-import Data.VCS.Ignore.Repo ( Repo(..)- , RepoError(..)- )-import System.Directory ( XdgDirectory(XdgConfig)- , canonicalizePath- , doesDirectoryExist- , getXdgDirectory- , makeAbsolute- )-import System.FilePath ( makeRelative- , (</>)- )-import qualified System.FilePath.Glob as G----- | Data type representing scanned instance of /GIT/ repository.-data Git = Git- { gitRepoRoot :: FilePath -- ^ absolute path to the repository- , gitPatterns :: [(FilePath, [Pattern])] -- ^ ignored patterns- }- deriving (Eq, Show)--instance Repo Git where- repoName = const "Git"- repoRoot = gitRepoRoot- scanRepo = scanRepo' globalPatterns repoPatterns gitIgnorePatterns isGitRepo- isIgnored = isIgnored'---- | Represents single pattern to be used as a rule for ignoring paths.-data Pattern = Pattern- { pPatterns :: [G.Pattern] -- ^ underlying implementation- , pRaw :: Text -- ^ raw textual representation of the pattern- , pIsNegated :: Bool -- ^ if the pattern is negation (starts with @!@)- }- deriving (Eq, Show)--instance IsString Pattern where- fromString = compilePattern . T.pack--------------------------------- PUBLIC FUNCTIONS ---------------------------------- | Compiles pattern.-compilePattern :: Text -- ^ raw pattern as text- -> Pattern -- ^ compiled pattern-compilePattern raw =- let woPrefix = fromMaybe raw $ T.stripPrefix "!" raw- patterns = r2 . r1 $ woPrefix- in Pattern { pPatterns = fmap (G.compile . T.unpack) patterns- , pRaw = raw- , pIsNegated = raw /= woPrefix- }- where- r1 p | any (`T.isPrefixOf` p) ["/", "*"] = p- | length (filter (not . T.null) . T.splitOn "/" $ p) == 1 = "**/" <> p- | otherwise = "/" <> p- r2 p | "/" `T.isSuffixOf` p = [p <> "**"]- | otherwise = [p, p <> "/**"]----- | Tests whether given path matches against the pattern.-matchesPattern :: Pattern -- ^ pattern to match against- -> FilePath -- ^ path to check- -> Bool -- ^ check result-matchesPattern ptn path = any (`G.match` path) (pPatterns ptn)----- | Parses /Glob/ patterns from given text source. Each line in input text is--- considered to be single pattern. Lines starting with @#@ (comments) and blank--- lines are skipped.------ >>> parsePatterns "*.xml\n.DS_Store"--- [Pattern {pPatterns = [compile "*.xml",compile "*.xml/*"], pRaw = "*.xml", pIsNegated = False},Pattern {pPatterns = [compile "**/.DS_Store",compile "**/.DS_Store/*"], pRaw = ".DS_Store", pIsNegated = False}]-parsePatterns :: Text -- ^ text to parse- -> [Pattern] -- ^ parsed patterns-parsePatterns = fmap compilePattern . filter (not . excluded) . T.lines- where- excluded = \line -> or $ fmap ($ T.stripStart line) [comment, T.null]- comment = \line -> "#" `T.isPrefixOf` line----- | Loads /Glob/ patterns from given text file. If the fille cannot be read for--- any reason, empty list is returned. See 'parsePatterns' for more details--- about parsing.-loadPatterns :: MonadIO m- => FilePath -- ^ path to text file to parse- -> m [Pattern] -- ^ parsed /Glob/ patterns-loadPatterns path = parsePatterns <$> liftIO content- where- content = catch (T.readFile path) (\(_ :: SomeException) -> pure T.empty)----- | Recursively finds all @.gitignore@ files within the given directory path.-findGitIgnores :: MonadIO m- => FilePath -- ^ path to the directory to search in- -> m [FilePath] -- ^ paths of found @.gitignore@ files-findGitIgnores repoDir = findPaths repoDir isGitIgnore- where isGitIgnore path = pure $ ".gitignore" `L.isSuffixOf` path----- | Recursively finds all @.gitignore@ files within the given directory path--- and parses them into /Glob/ patterns. See 'loadPatterns' and 'findGitIgnores'--- for more details.-gitIgnorePatterns :: MonadIO m- => FilePath- -- ^ path to the directory to search @.gitignore@ files in- -> m [(FilePath, [Pattern])]- -- ^ list of @.gitignore@ paths and parsed /Glob/ patterns-gitIgnorePatterns repoDir = do- gitIgnores <- findGitIgnores repoDir- mapM (\p -> (toPosixPath . path $ p, ) <$> loadPatterns p) gitIgnores- where path p = stripSuffix' ".gitignore" $ stripPrefix' repoDir p----- | Loads /GIT/ repository specific ignore patterns, present in--- @REPO_ROOT\/info\/exclude@ file.-repoPatterns :: MonadIO m- => FilePath -- ^ path to the /GIT/ repository root- -> m [Pattern] -- ^ parsed /Glob/ patterns-repoPatterns repoDir = loadPatterns $ repoDir </> "info" </> "exclude"----- | Loads global /GIT/ ignore patterns, present in--- @XDG_CONFIG_GOME\/git\/ignore@ file.-globalPatterns :: MonadIO m => m [Pattern]-globalPatterns =- (liftIO . getXdgDirectory XdgConfig $ ("git" </> "ignore")) >>= loadPatterns----- | Internal version of 'scanRepo', where individual functions needs to be--- explicitly provided, which is useful mainly for testing purposes.-scanRepo' :: (MonadIO m, MonadThrow m)- => m [Pattern]- -- ^ reference to 'globalPatterns' function (or similar)- -> (FilePath -> m [Pattern])- -- ^ reference to 'repoPatterns' function (or similar)- -> (FilePath -> m [(FilePath, [Pattern])])- -- ^ reference to 'gitIgnorePatterns' function (or similar)- -> (FilePath -> m Bool)- -- ^ reference to 'isGitRepo' function (or similar)- -> FilePath- -- ^ path to /GIT/ repository root- -> m Git- -- ^ scanned /Git/ repository-scanRepo' globalPatternsFn repoPatternsFn gitIgnoresFn isGitRepoFn repoDir = do- absRepoDir <- liftIO $ makeAbsolute repoDir- gitRepo <- isGitRepoFn absRepoDir- (if gitRepo then proceed else abort) absRepoDir- where- abort repoDir' = throwM $ InvalidRepo repoDir' "not a valid GIT repository"- proceed repoDir' = do- globalPatterns' <- globalPatternsFn- repoPatterns' <- repoPatternsFn repoDir'- gitIgnores <- gitIgnoresFn repoDir'- let (r, o) = sep gitIgnores- patterns = [("/", globalPatterns' <> repoPatterns' <> r)] <> o- pure Git { gitRepoRoot = repoDir', gitPatterns = patterns }- sep xs =- let predicate = \(p, _) -> p == "/"- woRoot = filter (not . predicate) xs- root = concat . maybeToList $ snd <$> L.find predicate xs- in (root, woRoot)----- | Internal version of 'isIgnored' function.-isIgnored' :: MonadIO m- => Git -- ^ scanned /GIT/ repository- -> FilePath -- ^ path to check if ignored- -> m Bool -- @True@ if given path is ignored-isIgnored' git@(Git _ patterns) path = do- np <- toPosixPath <$> normalize (repoRoot git) path- let ignored = any (check2 np False) (filtered np)- negated = any (check2 np True) (filtered np)- pure $ ignored && not negated- where- sanitized = addPrefix "/"- asRepoPath = \np -> (`stripPrefix'` sanitized np)- filtered = \np -> filter (onPath np) patterns- onPath = \np (p, _) -> p `L.isPrefixOf` sanitized np- check2 = \np negated (prefix, ptns) ->- any (`matchesPattern` asRepoPath np prefix)- . filter (\p -> pIsNegated p == negated)- $ ptns----- | Checks whether given directory path is valid /GIT/ repository.-isGitRepo :: MonadIO m- => FilePath -- ^ path to the directory to check- -> m Bool -- ^ @True@ if the given directory is valid repository-isGitRepo path = liftIO . doesDirectoryExist $ path </> ".git"--------------------------------- PRIVATE FUNCTIONS -------------------------------addPrefix :: String -> String -> String-addPrefix prefix str | prefix `L.isPrefixOf` str = str- | otherwise = prefix <> str---stripPrefix' :: String -> String -> String-stripPrefix' prefix str =- maybe str T.unpack (T.stripPrefix (T.pack prefix) (T.pack str))---stripSuffix' :: String -> String -> String-stripSuffix' suffix str =- maybe str T.unpack (T.stripSuffix (T.pack suffix) (T.pack str))---normalize :: MonadIO m => FilePath -> FilePath -> m FilePath-normalize repoDir path = do- canonicalized <- liftIO . canonicalizePath $ repoDir </> stripPrefix' "/" path- isDir <- liftIO $ doesDirectoryExist canonicalized- let suffix = if isDir || "/" `L.isSuffixOf` path then "/" else ""- pure $ makeRelative repoDir canonicalized <> suffix-
src/Data/VCS/Ignore/Types.hs view
@@ -1,56 +1,73 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE StrictData #-}--{-|-Module : Data.VCS.Ignore.Types-Description : Shared data types-Copyright : (c) 2020-2022 Vaclav Svejcar-License : BSD-3-Clause-Maintainer : vaclav.svejcar@gmail.com-Stability : experimental-Portability : POSIX--This module contains data types and functions shared across the library.--}--module Data.VCS.Ignore.Types- ( VCSIgnoreError(..)- , fromVCSIgnoreError- , toVCSIgnoreError- )-where--import Control.Exception ( Exception(..)- , SomeException- )-import Data.Typeable ( cast )------------------------------------ DATA TYPES ---------------------------------+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StrictData #-} --- | Top-level of any exception thrown by this library.-data VCSIgnoreError = forall e . Exception e => VCSIgnoreError e+-- |+-- Module : Data.VCS.Ignore.Types+-- Description : Public types shared by repository queries and traversal+-- Copyright : (c) 2020-2026 Vaclav Svejcar+-- License : BSD-3-Clause+-- Maintainer : vaclav.svejcar@gmail.com+-- Stability : experimental+-- Portability : portable+module Data.VCS.Ignore.Types (+ PathKind (..),+ Entry (..),+ WalkAction (..),+ WalkResult (..),+ GitError (..),+) where -instance Show VCSIgnoreError where- show (VCSIgnoreError e) = show e+import Control.Exception (Exception (..))+import Data.Text (Text)+import qualified Data.Text as T -instance Exception VCSIgnoreError where- displayException (VCSIgnoreError e) = displayException e+-- | Filesystem kind supplied to ignore queries and repository callbacks.+-- Only 'Directory' receives directory-only Git pattern semantics. Symbolic+-- links are never followed, even when their target is a directory.+data PathKind+ = RegularFile+ | Directory+ | SymbolicLink+ | Other+ deriving (Eq, Ord, Show) +-- | A non-ignored repository entry. The path is always relative to the+-- repository root.+--+-- >>> entryPath (Entry "src/Main.hs" RegularFile)+-- "src/Main.hs"+data Entry = Entry+ { entryPath :: FilePath+ , entryKind :: PathKind+ }+ deriving (Eq, Ord, Show) ------------------------------- PUBLIC FUNCTIONS ------------------------------+-- | Controls repository traversal after processing a visible entry.+data WalkAction+ = Continue+ | Prune+ | Stop+ deriving (Eq, Ord, Show) --- | Unwraps given exception from 'VCSIgnoreError'.-fromVCSIgnoreError :: Exception e- => SomeException -- ^ exception to unwrap- -> Maybe e -- ^ unwrapped exception-fromVCSIgnoreError e = do- VCSIgnoreError e' <- fromException e- cast e'+-- | Indicates whether a repository fold visited all reachable entries or was+-- stopped early by its callback.+data WalkResult a+ = WalkCompleted !a+ | WalkStopped !a+ deriving (Eq, Functor, Show) +-- | Errors caused by invalid Git repository metadata or query paths. Ordinary+-- filesystem failures retain their original 'IOError'.+data GitError+ = NotGitRepository FilePath+ | InvalidRepositoryPath FilePath+ | InvalidGitMetadata FilePath Text+ deriving (Eq, Show) --- | Wraps given exception from 'VCSIgnoreError'.-toVCSIgnoreError :: Exception e- => e -- ^ exception to wrap- -> SomeException -- ^ wrapped exception-toVCSIgnoreError = toException . VCSIgnoreError+instance Exception GitError where+ displayException (NotGitRepository path) =+ "Path '" <> path <> "' is not a Git working tree"+ displayException (InvalidRepositoryPath path) =+ "Path '" <> path <> "' is not a valid repository-relative path"+ displayException (InvalidGitMetadata path reason) =+ mconcat ["Invalid Git metadata at '", path, "': ", T.unpack reason]
− test/Data/VCS/Ignore/CoreSpec.hs
@@ -1,87 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TypeApplications #-}--module Data.VCS.Ignore.CoreSpec- ( spec- )-where--import Control.Monad.Catch ( throwM )-import qualified Data.List as L-import Data.VCS.Ignore.Core--import Data.VCS.Ignore.Repo ( Repo(..)- , RepoError(..)- )-import System.FilePath ( (</>) )-import Test.Hspec---spec :: Spec-spec = do-- describe "findRepo" $ do- it "finds repo for some path inside repo" $ do- let path = testRepoRoot </> "a" </> "b"- expected = TestRepo testRepoRoot- findRepo path `shouldReturn` Just expected-- it "finds no repo for path outside repo" $ do- let path = "some" </> "path"- findRepo path `shouldReturn` Nothing @TestRepo--- describe "listRepo" $ do- it "lists repository paths, based on the search filter" $ do- let expected =- [ ".gitignore"- , "a"- , "a" </> ".gitignore"- , "a" </> "b"- , "a" </> "b" </> ".gitignore"- , "a" </> "b" </> "test-b.txt"- , "a" </> "b" </> "test-b.xml"- , "a" </> "test-a.txt"- , "a" </> "test-a.xml"- ]- repo <- scanRepo @TestRepo testRepoRoot- result <- listRepo repo- L.sort result `shouldBe` L.sort expected--- describe "walkRepo" $ do- it "walks repository paths, based on the search filter" $ do- let fn = \path -> pure ("foo" </> path)- expected =- [ "foo" </> ".gitignore"- , "foo" </> "a"- , "foo" </> "a" </> ".gitignore"- , "foo" </> "a" </> "b"- , "foo" </> "a" </> "b" </> ".gitignore"- , "foo" </> "a" </> "b" </> "test-b.txt"- , "foo" </> "a" </> "b" </> "test-b.xml"- , "foo" </> "a" </> "test-a.txt"- , "foo" </> "a" </> "test-a.xml"- ]- repo <- scanRepo @TestRepo testRepoRoot- result <- walkRepo repo fn- L.sort result `shouldBe` L.sort expected---data TestRepo = TestRepo- { trPath :: FilePath- }- deriving (Eq, Show)--instance Repo TestRepo where- repoName = const "TestRepo"- repoRoot TestRepo {..} = trPath- scanRepo path | path == testRepoRoot = pure TestRepo { trPath = path }- | otherwise = throwM $ InvalidRepo path "err"- isIgnored _ path = pure $ "excluded.txt" `L.isSuffixOf` path---testRepoRoot :: FilePath-testRepoRoot = "test-data" </> "fake-git-repo"
− test/Data/VCS/Ignore/FileSystemSpec.hs
@@ -1,65 +0,0 @@-module Data.VCS.Ignore.FileSystemSpec- ( spec- )-where--import qualified Data.List as L-import Data.Maybe ( catMaybes )-import Data.VCS.Ignore.FileSystem-import System.FilePath ( (</>) )-import Test.Hspec---spec :: Spec-spec = do- describe "findPaths" $ do- it "recursively finds paths filtered by given predicate" $ do- let expected =- ["test-data" </> "list-files" </> "dir1" </> "dir2" </> "d.xml"]- predicate = pure <$> ("d.xml" `L.isSuffixOf`)- result <- findPaths ("test-data" </> "list-files") predicate- result `shouldBe` expected--- describe "listPaths" $ do- it "returns empty list if path doesn't exist" $ do- filePaths <- listPaths "non-existing-path"- filePaths `shouldBe` []-- it "recursively finds all paths in directory" $ do- result <- listPaths $ "test-data" </> "list-files"- let expected =- [ "test-data" </> "list-files"- , "test-data" </> "list-files" </> "a.txt"- , "test-data" </> "list-files" </> "dir1"- , "test-data" </> "list-files" </> "dir1" </> "b.txt"- , "test-data" </> "list-files" </> "dir1" </> "dir2"- , "test-data" </> "list-files" </> "dir1" </> "dir2" </> "c.txt"- , "test-data" </> "list-files" </> "dir1" </> "dir2" </> "d.xml"- ]- L.sort result `shouldBe` L.sort expected--- describe "walkPaths" $ do- it "recursively traverses and processes paths in directory" $ do- let- fn path =- if ".txt" `L.isSuffixOf` path then pure $ Just path else pure Nothing- expected =- [ "test-data" </> "list-files" </> "a.txt"- , "test-data" </> "list-files" </> "dir1" </> "b.txt"- , "test-data" </> "list-files" </> "dir1" </> "dir2" </> "c.txt"- ]- actual <- catMaybes <$> walkPaths ("test-data" </> "list-files") fn- L.sort actual `shouldBe` L.sort expected--- describe "toPosixPath" $ do- it "replaces any backward slashes with forward ones" $ do- let sample = "foo\\bar\\x.txt"- expected = "foo/bar/x.txt"- toPosixPath sample `shouldBe` expected-- it "keep forwars slashes as is" $ do- let sample = "foo/bar/x.txt"- toPosixPath sample `shouldBe` sample
+ test/Data/VCS/Ignore/Git/CompatibilitySpec.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.VCS.Ignore.Git.CompatibilitySpec (spec) where++import Control.Exception (bracket_)+import Control.Monad (unless)+import Data.VCS.Ignore (+ GitRepository,+ PathKind (..),+ isIgnored,+ openGitRepository,+ )+import System.Directory (createDirectoryIfMissing)+import System.Environment (+ lookupEnv,+ setEnv,+ unsetEnv,+ )+import System.Exit (ExitCode (..))+import System.FilePath (+ takeDirectory,+ (</>),+ )+import System.IO.Temp (withSystemTempDirectory)+import System.Process (readProcessWithExitCode)+import Test.Hspec++spec :: Spec+spec = describe "Git compatibility" $ do+ gitExample "matches Git for ordered, anchored, recursive, and escaped rules" $ \root repository -> do+ writeText+ (root </> ".gitignore")+ ( unlines+ [ "*.log"+ , "!keep.log"+ , "keep.log"+ , "/root.txt"+ , "artifacts/**/result.bin"+ , "cache/**"+ , "file?.[ch]"+ , "docs/[a-c].md"+ , "build/"+ , "\\#literal"+ , "\\!important"+ ]+ )++ assertMatchesGit repository root RegularFile "drop.log" "drop.log"+ assertMatchesGit repository root RegularFile "keep.log" "keep.log"+ assertMatchesGit repository root RegularFile "root.txt" "root.txt"+ assertMatchesGit repository root RegularFile "nested/root.txt" "nested/root.txt"+ assertMatchesGit repository root RegularFile "artifacts/a/b/result.bin" "artifacts/a/b/result.bin"+ assertMatchesGit repository root RegularFile "cache/a/b/value" "cache/a/b/value"+ assertMatchesGit repository root RegularFile "file1.c" "file1.c"+ assertMatchesGit repository root RegularFile "file10.c" "file10.c"+ assertMatchesGit repository root RegularFile "docs/b.md" "docs/b.md"+ assertMatchesGit repository root Directory "build" "build/"+ assertMatchesGit repository root RegularFile "#literal" "#literal"+ assertMatchesGit repository root RegularFile "!important" "!important"++ gitExample "keeps descendants ignored when their parent is excluded" $ \root repository -> do+ writeText (root </> ".gitignore") "build/\n"+ writeText (root </> "build" </> ".gitignore") "!keep.txt\n"++ assertMatchesGit repository root Directory "build" "build/"+ assertMatchesGit repository root RegularFile "build/keep.txt" "build/keep.txt"++ gitExample "allows re-inclusion while the parent directory remains visible" $ \root repository -> do+ writeText (root </> ".gitignore") "build/*.txt\n!build/keep.txt\n"++ assertMatchesGit repository root Directory "build" "build/"+ assertMatchesGit repository root RegularFile "build/drop.txt" "build/drop.txt"+ assertMatchesGit repository root RegularFile "build/keep.txt" "build/keep.txt"++ gitExample "does not extend a parent wildcard below a re-included directory" $ \root repository -> do+ writeText (root </> ".gitignore") "foo/*\n!foo/bar/\n"++ assertMatchesGit repository root Directory "foo/bar" "foo/bar/"+ assertMatchesGit repository root RegularFile "foo/bar/file.txt" "foo/bar/file.txt"++ gitExample "treats Glob number ranges as Git literals" $ \root repository -> do+ writeText (root </> ".gitignore") "value<1-3>.txt\n"++ assertMatchesGit repository root RegularFile "value1.txt" "value1.txt"+ assertMatchesGit repository root RegularFile "value<1-3>.txt" "value<1-3>.txt"++ gitExample "preserves an escaped hyphen inside a character class" $ \root repository -> do+ writeText (root </> ".gitignore") "[a\\-c].txt\n"++ assertMatchesGit repository root RegularFile "a.txt" "a.txt"+ assertMatchesGit repository root RegularFile "-.txt" "-.txt"+ assertMatchesGit repository root RegularFile "b.txt" "b.txt"+ assertMatchesGit repository root RegularFile "c.txt" "c.txt"++assertMatchesGit :: GitRepository -> FilePath -> PathKind -> FilePath -> FilePath -> Expectation+assertMatchesGit repository root kind repositoryPath gitPath = do+ actual <- isIgnored repository kind repositoryPath+ expected <- gitIgnores root gitPath+ unless+ (actual == expected)+ ( expectationFailure $+ mconcat+ [ "mismatch for "+ , show repositoryPath+ , " (Git path "+ , show gitPath+ , "): library="+ , show actual+ , ", Git="+ , show expected+ ]+ )++gitIgnores :: FilePath -> FilePath -> IO Bool+gitIgnores root path = do+ (exitCode, _, _) <-+ readProcessWithExitCode+ "git"+ [ "-C"+ , root+ , "check-ignore"+ , "--no-index"+ , "--quiet"+ , "--"+ , path+ ]+ ""+ case exitCode of+ ExitSuccess -> pure True+ ExitFailure 1 -> pure False+ ExitFailure code -> expectationFailure ("git check-ignore failed with " <> show code) >> pure False++gitExample :: String -> (FilePath -> GitRepository -> Expectation) -> Spec+gitExample description action =+ it description . withSystemTempDirectory "vcs-ignore-git-compatibility" $ \sandbox ->+ withEnvironment "XDG_CONFIG_HOME" (sandbox </> "xdg") $ do+ let root = sandbox </> "repository"+ createDirectoryIfMissing True root+ initializeGit root+ repository <- openGitRepository root+ action root repository++initializeGit :: FilePath -> IO ()+initializeGit root = do+ (exitCode, _, errors) <- readProcessWithExitCode "git" ["init", "--quiet", root] ""+ case exitCode of+ ExitSuccess -> pure ()+ ExitFailure code -> expectationFailure $ "git init failed with " <> show code <> ": " <> errors++withEnvironment :: String -> String -> IO a -> IO a+withEnvironment name value action = do+ original <- lookupEnv name+ bracket_ (setEnv name value) (restore original) action+ where+ restore Nothing = unsetEnv name+ restore (Just originalValue) = setEnv name originalValue++writeText :: FilePath -> String -> IO ()+writeText path content = do+ createDirectoryIfMissing True $ takeDirectory path+ writeFile path content
+ test/Data/VCS/Ignore/Git/Internal/PatternSpec.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Data.VCS.Ignore.Git.Internal.PatternSpec where++import Control.Exception (+ IOException,+ bracket_,+ try,+ )+import qualified Data.Text as T+import Data.VCS.Ignore.Git.Internal.Pattern+import Data.VCS.Ignore.Types (PathKind (..))+import System.Directory (+ createDirectory,+ createFileLink,+ getPermissions,+ readable,+ setPermissions,+ )+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec++spec :: Spec+spec = do+ describe "evaluatePatternGroups" $ do+ it "uses the last matching pattern across ordered groups" $ do+ let groups =+ [ group "/" "*.log\n!keep.log\n"+ , group "/nested/" "keep.log\n!keep.log\n"+ ]+ evaluatePatternGroups RegularFile groups "drop.log" `shouldBe` True+ evaluatePatternGroups RegularFile groups "keep.log" `shouldBe` False+ evaluatePatternGroups RegularFile groups "nested/keep.log" `shouldBe` False++ it "handles Git line parsing edge cases" $ do+ let groups =+ [ group+ "/"+ "# comment\r\n\\#literal\r\n\\!important\r\ntrailing \r\nescaped\\ \r\n"+ ]+ evaluatePatternGroups RegularFile groups "#literal" `shouldBe` True+ evaluatePatternGroups RegularFile groups "!important" `shouldBe` True+ evaluatePatternGroups RegularFile groups "trailing" `shouldBe` True+ evaluatePatternGroups RegularFile groups "trailing " `shouldBe` False+ evaluatePatternGroups RegularFile groups "escaped " `shouldBe` True++ it "applies directory-only patterns only to real directories" $ do+ let groups = [group "/" "build/\n"]+ evaluatePatternGroups Directory groups "build" `shouldBe` True+ evaluatePatternGroups RegularFile groups "build" `shouldBe` False+ evaluatePatternGroups SymbolicLink groups "build" `shouldBe` False+ evaluatePatternGroups Other groups "build" `shouldBe` False++ it "respects anchoring, nested scopes, and recursive wildcards" $ do+ let groups =+ [ group "/" "/root.txt\na/**/result.txt\ntree/**\n**/marker\n"+ , group "/nested/" "/local.txt\n"+ ]+ evaluatePatternGroups RegularFile groups "root.txt" `shouldBe` True+ evaluatePatternGroups RegularFile groups "deep/root.txt" `shouldBe` False+ evaluatePatternGroups RegularFile groups "a/result.txt" `shouldBe` True+ evaluatePatternGroups RegularFile groups "a/b/c/result.txt" `shouldBe` True+ evaluatePatternGroups RegularFile groups "tree/one/two/file" `shouldBe` True+ evaluatePatternGroups RegularFile groups "marker" `shouldBe` True+ evaluatePatternGroups RegularFile groups "deep/marker" `shouldBe` True+ evaluatePatternGroups RegularFile groups "nested/local.txt" `shouldBe` True+ evaluatePatternGroups RegularFile groups "nested/deep/local.txt" `shouldBe` False++ it "does not extend an ordinary pattern to every descendant" $ do+ let groups = [group "/" "foo/*\n!foo/bar/\n"]+ evaluatePatternGroups Directory groups "foo/bar" `shouldBe` False+ evaluatePatternGroups RegularFile groups "foo/bar/file.txt" `shouldBe` False++ describe "loadPatternsFile" $ do+ it "loads a regular ignore file"+ . withSystemTempDirectory "vcs-ignore-patterns"+ $ \directory -> do+ let path = directory </> ".gitignore"+ writeFile path "*.tmp\n"+ patterns <- loadPatternsFile False path+ evaluatePatternGroups RegularFile [PatternGroup "/" patterns] "file.tmp"+ `shouldBe` True++ it "treats missing, non-regular, and non-followed symbolic-link sources as empty"+ . withSystemTempDirectory "vcs-ignore-patterns"+ $ \directory -> do+ loadPatternsFile False (directory </> "missing") `shouldReturn` []+ let sourceDirectory = directory </> "directory-source"+ createDirectory sourceDirectory+ loadPatternsFile False sourceDirectory `shouldReturn` []+ let target = directory </> "rules"+ link = directory </> ".gitignore"+ writeFile target "*.tmp\n"+ createFileLink target link+ loadPatternsFile False link `shouldReturn` []++ it "propagates errors from an existing unreadable source when supported"+ . withSystemTempDirectory "vcs-ignore-patterns"+ $ \directory -> do+ let source = directory </> ".gitignore"+ writeFile source "*.tmp\n"+ permissions <- getPermissions source+ result <-+ bracket_+ (setPermissions source permissions{readable = False})+ (setPermissions source permissions)+ (try @IOException $ loadPatternsFile True source)+ case result of+ Left _ -> pure ()+ Right _ -> pendingWith "unreadable file permissions are not enforced"++group :: FilePath -> String -> PatternGroup+group prefix contents = PatternGroup prefix (parsePatterns $ T.pack contents)
+ test/Data/VCS/Ignore/Git/Internal/RepositorySpec.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Data.VCS.Ignore.Git.Internal.RepositorySpec (spec) where++import Control.Concurrent (+ forkIO,+ killThread,+ newEmptyMVar,+ putMVar,+ readMVar,+ takeMVar,+ )+import Control.Exception (+ IOException,+ SomeException,+ bracket_,+ try,+ )+import Control.Monad (replicateM)+import Data.Either (isLeft, isRight)+import Data.IORef (+ atomicModifyIORef',+ newIORef,+ readIORef,+ )+import Data.VCS.Ignore.Git.Internal.Pattern (+ PatternGroup (..),+ )+import Data.VCS.Ignore.Git.Internal.Repository+import Data.VCS.Ignore.Types (+ GitError (..),+ PathKind (..),+ )+import System.Directory (+ canonicalizePath,+ createDirectoryIfMissing,+ )+import System.Environment (+ lookupEnv,+ setEnv,+ unsetEnv,+ )+import System.FilePath (+ pathSeparator,+ takeDirectory,+ (</>),+ )+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec++spec :: Spec+spec = do+ describe "openGitRepository" $ do+ repositoryExample "opens a repository without scanning nested rules" $ \root -> do+ let nestedIgnore = root </> "nested" </> ".gitignore"+ writeText nestedIgnore "old.txt\n"+ repository <- openGitRepository root+ writeText nestedIgnore "new.txt\n"++ isIgnored repository RegularFile "nested/new.txt" `shouldReturn` True+ isIgnored repository RegularFile "nested/old.txt" `shouldReturn` False++ it "rejects a directory without Git metadata"+ . withSystemTempDirectory "vcs-ignore-invalid"+ $ \root ->+ openGitRepository root `shouldThrow` isNotRepository++ it "resolves gitfile and commondir metadata"+ . withIsolatedEnvironment+ $ \sandbox -> do+ let root = sandbox </> "repo"+ gitDirectory = sandbox </> "admin" </> "worktrees" </> "main"+ commonDirectory = sandbox </> "admin" </> "common"+ createDirectoryIfMissing True root+ createDirectoryIfMissing True gitDirectory+ createDirectoryIfMissing True $ commonDirectory </> "info"+ writeText (root </> ".git") "gitdir: ../admin/worktrees/main\n"+ writeText (gitDirectory </> "commondir") "../../common\n"+ writeText (commonDirectory </> "info" </> "exclude") "from-info.txt\n"++ repository <- openGitRepository root+ canonicalGitDirectory <- canonicalizePath gitDirectory+ canonicalCommon <- canonicalizePath commonDirectory+ gitRepositoryGitDirectory repository `shouldBe` canonicalGitDirectory+ gitRepositoryCommonDirectory repository `shouldBe` canonicalCommon+ isIgnored repository RegularFile "from-info.txt" `shouldReturn` True++ it "reports malformed gitfile metadata"+ . withIsolatedEnvironment+ $ \sandbox -> do+ let root = sandbox </> "repo"+ createDirectoryIfMissing True root+ writeText (root </> ".git") "not a gitdir\n"++ openGitRepository root `shouldThrow` isInvalidMetadata++ it "recognizes in-tree gitdir and commondir paths as metadata"+ . withIsolatedEnvironment+ $ \sandbox -> do+ let root = sandbox </> "repo"+ gitDirectory = root </> ".metadata" </> "worktree"+ commonDirectory = root </> ".metadata" </> "common"+ createDirectoryIfMissing True gitDirectory+ createDirectoryIfMissing True commonDirectory+ writeText (root </> ".git") "gitdir: .metadata/worktree\n"+ writeText (gitDirectory </> "commondir") "../common\n"++ repository <- openGitRepository root+ isRepositoryMetadata repository ".metadata/worktree" `shouldBe` True+ isRepositoryMetadata repository ".metadata/worktree/index" `shouldBe` True+ isRepositoryMetadata repository ".metadata/common" `shouldBe` True+ isRepositoryMetadata repository ".metadata/working-file" `shouldBe` False++ describe "findGitRepository" $ do+ repositoryExample "finds the nearest enclosing repository" $ \root -> do+ let nested = root </> "one" </> "two"+ createDirectoryIfMissing True nested++ (fmap repositoryRoot <$> findGitRepository nested)+ `shouldReturnJustCanonicalPath` root++ it "returns Nothing when no repository encloses the path"+ . withIsolatedEnvironment+ $ \sandbox ->+ (fmap repositoryRoot <$> findGitRepository sandbox)+ `shouldReturn` Nothing++ describe "repository rule context" $ do+ repositoryExample "applies global, info, root, and nested rules in order" $ \root -> do+ let sandbox = takeDirectory root+ writeText (sandbox </> "xdg" </> "git" </> "ignore") "*.cache\n"+ writeText (root </> ".git" </> "info" </> "exclude") "*.log\n"+ writeText (root </> ".gitignore") "!keep.log\n"+ writeText (root </> "nested" </> ".gitignore") "!keep.cache\n"+ repository <- openGitRepository root++ isIgnored repository RegularFile "drop.cache" `shouldReturn` True+ isIgnored repository RegularFile "drop.log" `shouldReturn` True+ isIgnored repository RegularFile "keep.log" `shouldReturn` False+ isIgnored repository RegularFile "nested/keep.cache" `shouldReturn` False++ repositoryExample "caches each directory rule group after first use" $ \root -> do+ let ignoreFile = root </> ".gitignore"+ writeText ignoreFile "cached.txt\n"+ repository <- openGitRepository root+ isIgnored repository RegularFile "cached.txt" `shouldReturn` True++ writeText ignoreFile ""+ isIgnored repository RegularFile "cached.txt" `shouldReturn` True++ repositoryExample "shares a cached rule load between concurrent queries" $ \root -> do+ writeText (root </> ".gitignore") "shared.txt\n"+ repository <- openGitRepository root+ start <- newEmptyMVar+ outputs <- replicateM 8 newEmptyMVar++ mapM_+ ( \output -> do+ _ <- forkIO $ do+ readMVar start+ isIgnored repository RegularFile "shared.txt" >>= putMVar output+ pure ()+ )+ outputs+ putMVar start ()++ results <- mapM readMVar outputs+ results `shouldBe` replicate 8 True++ repositoryExample "retries a shared rule load after owner cancellation" $ \root -> do+ repository <- openGitRepository root+ calls <- newIORef (0 :: Int)+ firstLoadStarted <- newEmptyMVar+ blockFirstLoad <- newEmptyMVar+ ownerResult <- newEmptyMVar+ waiterResult <- newEmptyMVar+ let loader _ = do+ call <- atomicModifyIORef' calls $ \count -> (count + 1, count + 1)+ if call == 1+ then putMVar firstLoadStarted () >> takeMVar blockFirstLoad >> pure []+ else pure []++ owner <- forkIO $ do+ result <- try @SomeException $ loadDirectoryRulesWith repository loader "."+ putMVar ownerResult result+ takeMVar firstLoadStarted+ _ <- forkIO $ do+ result <- try @SomeException $ loadDirectoryRulesWith repository loader "."+ putMVar waiterResult result+ killThread owner++ firstResult <- takeMVar ownerResult+ secondResult <- takeMVar waiterResult+ firstResult `shouldSatisfy` isLeft+ secondResult `shouldSatisfy` isRight+ readIORef calls `shouldReturn` 2++ repositoryExample "caches synchronous rule-loading failures" $ \root -> do+ repository <- openGitRepository root+ calls <- newIORef (0 :: Int)+ let loader _ = do+ atomicModifyIORef' calls $ \count -> (count + 1, ())+ ioError $ userError "rule load failed"++ firstResult <- try @IOException $ loadDirectoryRulesWith repository loader "."+ secondResult <- try @IOException $ loadDirectoryRulesWith repository loader "."+ firstResult `shouldSatisfy` isLeft+ secondResult `shouldSatisfy` isLeft+ readIORef calls `shouldReturn` 1++ repositoryExample "does not load rules below an ignored parent" $ \root -> do+ writeText (root </> ".gitignore") "build/\n"+ writeText (root </> "build" </> ".gitignore") "!keep.txt\n"+ repository <- openGitRepository root++ isIgnored repository Directory "build" `shouldReturn` True+ isIgnored repository RegularFile "build/keep.txt" `shouldReturn` True++ repositoryExample "does not apply a directory's rules to itself" $ \root -> do+ writeText (root </> "nested" </> ".gitignore") "nested/\nself.txt\n"+ repository <- openGitRepository root++ isIgnored repository Directory "nested" `shouldReturn` False+ isIgnored repository RegularFile "nested/self.txt" `shouldReturn` True++ repositoryExample "returns normalized prefixes for cached groups" $ \root -> do+ repository <- openGitRepository root+ rootGroups <- rootRuleContext repository+ nestedGroup <- loadDirectoryRules repository "nested/deeper"++ fmap patternGroupPrefix rootGroups `shouldBe` ["/", "/"]+ patternGroupPrefix nestedGroup `shouldBe` "/nested/deeper/"++ describe "repository paths" $ do+ it "normalizes valid relative paths" $ do+ validateRepositoryPath "" `shouldBe` Right "."+ validateRepositoryPath "./one//two" `shouldBe` Right "one/two"+ groupPrefix "." `shouldBe` "/"+ groupPrefix "one/two" `shouldBe` "/one/two/"++ it "rejects absolute and escaping paths" $ do+ validateRepositoryPath "/outside" `shouldSatisfy` isLeft+ validateRepositoryPath "../outside" `shouldSatisfy` isLeft+ validateRepositoryPath "inside/../outside" `shouldSatisfy` isLeft+ if pathSeparator == '\\'+ then validateRepositoryPath "C:\\outside" `shouldSatisfy` isLeft+ else validateRepositoryPath "C:\\outside" `shouldBe` Right "C:\\outside"++ repositoryExample "always ignores root Git metadata only" $ \root -> do+ repository <- openGitRepository root++ isRepositoryMetadata repository ".git" `shouldBe` True+ isRepositoryMetadata repository ".git/objects/value" `shouldBe` True+ isRepositoryMetadata repository "nested/.git" `shouldBe` False+ isIgnored repository Directory ".git" `shouldReturn` True+ isIgnored repository RegularFile ".git/config" `shouldReturn` True++repositoryExample :: String -> (FilePath -> Expectation) -> Spec+repositoryExample description action =+ it description . withIsolatedEnvironment $ \sandbox -> do+ let root = sandbox </> "repo"+ createDirectoryIfMissing True $ root </> ".git" </> "info"+ action root++withIsolatedEnvironment :: (FilePath -> IO a) -> IO a+withIsolatedEnvironment action =+ withSystemTempDirectory "vcs-ignore-repository" $ \sandbox ->+ withEnvironment "XDG_CONFIG_HOME" (sandbox </> "xdg") $+ action sandbox++withEnvironment :: String -> String -> IO a -> IO a+withEnvironment name value action = do+ original <- lookupEnv name+ bracket_ (setEnv name value) (restore original) action+ where+ restore Nothing = unsetEnv name+ restore (Just original) = setEnv name original++writeText :: FilePath -> String -> IO ()+writeText path content = do+ createDirectoryIfMissing True $ takeDirectory path+ writeFile path content++isNotRepository :: GitError -> Bool+isNotRepository (NotGitRepository _) = True+isNotRepository _ = False++isInvalidMetadata :: GitError -> Bool+isInvalidMetadata (InvalidGitMetadata _ _) = True+isInvalidMetadata _ = False++shouldReturnJustCanonicalPath :: IO (Maybe FilePath) -> FilePath -> Expectation+shouldReturnJustCanonicalPath action expectedPath = do+ expected <- canonicalizePath expectedPath+ action `shouldReturn` Just expected
+ test/Data/VCS/Ignore/Git/Internal/TraversalSpec.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Data.VCS.Ignore.Git.Internal.TraversalSpec (spec) where++import Control.Exception (+ IOException,+ bracket_,+ try,+ )+import Control.Monad (when)+import Data.IORef (+ modifyIORef',+ newIORef,+ readIORef,+ )+import qualified Data.List as L+import Data.VCS.Ignore.Git.Internal.Repository (+ GitRepository,+ openGitRepository,+ )+import Data.VCS.Ignore.Git.Internal.Traversal+import Data.VCS.Ignore.Types+import System.Directory (+ createDirectoryIfMissing,+ createDirectoryLink,+ removeDirectoryLink,+ removeDirectoryRecursive,+ renameDirectory,+ )+import System.Environment (+ lookupEnv,+ setEnv,+ unsetEnv,+ )+import System.FilePath (+ takeDirectory,+ (</>),+ )+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec++spec :: Spec+spec = do+ describe "foldRepo" $ do+ it "visits entries in depth-first preorder without emitting the root"+ . withRepository+ $ \root repository -> do+ writeText (root </> "directory" </> "child.txt") "child"+ writeText (root </> "file.txt") "file"++ result <- foldRepo repository [] collectEntry++ entries <- completedValue result+ let paths = entryPath <$> reverse entries+ paths `shouldNotContain` [""]+ paths `shouldMatchList` ["directory", "directory" </> "child.txt", "file.txt"]+ reverse entries+ `shouldMatchList` [ Entry "directory" Directory+ , Entry ("directory" </> "child.txt") RegularFile+ , Entry "file.txt" RegularFile+ ]+ L.elemIndex ("directory" </> "child.txt") paths+ `shouldBe` ((+ 1) <$> L.elemIndex "directory" paths)++ it "automatically prunes ignored directories and repository metadata"+ . withRepository+ $ \root repository -> do+ writeText (root </> ".gitignore") "ignored/\n"+ writeText (root </> "ignored" </> "hidden.txt") "hidden"+ writeText (root </> "visible.txt") "visible"++ entries <- listRepo repository++ entryPath <$> entries `shouldMatchList` [".gitignore", "visible.txt"]++ it "loads a visible directory's rules before visiting its children"+ . withRepository+ $ \root repository -> do+ writeText (root </> "nested" </> ".gitignore") "*.tmp\n"+ writeText (root </> "nested" </> "drop.tmp") "ignored"+ writeText (root </> "nested" </> "keep.txt") "visible"++ entries <- listRepo repository++ entryPath <$> entries+ `shouldMatchList` [ "nested"+ , "nested" </> ".gitignore"+ , "nested" </> "keep.txt"+ ]++ it "honours caller pruning without visiting descendants"+ . withRepository+ $ \root repository -> do+ writeText (root </> "pruned" </> "child.txt") "child"+ writeText (root </> "visible" </> "child.txt") "child"++ result <- foldRepo repository [] $ \entries entry ->+ pure+ ( entry : entries+ , if entryPath entry == "pruned" then Prune else Continue+ )++ entries <- reverse <$> completedValue result+ entryPath <$> entries+ `shouldMatchList` ["pruned", "visible", "visible" </> "child.txt"]++ it "treats Prune on a file as Continue"+ . withRepository+ $ \root repository -> do+ writeText (root </> "first.txt") "first"+ writeText (root </> "second.txt") "second"++ result <- foldRepo repository [] $ \entries entry ->+ pure (entryPath entry : entries, Prune)++ paths <- reverse <$> completedValue result+ paths `shouldMatchList` ["first.txt", "second.txt"]++ it "does not follow a directory replaced by a symlink in the callback"+ . withRepository+ $ \root repository ->+ withSystemTempDirectory "vcs-ignore-replacement" $ \outside -> do+ let directory = root </> "directory"+ moved = root </> "moved"+ writeText (directory </> "inside.txt") "inside"+ writeText (outside </> "outside.txt") "outside"++ result <- try @IOException $ createDirectoryLink outside (root </> "probe")+ case result of+ Left _ -> pendingWith "directory symbolic links are unavailable"+ Right _ -> do+ removeDirectoryLink $ root </> "probe"+ entries <- listWithReplacement repository directory moved outside+ entryPath <$> entries `shouldBe` ["directory"]++ it "skips a directory removed by the callback"+ . withRepository+ $ \root repository -> do+ let directory = root </> "directory"+ writeText (directory </> "inside.txt") "inside"++ result <- foldRepo repository [] $ \entries entry -> do+ when (entryPath entry == "directory") $+ removeDirectoryRecursive directory+ pure (entry : entries, Continue)++ reverse <$> completedValue result+ `shouldReturn` [Entry "directory" Directory]++ it "propagates Stop through all remaining traversal levels"+ . withRepository+ $ \root repository -> do+ writeText (root </> "one" </> "child.txt") "child"+ writeText (root </> "two" </> "child.txt") "child"++ result <- foldRepo repository (0 :: Int) $ \count _ ->+ pure (count + 1, Stop)++ result `shouldBe` WalkStopped 1++ it "forces the initial accumulator even for an empty repository"+ . withRepository+ $ \_ repository ->+ foldRepo repository (error "strict accumulator" :: Int) keepWalking+ `shouldThrow` errorCall "strict accumulator"++ it "propagates callback failures"+ . withRepository+ $ \root repository -> do+ writeText (root </> "entry.txt") "entry"++ walkRepo repository (const . ioError $ userError "callback failure")+ `shouldThrow` anyIOException++ describe "repository traversal wrappers" $ do+ it "does not follow directory symbolic links"+ . withRepository+ $ \root repository ->+ withSystemTempDirectory "vcs-ignore-target" $ \target -> do+ writeText (target </> "outside.txt") "outside"+ linkResult <- try @IOException $ createDirectoryLink target (root </> "link")+ case linkResult of+ Left _ -> pendingWith "directory symbolic links are unavailable"+ Right _ -> do+ entries <- listRepo repository+ entries `shouldBe` [Entry "link" SymbolicLink]++ it "walkRepo reports normal completion"+ . withRepository+ $ \root repository -> do+ writeText (root </> "entry.txt") "entry"+ result <- walkRepo repository (const $ pure Continue)+ result `shouldBe` WalkCompleted ()++ it "forRepo_ performs an effect for every visible entry"+ . withRepository+ $ \root repository -> do+ writeText (root </> "first.txt") "first"+ writeText (root </> "second.txt") "second"+ visited <- newIORef []++ forRepo_ repository $ \entry ->+ modifyIORef' visited (entryPath entry :)++ paths <- readIORef visited+ paths `shouldMatchList` ["first.txt", "second.txt"]++collectEntry :: [Entry] -> Entry -> IO ([Entry], WalkAction)+collectEntry entries entry = pure (entry : entries, Continue)++keepWalking :: Int -> Entry -> IO (Int, WalkAction)+keepWalking state _ = pure (state, Continue)++completedValue :: WalkResult a -> IO a+completedValue (WalkCompleted value) = pure value+completedValue (WalkStopped _) = do+ expectationFailure "expected completed traversal"+ error "unreachable"++listWithReplacement :: GitRepository -> FilePath -> FilePath -> FilePath -> IO [Entry]+listWithReplacement repository directory moved outside = do+ result <- foldRepo repository [] $ \entries entry -> do+ when (entryPath entry == "directory") $ do+ renameDirectory directory moved+ createDirectoryLink outside directory+ pure (entry : entries, Continue)+ reverse <$> completedValue result++withRepository :: (FilePath -> GitRepository -> IO a) -> IO a+withRepository action =+ withSystemTempDirectory "vcs-ignore-traversal" $ \sandbox ->+ withEnvironment "XDG_CONFIG_HOME" (sandbox </> "xdg") $ do+ let root = sandbox </> "repository"+ createDirectoryIfMissing True $ root </> ".git" </> "info"+ repository <- openGitRepository root+ action root repository++withEnvironment :: String -> String -> IO a -> IO a+withEnvironment name value action = do+ original <- lookupEnv name+ bracket_ (setEnv name value) (restore original) action+ where+ restore Nothing = unsetEnv name+ restore (Just originalValue) = setEnv name originalValue++writeText :: FilePath -> String -> IO ()+writeText path content = do+ createDirectoryIfMissing True $ takeDirectory path+ writeFile path content
− test/Data/VCS/Ignore/Repo/GitSpec.hs
@@ -1,139 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.VCS.Ignore.Repo.GitSpec where--import qualified Data.List as L-import qualified Data.Text as T-import Data.VCS.Ignore.Repo ( RepoError(..) )-import Data.VCS.Ignore.Repo.Git-import System.Directory ( makeAbsolute )-import System.FilePath ( (</>) )-import Test.Hspec---spec :: Spec-spec = do- let repo = "test-data" </> "fake-git-repo"-- describe "compilePattern" $ do- it "compiles negated pattern" $ do- compilePattern "!/foo/bar"- `shouldBe` Pattern ["/foo/bar", "/foo/bar/**"] "!/foo/bar" True-- it "compiles pattern matching files or directories inside path" $ do- compilePattern ".hidden"- `shouldBe` Pattern ["**/.hidden", "**/.hidden/**"] ".hidden" False- compilePattern ".hidden/"- `shouldBe` Pattern ["**/.hidden/**"] ".hidden/" False--- describe "matchesPattern" $ do- it "matches all content in subdirectory" $ do- matchesPattern (compilePattern "/foo/*") "/foo" `shouldBe` False- matchesPattern (compilePattern "/foo/*") "/foo/bar" `shouldBe` True-- it "matches all content in all subdirectories" $ do- matchesPattern (compilePattern "/foo/**") "/foo/bar" `shouldBe` True- matchesPattern (compilePattern "/foo/**") "/foo/bar/c" `shouldBe` True-- it "matches negated pattern" $ do- matchesPattern (compilePattern "!/foo/*") "/foo" `shouldBe` False- matchesPattern (compilePattern "!/foo/*") "/foo/bar" `shouldBe` True-- it "matches dir pattern anywhere in the path" $ do- matchesPattern (compilePattern "bar/") "/foo/bar/x" `shouldBe` True- matchesPattern (compilePattern "bar/") "/foo/bar" `shouldBe` False-- it "matches dir or file pattern anywhere in the path" $ do- matchesPattern (compilePattern "bar") "/foo/bar/x" `shouldBe` True- matchesPattern (compilePattern "bar") "/foo/bar" `shouldBe` True--- describe "parsePatterns" $ do- it "parses glob patterns from input text (pattern per line)" $ do- let input = T.unlines [".cabal-sandbox/", "## comment", ".DS_Store"]- expected = [".cabal-sandbox/", ".DS_Store"]- parsePatterns input `shouldBe` expected--- describe "loadPatterns" $ do- it "loads and parses glob patterns from input file" $ do- let source = repo </> "a" </> ".gitignore"- expected = ["**/*.xml"]- loadPatterns source `shouldReturn` expected-- it "returns empty list if input cannot be read" $ do- let source = repo </> "non-existing"- loadPatterns source `shouldReturn` []--- describe "findGitIgnores" $ do- it "finds all .gitignore files in repo" $ do- let expected =- [ repo </> "a" </> ".gitignore"- , repo </> "a" </> "b" </> ".gitignore"- , repo </> ".gitignore"- ]- L.sort <$> findGitIgnores repo `shouldReturn` L.sort expected--- describe "gitIgnorePatterns" $ do- it "loads patterns for all .gitignore files in repo" $ do- let expected =- [("/a/", ["**/*.xml"]), ("/a/b/", ["*.txt"]), ("/", ["foo"])]- sortFst <$> gitIgnorePatterns repo `shouldReturn` sortFst expected--- describe "scanRepo'" $ do- it "scans repository for ignored patterns" $ do- absRepo <- makeAbsolute repo- let- fn1 = pure []- fn2 = const $ pure []- fn3 = const $ pure True- expected = Git- { gitPatterns = sortFst- [("/", ["foo"]), ("/a/", ["**/*.xml"]), ("/a/b/", ["*.txt"])]- , gitRepoRoot = absRepo- }- result <- scanRepo' fn1 fn2 gitIgnorePatterns fn3 repo- let result' = result { gitPatterns = sortFst (gitPatterns result) }- result' `shouldBe` expected-- it "aborts scanning if given path is not valid GIT repo" $ do- let fn1 = pure []- fn2 = const $ pure []- fn3 = const $ pure False- let err (InvalidRepo _ _) = True- scanRepo' fn1 fn2 gitIgnorePatterns fn3 repo `shouldThrow` err--- describe "isIgnored'" $ do- it "checks whether given path is excluded" $ do- absRepo <- makeAbsolute repo- let git = Git- { gitPatterns = [ ("/" , ["!keep.xml", ".hidden/", ".hid"])- , ("/a/" , ["**/*.xml"])- , ("/a/b/", ["*.txt"])- ]- , gitRepoRoot = absRepo- }- isIgnored' git "foo/bar" `shouldReturn` False- isIgnored' git "a/hello.txt" `shouldReturn` False- isIgnored' git "a/hello.xml" `shouldReturn` True- isIgnored' git "a/b/hello.xml" `shouldReturn` True- isIgnored' git "a/b/keep.xml" `shouldReturn` False- isIgnored' git "/foo/bar" `shouldReturn` False- isIgnored' git "/a/hello.txt" `shouldReturn` False- isIgnored' git "/a/hello.xml" `shouldReturn` True- isIgnored' git "/a/b/hello.xml" `shouldReturn` True- isIgnored' git "/a/b/../hello.txt" `shouldReturn` False- isIgnored' git "/a/b/../hello.xml" `shouldReturn` True- isIgnored' git "/a/b/.hidden" `shouldReturn` False- isIgnored' git "/a/b/.hidden/foo" `shouldReturn` True- isIgnored' git "/a/b/.hid" `shouldReturn` True- isIgnored' git "/a/b/.hid/foo" `shouldReturn` True---sortFst :: Ord a => [(a, b)] -> [(a, b)]-sortFst = L.sortOn fst
vcs-ignore.cabal view
@@ -1,25 +1,24 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack name: vcs-ignore-version: 0.0.2.0-synopsis: Library for handling files ignored by VCS systems.-description: vcs-ignore is small Haskell library used to find, check and process files ignored by selected VCS.+version: 0.1.0.0+synopsis: Query Git ignore rules and traverse visible repository entries.+description: vcs-ignore provides lazy Git ignore queries and a pruning, early-stopping repository traversal built on one shared rule engine. category: Development-homepage: https://github.com/vaclavsvejcar/vcs-ignore-bug-reports: https://github.com/vaclavsvejcar/vcs-ignore/issues+homepage: https://github.com/xwinus/vcs-ignore+bug-reports: https://github.com/xwinus/vcs-ignore/issues author: Vaclav Svejcar maintainer: vaclav.svejcar@gmail.com-copyright: Copyright (c) 2020-2022 Vaclav Svejcar+copyright: Copyright (c) 2020-2026 Vaclav Svejcar license: BSD-3-Clause license-file: LICENSE build-type: Simple extra-source-files: README.md- CHANGELOG.md test-data/fake-git-repo/.gitignore test-data/fake-git-repo/a/test-a.txt test-data/fake-git-repo/a/test-a.xml@@ -31,20 +30,23 @@ test-data/list-files/dir1/b.txt test-data/list-files/dir1/dir2/c.txt test-data/list-files/dir1/dir2/d.xml+extra-doc-files:+ CHANGELOG.md+ RELEASING.md source-repository head type: git- location: https://github.com/vaclavsvejcar/vcs-ignore+ location: https://github.com/xwinus/vcs-ignore library exposed-modules: Data.VCS.Ignore- Data.VCS.Ignore.Core- Data.VCS.Ignore.FileSystem- Data.VCS.Ignore.Repo- Data.VCS.Ignore.Repo.Git+ Data.VCS.Ignore.Git Data.VCS.Ignore.Types other-modules:+ Data.VCS.Ignore.Git.Internal.Pattern+ Data.VCS.Ignore.Git.Internal.Repository+ Data.VCS.Ignore.Git.Internal.Traversal Paths_vcs_ignore autogen-modules: Paths_vcs_ignore@@ -52,13 +54,12 @@ src ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Werror=incomplete-patterns build-depends:- Glob- , base >=4.7 && <5- , containers- , directory- , exceptions- , filepath- , text+ Glob >=0.10.2 && <0.11+ , base >=4.20 && <4.23+ , containers >=0.6 && <0.9+ , directory >=1.3.8 && <1.4+ , filepath >=1.4.2 && <1.6+ , text >=2.0 && <2.2 default-language: Haskell2010 executable ignore@@ -67,58 +68,73 @@ Main.Options Main.Vendor Paths_vcs_ignore+ autogen-modules:+ Paths_vcs_ignore hs-source-dirs: app ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Werror=incomplete-patterns -threaded -rtsopts -with-rtsopts=-N build-depends:- base >=4.7 && <5- , containers- , directory- , exceptions- , filepath- , optparse-applicative- , text+ base >=4.20 && <4.23+ , containers >=0.6 && <0.9+ , directory >=1.3.8 && <1.4+ , filepath >=1.4.2 && <1.6+ , optparse-applicative ==0.18.*+ , text >=2.0 && <2.2 , vcs-ignore default-language: Haskell2010 -test-suite doctest- type: exitcode-stdio-1.0- main-is: Main.hs- other-modules:- Paths_vcs_ignore- hs-source-dirs:- doctest- ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Werror=incomplete-patterns- build-depends:- base >=4.7 && <5- , containers- , directory- , doctest- , exceptions- , filepath- , text- default-language: Haskell2010- test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules:- Data.VCS.Ignore.CoreSpec- Data.VCS.Ignore.FileSystemSpec- Data.VCS.Ignore.Repo.GitSpec+ Data.VCS.Ignore+ Data.VCS.Ignore.Git+ Data.VCS.Ignore.Git.Internal.Pattern+ Data.VCS.Ignore.Git.Internal.Repository+ Data.VCS.Ignore.Git.Internal.Traversal+ Data.VCS.Ignore.Types+ Data.VCS.Ignore.Git.CompatibilitySpec+ Data.VCS.Ignore.Git.Internal.PatternSpec+ Data.VCS.Ignore.Git.Internal.RepositorySpec+ Data.VCS.Ignore.Git.Internal.TraversalSpec Paths_vcs_ignore+ autogen-modules:+ Paths_vcs_ignore hs-source-dirs:+ src test ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Werror=incomplete-patterns -threaded -rtsopts -with-rtsopts=-N build-tool-depends: hspec-discover:hspec-discover build-depends:- base >=4.7 && <5- , containers- , directory- , exceptions- , filepath+ Glob >=0.10.2 && <0.11+ , base >=4.20 && <4.23+ , containers >=0.6 && <0.9+ , directory >=1.3.8 && <1.4+ , filepath >=1.4.2 && <1.6 , hspec- , text+ , process+ , temporary+ , text >=2.0 && <2.2+ default-language: Haskell2010++benchmark repository-traversal+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_vcs_ignore+ autogen-modules:+ Paths_vcs_ignore+ hs-source-dirs:+ benchmark+ ghc-options: -optP-Wno-nonportable-include-path -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Werror=incomplete-patterns+ build-depends:+ base >=4.20 && <4.23+ , containers >=0.6 && <0.9+ , criterion+ , directory >=1.3.8 && <1.4+ , filepath >=1.4.2 && <1.6+ , temporary+ , text >=2.0 && <2.2 , vcs-ignore default-language: Haskell2010