diff --git a/CHANGES.txt b/CHANGES.txt new file mode 100644 --- /dev/null +++ b/CHANGES.txt @@ -0,0 +1,6 @@ +Changelog for filepattern + +0.1, released 2019-02-12 + Substantial (almost total) rewrite + Remove // patterns + Split from shake-0.16 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Neil Mitchell 2011-2019. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Neil Mitchell nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# FilePattern [![Hackage version](https://img.shields.io/hackage/v/filepattern.svg?label=Hackage)](https://hackage.haskell.org/package/filepattern) [![Stackage version](https://www.stackage.org/package/filepattern/badge/nightly?label=Stackage)](https://www.stackage.org/package/filepattern) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/filepattern/master.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/filepattern) [![Windows Build Status](https://img.shields.io/appveyor/ci/ndmitchell/filepattern/master.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/filepattern) + +A file path matching library, loosely modelled on the semantics from: + +* [VS Code](https://code.visualstudio.com/docs/editor/codebasics#_advanced-search-options). +* [Git](https://git-scm.com/docs/gitignore). +* [Glob](https://www.npmjs.com/package/glob). + +Originally part of [Shake](http://shakebuild.com/), now split off as a separate project. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/filepattern.cabal b/filepattern.cabal new file mode 100644 --- /dev/null +++ b/filepattern.cabal @@ -0,0 +1,75 @@ +cabal-version: >= 1.18 +build-type: Simple +name: filepattern +version: 0.1 +license: BSD3 +license-file: LICENSE +category: Development, FilePath +author: Neil Mitchell , Evan Rutledge Borden +maintainer: Neil Mitchell +copyright: Neil Mitchell 2011-2019 +synopsis: File path glob-like matching +description: + A library for matching files using patterns such as @\"src\/**\/*.png\"@ for all @.png@ files + recursively under the @src@ directory. Features: + . + * All matching is /O(n)/. + . + * See "System.FilePattern" and 'System.FilePattern.?==' simple matching and semantics. + . + * Use 'System.FilePattern.match' and 'System.FilePattern.substitute' to extract suitable + strings from the @*@ and @**@ matches, and substitute them back into other patterns. + . + * Use 'System.FilePattern.step' and 'System.FilePattern.matchMany' to perform bulk matching + of many patterns against many paths simultaneously. + . + * Use "System.FilePattern.Directory" to perform optimised directory traverals using patterns. + . + Originally taken from the . +bug-reports: https://github.com/eborden/filepattern/issues +tested-with: GHC==8.6.3, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +extra-doc-files: + CHANGES.txt + README.md + +source-repository head + type: git + location: https://github.com/eborden/filepattern.git + +library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: + base == 4.*, + directory, + extra >= 1.6.2, + filepath + if impl(ghc < 8.0) + build-depends: semigroups >= 0.18 + exposed-modules: + System.FilePattern + System.FilePattern.Directory + other-modules: + System.FilePattern.Core + System.FilePattern.ListBy + System.FilePattern.Monads + System.FilePattern.Step + System.FilePattern.Tree + System.FilePattern.Wildcard + + +test-suite filepattern-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: test + build-depends: + base == 4.*, + directory, + extra, + filepattern, + filepath, + QuickCheck >= 2.0 + other-modules: + Test.Cases + Test.Util diff --git a/src/System/FilePattern.hs b/src/System/FilePattern.hs new file mode 100644 --- /dev/null +++ b/src/System/FilePattern.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE ConstraintKinds, RecordWildCards, ScopedTypeVariables #-} + +-- | A module for matching files using patterns such as @\"src\/**\/*.png\"@ for all @.png@ files +-- recursively under the @src@ directory. See 'System.FilePattern.?==' for the semantics of +-- 'System.FilePattern.FilePattern' values. Features: +-- +-- * All matching is /O(n)/. +-- +-- * Use 'System.FilePattern.match' and 'System.FilePattern.substitute' to extract suitable +-- strings from the @*@ and @**@ matches, and substitute them back into other patterns. +-- +-- * Use 'System.FilePattern.step' and 'System.FilePattern.matchMany' to perform bulk matching +-- of many patterns against many paths simultaneously. +-- +-- * Use "System.FilePattern.Directory" to perform optimised directory traverals using patterns. +module System.FilePattern( + FilePattern, (?==), match, substitute, arity, + -- * Multiple patterns and paths + step, step_, Step(..), StepNext(..), matchMany + ) where + +import Control.Exception.Extra +import Data.Maybe +import Data.Tuple.Extra +import Data.List.Extra +import System.FilePattern.Tree +import System.FilePattern.Core(FilePattern, parsePattern, parsePath, renderPath) +import qualified System.FilePattern.Core as Core +import System.FilePattern.Step +import Prelude + + +--------------------------------------------------------------------- +-- PATTERNS + +-- | Match a 'FilePattern' against a 'FilePath'. There are two special forms: +-- +-- * @*@ matches part of a path component, excluding any separators. +-- +-- * @**@ as a path component matches an arbitrary number of path components. +-- +-- Some examples: +-- +-- * @test.c@ matches @test.c@ and nothing else. +-- +-- * @*.c@ matches all @.c@ files in the current directory, so @file.c@ matches, +-- but @file.h@ and @dir\/file.c@ don't. +-- +-- * @**/*.c@ matches all @.c@ files anywhere on the filesystem, +-- so @file.c@, @dir\/file.c@, @dir1\/dir2\/file.c@ and @\/path\/to\/file.c@ all match, +-- but @file.h@ and @dir\/file.h@ don't. +-- +-- * @dir\/*\/*@ matches all files one level below @dir@, so @dir\/one\/file.c@ and +-- @dir\/two\/file.h@ match, but @file.c@, @one\/dir\/file.c@, @dir\/file.h@ +-- and @dir\/one\/two\/file.c@ don't. +-- +-- Patterns with constructs such as @foo\/..\/bar@ will never match +-- normalised 'FilePath' values, so are unlikely to be correct. +(?==) :: FilePattern -> FilePath -> Bool +(?==) w = isJust . match w + + +-- | Like '?==', but returns 'Nothing' on if there is no match, otherwise 'Just' with the list +-- of fragments matching each wildcard. For example: +-- +-- @ +-- isJust ('match' p x) == (p '?==' x) +-- 'match' \"**\/*.c\" \"test.txt\" == Nothing +-- 'match' \"**\/*.c\" \"foo.c\" == Just [\"",\"foo\"] +-- 'match' \"**\/*.c\" \"bar\/baz\/foo.c\" == Just [\"bar\/baz/\",\"foo\"] +-- @ +-- +-- On Windows any @\\@ path separators will be replaced by @\/@. +match :: FilePattern -> FilePath -> Maybe [String] +match w = Core.match (parsePattern w) . parsePath + + +--------------------------------------------------------------------- +-- MULTIPATTERN COMPATIBLE SUBSTITUTIONS + +-- | How many @*@ and @**@ elements are there. +-- +-- @ +-- 'arity' \"test.c\" == 0 +-- 'arity' \"**\/*.c\" == 2 +-- @ +arity :: FilePattern -> Int +arity = Core.arity . parsePattern + + +-- | Given a successful 'match', substitute it back in to a pattern with the same 'arity'. +-- Raises an error if the number of parts does not match the arity of the pattern. +-- +-- @ +-- p '?==' x ==> 'substitute' (fromJust $ 'match' p x) p == x +-- 'substitute' \"**\/*.c\" [\"dir\",\"file\"] == \"dir/file.c\" +-- @ +substitute :: Partial => FilePattern -> [String] -> FilePath +substitute w xs = maybe (error msg) renderPath $ Core.substitute (parsePattern w) xs + where + msg = "Failed substitute, patterns of different arity. Pattern " ++ show w ++ + " expects " ++ show (arity w) ++ " elements, but got " ++ show (length xs) ++ + " namely " ++ show xs ++ "." + + +-- | Efficiently match many 'FilePattern's against many 'FilePath's in a single operation. +-- Note that the returned matches are not guaranteed to be in any particular order. +-- +-- > matchMany [(a, pat)] [(b, path)] == maybeToList (map (a,b,) (match pat path)) +matchMany :: [(a, FilePattern)] -> [(b, FilePath)] -> [(a, b, [String])] +matchMany pats = f (step pats) . makeTree . map (second $ (\(Core.Path x) -> x) . parsePath) + where + f Step{..} (Tree bs xs) = concat $ + [(a, b, ps) | (a, ps) <- stepDone, b <- bs] : + [f (stepApply x) t | (x, t) <- xs, case stepNext of StepOnly xs -> x `elem` xs; _ -> True] diff --git a/src/System/FilePattern/Core.hs b/src/System/FilePattern/Core.hs new file mode 100644 --- /dev/null +++ b/src/System/FilePattern/Core.hs @@ -0,0 +1,128 @@ + +-- | The type of patterns and wildcards, and operations working on parsed versions. +module System.FilePattern.Core( + FilePattern, + Pattern(..), parsePattern, + Path(..), parsePath, renderPath, + mkParts, + match, substitute, + arity + ) where + +import Data.Functor +import Control.Applicative +import System.FilePattern.Wildcard +import System.FilePath (isPathSeparator) +import Data.Either.Extra +import Data.Traversable +import qualified Data.Foldable as F +import System.FilePattern.Monads +import Data.List.Extra +import Prelude + + +-- | A type synonym for file patterns, containing @**@ and @*@. For the syntax +-- and semantics of 'FilePattern' see 'System.FilePattern.?=='. +-- +-- Most 'FilePath' values lacking literal @.@ and @..@ components are suitable as 'FilePattern' values which match +-- only that specific file. On Windows @\\@ is treated as equivalent to @\/@. +-- +-- You can write 'FilePattern' values as a literal string, or build them +-- up using the operators '<.>' and '' (but be aware that @\"\" '' \"foo\"@ produces @\"./foo\"@). +type FilePattern = String + + +newtype Path = Path [String] + deriving (Show,Eq,Ord) + +newtype Pattern = Pattern (Wildcard [Wildcard String]) + deriving (Show,Eq,Ord) + + +-- [Note: Split on ""] +-- +-- For parsing patterns and paths, "" can either be [] or [""]. +-- Assuming they are consistent, the only cases that are relevant are: +-- +-- > match "" "" = Just [] +-- > match "*" "" = if [] then Nothing else Just [""] +-- > match "**" "" = if [] then Just [] else Just [""] +-- +-- We pick "" splits as [""] because that is slightly more permissive, +-- follows the builtin semantics of split, and matches the 'filepath' +-- library slightly better. + +parsePath :: FilePath -> Path +parsePath = Path . split isPathSeparator + +renderPath :: Path -> FilePattern +renderPath (Path x) = intercalate "/" x + +parsePattern :: FilePattern -> Pattern +parsePattern = Pattern . fmap (map $ f '*') . f "**" . split isPathSeparator + where + f :: Eq a => a -> [a] -> Wildcard [a] + f x xs = case split (== x) xs of + pre:mid_post -> case unsnoc mid_post of + Nothing -> Literal pre + Just (mid, post) -> Wildcard pre mid post + + +-- [Note: Conversion of parts to String] +-- +-- The match of * is String, but the match for ** is really [String]. +-- To simplify the API, since everything else is String encoding [String], +-- we want to convert that [String] to String. We considered 3 solutions. +-- +-- 1) Since we know the elements of [String] don't contain /, a natural +-- solution is to insert / characters between items with intercalate, but that +-- doesn't work because [] and [""] end up with the same representation, but +-- are very different, e.g. +-- +-- > match "**/a" "a" = Just [] +-- > match "**/a" "/a" = Just [""] +-- +-- 2) We can join with "/" after every component, so ["a","b"] becomes +-- "a/b/". But that causes / characters to appear from nowhere, e.g. +-- +-- > match "**" "a" = Just ["a/"] +-- +-- 3) Logically, the only sensible encoding for [] must be "". Because [""] +-- can't be "" (would clash), it must be "/". Therefore we follow solution 2 normally, +-- but switch to solution 1 iff all the components are empty. +-- We implement this scheme with mkParts/fromParts. +-- +-- Even after all that, we still have weird corner cases like: +-- +-- > match "**" "/" = Just ["//"] +-- +-- But the only realistic path it applies to is /, which should be pretty rare. + + +mkParts :: [String] -> String +mkParts xs | all null xs = replicate (length xs) '/' + | otherwise = intercalate "/" xs + +fromParts :: String -> [String] +fromParts xs | all isPathSeparator xs = replicate (length xs) [] + | otherwise = split isPathSeparator xs + +match :: Pattern -> Path -> Maybe [String] +match (Pattern w) (Path x) = f <$> wildcardMatch (wildcardMatch equals) w x + where + f :: [Either [[Either [()] String]] [String]] -> [String] + f (Left x:xs) = rights (concat x) ++ f xs + f (Right x:xs) = mkParts x : f xs + f [] = [] + + +substitute :: Pattern -> [String] -> Maybe Path +substitute (Pattern w) ps = do + let inner w = concat <$> wildcardSubst getNext pure w + outer w = concat <$> wildcardSubst (fromParts <$> getNext) (traverse inner) w + (ps, v) <- runNext ps $ outer w + if null ps then Just $ Path v else Nothing + + +arity :: Pattern -> Int +arity (Pattern x) = sum $ wildcardArity x : map wildcardArity (concat $ F.toList x) diff --git a/src/System/FilePattern/Directory.hs b/src/System/FilePattern/Directory.hs new file mode 100644 --- /dev/null +++ b/src/System/FilePattern/Directory.hs @@ -0,0 +1,97 @@ + +-- | Optimised directory traversal using 'FilePattern' values. +-- +-- /Case Sensitivity/: these traversals are optimised to reduce the number of IO operations +-- performed. In particular, if the relevant subdirectories can be determined in +-- advance it will use 'doesDirectoryExist' rather than 'getDirectoryContents'. +-- However, on case-insensitive file systems, if there is a directory @foo@, +-- then @doesDirectoryExist \"FOO\"@ will report @True@, but @FOO@ won't be a result +-- returned by 'getDirectoryContents', which may result in different search results +-- depending on whether a certain optimisations kick in. +-- +-- If these optimisation differences are absolutely unacceptable use 'getDirectoryFilesIgnoreSlow'. +-- However, normally these differences are not a problem. +module System.FilePattern.Directory( + getDirectoryFiles, + getDirectoryFilesIgnore, + getDirectoryFilesIgnoreSlow + ) where + +import Control.Monad.Extra +import Data.Functor +import Data.List +import System.Directory +import System.FilePath +import System.FilePattern.Core +import System.FilePattern.Step +import Prelude + + +-- | Get the files below a certain root that match any of the 'FilePattern' values. Only matches +-- files, not directories. Avoids traversing into directories that it can detect won't have +-- any matches in. +-- +-- > getDirectoryFiles "myproject/src" ["**/*.h","**/*.c"] +-- +-- If there are certain directories/files that should not be explored, use 'getDirectoryFilesIgnore'. +-- +-- /Warning/: on case-insensitive file systems certain optimisations can cause surprising results. +-- See the top of the module for details. +getDirectoryFiles :: FilePath -> [FilePattern] -> IO [FilePath] +getDirectoryFiles dir match = operation False dir match [] + + + +-- | Get the files below a certain root matching any of the first set of 'FilePattern' values, +-- but don't return any files which match any ignore pattern. Typically the ignore pattens will +-- end with @\/**@, e.g. @.git\/**@. +-- +-- /Warning/: on case-insensitive file systems certain optimisations can cause surprising results. +-- See the top of the module for details. +getDirectoryFilesIgnore :: FilePath -> [FilePattern] -> [FilePattern] -> IO [FilePath] +getDirectoryFilesIgnore = operation False + + +-- | Like 'getDirectoryFilesIgnore' but that the optimisations that may change behaviour on a +-- case-insensitive file system. Note that this function will never return more results +-- then 'getDirectoryFilesIgnore', and may return less. However, it will obey invariants +-- such as: +-- +-- > getDirectoryFilesIgnoreSlow root [x] [] ++ getDirectoryFilesIgnoreSlow root [y] [] +-- > == getDirectoryFilesIgnoreSlow root [x,y] [] +-- +-- In contrast 'getDirectoryFilesIgnore' only guarantees that invariant on +-- case-sensitive file systems. +getDirectoryFilesIgnoreSlow :: FilePath -> [FilePattern] -> [FilePattern] -> IO [FilePath] +getDirectoryFilesIgnoreSlow = operation True + + +operation :: Bool -> FilePath -> [FilePattern] -> [FilePattern] -> IO [FilePath] +operation slow rootBad yes no = f [] (step_ yes) (step_ no) + where + -- normalise out Windows vs other behaviour around "", make sure we end with / + root = if rootBad == "" then "./" else addTrailingPathSeparator rootBad + + -- parts is a series of path components joined with trailing / characters + f parts yes no + | StepEverything <- stepNext no = return [] + | not slow, StepOnly xs <- stepNext yes = g parts yes no xs False + | otherwise = do + xs <- filter (not . all (== '.')) <$> getDirectoryContents (root ++ parts) + g parts yes no xs True + + -- doesExist means that one of doesFileExist or doesDirectoryExist is true + g parts yes no xs doesExist = + concatForM (sort xs) $ \x -> do + let path = root ++ parts ++ x + -- deliberately shadow since using yes/no from now on would be wrong + yes <- return $ stepApply yes x + no <- return $ stepApply no x + isFile <- if stepDone yes /= [] && stepDone no == [] then Just <$> doesFileExist path else return Nothing + case isFile of + Just True -> return [parts ++ x] + _ | StepEverything <- stepNext no -> return [] + | StepOnly [] <- stepNext yes -> return [] + | otherwise -> do + b <- if doesExist && isFile == Just False then return True else doesDirectoryExist path + if not b then return [] else f (parts ++ x ++ "/") yes no diff --git a/src/System/FilePattern/ListBy.hs b/src/System/FilePattern/ListBy.hs new file mode 100644 --- /dev/null +++ b/src/System/FilePattern/ListBy.hs @@ -0,0 +1,30 @@ + +-- | Operations on lists, generated to an arbitrary generating equality +module System.FilePattern.ListBy( + eqListBy, stripPrefixBy, stripSuffixBy, stripInfixBy + ) where + +import Control.Applicative +import Data.Tuple.Extra + + +eqListBy :: (a -> b -> Maybe c) -> [a] -> [b] -> Maybe [c] +eqListBy _ [] [] = Just [] +eqListBy eq (a:as) (b:bs) = liftA2 (:) (eq a b) (eqListBy eq as bs) +eqListBy _ _ _ = Nothing + + +stripPrefixBy :: (a -> b -> Maybe c) -> [a] -> [b] -> Maybe ([c], [b]) +stripPrefixBy eq [] bs = Just ([], bs) +stripPrefixBy eq _ [] = Nothing +stripPrefixBy eq (a:as) (b:bs) = do c <- eq a b; first (c:) <$> stripPrefixBy eq as bs + +stripSuffixBy :: (a -> b -> Maybe c) -> [a] -> [b] -> Maybe ([b], [c]) +stripSuffixBy eq [] bs = Just (bs, []) -- shortcut, but equal to the equation below +stripSuffixBy eq _ [] = Nothing -- shortcut, but equal to the equation below +stripSuffixBy eq as bs = (\(c,b) -> (reverse b, reverse c)) <$> stripPrefixBy eq (reverse as) (reverse bs) + +stripInfixBy :: (a -> b -> Maybe c) -> [a] -> [b] -> Maybe ([b], [c], [b]) +stripInfixBy eq needle haystack | Just (ans, rest) <- stripPrefixBy eq needle haystack = Just ([], ans, rest) +stripInfixBy eq needle [] = Nothing +stripInfixBy eq needle (x:xs) = (\(a,b,c) -> (x:a,b,c)) <$> stripInfixBy eq needle xs diff --git a/src/System/FilePattern/Monads.hs b/src/System/FilePattern/Monads.hs new file mode 100644 --- /dev/null +++ b/src/System/FilePattern/Monads.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveFunctor #-} + +-- | Some useful Monads +module System.FilePattern.Monads( + Next, runNext, getNext + ) where + +import Control.Applicative +import Prelude + +-- | Next is a monad which has a series of elements, and can pull off the next one +newtype Next e a = Next ([e] -> Maybe ([e], a)) + deriving Functor + +instance Applicative (Next e) where + pure a = Next $ \es -> Just (es, a) + Next f <*> Next x = Next $ \es -> do + (es, f) <- f es + (es, x) <- x es + Just (es, f x) + +getNext :: Next e e +getNext = Next $ \x -> case x of + e:es -> Just (es, e) + _ -> Nothing + +runNext :: [e] -> Next e a -> Maybe ([e], a) +runNext ps (Next f) = f ps diff --git a/src/System/FilePattern/Step.hs b/src/System/FilePattern/Step.hs new file mode 100644 --- /dev/null +++ b/src/System/FilePattern/Step.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE ViewPatterns, DeriveFunctor, BangPatterns, TupleSections, RecordWildCards #-} + +-- | Applying a set of paths vs a set of patterns efficiently +module System.FilePattern.Step( + step, step_, Step(..), StepNext(..) + ) where + +import System.FilePattern.Core +import System.FilePattern.Tree +import System.FilePattern.Wildcard + +import Control.Monad.Extra +import Data.List.Extra +import Data.Semigroup +import Data.Tuple.Extra +import Data.Functor +import Data.Either +import qualified Data.List.NonEmpty as NE +import Prelude + + +-- | What we know about the next step values. +data StepNext + = + -- | All components not listed will result in dull 'Step' values from 'stepApply', + -- with 'stepNext' being @'StepOnly' []@ and 'stepDone' being @[]@. The field is a set - their order + -- is irrelevant but there will be no duplicates in values arising from 'step'. + StepOnly [String] + | -- | All calls to 'stepApply' will return 'stepNext' being 'StepEverything' with a non-empty 'stepDone'. + StepEverything + | -- | We have no additional information about the output from 'stepApply'. + StepUnknown + deriving (Eq,Ord,Show) + + +mergeStepNext :: [StepNext] -> StepNext +mergeStepNext = f id + where + f rest [] = StepOnly $ rest [] + f rest (StepUnknown:xs) = if StepEverything `elem` xs then StepEverything else StepUnknown + f rest (StepEverything:xs) = StepEverything + f rest (StepOnly x:xs) = f (rest . (x ++)) xs + +normaliseStepNext :: StepNext -> StepNext +normaliseStepNext (StepOnly xs) = StepOnly $ nubOrd xs +normaliseStepNext x = x + + +instance Semigroup StepNext where + a <> b = sconcat $ NE.fromList [a,b] + sconcat = normaliseStepNext . mergeStepNext . NE.toList + +instance Monoid StepNext where + mempty = StepOnly [] + mappend = (<>) + mconcat = maybe mempty sconcat . NE.nonEmpty -- important: use the fast sconcat + + +-- | The result of 'step', used to process successive path components of a set of 'FilePath's. +data Step a = Step + {stepDone :: [(a, [String])] + -- ^ The files that match at this step. Includes the list that would have been produced by 'System.FilePattern.match', + -- along with the values passed to 'step'. These results are not necessarily in order. + ,stepNext :: StepNext + -- ^ Information about the results of calling 'stepApply'. See 'StepNext' for details. + ,stepApply :: String -> Step a + -- ^ Apply one component from a 'FilePath' to get a new 'Step'. + } + deriving Functor + +mergeStep :: (StepNext -> StepNext) -> [Step a] -> Step a +mergeStep f [] = mempty +mergeStep f [x] = x +mergeStep f xs = Step + {stepDone = concatMap stepDone xs + ,stepNext = f $ mergeStepNext $ map stepNext xs + ,stepApply = \x -> mergeStep f $ map (`stepApply` x) xs + } + +instance Semigroup (Step a) where + a <> b = sconcat $ NE.fromList [a,b] + sconcat (NE.toList -> ss) + | [s] <- ss = s + | otherwise = Step + {stepDone = concatMap stepDone ss + ,stepNext = mconcat $ map stepNext ss + ,stepApply = \x -> fastFoldMap (`stepApply` x) ss + } + +instance Monoid (Step a) where + mempty = Step [] mempty $ const mempty + mappend = (<>) + mconcat = maybe mempty sconcat . NE.nonEmpty -- important: use the fast sconcat + +fastFoldMap :: Monoid m => (a -> m) -> [a] -> m +fastFoldMap f = mconcat . map f -- important: use the fast mconcat + + +-- Invariant: No two adjacent Lits +-- Invariant: No empty Lits +data Pat = Lits [Wildcard String] + | StarStar + | End + deriving (Show,Eq,Ord) + +toPat :: Pattern -> [Pat] +toPat (Pattern (Literal xs)) = [Lits xs] +toPat (Pattern (Wildcard pre mid post)) = intercalate [StarStar] $ map lit $ pre : mid ++ [post] + where lit xs = [Lits xs | xs /= []] + + +-- | Efficient matching of a set of 'FilePattern's against a set of 'FilePath's. +-- First call 'step' passing in all the 'FilePattern's, with a tag for each one. +-- Next call the methods of 'Step', providing the components of the 'FilePath's in turn. +-- +-- Useful for efficient bulk searching, particularly directory scanning, where you can +-- avoid descending into directories which cannot match. +step :: [(a, FilePattern)] -> Step a +step = restore . ($ id) . f [] . makeTree . map (second $ toPat . parsePattern) + where + f :: [Pat] -> Tree Pat a -> (Parts -> Step [a]) + f seen (Tree ends nxts) = \parts -> mergeStep id $ map ($ parts) $ sEnds ++ sNxts + where + sEnds = case unroll ends (seen ++ [End]) of + _ | null ends -> [] + Just ([], c) -> [c (error "step invariant violated (1)")] + _ -> error $ "step invariant violated (2), " ++ show seen + + sNxts = flip map nxts $ \(p,ps) -> + let seen2 = seen ++ [p] in + case unroll (error "step invariant violated (3)") seen2 of + Nothing -> f seen2 ps + Just (nxt, c) -> c (f [] $ retree nxt ps) + + retree [] t = t + retree (p:ps) t = Tree [] [(p, retree ps t)] + + restore :: Step [a] -> Step a -- and restore the stepNext invariant + restore Step{..} = Step + {stepDone = [(a, b) | (as,b) <- stepDone, a <- as] + ,stepNext = normaliseStepNext stepNext + ,stepApply = restore . stepApply + } + +-- | Like 'step' but using @()@ as the tag for each 'FilePattern'. +step_ :: [FilePattern] -> Step () +step_ = step . map ((),) + + +match1 :: Wildcard String -> String -> Maybe [String] +match1 w x = rights <$> wildcardMatch equals w x + + +type Parts = [String] -> [String] + +-- Given a prefix of the pattern, if you can deal with it, return +-- the rest of the pattern in the prefix you didn't match, and something that given +-- a matcher for the rest of the pattern, returns a matcher for the whole pattern. +unroll :: a -> [Pat] -> Maybe ([Pat], (Parts -> Step a) -> Parts -> Step a) +-- normal path, dispatch on what you find next +unroll val [End] = Just ([], \_ parts -> mempty{stepDone = [(val, parts [])]}) + +-- two stars in a row, the first will match nothing, the second everything +unroll val [StarStar,StarStar] = Just ([StarStar], \cont parts -> cont (parts . ([]:))) + +-- if you have literals next, match them +unroll val [Lits (l:ls)] = Just ([Lits ls | ls /= []], \cont parts -> Step + {stepDone = [] + ,stepNext = case l of Literal v -> StepOnly [v]; Wildcard{} -> StepUnknown + ,stepApply = \s -> case match1 l s of + Just xs -> cont (parts . (xs++)) + Nothing -> mempty + }) + +-- if anything else is allowed, just quickly allow it +unroll val [StarStar,End] = Just ([], \_ parts -> g parts []) + where + g parts rseen = Step + {stepDone = [(val, parts [mkParts $ reverse rseen])] + ,stepNext = StepEverything + ,stepApply = \s -> g parts (s:rseen) + } + +-- if you have a specific tail prefix, find it +unroll val [StarStar,Lits (reverse &&& length -> (rls,nls)),End] = Just ([], \_ parts -> g parts 0 []) + where + g parts !nseen rseen = Step + {stepDone = case zipWithM match1 rls rseen of + _ | nseen < nls -> [] -- fast path + Just xss -> [(val, parts $ mkParts (reverse $ drop nls rseen) : concat (reverse xss))] + Nothing -> [] + ,stepNext = StepUnknown + ,stepApply = \s -> g parts (nseen+1) (s:rseen) + } + +-- we know the next literal, and it doesn't have any constraints immediately after +unroll val [StarStar,Lits [l],StarStar] = Just ([StarStar], \cont parts -> g cont parts []) + where + g cont parts rseen = Step + {stepDone = [] + ,stepNext = StepUnknown + ,stepApply = \s -> case match1 l s of + Just xs -> cont (parts . (++) (mkParts (reverse rseen) : xs)) + Nothing -> g cont parts (s:rseen) + } + +-- the hard case, a floating substring, accumulate at least N, then star testing in reverse +unroll val [StarStar,Lits (reverse &&& length -> (rls,nls)),StarStar] = Just ([StarStar], \cont parts -> g cont parts 0 []) + where + g cont parts !nseen rseen = Step + {stepDone = [] + ,stepNext = StepUnknown + ,stepApply = \s -> case zipWithM match1 rls (s:rseen) of + _ | nseen+1 < nls -> g cont parts (nseen+1) (s:rseen) -- not enough accumulated yet + Nothing -> g cont parts (nseen+1) (s:rseen) + Just xss -> cont (parts . (++) (mkParts (reverse $ drop nls $ s:rseen) : concat (reverse xss))) + } + +unroll _ _ = Nothing diff --git a/src/System/FilePattern/Tree.hs b/src/System/FilePattern/Tree.hs new file mode 100644 --- /dev/null +++ b/src/System/FilePattern/Tree.hs @@ -0,0 +1,19 @@ + +-- | Build up shared prefix trees +module System.FilePattern.Tree( + Tree(..), makeTree + ) where + +import Data.List.Extra +import Prelude + + +data Tree k v = Tree [v] [(k, Tree k v)] + +makeTree :: Ord k => [(v, [k])] -> Tree k v +makeTree = f . sortOn snd + where + f xs = Tree (map fst empty) [(fst $ head gs, f $ map snd gs) | gs <- groups] + where + (empty, nonEmpty) = span (null . snd) xs + groups = groupOn fst [(x, (a,xs)) | (a,x:xs) <- nonEmpty] diff --git a/src/System/FilePattern/Wildcard.hs b/src/System/FilePattern/Wildcard.hs new file mode 100644 --- /dev/null +++ b/src/System/FilePattern/Wildcard.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable #-} + +-- | The type of wildcards, which generalises to both patterns +-- inside a filename and along patterns. e.g. +-- +-- > *xy* = Wildcard [] ["xy"] [] +-- > **/xxx/yyy/** = Wildcard [] [[Literal "xxx", Literal "yyy"]] [] +-- +-- Some more examples focusing on the first type of pattern: +-- +-- > xyz = Literal "xyz" +-- > x*y*z = Wildcard "x" ["y"] ["z"] +-- > x**z = Wildcard "x" [""] ["z"] +module System.FilePattern.Wildcard( + Wildcard(..), + wildcardMatch, + wildcardSubst, + wildcardArity, + equals + ) where + +import Data.Functor +import Data.List.Extra +import Control.Applicative +import Control.Monad.Extra +import System.FilePattern.ListBy +import Data.Traversable +import qualified Data.Foldable as F +import Prelude + + +equals :: Eq a => a -> a -> Maybe () +equals x y = if x == y then Just () else Nothing + + +-- | Representing either literals, or wildcards +data Wildcard a = Wildcard a [a] a -- ^ prefix [mid-parts] suffix + | Literal a -- ^ literal match + deriving (Show,Eq,Ord,Functor,F.Foldable) + +-- | Given a wildcard, and a test string, return the matches. +-- Only return the first (all patterns left-most) valid star matching. +wildcardMatch :: (a -> b -> Maybe c) -> Wildcard [a] -> [b] -> Maybe [Either [c] [b]] +wildcardMatch eq (Literal mid) x = (:[]) . Left <$> eqListBy eq mid x +wildcardMatch eq (Wildcard pre mid post) x = do + (pre, x) <- stripPrefixBy eq pre x + (x, post) <- stripSuffixBy eq post x + mid <- stripInfixes mid x + return $ [Left pre] ++ mid ++ [Left post] + where + stripInfixes [] x = Just [Right x] + stripInfixes (m:ms) y = do + (a,b,x) <- stripInfixBy eq m y + (\c -> Right a:Left b:c) <$> stripInfixes ms x + + +wildcardSubst :: Applicative m => m b -> (a -> m b) -> Wildcard a -> m [b] +wildcardSubst gap lit (Literal x) = (:[]) <$> lit x +wildcardSubst gap lit (Wildcard pre mid post) = (:) <$> + lit pre <*> + (concat <$> traverse (\v -> (\a b -> [a,b]) <$> gap <*> lit v) (mid ++ [post])) + + +wildcardArity :: Wildcard a -> Int +wildcardArity (Literal _) = 0 +wildcardArity (Wildcard _ xs _) = length xs + 1 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE RecordWildCards, TupleSections #-} + +module Main(main) where + +import Control.Monad.Extra +import Data.List.Extra +import Data.Functor +import Data.Tuple.Extra +import qualified Test.Util as T +import Data.Maybe +import System.FilePattern as FilePattern +import System.FilePath(isPathSeparator) +import System.IO.Unsafe +import Test.QuickCheck +import Test.Cases +import Prelude + + +--------------------------------------------------------------------- +-- TEST UTILITIES + +newtype ArbPattern = ArbPattern FilePattern deriving (Show,Eq) +newtype ArbPath = ArbPath FilePath deriving (Show,Eq) + +-- Since / and * are the only "interesting" elements, just add ab to round out the set + +instance Arbitrary ArbPattern where + arbitrary = fmap (ArbPattern . concat) $ listOf $ elements $ "**" : map (:[]) "\\/*ab." + shrink (ArbPattern x) = map ArbPattern $ shrinkList (\x -> ['/' | x == '\\']) x + +instance Arbitrary ArbPath where + arbitrary = fmap ArbPath $ listOf $ elements "\\/ab." + shrink (ArbPath x) = map ArbPath $ shrinkList (\x -> ['/' | x == '\\']) x + + +runStepSimple :: FilePattern -> FilePath -> Maybe [String] +runStepSimple pat path = f (step_ [pat]) $ split isPathSeparator path + where + f Step{..} [] = snd <$> listToMaybe stepDone + f Step{..} (x:xs) = f (stepApply x) xs + +runStepComplex :: FilePattern -> FilePath -> Maybe [String] +runStepComplex pat path = fmap thd3 $ listToMaybe $ matchMany [((), pat)] [((), path)] + + +--------------------------------------------------------------------- +-- DRIVER + +main :: IO () +main = do + putStrLn "Testing..." + testCases + T.TestData{..} <- T.unsafeTestData + putStrLn $ "Passed " ++ show testDataCases ++ " specific cases" + -- when False $ dot $ testWalk s + testProperties $ testDataPats ++ testDataPaths + putStrLn "SUCCESS (all tests completed)" + + +testProperties :: [String] -> IO () +testProperties xs = do + resOne <- fmap (catMaybes . concat) $ forM (zipFrom 1 xs) $ \(ix,x) -> forM (zipFrom 1 xs) $ \(iy,y) -> fmap (ix,iy,) <$> prop x y + let resMany = matchMany (zipFrom 1 xs) (zipFrom 1 xs) + T.assertBool (sort resOne == sort resMany) "matchMany" [] + putStrLn $ "Passed " ++ show (length xs ^ 2) ++ " properties on specific cases" + Success{} <- quickCheckWithResult stdArgs{maxSuccess=10000} $ \(ArbPattern p) (ArbPath x) -> + (if p ?== x then label "match" else property) $ unsafePerformIO $ prop p x >> return True + return () + where + prop :: FilePattern -> FilePath -> IO (Maybe [String]) + prop pat file = do + let ans = match pat file + let fields = ["Pattern" T.#= pat, "File" T.#= file, "Match" T.#= ans] + whenJust ans $ \ans -> T.assertBool (length ans == arity pat) "arity" fields + let res = pat ?== file in T.assertBool (res == isJust ans) "?==" $ fields ++ ["?==" T.#= res] + let res = runStepSimple pat file in T.assertBool (res == ans) "step (simple)" $ fields ++ ["step" T.#= res] + let res = runStepComplex pat file in T.assertBool (res == ans) "step (complex)" $ fields ++ ["step" T.#= res] + let norm = (\x -> if null x then [""] else x) . filter (/= ".") . split isPathSeparator + when (isJust ans) $ let res = substitute pat (fromJust $ FilePattern.match pat file) in + T.assertBool (norm res == norm file) "substitute" $ fields ++ ["Match" T.#= FilePattern.match pat file, "Got" T.#= res, "Input (norm)" T.#= norm file, "Got (norm)" T.#= norm res] + return ans diff --git a/test/Test/Cases.hs b/test/Test/Cases.hs new file mode 100644 --- /dev/null +++ b/test/Test/Cases.hs @@ -0,0 +1,167 @@ + +module Test.Cases(testCases) where + +import Test.Util +import System.FilePath(()) +import System.Info.Extra + + +testCases :: IO () +testCases = testMatch >> testArity >> testSubstitute >> testStepNext >> testDirectory + + +testArity :: IO () +testArity = do + arity "" 0 + arity "a*b" 1 + arity "a//b" 0 + arity "a/**/b" 1 + arity "/a/b/cccc_" 0 + arity "a///b" 0 + arity "foo/**/*" 2 + arity "//*a.txt" 1 + arity "foo//a*.txt" 1 + arity "**/*a.txt" 2 + arity "foo/**/a*.txt" 2 + arity "//*a.txt" 1 + arity "foo//a*.*txt" 2 + arity "foo/**/a*.*txt" 3 + + +testSubstitute :: IO () +testSubstitute = do + substitute "**/*a*.txt" ["","test","da"] "testada.txt" + substitute "**/*a.txt" ["foo/bar","test"] "foo/bar/testa.txt" + -- error if the number of replacements is wrong + substituteErr "nothing" ["test"] ["substitute","nothing","expects 0","got 1","test"] + substituteErr "*/*" ["test"] ["substitute","*/*","expects 2","got 1","test"] + + +testMatch :: IO () +testMatch = do + matchN "//*.c" "foo/bar/baz.c" + matchY "**/*.c" "foo/bar/baz.c" ["foo/bar","baz"] + matchY ("**" "*.c") ("foo/bar" "baz.c") ["foo/bar","baz"] + matchY "*.c" "baz.c" ["baz"] + matchN "//*.c" "baz.c" + matchY "**/*.c" "baz.c" ["","baz"] + matchY "**/*a.txt" "foo/bar/testa.txt" ["foo/bar","test"] + matchN "**/*.c" "baz.txt" + matchY "**/*a.txt" "testa.txt" ["","test"] + matchY "**/a.txt" "a.txt" [""] + matchY "a/**/b" "a/b" [""] + matchY "a/**/b" "a/x/b" ["x"] + matchY "a/**/b" "a/x/y/b" ["x/y"] + matchY "a/**/**/b" "a/x/y/b" ["","x/y"] + matchY "**/*a*.txt" "testada.txt" ["","test","da"] + matchY "test.c" "test.c" [] + matchN "*.c" "foor/bar.c" + matchN "*/*.c" "foo/bar/baz.c" + matchN "foo//bar" "foobar" + matchN "foo/**/bar" "foobar" + matchN "foo//bar" "foobar/bar" + matchN "foo/**/bar" "foobar/bar" + matchN "foo//bar" "foo/foobar" + matchN "foo/**/bar" "foo/foobar" + matchN "foo//bar" "foo/bar" + matchY "foo/**/bar" "foo/bar" [""] + matchY "foo/bar" ("foo" "bar") [] + matchY ("foo" "bar") "foo/bar" [] + matchY ("foo" "bar") ("foo" "bar") [] + matchY "**/*.c" ("bar" "baz" "foo.c") ["bar/baz","foo"] + matchY "**/*" "/bar" ["/","bar"] + matchN "/bob//foo" "/bob/this/test/foo" + matchY "/bob/**/foo" "/bob/this/test/foo" ["this/test"] + matchN "/bob//foo" "bob/this/test/foo" + matchN "/bob/**/foo" "bob/this/test/foo" + matchN "bob//foo/" "bob/this/test/foo/" + matchY "bob/**/foo/" "bob/this/test/foo/" ["this/test"] + matchY "bob/**/foo/" "bob/foo/" [""] + matchY "bob/**/foo/" "bob//foo/" ["/"] + matchN "bob//foo/" "bob/this/test/foo" + matchN "bob/**/foo/" "bob/this/test/foo" + matchY ("**" "*a*.txt") "testada.txt" ["","test","da"] + matchN "a//" "a" + matchY "a/**" "a" [""] + matchY "a/**" "a/" ["/"] + matchN "/a//" "/a" + matchY "a/**" "a" [""] + matchY "/a/**" "/a" [""] + matchN "///a//" "/a" + matchY "**/a/**" "/a" ["/",""] + matchN "///" "" + matchY "/**" "/" ["/"] + matchY "**/" "a/" ["a"] + matchY "**/**" "" ["","/"] + matchY "x/**/y" "x/y" [""] + matchY "x/**/" "x/" [""] + matchY "x/**/" "x/foo/" ["foo"] + matchN "x///" "x" + matchN "x/**/" "x" + matchY "x/**/" "x/foo/bar/" ["foo/bar"] + matchN "x///" "x/foo/bar" + matchN "x/**/" "x/foo/bar" + matchY "x/**/*/y" "x/z/y" ["","z"] + matchY "" "" [] + matchN "" "y" + matchN "" "/" + + matchY "*/*" "x/y" ["x","y"] + matchN "*/*" "x" + matchY "**/*" "x" ["","x"] + matchY "**/*" "" ["",""] + matchY "*/**" "x" ["x",""] + matchY "*/**/*" "x/y" ["x","","y"] + matchN "*//*" "" + matchN "*/**/*" "" + matchN "*//*" "x" + matchN "*/**/*" "x" + matchN "*//*//*" "x/y" + matchN "*/**/*/**/*" "x/y" + matchY "**/*/" "/" ["",""] + matchY "*/**/**/" "/" ["","",""] + matchN "b*b*b*//" "bb" + matchN "b*b*b*/**" "bb" + + matchY "**" "/" ["//"] -- UGLY corner case + matchY "**/x" "/x" ["/"] + matchY "**" "x/" ["x/"] + let s = if isWindows then '/' else '\\' + matchY "**" "\\\\drive" [s:s:"drive"] + matchY "**" "C:\\drive" ["C:"++s:"drive"] + matchY "**" "C:drive" ["C:drive"] + + matchN "./file" "file" + matchN "/file" "file" + matchN "foo/./bar" "foo/bar" + matchY "foo/./bar" "foo/./bar" [] + matchN "foo/./bar" "foo/bar" + matchY "**z" "xyz" ["","xy"] + matchY "**/a/b*" "a/a/a/a/bc" ["a/a/a","c"] + matchY "**/a/b/**" "a/a/a/a/b/c" ["a/a/a","c"] + + +testStepNext :: IO () +testStepNext = do + stepNext ["*.xml"] [] StepUnknown + stepNext ["*.xml"] ["foo"] $ StepOnly [] + stepNext ["**/*.xml"] [] StepUnknown + stepNext ["**/*.xml"] ["foo"] StepUnknown + stepNext ["foo/bar/*.xml"] [] $ StepOnly ["foo"] + stepNext ["foo/bar/*.xml"] ["oof"] $ StepOnly [] + stepNext ["foo/bar/*.xml"] ["foo"] $ StepOnly ["bar"] + stepNext ["a","b/c"] [] $ StepOnly ["a","b"] + stepNext ["a","b/c"] ["b"] $ StepOnly ["c"] + stepNext ["*/x"] [] StepUnknown + stepNext ["*/x"] ["foo"] $ StepOnly ["x"] + stepNext ["*/**"] ["bar"] StepEverything + + +testDirectory :: IO () +testDirectory = do + getDirectory ["**/*.c"] [] ["baz/test.c","baz/zoo.c","foo/bar.c","foo/foo/foo.c","zoo.c"] ["extra/test.h","foo.c/bob.h"] + -- Currently no way to test what it can access, sadly + -- should only look inside: foo + getDirectory ["foo/*.c"] [] ["foo/bar.c","foo/baz.c"] ["foo.c","foo/bar/baz.c","test/foo.c"] + -- should only look inside: . foo zoo + getDirectory ["foo/*.c","**/*.h"] [".git/**","**/no.*"] ["foo/bar.c","foo/baz.h","zoo/test.h"] ["foo/no.c",".git/foo.h","zoo/test.c"] diff --git a/test/Test/Util.hs b/test/Test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Util.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE RecordWildCards, ConstraintKinds #-} + +module Test.Util( + assertBool, (#=), + matchY, matchN, + arity, + substitute, substituteErr, + stepNext, + getDirectory, + TestData(..), unsafeTestData, + FP.StepNext(..) + ) where + +import Control.Exception.Extra +import Control.Monad.Extra +import Data.List.Extra +import Data.IORef.Extra +import System.Directory +import System.FilePath +import System.FilePattern(FilePattern) +import qualified System.FilePattern as FP +import qualified System.FilePattern.Directory as FP +import System.IO.Extra +import System.IO.Unsafe + + +--------------------------------------------------------------------- +-- COLLECT TEST DATA + +data TestData = TestData + {testDataCases :: {-# UNPACK #-} !Int + ,testDataPats :: [FilePattern] + ,testDataPaths :: [FilePath] + } + +{-# NOINLINE testData #-} +testData :: IORef TestData +testData = unsafePerformIO $ newIORef $ TestData 0 [] [] + +addTestData :: [FilePattern] -> [FilePath] -> IO () +addTestData pats paths = atomicModifyIORef' testData $ \t -> (f t, ()) + where f TestData{..} = TestData (testDataCases+1) (reverse pats ++ testDataPats) (reverse paths ++ testDataPaths) + +unsafeTestData :: IO TestData +unsafeTestData = atomicModifyIORef' testData $ \t -> (TestData 0 [] [], f t) + where f TestData{..} = TestData testDataCases (nubSort $ reverse testDataPats) (nubSort $ reverse testDataPaths) + + +--------------------------------------------------------------------- +-- TEST UTILITIES + +assertBool :: Partial => Bool -> String -> [String] -> IO () +assertBool b msg fields = unless b $ error $ unlines $ + ("ASSERTION FAILED: " ++ msg) : fields + +assertException :: (Show a, Partial) => IO a -> [String] -> String -> [String] -> IO () +assertException a parts msg fields = do + res <- try_ $ evaluate . length . show =<< a + case res of + Left e -> assertBool (all (`isInfixOf` show e) parts) msg $ ["Expected" #= parts, "Got" #= e] ++ fields + Right _ -> assertBool False msg $ ["Expected" #= parts, "Got" #= ""] ++ fields + +(#=) :: Show a => String -> a -> String +(#=) a b = a ++ ": " ++ show b + + +--------------------------------------------------------------------- +-- TEST WRAPPERS + +match :: Partial => FilePattern -> FilePath -> Maybe [String] -> IO () +match pat path want = do + addTestData [pat] [path] + let got = FP.match pat path + assertBool (want == got) "match" ["Pattern" #= pat, "Path" #= path, "Expected" #= want, "Got" #= got] + +matchY :: Partial => FilePattern -> FilePath -> [String] -> IO () +matchY pat path xs = match pat path $ Just xs + +matchN :: Partial => FilePattern -> FilePath -> IO () +matchN pat path = match pat path Nothing + + +arity :: Partial => FilePattern -> Int -> IO () +arity pat want = do + addTestData [pat] [] + let got = FP.arity pat + assertBool (want == got) "arity" ["Pattern" #= pat, "Expected" #= want, "Got" #= got] + + +substitute :: Partial => FilePattern -> [String] -> FilePath -> IO () +substitute pat parts want = do + addTestData [pat] [want] + let got = FP.substitute pat parts + assertBool (want == got) "substitute" ["Pattern" #= pat, "Parts" #= parts, "Expected" #= want, "Got" #= got] + +substituteErr :: Partial => FilePattern -> [String] -> [String] -> IO () +substituteErr pat parts want = do + addTestData [pat] [] + assertException (return $ FP.substitute pat parts) want "substitute" ["Pattern" #= pat, "Parts" #= parts] + + +stepNext :: [FilePattern] -> [String] -> FP.StepNext -> IO () +stepNext pat path want = do + addTestData pat [] + let got = f (FP.step_ pat) path + assertBool (want == got) "stepNext" ["Pattern" #= pat, "Path" #= path, "Expected" #= want, "Got" #= got] + where + f FP.Step{..} [] = stepNext + f FP.Step{..} (x:xs) = f (stepApply x) xs + + +getDirectory :: [FilePattern] -> [FilePattern] -> [FilePath] -> [FilePath] -> IO () +getDirectory match ignore want avoid = + withTempDir $ \root -> do + forM_ (want ++ avoid) $ \x -> do + createDirectoryIfMissing True $ root takeDirectory x + writeFile (root x) "" + got <- FP.getDirectoryFilesIgnore root match ignore + assertBool (want == got) "getDirectory" ["Root" #= root, "Match" #= match, "Ignore" #= ignore, "Want" #= want, "Got" #= got, "Avoid" #= avoid]