Glob 0.7.14 → 0.10.2
raw patch · 23 files changed
Files
- CHANGELOG.txt +263/−174
- CREDITS.txt +7/−5
- Glob.cabal +97/−87
- LICENSE.txt +28/−28
- README.txt +21/−21
- Setup.hs +2/−2
- System/FilePath/Glob.hs +79/−74
- System/FilePath/Glob/Base.hs +704/−636
- System/FilePath/Glob/Directory.hs +383/−297
- System/FilePath/Glob/Match.hs +178/−157
- System/FilePath/Glob/Primitive.hs +57/−57
- System/FilePath/Glob/Simplify.hs +42/−42
- System/FilePath/Glob/Utils.hs +186/−167
- tests/Main.hs +36/−32
- tests/Tests/Base.hs +91/−80
- tests/Tests/Compiler.hs +41/−22
- tests/Tests/Directory.hs +174/−0
- tests/Tests/Instances.hs +69/−59
- tests/Tests/Matcher.hs +78/−50
- tests/Tests/Optimizer.hs +55/−29
- tests/Tests/Regression.hs +156/−132
- tests/Tests/Simplifier.hs +34/−30
- tests/Tests/Utils.hs +54/−43
CHANGELOG.txt view
@@ -1,174 +1,263 @@-0.7.14, 2016-12-29:- Update dependencies to allow directory-1.3.--0.7.13, 2016-11-25:- Update test dependencies to allow HUnit-1.5.--0.7.12, 2016-10-07:- Update test dependencies to allow HUnit-1.4.--0.7.11, 2016-08-08:- Got rid of tests/Utils.hs to fix test compilation on case-insensitive- filesystems (tests/Utils.hs vs tests/Tests/Utils.hs).--0.7.10, 2016-07-18:- Update dependencies to allow dlist-0.8.--0.7.9, 2016-07-02:- Add missing Utils module to test suite, so that the tests provided with- the sdist tarball actually run.--0.7.8, 2016-07-01:- Add dependency on transformers-compat to allow using- Control.Monad.Trans.Except also with older library versions.--0.7.7, 2016-06-28:- Update test dependencies to allow HUnit-1.3.--0.7.6, 2016-06-28:- Update dependencies to allow filepath-1.4.-- Added Cabal Source-Repository metadata, pointing to GitHub.-- Integrated tests with Cabal so that they can be run with "cabal test".-- Got rid of deprecation warnings by using Control.Monad.Trans.Except- instead of Control.Monad.Trans.Error.-- Added Semigroup instance, bringing in a new dependency on semigroups on- pre-8.0 GHC versions.--0.7.5, 2014-05-08:- Update dependencies to allow transformers-0.4.--0.7.4, 2014-03-18:- Update dependencies to allow dlist-0.7.--0.7.3, 2013-12-01:- Update dependencies to allow dlist-0.6.--0.7.2, 2012-10-18:- Update dependencies to allow directory-1.2.--0.7.1, 2012-07-03:- Update dependencies to allow transformers-0.3, and generally tighten- them according to the policy.--0.7, 2012-01-03:- Changed function types:- System.FilePath.Glob.glob :: String -> IO [FilePath]- Now takes a String to be compiled instead of an already-compiled- Pattern.-- Added a README and more basic usage documentation.--0.6.1, 2011-09-14:- Bug fix: globDir should now ignore the given directory when given an- absolute path on Windows.-- Doc fix: noted that globDir doesn't actually fully ignore the given- directory if the Pattern starts with a path separator.--0.6, 2011-09-12:- New functions:- System.FilePath.Glob.glob :: Pattern -> IO [FilePath]-- Change: globDir, given a Pattern starting with a path separator, now ignores- the given directory. Thus e.g. globDir (compile "/*") d gives the- contents of "/" regardless of the value of d.-- Thanks to Max Bolingbroke for the feature request.-- Changed dependency on mtl to transformers.--0.5.1, 2010-11-23:- Update dependencies to allow for mtl 2.0.--0.5, 2009-12-01:- New functions:- System.FilePath.Glob.globDir :: Pattern -> FilePath -> IO [FilePath]--0.4, 2009-01-31:- New functions:- System.FilePath.Glob.commonDirectory :: Pattern -> (FilePath, Pattern)-- System.FilePath.Glob.simplify :: Pattern -> Pattern- System.FilePath.Glob.decompile :: Pattern -> String-- System.FilePath.Glob.tryCompileWith :: CompOptions -> String -> Either String Pattern- System.FilePath.Glob.compileWith :: CompOptions -> String -> Pattern- System.FilePath.Glob.compDefault :: CompOptions- System.FilePath.Glob.compPosix :: CompOptions-- System.FilePath.Glob.matchWith :: MatchOptions -> Pattern -> FilePath -> Bool- System.FilePath.Glob.globDirWith :: MatchOptions -> [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath])- System.FilePath.Glob.matchDefault :: MatchOptions- System.FilePath.Glob.matchPosix :: MatchOptions-- System.FilePath.Glob.Primitives.literal :: String -> Pattern- System.FilePath.Glob.Primitives.singleWildcard :: Pattern- System.FilePath.Glob.Primitives.wildcard :: Pattern- System.FilePath.Glob.Primitives.recursiveWildcard :: Pattern- System.FilePath.Glob.Primitives.charRange :: Bool -> [Either Char (Char,Char)] -> Pattern- System.FilePath.Glob.Primitives.numberRange :: Maybe Integer -> Maybe Integer -> Pattern-- Removed functions:- System.FilePath.Glob.tryCompile (no longer needed / superceded by tryCompileWith)-- New instances:- Monoid Pattern- Read Pattern-- Change: ".." can now be matched, by patterns such as ".*".- Change: globDir, given "" as the directory, uses getCurrentDirectory.- Change: globDir now keeps track of the number of path separators, thus- "a//*" will return "a//b" instead of "a/b" as a match result.- Change: if character ranges begin with ! or ^, these characters are now- considered the start of the range: [^-~] is the range ^ through ~,- not the inverse of [-~].-- Regression fix: handle directories without read permissions even more- properly.-- Bug fix: globDir doesn't convert patterns like "a./b" to "ab".- Bug fix: the Show instance used to show "[?]" as the very different "?" (and- a few similar cases).- Bug fix: "//./" wasn't getting optimized properly.- Bug fix: ".//a" matched "/a" and not "a" or "./a".- Bug fix: "f**/a" didn't match "foo/a".- Bug fix: ".**/a" didn't match ".foo/a".- Bug fix: ".**/a" matched "../a".- Bug fixes: globDir and match, in general, handled patterns starting with- ".*" or ".**/" quite differently.- Bug fix: globDir never matched "foo/" to the directory "foo".- Bug fix: globDir never matched "foo**/" to the directory "foo".- Bug fix: show (compile "[a!b]") resulted in "[!ab]".--0.3.2, 2008-12-20:- Regression fix: handle directories without read permissions properly.-- Convenience for developers: -XTemplateHaskell no longer barfs on- Compile.hs.--0.3.1, 2008-10-31:- Corrected the Cabal-Version field.--0.3, 2008-10-19:- Further performance improvements to globDir.- Bug fix: handle empty pattern lists correctly in globDir.- Added dependency: Win32, for Windows OSs.--0.2, 2008-10-18:- Performance improvements to globDir, no functionality changes.- Added dependency: dlist.--0.1, 2008-10-17:- Initial release.-- Functions:- System.FilePath.Glob.tryCompile :: String -> Either String Pattern- System.FilePath.Glob.compile :: String -> Pattern- System.FilePath.Glob.match :: Pattern -> FilePath -> Bool- System.FilePath.Glob.globDir :: [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath])-- Dependencies: base, containers, directory, filepath, mtl.+0.10.2, 2021-11-10: + Relaxed transformers-compat version bound. + + Supported Win32 2.12.0.0 or higher. + +0.10.1, 2020-07-19: + Updated code and dependencies to support dlist-1.0. + + Cabal-Version minimum bumped to 1.10 as Hackage now rejects older minima. + +0.10.0, 2018-12-19: + Bug fix: "**/" matched hidden directories in some scenarios even when + matchDotsImplicitly was set to False. + Thanks to Travis Sunderland for the report as well as the fix. + +0.9.3, 2018-09-22: + Updated dependencies to allow containers-0.7 (GHC 8.6). Thanks to + chessai for the merge request. + + Updated tests to compile with GHC 8.6. + +0.9.2, 2018-02-26: + Updated dependencies to allow transformers-compat-0.6. + +0.9.1, 2017-11-04: + Made Tests.Utils use Ints instead of Floats to avoid spurious failures + that aren't of any concern. + + Updated test dependencies to allow HUnit-1.6. + +0.9.0, 2017-10-01: + Thanks to Harry Garrood for many contributions to this release. + + New functions, data types, and constants: + System.FilePath.Glob.isLiteral :: Pattern -> Bool + Tells whether a Pattern is a literal file path. + + Thanks to Simon Hengel and Harry Garrood for the + feature request. + + System.FilePath.Glob.GlobOptions + Options for the glob* family of IO functions. + + System.FilePath.Glob.globDefault :: GlobOptions + Use matchDefault and don't return unmatched files. + + + Changed function types: + System.FilePath.Glob.globDir :: [Pattern] -> FilePath -> IO [[FilePath]] + No longer returns unmatched paths, like globDir1. + + System.FilePath.Glob.globDirWith :: GlobOptions -> [Pattern] -> FilePath -> IO ([[FilePath]], Maybe [FilePath]) + Takes GlobOptions instead of MatchOptions, and returns + unmatched paths in a Maybe corresponding to whether they + were requested in the options or not. + + This is a significant performance boost for all glob* + functions when unmatched file paths are not desired. + + Optimization: when unmatched file paths are not requested, glob and + globDir1 use commonDirectory to avoid extra + getDirectoryContents calls at the start. + Optimization: character ranges containing . or / are simplified more + than before, especially when they make the entire pattern + incapable of matching anything. + Optimization: extension separator matching where the extension is + surrounded by other literals (e.g. "*.txt" or "foo.*" or + simply "foo.txt") should be quicker in general, and the + Patterns should be smaller. (This adds to the number of + places where the code assumes that the extension separator + is the '.' character.) + + Bug fix: commonDirectory should no longer add extra directory separators + to the Pattern. + Bug fix: the glob* functions should now place slashes correctly when + using recursively matching patterns with extra slashes, such as + "**//foo". + Bug fix: number ranges are no longer optimized to single characters, so + that leading zeroes are handled correctly: e.g. "<0-9>" didn't + match "007". + Bug fix: "//" did not match itself. + Bug fix: ".//" did not match itself. + Bug fix: "x" did not match ".//x" (with ignoreDotSlash enabled). + Bug fix: "<-><->" matched single digit numbers. + Bug fix: "<0-0><1-1>" didn't match "01". + +0.8.0, 2017-05-27: + Added instance IsString Pattern, thanks to Mitsutoshi Aoe. + +0.7.14, 2016-12-29: + Update dependencies to allow directory-1.3. + +0.7.13, 2016-11-25: + Update test dependencies to allow HUnit-1.5. + +0.7.12, 2016-10-07: + Update test dependencies to allow HUnit-1.4. + +0.7.11, 2016-08-08: + Got rid of tests/Utils.hs to fix test compilation on case-insensitive + filesystems (tests/Utils.hs vs tests/Tests/Utils.hs). + +0.7.10, 2016-07-18: + Update dependencies to allow dlist-0.8. + +0.7.9, 2016-07-02: + Add missing Utils module to test suite, so that the tests provided with + the sdist tarball actually run. + +0.7.8, 2016-07-01: + Add dependency on transformers-compat to allow using + Control.Monad.Trans.Except also with older library versions. + +0.7.7, 2016-06-28: + Update test dependencies to allow HUnit-1.3. + +0.7.6, 2016-06-28: + Update dependencies to allow filepath-1.4. + + Added Cabal Source-Repository metadata, pointing to GitHub. + + Integrated tests with Cabal so that they can be run with "cabal test". + + Got rid of deprecation warnings by using Control.Monad.Trans.Except + instead of Control.Monad.Trans.Error. + + Added Semigroup instance, bringing in a new dependency on semigroups on + pre-8.0 GHC versions. + +0.7.5, 2014-05-08: + Update dependencies to allow transformers-0.4. + +0.7.4, 2014-03-18: + Update dependencies to allow dlist-0.7. + +0.7.3, 2013-12-01: + Update dependencies to allow dlist-0.6. + +0.7.2, 2012-10-18: + Update dependencies to allow directory-1.2. + +0.7.1, 2012-07-03: + Update dependencies to allow transformers-0.3, and generally tighten + them according to the policy. + +0.7, 2012-01-03: + Changed function types: + System.FilePath.Glob.glob :: String -> IO [FilePath] + Now takes a String to be compiled instead of an already-compiled + Pattern. + + Added a README and more basic usage documentation. + +0.6.1, 2011-09-14: + Bug fix: globDir should now ignore the given directory when given an + absolute path on Windows. + + Doc fix: noted that globDir doesn't actually fully ignore the given + directory if the Pattern starts with a path separator. + +0.6, 2011-09-12: + New functions: + System.FilePath.Glob.glob :: Pattern -> IO [FilePath] + + Change: globDir, given a Pattern starting with a path separator, now ignores + the given directory. Thus e.g. globDir (compile "/*") d gives the + contents of "/" regardless of the value of d. + + Thanks to Max Bolingbroke for the feature request. + + Changed dependency on mtl to transformers. + +0.5.1, 2010-11-23: + Update dependencies to allow for mtl 2.0. + +0.5, 2009-12-01: + New functions: + System.FilePath.Glob.globDir :: Pattern -> FilePath -> IO [FilePath] + +0.4, 2009-01-31: + New functions: + System.FilePath.Glob.commonDirectory :: Pattern -> (FilePath, Pattern) + + System.FilePath.Glob.simplify :: Pattern -> Pattern + System.FilePath.Glob.decompile :: Pattern -> String + + System.FilePath.Glob.tryCompileWith :: CompOptions -> String -> Either String Pattern + System.FilePath.Glob.compileWith :: CompOptions -> String -> Pattern + System.FilePath.Glob.compDefault :: CompOptions + System.FilePath.Glob.compPosix :: CompOptions + + System.FilePath.Glob.matchWith :: MatchOptions -> Pattern -> FilePath -> Bool + System.FilePath.Glob.globDirWith :: MatchOptions -> [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath]) + System.FilePath.Glob.matchDefault :: MatchOptions + System.FilePath.Glob.matchPosix :: MatchOptions + + System.FilePath.Glob.Primitives.literal :: String -> Pattern + System.FilePath.Glob.Primitives.singleWildcard :: Pattern + System.FilePath.Glob.Primitives.wildcard :: Pattern + System.FilePath.Glob.Primitives.recursiveWildcard :: Pattern + System.FilePath.Glob.Primitives.charRange :: Bool -> [Either Char (Char,Char)] -> Pattern + System.FilePath.Glob.Primitives.numberRange :: Maybe Integer -> Maybe Integer -> Pattern + + Removed functions: + System.FilePath.Glob.tryCompile (no longer needed / superceded by tryCompileWith) + + New instances: + Monoid Pattern + Read Pattern + + Change: ".." can now be matched, by patterns such as ".*". + Change: globDir, given "" as the directory, uses getCurrentDirectory. + Change: globDir now keeps track of the number of path separators, thus + "a//*" will return "a//b" instead of "a/b" as a match result. + Change: if character ranges begin with ! or ^, these characters are now + considered the start of the range: [^-~] is the range ^ through ~, + not the inverse of [-~]. + + Regression fix: handle directories without read permissions even more + properly. + + Bug fix: globDir doesn't convert patterns like "a./b" to "ab". + Bug fix: the Show instance used to show "[?]" as the very different "?" (and + a few similar cases). + Bug fix: "//./" wasn't getting optimized properly. + Bug fix: ".//a" matched "/a" and not "a" or "./a". + Bug fix: "f**/a" didn't match "foo/a". + Bug fix: ".**/a" didn't match ".foo/a". + Bug fix: ".**/a" matched "../a". + Bug fixes: globDir and match, in general, handled patterns starting with + ".*" or ".**/" quite differently. + Bug fix: globDir never matched "foo/" to the directory "foo". + Bug fix: globDir never matched "foo**/" to the directory "foo". + Bug fix: show (compile "[a!b]") resulted in "[!ab]". + +0.3.2, 2008-12-20: + Regression fix: handle directories without read permissions properly. + + Convenience for developers: -XTemplateHaskell no longer barfs on + Compile.hs. + +0.3.1, 2008-10-31: + Corrected the Cabal-Version field. + +0.3, 2008-10-19: + Further performance improvements to globDir. + Bug fix: handle empty pattern lists correctly in globDir. + Added dependency: Win32, for Windows OSs. + +0.2, 2008-10-18: + Performance improvements to globDir, no functionality changes. + Added dependency: dlist. + +0.1, 2008-10-17: + Initial release. + + Functions: + System.FilePath.Glob.tryCompile :: String -> Either String Pattern + System.FilePath.Glob.compile :: String -> Pattern + System.FilePath.Glob.match :: Pattern -> FilePath -> Bool + System.FilePath.Glob.globDir :: [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath]) + + Dependencies: base, containers, directory, filepath, mtl.
CREDITS.txt view
@@ -1,5 +1,7 @@-In alphabetical order by surname:--Stephen Hicks-Matti Niemenmaa-Masahiro Sakai+In alphabetical order by surname: + +Harry Garrood +Stephen Hicks +Matti Niemenmaa +Masahiro Sakai +Travis Sunderland
Glob.cabal view
@@ -1,87 +1,97 @@-Cabal-Version: >= 1.9.2--Name: Glob-Version: 0.7.14-Homepage: http://iki.fi/matti.niemenmaa/glob/-Synopsis: Globbing library-Category: System-Stability: provisional-Description:- A library for globbing: matching patterns against file paths.--Author: Matti Niemenmaa-Maintainer: Matti Niemenmaa <matti.niemenmaa+glob@iki.fi>-License: BSD3-License-File: LICENSE.txt--Build-Type: Simple--Extra-Source-Files: CHANGELOG.txt- CREDITS.txt- README.txt--Source-Repository head- Type: git- Location: https://github.com/Deewiant/glob--Library- Build-Depends: base >= 4 && < 5- , containers < 0.6- , directory < 1.4- , dlist >= 0.4 && < 0.9- , filepath >= 1.1 && < 1.5- , transformers >= 0.2 && < 0.6- , transformers-compat >= 0.3 && < 0.6-- if impl(ghc < 8.0)- Build-Depends: semigroups >= 0.18 && < 0.19-- if os(windows)- Build-Depends: Win32 == 2.*-- Exposed-Modules: System.FilePath.Glob- System.FilePath.Glob.Primitive- Other-Modules: System.FilePath.Glob.Base- System.FilePath.Glob.Directory- System.FilePath.Glob.Match- System.FilePath.Glob.Simplify- System.FilePath.Glob.Utils--Test-Suite glob-tests- type: exitcode-stdio-1.0-- hs-source-dirs: ., tests- main-is: Main.hs-- Build-Depends: base >= 4 && < 5- , containers < 0.6- , directory < 1.4- , dlist >= 0.4 && < 0.9- , filepath >= 1.1 && < 1.5- , transformers >= 0.2 && < 0.6- , transformers-compat >= 0.3 && < 0.6- , HUnit >= 1.2 && < 1.6- , QuickCheck >= 2 && < 3- , test-framework >= 0.2 && < 1- , test-framework-hunit >= 0.2 && < 1- , test-framework-quickcheck2 >= 0.3 && < 1-- if impl(ghc < 8.0)- Build-Depends: semigroups >= 0.18 && < 0.19-- if os(windows)- Build-Depends: Win32 == 2.*-- Other-Modules: System.FilePath.Glob.Base- System.FilePath.Glob.Directory- System.FilePath.Glob.Match- System.FilePath.Glob.Simplify- System.FilePath.Glob.Utils- Tests.Base- Tests.Compiler- Tests.Instances- Tests.Matcher- Tests.Optimizer- Tests.Regression- Tests.Simplifier- Tests.Utils+Cabal-Version: >= 1.10 + +Name: Glob +Version: 0.10.2 +Homepage: http://iki.fi/matti.niemenmaa/glob/ +Synopsis: Globbing library +Category: System +Stability: provisional +Description: + A library for globbing: matching patterns against file paths. + +Author: Matti Niemenmaa +Maintainer: Matti Niemenmaa <matti.niemenmaa+glob@iki.fi> +License: BSD3 +License-File: LICENSE.txt + +Build-Type: Simple + +Extra-Source-Files: CHANGELOG.txt + CREDITS.txt + README.txt + +Source-Repository head + Type: git + Location: https://github.com/Deewiant/glob + +Library + Build-Depends: base >= 4 && < 5 + , containers < 0.7 + , directory < 1.4 + , dlist >= 0.4 && < 1.1 + , filepath >= 1.1 && < 1.5 + , transformers >= 0.2 && < 0.6 + , transformers-compat >= 0.3 && < 0.8 + + if impl(ghc < 8.0) + Build-Depends: semigroups >= 0.18 && < 0.20 + + if os(windows) + Build-Depends: Win32 == 2.* + + Default-Language: Haskell98 + + Exposed-Modules: System.FilePath.Glob + System.FilePath.Glob.Primitive + Other-Modules: System.FilePath.Glob.Base + System.FilePath.Glob.Directory + System.FilePath.Glob.Match + System.FilePath.Glob.Simplify + System.FilePath.Glob.Utils + + GHC-Options: -Wall + +Test-Suite glob-tests + type: exitcode-stdio-1.0 + + hs-source-dirs: ., tests + main-is: Main.hs + + Build-Depends: base >= 4 && < 5 + , containers < 0.7 + , directory < 1.4 + , dlist >= 0.4 && < 1.1 + , filepath >= 1.1 && < 1.5 + , transformers >= 0.2 && < 0.6 + , transformers-compat >= 0.3 && < 0.8 + , HUnit >= 1.2 && < 1.7 + , QuickCheck >= 2 && < 3 + , test-framework >= 0.2 && < 1 + , test-framework-hunit >= 0.2 && < 1 + , test-framework-quickcheck2 >= 0.3 && < 1 + + if impl(ghc < 8.0) + Build-Depends: semigroups >= 0.18 && < 0.20 + + if os(windows) + Build-Depends: Win32 == 2.* + + Default-Language: Haskell98 + + Other-Modules: System.FilePath.Glob.Base + System.FilePath.Glob.Directory + System.FilePath.Glob.Match + System.FilePath.Glob.Primitive + System.FilePath.Glob.Simplify + System.FilePath.Glob.Utils + Tests.Base + Tests.Compiler + Tests.Directory + Tests.Instances + Tests.Matcher + Tests.Optimizer + Tests.Regression + Tests.Simplifier + Tests.Utils + + GHC-Options: -Wall
LICENSE.txt view
@@ -1,28 +1,28 @@-The code in Glob is released under the license below. Copyrights to parts of-the code are held by whoever wrote the code in question: see CREDITS.txt for a-list of authors.--Copyright (c) 2008-2016 <authors>-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 the project nor the names of its contributors may be- used to endorse or promote products derived from this software without- specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.+The code in Glob is released under the license below. Copyrights to parts of +the code are held by whoever wrote the code in question: see CREDITS.txt for a +list of authors. + +Copyright (c) 2008-2018 <authors> +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 the project nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.
README.txt view
@@ -1,21 +1,21 @@-This is Glob, a Haskell library for globbing, i.e. pattern matching file paths-akin to the POSIX glob() function. Haddock documentation is included, and can-be built with the 'cabal haddock' command. Basic usage info is repeated below:--Matching pattern (a String) against filepath (a FilePath):-- match (compile pattern) filepath--Matching a pattern against all paths in the current working directory:-- glob pattern--Matching a pattern against all paths in a given directory (a FilePath):-- globDir1 (compile pattern) directorypath--Matching a list of patterns against all paths in a given directory, returning-the matches for each pattern as well as the paths not matched by any of the-patterns:-- globDir (map compile patterns) directorypath+This is Glob, a Haskell library for globbing, i.e. pattern matching file paths +akin to the POSIX glob() function. Haddock documentation is included, and can +be built with the 'cabal haddock' command. Basic usage info is repeated below: + +Matching pattern (a String) against filepath (a FilePath): + + match (compile pattern) filepath + +Matching a pattern against all paths in the current working directory: + + glob pattern + +Matching a pattern against all paths in a given directory (a FilePath): + + globDir1 (compile pattern) directorypath + +Matching a list of patterns against all paths in a given directory, returning +the matches for each pattern as well as the paths not matched by any of the +patterns: + + globDir (map compile patterns) directorypath
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
System/FilePath/Glob.hs view
@@ -1,74 +1,79 @@--- File created: 2008-10-10 13:37:42---- | A library for globbing: matching patterns against file paths akin to the--- POSIX @glob()@ function.------ Pattern syntax is documented by 'compile'. To toggle features at compile--- time, look into 'CompOptions'. To modify matching behaviour, look into--- 'MatchOptions'.------ Basic usage examples:------ Matching a 'String' pattern against a 'FilePath':------ @--- 'match' ('compile' pattern) filepath--- @------ Matching a 'String' pattern against all paths in the current working--- directory:------ @--- 'glob' pattern--- @------ Matching a 'String' pattern against all paths in a given directory (a--- 'FilePath'):------ @--- 'globDir1' ('compile' pattern) directorypath--- @------ Matching a list of 'String' patterns against all paths in a given directory,--- returning the matches for each pattern as well as the paths not matched by--- any of the patterns:------ @--- 'globDir' (map 'compile' patterns) directorypath--- @-module System.FilePath.Glob- ( -- * Data type- Pattern- -- * Functions- -- ** Compilation- , compile, decompile, simplify- -- *** Options- , CompOptions(..)- , compileWith, tryCompileWith- -- **** Predefined option sets- , compDefault, compPosix- -- ** Matching- , match- , globDir, globDir1, glob- -- *** Options- , MatchOptions(..)- , matchWith- , globDirWith- -- **** Predefined option sets- , matchDefault, matchPosix- -- ** Miscellaneous- , commonDirectory- ) where--import System.FilePath.Glob.Base ( Pattern- , CompOptions(..), MatchOptions(..)- , compDefault, compPosix- , matchDefault, matchPosix- , compile, compileWith, tryCompileWith- , decompile- )-import System.FilePath.Glob.Directory ( globDir, globDirWith, globDir1, glob- , commonDirectory- )-import System.FilePath.Glob.Match (match, matchWith)-import System.FilePath.Glob.Simplify (simplify)+-- File created: 2008-10-10 13:37:42 + +-- | A library for globbing: matching patterns against file paths akin to the +-- POSIX @glob()@ function. +-- +-- Pattern syntax is documented by 'compile'. To toggle features at compile +-- time, look into 'CompOptions'. To modify matching behaviour, look into +-- 'MatchOptions'. +-- +-- Basic usage examples: +-- +-- Matching a 'String' pattern against a 'FilePath': +-- +-- @ +-- 'match' ('compile' pattern) filepath +-- @ +-- +-- Matching a 'String' pattern against all paths in the current working +-- directory: +-- +-- @ +-- 'glob' pattern +-- @ +-- +-- Matching a 'String' pattern against all paths in a given directory (a +-- 'FilePath'): +-- +-- @ +-- 'globDir1' ('compile' pattern) directorypath +-- @ +-- +-- Matching a list of 'String' patterns against all paths in a given directory, +-- returning the matches for each pattern as well as the paths not matched by +-- any of the patterns: +-- +-- @ +-- 'globDir' (map 'compile' patterns) directorypath +-- @ +module System.FilePath.Glob + ( -- * Data type + Pattern + -- * Functions + -- ** Compilation + , compile, decompile, simplify + -- *** Options + , CompOptions(..) + , compileWith, tryCompileWith + -- **** Predefined option sets + , compDefault, compPosix + -- ** Matching + , match + , globDir, globDir1, glob + -- *** Options + , MatchOptions(..) + , matchWith + , GlobOptions(..) + , globDirWith + -- **** Predefined option sets + , matchDefault, matchPosix + , globDefault + -- ** Miscellaneous + , commonDirectory + , isLiteral + ) where + +import System.FilePath.Glob.Base ( Pattern + , CompOptions(..), MatchOptions(..) + , compDefault, compPosix + , matchDefault, matchPosix + , compile, compileWith, tryCompileWith + , decompile + , isLiteral + ) +import System.FilePath.Glob.Directory ( GlobOptions(..), globDefault + , globDir, globDirWith, globDir1, glob + , commonDirectory + ) +import System.FilePath.Glob.Match (match, matchWith) +import System.FilePath.Glob.Simplify (simplify)
System/FilePath/Glob/Base.hs view
@@ -1,636 +1,704 @@--- File created: 2008-10-10 13:29:26--{-# LANGUAGE CPP #-}--module System.FilePath.Glob.Base- ( Token(..), Pattern(..)-- , CompOptions(..), MatchOptions(..)- , compDefault, compPosix, matchDefault, matchPosix-- , decompile-- , compile- , compileWith, tryCompileWith- , tokenize -- for tests-- , optimize-- , liftP, tokToLower- ) where--import Control.Arrow (first)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)-import Control.Monad.Trans.Writer.Strict (Writer, runWriter, tell)-import Control.Exception (assert)-import Data.Char (isDigit, isAlpha, toLower)-import Data.List (find, sortBy)-import Data.List.NonEmpty (toList)-import Data.Maybe (fromMaybe)-import Data.Monoid (Monoid, mappend, mempty, mconcat)-import Data.Semigroup (Semigroup, (<>), sconcat, stimes)-import System.FilePath ( pathSeparator, extSeparator- , isExtSeparator, isPathSeparator- )--import System.FilePath.Glob.Utils ( dropLeadingZeroes- , isLeft, fromLeft- , increasingSeq- , addToRange, overlap- )--#if __GLASGOW_HASKELL__-import Text.Read (readPrec, lexP, parens, prec, Lexeme(Ident))-#endif--data Token- -- primitives- = Literal !Char- | ExtSeparator -- .- | PathSeparator -- /- | NonPathSeparator -- ?- | CharRange !Bool [Either Char (Char,Char)] -- []- | OpenRange (Maybe String) (Maybe String) -- <>- | AnyNonPathSeparator -- *- | AnyDirectory -- **/-- -- after optimization only- | LongLiteral !Int String- deriving (Eq)---- Note: CharRanges aren't converted, because this is tricky in general.--- Consider for instance [@-[], which includes the range A-Z. This would need--- to become [@[a-z]: so essentially we'd need to either:------ 1) Have a list of ranges of uppercase Unicode. Check if our range--- overlaps with any of them and if it does, take the non-overlapping--- part and combine it with the toLower of the overlapping part.------ 2) Simply expand the entire range to a list and map toLower over it.------ In either case we'd need to re-optimize the CharRange—we can't assume that--- if the uppercase characters are consecutive, so are the lowercase.------ 1) might be feasible if someone bothered to get the latest data.------ 2) obviously isn't since you might have 'Right (minBound, maxBound)' in--- there somewhere.------ The current solution is to just check both the toUpper of the character and--- the toLower.-tokToLower :: Token -> Token-tokToLower (Literal c) = Literal (toLower c)-tokToLower (LongLiteral n s) = LongLiteral n (map toLower s)-tokToLower tok = tok---- |An abstract data type representing a compiled pattern.------ Note that the 'Eq' instance cannot tell you whether two patterns behave in--- the same way; only whether they compile to the same 'Pattern'. For instance,--- @'compile' \"x\"@ and @'compile' \"[x]\"@ may or may not compare equal,--- though a @'match'@ will behave the exact same way no matter which 'Pattern'--- is used.-newtype Pattern = Pattern { unPattern :: [Token] } deriving (Eq)--liftP :: ([Token] -> [Token]) -> Pattern -> Pattern-liftP f (Pattern pat) = Pattern (f pat)--instance Show Token where- show (Literal c)- | c `elem` "*?[<" || isExtSeparator c- = ['[',c,']']- | otherwise = assert (not $ isPathSeparator c) [c]- show ExtSeparator = [ extSeparator]- show PathSeparator = [pathSeparator]- show NonPathSeparator = "?"- show AnyNonPathSeparator = "*"- show AnyDirectory = "**/"- show (LongLiteral _ s) = concatMap (show . Literal) s- show (OpenRange a b) =- '<' : fromMaybe "" a ++ "-" ++- fromMaybe "" b ++ ">"-- -- We have to be careful here with ^ and ! lest [a!b] become [!ab]. So we- -- just put them at the end.- --- -- Also, [^x-] was sorted and should not become [^-x].- show (CharRange b r) =- let f = either (:[]) (\(x,y) -> [x,'-',y])- (caret,exclamation,fs) =- foldr (\c (ca,ex,ss) ->- case c of- Left '^' -> ("^",ex,ss)- Left '!' -> (ca,"!",ss)- _ -> (ca, ex,(f c ++) . ss)- )- ("", "", id)- r- (beg,rest) = let s' = fs []- (x,y) = splitAt 1 s'- in if not b && x == "-"- then (y,x)- else (s',"")- in concat [ "["- , if b then "" else "^"- , beg, caret, exclamation, rest- , "]"- ]--instance Show Pattern where- showsPrec d p = showParen (d > 10) $- showString "compile " . showsPrec (d+1) (decompile p)--instance Read Pattern where-#if __GLASGOW_HASKELL__- readPrec = parens . prec 10 $ do- Ident "compile" <- lexP- fmap compile readPrec-#else- readsPrec d = readParen (d > 10) $ \r -> do- ("compile",string) <- lex r- (xs,rest) <- readsPrec (d+1) string- [(compile xs, rest)]-#endif--instance Semigroup Pattern where- Pattern a <> Pattern b = optimize $ Pattern (a <> b)- sconcat = optimize . Pattern . concatMap unPattern . toList- stimes n (Pattern a) = optimize $ Pattern (stimes n a)--instance Monoid Pattern where- mempty = Pattern []- mappend = (<>)- mconcat = optimize . Pattern . concatMap unPattern---- |Options which can be passed to the 'tryCompileWith' or 'compileWith'--- functions: with these you can selectively toggle certain features at compile--- time.------ Note that some of these options depend on each other: classes can never--- occur if ranges aren't allowed, for instance.---- We could presumably put locale information in here, too.-data CompOptions = CompOptions- { characterClasses :: Bool -- ^Allow character classes, @[[:...:]]@.- , characterRanges :: Bool -- ^Allow character ranges, @[...]@.- , numberRanges :: Bool -- ^Allow open ranges, @\<...>@.- , wildcards :: Bool -- ^Allow wildcards, @*@ and @?@.- , recursiveWildcards :: Bool -- ^Allow recursive wildcards, @**/@.-- , pathSepInRanges :: Bool- -- ^Allow path separators in character ranges.- --- -- If true, @a[/]b@ never matches anything (since character ranges can't- -- match path separators); if false and 'errorRecovery' is enabled,- -- @a[/]b@ matches itself, i.e. a file named @]b@ in the subdirectory- -- @a[@.-- , errorRecovery :: Bool- -- ^If the input is invalid, recover by turning any invalid part into- -- literals. For instance, with 'characterRanges' enabled, @[abc@ is an- -- error by default (unclosed character range); with 'errorRecovery', the- -- @[@ is turned into a literal match, as though 'characterRanges' were- -- disabled.- } deriving (Show,Read,Eq)---- |The default set of compilation options: closest to the behaviour of the--- @zsh@ shell, with 'errorRecovery' enabled.------ All options are enabled.-compDefault :: CompOptions-compDefault = CompOptions- { characterClasses = True- , characterRanges = True- , numberRanges = True- , wildcards = True- , recursiveWildcards = True- , pathSepInRanges = True- , errorRecovery = True- }---- |Options for POSIX-compliance, as described in @man 7 glob@.------ 'numberRanges', 'recursiveWildcards', and 'pathSepInRanges' are disabled.-compPosix :: CompOptions-compPosix = CompOptions- { characterClasses = True- , characterRanges = True- , numberRanges = False- , wildcards = True- , recursiveWildcards = False- , pathSepInRanges = False- , errorRecovery = True- }---- |Options which can be passed to the 'matchWith' or 'globDirWith' functions:--- with these you can selectively toggle certain features at matching time.-data MatchOptions = MatchOptions- { matchDotsImplicitly :: Bool- -- ^Allow @*@, @?@, and @**/@ to match @.@ at the beginning of paths.-- , ignoreCase :: Bool- -- ^Case-independent matching.-- , ignoreDotSlash :: Bool- -- ^Treat @./@ as a no-op in both paths and patterns.- --- -- (Of course e.g. @../@ means something different and will not be- -- ignored.)- }---- |The default set of execution options: closest to the behaviour of the @zsh@--- shell.------ Currently identical to 'matchPosix'.-matchDefault :: MatchOptions-matchDefault = matchPosix---- |Options for POSIX-compliance, as described in @man 7 glob@.------ 'ignoreDotSlash' is enabled, the rest are disabled.-matchPosix :: MatchOptions-matchPosix = MatchOptions- { matchDotsImplicitly = False- , ignoreCase = False- , ignoreDotSlash = True- }---- |Decompiles a 'Pattern' object into its textual representation: essentially--- the inverse of 'compile'.------ Note, however, that due to internal optimization, @decompile . compile@ is--- not the identity function. Instead, @compile . decompile@ is.------ Be careful with 'CompOptions': 'decompile' always produces a 'String' which--- can be passed to 'compile' to get back the same 'Pattern'. @compileWith--- options . decompile@ is /not/ the identity function unless @options@ is--- 'compDefault'.-decompile :: Pattern -> String-decompile = concatMap show . unPattern----------------------------------------------- COMPILATION------------------------------------------------ |Compiles a glob pattern from its textual representation into a 'Pattern'--- object.------ For the most part, a character matches itself. Recognized operators are as--- follows:------ [@?@] Matches any character except path separators.------ [@*@] Matches any number of characters except path separators,--- including the empty string.------ [@[..\]@] Matches any of the enclosed characters. Ranges of characters can--- be specified by separating the endpoints with a @\'-'@. @\'-'@ or--- @']'@ can be matched by including them as the first character(s)--- in the list. Never matches path separators: @[\/]@ matches--- nothing at all. Named character classes can also be matched:--- @[:x:]@ within @[]@ specifies the class named @x@, which matches--- certain predefined characters. See below for a full list.------ [@[^..\]@ or @[!..\]@] Like @[..]@, but matches any character /not/ listed.--- Note that @[^-x]@ is not the inverse of @[-x]@, but--- the range @[^-x]@.------ [@\<m-n>@] Matches any integer in the range m to n, inclusive. The range may--- be open-ended by leaving out either number: @\"\<->\"@, for--- instance, matches any integer.------ [@**/@] Matches any number of characters, including path separators,--- excluding the empty string.------ Supported character classes:------ [@[:alnum:\]@] Equivalent to @\"0-9A-Za-z\"@.------ [@[:alpha:\]@] Equivalent to @\"A-Za-z\"@.------ [@[:blank:\]@] Equivalent to @\"\\t \"@.------ [@[:cntrl:\]@] Equivalent to @\"\\0-\\x1f\\x7f\"@.------ [@[:digit:\]@] Equivalent to @\"0-9\"@.------ [@[:graph:\]@] Equivalent to @\"!-~\"@.------ [@[:lower:\]@] Equivalent to @\"a-z\"@.------ [@[:print:\]@] Equivalent to @\" -~\"@.------ [@[:punct:\]@] Equivalent to @\"!-\/:-\@[-`{-~\"@.------ [@[:space:\]@] Equivalent to @\"\\t-\\r \"@.------ [@[:upper:\]@] Equivalent to @\"A-Z\"@.------ [@[:xdigit:\]@] Equivalent to @\"0-9A-Fa-f\"@.------ Note that path separators (typically @\'/\'@) have to be matched explicitly--- or using the @**/@ pattern. In addition, extension separators (typically--- @\'.\'@) have to be matched explicitly at the beginning of the pattern or--- after any path separator.------ If a system supports multiple path separators, any one of them will match--- any of them. For instance, on Windows, @\'/\'@ will match itself as well as--- @\'\\\'@.------ Error recovery will be performed: erroneous operators will not be considered--- operators, but matched as literal strings. Such operators include:------ * An empty @[]@ or @[^]@ or @[!]@------ * A @[@ or @\<@ without a matching @]@ or @>@------ * A malformed @\<>@: e.g. nonnumeric characters or no hyphen------ So, e.g. @[]@ will match the string @\"[]\"@.-compile :: String -> Pattern-compile = compileWith compDefault---- |Like 'compile', but recognizes operators according to the given--- 'CompOptions' instead of the defaults.------ If an error occurs and 'errorRecovery' is disabled, 'error' will be called.-compileWith :: CompOptions -> String -> Pattern-compileWith opts = either error id . tryCompileWith opts---- |A safe version of 'compileWith'.------ If an error occurs and 'errorRecovery' is disabled, the error message will--- be returned in a 'Left'.-tryCompileWith :: CompOptions -> String -> Either String Pattern-tryCompileWith opts = fmap optimize . tokenize opts--tokenize :: CompOptions -> String -> Either String Pattern-tokenize opts = fmap Pattern . sequence . go- where- err _ c cs | errorRecovery opts = Right (Literal c) : go cs- err s _ _ = [Left s]-- go :: String -> [Either String Token]- go [] = []- go ('?':cs) | wcs = Right NonPathSeparator : go cs- go ('*':cs) | wcs =- case cs of- '*':p:xs | rwcs && isPathSeparator p- -> Right AnyDirectory : go xs- _ -> Right AnyNonPathSeparator : go cs-- go ('[':cs) | crs = let (range,rest) = charRange opts cs- in case range of- Left s -> err s '[' cs- r -> r : go rest-- go ('<':cs) | ors =- let (range, rest) = break (=='>') cs- in if null rest- then err "compile :: unclosed <> in pattern" '<' cs- else case openRange range of- Left s -> err s '<' cs- r -> r : go (tail rest)- go (c:cs)- | isPathSeparator c = Right PathSeparator : go cs- | isExtSeparator c = Right ExtSeparator : go cs- | otherwise = Right (Literal c) : go cs-- wcs = wildcards opts- rwcs = recursiveWildcards opts- crs = characterRanges opts- ors = numberRanges opts---- <a-b> where a > b can never match anything; this is not considered an error-openRange :: String -> Either String Token-openRange ['-'] = Right $ OpenRange Nothing Nothing-openRange ('-':s) =- case span isDigit s of- (b,"") -> Right $ OpenRange Nothing (openRangeNum b)- _ -> Left $ "compile :: bad <>, expected number, got " ++ s-openRange s =- case span isDigit s of- (a,"-") -> Right $ OpenRange (openRangeNum a) Nothing- (a,'-':s') ->- case span isDigit s' of- (b,"") -> Right $ OpenRange (openRangeNum a) (openRangeNum b)- _ -> Left $ "compile :: bad <>, expected number, got " ++ s'- _ -> Left $ "compile :: bad <>, expected number followed by - in " ++ s--openRangeNum :: String -> Maybe String-openRangeNum = Just . dropLeadingZeroes--type CharRange = [Either Char (Char,Char)]--charRange :: CompOptions -> String -> (Either String Token, String)-charRange opts zs =- case zs of- y:ys | y `elem` "^!" ->- case ys of- -- [!-#] is not the inverse of [-#], it is the range ! through- -- #- '-':']':xs -> (Right (CharRange False [Left '-']), xs)- '-' :_ -> first (fmap (CharRange True )) (start zs)- xs -> first (fmap (CharRange False)) (start xs)- _ -> first (fmap (CharRange True )) (start zs)- where- start :: String -> (Either String CharRange, String)- start (']':xs) = run $ char ']' xs- start ('-':xs) = run $ char '-' xs- start xs = run $ go xs-- run :: ExceptT String (Writer CharRange) String- -> (Either String CharRange, String)- run m = case runWriter.runExceptT $ m of- (Left err, _) -> (Left err, [])- (Right rest, cs) -> (Right cs, rest)-- go :: String -> ExceptT String (Writer CharRange) String- go ('[':':':xs) | characterClasses opts = readClass xs- go ( ']':xs) = return xs- go ( c:xs) =- if not (pathSepInRanges opts) && isPathSeparator c- then throwE "compile :: path separator within []"- else char c xs- go [] = throwE "compile :: unclosed [] in pattern"-- char :: Char -> String -> ExceptT String (Writer CharRange) String- char c ('-':x:xs) =- if x == ']'- then ltell [Left c, Left '-'] >> return xs- else ltell [Right (c,x)] >> go xs-- char c xs = ltell [Left c] >> go xs-- readClass :: String -> ExceptT String (Writer CharRange) String- readClass xs = let (name,end) = span isAlpha xs- in case end of- ':':']':rest -> charClass name >> go rest- _ -> ltell [Left '[',Left ':'] >> go xs-- charClass :: String -> ExceptT String (Writer CharRange) ()- charClass name =- -- The POSIX classes- --- -- TODO: this is ASCII-only, not sure how this should be extended- -- Unicode, or with a locale as input, or something else?- case name of- "alnum" -> ltell [digit,upper,lower]- "alpha" -> ltell [upper,lower]- "blank" -> ltell blanks- "cntrl" -> ltell [Right ('\0','\x1f'), Left '\x7f']- "digit" -> ltell [digit]- "graph" -> ltell [Right ('!','~')]- "lower" -> ltell [lower]- "print" -> ltell [Right (' ','~')]- "punct" -> ltell punct- "space" -> ltell spaces- "upper" -> ltell [upper]- "xdigit" -> ltell [digit, Right ('A','F'), Right ('a','f')]- _ ->- throwE ("compile :: unknown character class '" ++name++ "'")-- digit = Right ('0','9')- upper = Right ('A','Z')- lower = Right ('a','z')- punct = map Right [('!','/'), (':','@'), ('[','`'), ('{','~')]- blanks = [Left '\t', Left ' ']- spaces = [Right ('\t','\r'), Left ' ']-- ltell = lift . tell------------------------------------------------ OPTIMIZATION----------------------------------------------optimize :: Pattern -> Pattern-optimize = liftP (fin . go)- where- fin [] = []-- -- Literals to LongLiteral- -- Has to be done here: we can't backtrack in go, but some cases might- -- result in consecutive Literals being generated.- -- E.g. "a[b]".- fin (x:y:xs) | isLiteral x && isLiteral y =- let (ls,rest) = span isLiteral xs- in fin $ LongLiteral (length ls + 2)- (foldr (\(Literal a) -> (a:)) [] (x:y:ls))- : rest-- -- concatenate LongLiterals- -- Has to be done here because LongLiterals are generated above.- --- -- So one could say that we have one pass (go) which flattens everything as- -- much as it can and one pass (fin) which concatenates what it can.- fin (LongLiteral l1 s1 : LongLiteral l2 s2 : xs) =- fin $ LongLiteral (l1+l2) (s1++s2) : xs-- fin (LongLiteral l s : Literal c : xs) =- fin $ LongLiteral (l+1) (s++[c]) : xs-- fin (LongLiteral 1 s : xs) = Literal (head s) : fin xs-- fin (Literal c : LongLiteral l s : xs) =- fin $ LongLiteral (l+1) (c:s) : xs-- fin (x:xs) = x : fin xs-- go [] = []- go (x@(CharRange _ _) : xs) =- case optimizeCharRange x of- x'@(CharRange _ _) -> x' : go xs- x' -> go (x':xs)-- -- <a-a> -> a- go (OpenRange (Just a) (Just b):xs)- | a == b = LongLiteral (length a) a : go xs-- -- <a-b> -> [a-b]- -- a and b are guaranteed non-null- go (OpenRange (Just [a]) (Just [b]):xs)- | b > a = go $ CharRange True [Right (a,b)] : xs-- go (x:xs) =- case find ($ x) compressors of- Just c -> let (compressed,ys) = span c xs- in if null compressed- then x : go ys- else go (x : ys)- Nothing -> x : go xs-- compressors = [isStar, isStarSlash, isAnyNumber]-- isLiteral (Literal _) = True- isLiteral _ = False- isStar AnyNonPathSeparator = True- isStar _ = False- isStarSlash AnyDirectory = True- isStarSlash _ = False- isAnyNumber (OpenRange Nothing Nothing) = True- isAnyNumber _ = False--optimizeCharRange :: Token -> Token-optimizeCharRange (CharRange b_ rs) = fin b_ . go . sortCharRange $ rs- where- -- [/] is interesting, it actually matches nothing at all- -- [.] can be Literalized though, just don't make it into an ExtSeparator so- -- that it doesn't match a leading dot- fin True [Left c] | not (isPathSeparator c) = Literal c- fin True [Right r] | r == (minBound,maxBound) = NonPathSeparator- fin b x = CharRange b x-- go [] = []-- go (x@(Left c) : xs) =- case xs of- [] -> [x]- y@(Left d) : ys- -- [aaaaa] -> [a]- | c == d -> go$ Left c : ys- | d == succ c ->- let (ls,rest) = span isLeft xs -- start from y- (catable,others) = increasingSeq (map fromLeft ls)- range = (c, head catable)-- in -- three (or more) Lefts make a Right- if null catable || null (tail catable)- then x : y : go ys- -- [abcd] -> [a-d]- else go$ Right range : map Left others ++ rest-- | otherwise -> x : go xs-- Right r : ys ->- case addToRange r c of- -- [da-c] -> [a-d]- Just r' -> go$ Right r' : ys- Nothing -> x : go xs-- go (x@(Right r) : xs) =- case xs of- [] -> [x]- Left c : ys ->- case addToRange r c of- -- [a-cd] -> [a-d]- Just r' -> go$ Right r' : ys- Nothing -> x : go xs-- Right r' : ys ->- case overlap r r' of- -- [a-cb-d] -> [a-d]- Just o -> go$ Right o : ys- Nothing -> x : go xs-optimizeCharRange _ = error "Glob.optimizeCharRange :: internal error"--sortCharRange :: [Either Char (Char,Char)] -> [Either Char (Char,Char)]-sortCharRange = sortBy cmp- where- cmp (Left a) (Left b) = compare a b- cmp (Left a) (Right (b,_)) = compare a b- cmp (Right (a,_)) (Left b) = compare a b- cmp (Right (a,_)) (Right (b,_)) = compare a b+-- File created: 2008-10-10 13:29:26 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} + +module System.FilePath.Glob.Base + ( Token(..), Pattern(..) + + , CompOptions(..), MatchOptions(..) + , compDefault, compPosix, matchDefault, matchPosix + + , decompile + + , compile + , compileWith, tryCompileWith + , tokenize -- for tests + + , optimize + + , liftP, tokToLower + + , isLiteral + ) where + +import Control.Arrow (first) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Control.Monad.Trans.Writer.Strict (Writer, runWriter, tell) +import Control.Exception (assert) +import Data.Char (isDigit, isAlpha, toLower) +import Data.List (find, sortBy) +import Data.List.NonEmpty (toList) +import Data.Maybe (fromMaybe) +-- Monoid is re-exported from Prelude as of 4.8.0.0 +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (Monoid, mappend, mempty, mconcat) +#endif +#if MIN_VERSION_base(4,11,0) +import Data.Semigroup (sconcat, stimes) +#else +import Data.Semigroup (Semigroup, (<>), sconcat, stimes) +#endif +import Data.String (IsString(fromString)) +import System.FilePath ( pathSeparator, extSeparator + , isExtSeparator, isPathSeparator + ) + +import System.FilePath.Glob.Utils ( dropLeadingZeroes + , isLeft, fromLeft + , increasingSeq + , addToRange, overlap + ) + +#if __GLASGOW_HASKELL__ +import Text.Read (readPrec, lexP, parens, prec, Lexeme(Ident)) +#endif + +data Token + -- primitives + = Literal !Char + | ExtSeparator -- . optimized away to Literal + | PathSeparator -- / + | NonPathSeparator -- ? + | CharRange !Bool [Either Char (Char,Char)] -- [] + | OpenRange (Maybe String) (Maybe String) -- <> + | AnyNonPathSeparator -- * + | AnyDirectory -- **/ + + -- after optimization only + | LongLiteral !Int String + | Unmatchable -- [/], or [.] at the beginning or after a path separator + deriving (Eq) + +-- Note: CharRanges aren't converted, because this is tricky in general. +-- Consider for instance [@-[], which includes the range A-Z. This would need +-- to become [@[a-z]: so essentially we'd need to either: +-- +-- 1) Have a list of ranges of uppercase Unicode. Check if our range +-- overlaps with any of them and if it does, take the non-overlapping +-- part and combine it with the toLower of the overlapping part. +-- +-- 2) Simply expand the entire range to a list and map toLower over it. +-- +-- In either case we'd need to re-optimize the CharRange—we can't assume that +-- if the uppercase characters are consecutive, so are the lowercase. +-- +-- 1) might be feasible if someone bothered to get the latest data. +-- +-- 2) obviously isn't since you might have 'Right (minBound, maxBound)' in +-- there somewhere. +-- +-- The current solution is to just check both the toUpper of the character and +-- the toLower. +tokToLower :: Token -> Token +tokToLower (Literal c) = Literal (toLower c) +tokToLower (LongLiteral n s) = LongLiteral n (map toLower s) +tokToLower tok = tok + +-- |An abstract data type representing a compiled pattern. +-- +-- Note that the 'Eq' instance cannot tell you whether two patterns behave in +-- the same way; only whether they compile to the same 'Pattern'. For instance, +-- @'compile' \"x\"@ and @'compile' \"[x]\"@ may or may not compare equal, +-- though a @'match'@ will behave the exact same way no matter which 'Pattern' +-- is used. +newtype Pattern = Pattern { unPattern :: [Token] } deriving (Eq) + +liftP :: ([Token] -> [Token]) -> Pattern -> Pattern +liftP f (Pattern pat) = Pattern (f pat) + +instance Show Token where + show (Literal c) + | c `elem` "*?[<" = ['[',c,']'] + | otherwise = assert (not $ isPathSeparator c) [c] + show ExtSeparator = [ extSeparator] + show PathSeparator = [pathSeparator] + show NonPathSeparator = "?" + show AnyNonPathSeparator = "*" + show AnyDirectory = "**/" + show (LongLiteral _ s) = concatMap (show . Literal) s + show (OpenRange a b) = + '<' : fromMaybe "" a ++ "-" ++ + fromMaybe "" b ++ ">" + + -- We have to be careful here with ^ and ! lest [a!b] become [!ab]. So we + -- just put them at the end. + -- + -- Also, [^x-] was sorted and should not become [^-x]. + -- + -- Also, for something like [/!^] or /[.^!] that got optimized to have just ^ + -- and ! we need to add a dummy /. + show (CharRange b r) = + let f = either (:[]) (\(x,y) -> [x,'-',y]) + (caret,exclamation,fs) = + foldr (\c (ca,ex,ss) -> + case c of + Left '^' -> ("^",ex,ss) + Left '!' -> (ca,"!",ss) + _ -> (ca, ex,(f c ++) . ss) + ) + ("", "", id) + r + (beg,rest) = let s' = fs [] + (x,y) = splitAt 1 s' + in if not b && x == "-" + then (y,x) + else (s',"") + in concat [ "[" + , if b then "" else "^" + , if b && null beg && not (null caret && null exclamation) then "/" else "" + , beg, caret, exclamation, rest + , "]" + ] + + show Unmatchable = "[.]" + +instance Show Pattern where + showsPrec d p = showParen (d > 10) $ + showString "compile " . showsPrec (d+1) (decompile p) + +instance Read Pattern where +#if __GLASGOW_HASKELL__ + readPrec = parens . prec 10 $ do + Ident "compile" <- lexP + fmap compile readPrec +#else + readsPrec d = readParen (d > 10) $ \r -> do + ("compile",string) <- lex r + (xs,rest) <- readsPrec (d+1) string + [(compile xs, rest)] +#endif + +instance Semigroup Pattern where + Pattern a <> Pattern b = optimize $ Pattern (a <> b) + sconcat = optimize . Pattern . concatMap unPattern . toList + stimes n (Pattern a) = optimize $ Pattern (stimes n a) + +instance Monoid Pattern where + mempty = Pattern [] + mappend = (<>) + mconcat = optimize . Pattern . concatMap unPattern + +instance IsString Pattern where + fromString = compile + +-- |Options which can be passed to the 'tryCompileWith' or 'compileWith' +-- functions: with these you can selectively toggle certain features at compile +-- time. +-- +-- Note that some of these options depend on each other: classes can never +-- occur if ranges aren't allowed, for instance. + +-- We could presumably put locale information in here, too. +data CompOptions = CompOptions + { characterClasses :: Bool -- ^Allow character classes, @[[:...:]]@. + , characterRanges :: Bool -- ^Allow character ranges, @[...]@. + , numberRanges :: Bool -- ^Allow open ranges, @\<...>@. + , wildcards :: Bool -- ^Allow wildcards, @*@ and @?@. + , recursiveWildcards :: Bool -- ^Allow recursive wildcards, @**/@. + + , pathSepInRanges :: Bool + -- ^Allow path separators in character ranges. + -- + -- If true, @a[/]b@ never matches anything (since character ranges can't + -- match path separators); if false and 'errorRecovery' is enabled, + -- @a[/]b@ matches itself, i.e. a file named @]b@ in the subdirectory + -- @a[@. + + , errorRecovery :: Bool + -- ^If the input is invalid, recover by turning any invalid part into + -- literals. For instance, with 'characterRanges' enabled, @[abc@ is an + -- error by default (unclosed character range); with 'errorRecovery', the + -- @[@ is turned into a literal match, as though 'characterRanges' were + -- disabled. + } deriving (Show,Read,Eq) + +-- |The default set of compilation options: closest to the behaviour of the +-- @zsh@ shell, with 'errorRecovery' enabled. +-- +-- All options are enabled. +compDefault :: CompOptions +compDefault = CompOptions + { characterClasses = True + , characterRanges = True + , numberRanges = True + , wildcards = True + , recursiveWildcards = True + , pathSepInRanges = True + , errorRecovery = True + } + +-- |Options for POSIX-compliance, as described in @man 7 glob@. +-- +-- 'numberRanges', 'recursiveWildcards', and 'pathSepInRanges' are disabled. +compPosix :: CompOptions +compPosix = CompOptions + { characterClasses = True + , characterRanges = True + , numberRanges = False + , wildcards = True + , recursiveWildcards = False + , pathSepInRanges = False + , errorRecovery = True + } + +-- |Options which can be passed to the 'matchWith' or 'globDirWith' functions: +-- with these you can selectively toggle certain features at matching time. +data MatchOptions = MatchOptions + { matchDotsImplicitly :: Bool + -- ^Allow @*@, @?@, and @**/@ to match @.@ at the beginning of paths. + + , ignoreCase :: Bool + -- ^Case-independent matching. + + , ignoreDotSlash :: Bool + -- ^Treat @./@ as a no-op in both paths and patterns. + -- + -- (Of course e.g. @../@ means something different and will not be + -- ignored.) + } + +-- |The default set of execution options: closest to the behaviour of the @zsh@ +-- shell. +-- +-- Currently identical to 'matchPosix'. +matchDefault :: MatchOptions +matchDefault = matchPosix + +-- |Options for POSIX-compliance, as described in @man 7 glob@. +-- +-- 'ignoreDotSlash' is enabled, the rest are disabled. +matchPosix :: MatchOptions +matchPosix = MatchOptions + { matchDotsImplicitly = False + , ignoreCase = False + , ignoreDotSlash = True + } + +-- |Decompiles a 'Pattern' object into its textual representation: essentially +-- the inverse of 'compile'. +-- +-- Note, however, that due to internal optimization, @decompile . compile@ is +-- not the identity function. Instead, @compile . decompile@ is. +-- +-- Be careful with 'CompOptions': 'decompile' always produces a 'String' which +-- can be passed to 'compile' to get back the same 'Pattern'. @compileWith +-- options . decompile@ is /not/ the identity function unless @options@ is +-- 'compDefault'. +decompile :: Pattern -> String +decompile = concatMap show . unPattern + +------------------------------------------ +-- COMPILATION +------------------------------------------ + + +-- |Compiles a glob pattern from its textual representation into a 'Pattern' +-- object. +-- +-- For the most part, a character matches itself. Recognized operators are as +-- follows: +-- +-- [@?@] Matches any character except path separators. +-- +-- [@*@] Matches any number of characters except path separators, +-- including the empty string. +-- +-- [@[..\]@] Matches any of the enclosed characters. Ranges of characters can +-- be specified by separating the endpoints with a @\'-'@. @\'-'@ or +-- @']'@ can be matched by including them as the first character(s) +-- in the list. Never matches path separators: @[\/]@ matches +-- nothing at all. Named character classes can also be matched: +-- @[:x:]@ within @[]@ specifies the class named @x@, which matches +-- certain predefined characters. See below for a full list. +-- +-- [@[^..\]@ or @[!..\]@] Like @[..]@, but matches any character /not/ listed. +-- Note that @[^-x]@ is not the inverse of @[-x]@, but +-- the range @[^-x]@. +-- +-- [@\<m-n>@] Matches any integer in the range m to n, inclusive. The range may +-- be open-ended by leaving out either number: @\"\<->\"@, for +-- instance, matches any integer. +-- +-- [@**/@] Matches any number of characters, including path separators, +-- excluding the empty string. +-- +-- Supported character classes: +-- +-- [@[:alnum:\]@] Equivalent to @\"0-9A-Za-z\"@. +-- +-- [@[:alpha:\]@] Equivalent to @\"A-Za-z\"@. +-- +-- [@[:blank:\]@] Equivalent to @\"\\t \"@. +-- +-- [@[:cntrl:\]@] Equivalent to @\"\\0-\\x1f\\x7f\"@. +-- +-- [@[:digit:\]@] Equivalent to @\"0-9\"@. +-- +-- [@[:graph:\]@] Equivalent to @\"!-~\"@. +-- +-- [@[:lower:\]@] Equivalent to @\"a-z\"@. +-- +-- [@[:print:\]@] Equivalent to @\" -~\"@. +-- +-- [@[:punct:\]@] Equivalent to @\"!-\/:-\@[-`{-~\"@. +-- +-- [@[:space:\]@] Equivalent to @\"\\t-\\r \"@. +-- +-- [@[:upper:\]@] Equivalent to @\"A-Z\"@. +-- +-- [@[:xdigit:\]@] Equivalent to @\"0-9A-Fa-f\"@. +-- +-- Note that path separators (typically @\'/\'@) have to be matched explicitly +-- or using the @**/@ pattern. In addition, extension separators (typically +-- @\'.\'@) have to be matched explicitly at the beginning of the pattern or +-- after any path separator. +-- +-- If a system supports multiple path separators, any one of them will match +-- any of them. For instance, on Windows, @\'/\'@ will match itself as well as +-- @\'\\\'@. +-- +-- Error recovery will be performed: erroneous operators will not be considered +-- operators, but matched as literal strings. Such operators include: +-- +-- * An empty @[]@ or @[^]@ or @[!]@ +-- +-- * A @[@ or @\<@ without a matching @]@ or @>@ +-- +-- * A malformed @\<>@: e.g. nonnumeric characters or no hyphen +-- +-- So, e.g. @[]@ will match the string @\"[]\"@. +compile :: String -> Pattern +compile = compileWith compDefault + +-- |Like 'compile', but recognizes operators according to the given +-- 'CompOptions' instead of the defaults. +-- +-- If an error occurs and 'errorRecovery' is disabled, 'error' will be called. +compileWith :: CompOptions -> String -> Pattern +compileWith opts = either error id . tryCompileWith opts + +-- |A safe version of 'compileWith'. +-- +-- If an error occurs and 'errorRecovery' is disabled, the error message will +-- be returned in a 'Left'. +tryCompileWith :: CompOptions -> String -> Either String Pattern +tryCompileWith opts = fmap optimize . tokenize opts + +tokenize :: CompOptions -> String -> Either String Pattern +tokenize opts = fmap Pattern . sequence . go + where + err _ c cs | errorRecovery opts = Right (Literal c) : go cs + err s _ _ = [Left s] + + go :: String -> [Either String Token] + go [] = [] + go ('?':cs) | wcs = Right NonPathSeparator : go cs + go ('*':cs) | wcs = + case cs of + '*':p:xs | rwcs && isPathSeparator p + -> Right AnyDirectory : go xs + _ -> Right AnyNonPathSeparator : go cs + + go ('[':cs) | crs = let (range,rest) = charRange opts cs + in case range of + Left s -> err s '[' cs + r -> r : go rest + + go ('<':cs) | ors = + let (range, rest) = break (=='>') cs + in if null rest + then err "compile :: unclosed <> in pattern" '<' cs + else case openRange range of + Left s -> err s '<' cs + r -> r : go (tail rest) + go (c:cs) + | isPathSeparator c = Right PathSeparator : go cs + | isExtSeparator c = Right ExtSeparator : go cs + | otherwise = Right (Literal c) : go cs + + wcs = wildcards opts + rwcs = recursiveWildcards opts + crs = characterRanges opts + ors = numberRanges opts + +-- <a-b> where a > b can never match anything; this is not considered an error +openRange :: String -> Either String Token +openRange ['-'] = Right $ OpenRange Nothing Nothing +openRange ('-':s) = + case span isDigit s of + (b,"") -> Right $ OpenRange Nothing (openRangeNum b) + _ -> Left $ "compile :: bad <>, expected number, got " ++ s +openRange s = + case span isDigit s of + (a,"-") -> Right $ OpenRange (openRangeNum a) Nothing + (a,'-':s') -> + case span isDigit s' of + (b,"") -> Right $ OpenRange (openRangeNum a) (openRangeNum b) + _ -> Left $ "compile :: bad <>, expected number, got " ++ s' + _ -> Left $ "compile :: bad <>, expected number followed by - in " ++ s + +openRangeNum :: String -> Maybe String +openRangeNum = Just . dropLeadingZeroes + +type CharRange = [Either Char (Char,Char)] + +charRange :: CompOptions -> String -> (Either String Token, String) +charRange opts zs = + case zs of + y:ys | y `elem` "^!" -> + case ys of + -- [!-#] is not the inverse of [-#], it is the range ! through + -- # + '-':']':xs -> (Right (CharRange False [Left '-']), xs) + '-' :_ -> first (fmap (CharRange True )) (start zs) + xs -> first (fmap (CharRange False)) (start xs) + _ -> first (fmap (CharRange True )) (start zs) + where + start :: String -> (Either String CharRange, String) + start (']':xs) = run $ char ']' xs + start ('-':xs) = run $ char '-' xs + start xs = run $ go xs + + run :: ExceptT String (Writer CharRange) String + -> (Either String CharRange, String) + run m = case runWriter.runExceptT $ m of + (Left err, _) -> (Left err, []) + (Right rest, cs) -> (Right cs, rest) + + go :: String -> ExceptT String (Writer CharRange) String + go ('[':':':xs) | characterClasses opts = readClass xs + go ( ']':xs) = return xs + go ( c:xs) = + if not (pathSepInRanges opts) && isPathSeparator c + then throwE "compile :: path separator within []" + else char c xs + go [] = throwE "compile :: unclosed [] in pattern" + + char :: Char -> String -> ExceptT String (Writer CharRange) String + char c ('-':x:xs) = + if x == ']' + then ltell [Left c, Left '-'] >> return xs + else ltell [Right (c,x)] >> go xs + + char c xs = ltell [Left c] >> go xs + + readClass :: String -> ExceptT String (Writer CharRange) String + readClass xs = let (name,end) = span isAlpha xs + in case end of + ':':']':rest -> charClass name >> go rest + _ -> ltell [Left '[',Left ':'] >> go xs + + charClass :: String -> ExceptT String (Writer CharRange) () + charClass name = + -- The POSIX classes + -- + -- TODO: this is ASCII-only, not sure how this should be extended + -- Unicode, or with a locale as input, or something else? + case name of + "alnum" -> ltell [digit,upper,lower] + "alpha" -> ltell [upper,lower] + "blank" -> ltell blanks + "cntrl" -> ltell [Right ('\0','\x1f'), Left '\x7f'] + "digit" -> ltell [digit] + "graph" -> ltell [Right ('!','~')] + "lower" -> ltell [lower] + "print" -> ltell [Right (' ','~')] + "punct" -> ltell punct + "space" -> ltell spaces + "upper" -> ltell [upper] + "xdigit" -> ltell [digit, Right ('A','F'), Right ('a','f')] + _ -> + throwE ("compile :: unknown character class '" ++name++ "'") + + digit = Right ('0','9') + upper = Right ('A','Z') + lower = Right ('a','z') + punct = map Right [('!','/'), (':','@'), ('[','`'), ('{','~')] + blanks = [Left '\t', Left ' '] + spaces = [Right ('\t','\r'), Left ' '] + + ltell = lift . tell + + +------------------------------------------ +-- OPTIMIZATION +------------------------------------------ + + +optimize :: Pattern -> Pattern +optimize (Pattern pat) = + Pattern . fin $ + case pat of + e : ts | e == ExtSeparator || e == Literal '.' -> + checkUnmatchable (Literal '.' :) (go ts) + _ -> + -- Handle the case where the whole pattern starts with a + -- now-literalized [.]. LongLiterals haven't been created yet so + -- checking for Literal suffices. + case go pat of + Literal '.' : _ -> [Unmatchable] + opat -> checkUnmatchable id opat + where + fin [] = [] + + -- Literals to LongLiteral + -- Has to be done here: we can't backtrack in go, but some cases might + -- result in consecutive Literals being generated. + -- E.g. "a[b]". + fin (x:y:xs) | Just x' <- isCharLiteral x, Just y' <- isCharLiteral y = + let (ls,rest) = spanMaybe isCharLiteral xs + in fin $ LongLiteral (length ls + 2) + (foldr (\a -> (a:)) [] (x':y':ls)) + : rest + + -- concatenate LongLiterals + -- Has to be done here because LongLiterals are generated above. + -- + -- So one could say that we have one pass (go) which flattens everything as + -- much as it can and one pass (fin) which concatenates what it can. + fin (LongLiteral l1 s1 : LongLiteral l2 s2 : xs) = + fin $ LongLiteral (l1+l2) (s1++s2) : xs + + fin (LongLiteral l s : Literal c : xs) = + fin $ LongLiteral (l+1) (s++[c]) : xs + + fin (LongLiteral 1 s : xs) = Literal (head s) : fin xs + + fin (Literal c : LongLiteral l s : xs) = + fin $ LongLiteral (l+1) (c:s) : xs + + fin (x:xs) = x : fin xs + + go [] = [] + + -- Get rid of ExtSeparators, so that they can hopefully be combined into + -- LongLiterals later. + -- + -- /. -> fine + -- . elsewhere -> fine + -- /[.] -> Unmatchable + -- [.] at start of pattern -> handled outside 'go' + go (p@PathSeparator : ExtSeparator : xs) = p : Literal '.' : go xs + go (ExtSeparator : xs) = Literal '.' : go xs + go (p@PathSeparator : x@(CharRange _ _) : xs) = + p : case optimizeCharRange True x of + x'@(CharRange _ _) -> x' : go xs + Literal '.' -> [Unmatchable] + x' -> go (x':xs) + + go (x@(CharRange _ _) : xs) = + case optimizeCharRange False x of + x'@(CharRange _ _) -> x' : go xs + x' -> go (x':xs) + + -- Put [0-9] in front of <-> to allow compressing <->[0-9]<->. Handling the + -- [0-9] first in matching should also be faster in general. + go (o@(OpenRange Nothing Nothing) : d : xs) | d == anyDigit = + d : go (o : xs) + + go (x:xs) = + case find ((== x) . fst) compressables of + Just (_, f) -> let (compressed,ys) = span (== x) xs + in if null compressed + then x : go ys + else f (length compressed) ++ go (x : ys) + Nothing -> x : go xs + + checkUnmatchable f ts = if Unmatchable `elem` ts then [Unmatchable] else f ts + + compressables = [ (AnyNonPathSeparator, const []) + , (AnyDirectory, const []) + , (OpenRange Nothing Nothing, \n -> replicate n anyDigit) + ] + + isCharLiteral (Literal x) = Just x + isCharLiteral _ = Nothing + + anyDigit = CharRange True [Right ('0', '9')] + +-- | Like 'span', but let's use a -> Maybe b predicate +spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) +spanMaybe f = go + where + go xs@[] = ([], xs) + go xs@(x : xs') = case f x of + Nothing -> ([], xs) + Just y -> let (ys, zs) = go xs' in (y : ys, zs) + +optimizeCharRange :: Bool -> Token -> Token +optimizeCharRange precededBySlash (CharRange b rs) = + fin . stripUnmatchable . go . sortCharRange $ rs + where + -- [/] is interesting, it actually matches nothing at all + -- [.] can be Literalized though, just don't make it into an ExtSeparator so + -- that it doesn't match a leading dot + fin [Left c] | b = if isPathSeparator c then Unmatchable else Literal c + fin [Right r] | b && r == (minBound,maxBound) = NonPathSeparator + fin x = CharRange b x + + stripUnmatchable xs@(_:_:_) | b = + filter (\x -> (not precededBySlash || x /= Left '.') && x /= Left '/') xs + stripUnmatchable xs = xs + + go [] = [] + + go (x@(Left c) : xs) = + case xs of + [] -> [x] + y@(Left d) : ys + -- [aaaaa] -> [a] + | c == d -> go$ Left c : ys + | d == succ c -> + let (ls,rest) = span isLeft xs -- start from y + (catable,others) = increasingSeq (map fromLeft ls) + range = (c, head catable) + + in -- three (or more) Lefts make a Right + if null catable || null (tail catable) + then x : y : go ys + -- [abcd] -> [a-d] + else go$ Right range : map Left others ++ rest + + | otherwise -> x : go xs + + Right r : ys -> + case addToRange r c of + -- [da-c] -> [a-d] + Just r' -> go$ Right r' : ys + Nothing -> x : go xs + + go (x@(Right r) : xs) = + case xs of + [] -> [x] + Left c : ys -> + case addToRange r c of + -- [a-cd] -> [a-d] + Just r' -> go$ Right r' : ys + Nothing -> x : go xs + + Right r' : ys -> + case overlap r r' of + -- [a-cb-d] -> [a-d] + Just o -> go$ Right o : ys + Nothing -> x : go xs +optimizeCharRange _ _ = error "Glob.optimizeCharRange :: internal error" + +sortCharRange :: [Either Char (Char,Char)] -> [Either Char (Char,Char)] +sortCharRange = sortBy cmp + where + cmp (Left a) (Left b) = compare a b + cmp (Left a) (Right (b,_)) = compare a b + cmp (Right (a,_)) (Left b) = compare a b + cmp (Right (a,_)) (Right (b,_)) = compare a b + +-- |Returns `True` iff the given `Pattern` is a literal file path, i.e. it has +-- no wildcards, character ranges, etc. +isLiteral :: Pattern -> Bool +isLiteral = all lit . unPattern + where + lit (Literal _) = True + lit (LongLiteral _ _) = True + lit PathSeparator = True + lit _ = False
System/FilePath/Glob/Directory.hs view
@@ -1,297 +1,383 @@--- File created: 2008-10-16 12:12:50--module System.FilePath.Glob.Directory- ( globDir, globDirWith, globDir1, glob- , commonDirectory- ) where--import Control.Arrow (first, second)-import Control.Monad (forM)-import qualified Data.DList as DL-import Data.DList (DList)-import Data.List ((\\))-import System.Directory ( doesDirectoryExist, getDirectoryContents- , getCurrentDirectory- )-import System.FilePath ( (</>), takeDrive, splitDrive- , extSeparator, isExtSeparator- , pathSeparator, isPathSeparator- )--import System.FilePath.Glob.Base ( Pattern(..), Token(..)- , MatchOptions, matchDefault- , compile- )-import System.FilePath.Glob.Match (matchWith)-import System.FilePath.Glob.Utils ( getRecursiveContents- , nubOrd- , pathParts- , partitionDL- , catchIO- )--- The Patterns in TypedPattern don't contain PathSeparator or AnyDirectory------ We store the number of PathSeparators that Dir and AnyDir were followed by--- so that "foo////*" can match "foo/bar" but return "foo////bar". It's the--- exact number for convenience: (</>) doesn't add a path separator if one is--- already there. This way, '\(Dir n _) -> replicate n pathSeparator </> "bar"'--- results in the correct amount of slashes.-data TypedPattern- = Any Pattern -- pattern- | Dir Int Pattern -- pattern/- | AnyDir Int Pattern -- pattern**/- deriving Show---- |Matches each given 'Pattern' against the contents of the given 'FilePath',--- recursively. The result pair\'s first component contains the matched paths,--- grouped for each given 'Pattern', and the second contains all paths which--- were not matched by any 'Pattern'. The results are not in any defined order.------ The given directory is prepended to all the matches: the returned paths are--- all valid from the point of view of the current working directory.------ If multiple 'Pattern's match a single 'FilePath', that path will be included--- in multiple groups.------ Two 'FilePath's which can be canonicalized to the same file (e.g. @\"foo\"@--- and @\"./foo\"@) may appear separately if explicit matching on paths--- beginning with @\".\"@ is done. Looking for @\".*/*\"@, for instance, will--- cause @\"./foo\"@ to return as a match but @\"foo\"@ to not be matched.------ This function is different from a simple 'filter' over all the contents of--- the directory: the matching is performed relative to the directory, so that--- for instance the following is true:------ > fmap (head.fst) (globDir [compile "*"] dir) == getDirectoryContents dir------ (With the exception that that glob won't match anything beginning with @.@.)------ If the given 'FilePath' is @[]@, 'getCurrentDirectory' will be used.------ If the given 'Pattern' starts with a drive (as defined by--- 'System.FilePath'), it is not relative to the given directory and the--- 'FilePath' parameter is completely ignored! Similarly, if the given--- 'Pattern' starts with a path separator, only the drive part of the--- 'FilePath' is used. On Posix systems these behaviours are equivalent:--- 'Pattern's starting with @\/@ work relative to @\/@. On Windows, 'Pattern's--- starting with @\/@ or @\\@ work relative only to the drive part of the--- 'FilePath' and 'Pattern's starting with absolute paths ignore the--- 'FilePath'.------ Note that in some cases results outside the given directory may be returned:--- for instance the @.*@ pattern matches the @..@ directory.------ Any results deeper than in the given directory are enumerated lazily, using--- 'unsafeInterleaveIO'.------ Directories without read permissions are returned as entries but their--- contents, of course, are not.-globDir :: [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath])-globDir = globDirWith matchDefault---- |Like 'globDir', but applies the given 'MatchOptions' instead of the--- defaults when matching.-globDirWith :: MatchOptions -> [Pattern] -> FilePath- -> IO ([[FilePath]], [FilePath])-globDirWith _ [] dir = do- dir' <- if null dir then getCurrentDirectory else return dir- c <- getRecursiveContents dir'- return ([], DL.toList c)--globDirWith opts pats@(_:_) dir = do- results <- mapM (\p -> globDir'0 opts p dir) pats-- let (matches, others) = unzip results- allMatches = DL.toList . DL.concat $ matches- allOthers = DL.toList . DL.concat $ others-- return ( map DL.toList matches- , nubOrd allOthers \\ allMatches- )---- |A convenience wrapper on top of 'globDir', for when you only have one--- 'Pattern' you care about. Returns only the matched paths.-globDir1 :: Pattern -> FilePath -> IO [FilePath]-globDir1 p = fmap (head . fst) . globDir [p]---- |The simplest IO function. Finds matches to the given pattern in the current--- working directory. Takes a 'String' instead of a 'Pattern' to avoid the need--- for a call to 'compile', simplifying usage further.------ Can also be seen as a convenience wrapper on top of 'globDir1', for when you--- want to work in the current directory or have a pattern referring to an--- absolute path.-glob :: String -> IO [FilePath]-glob = flip globDir1 "" . compile--globDir'0 :: MatchOptions -> Pattern -> FilePath- -> IO (DList FilePath, DList FilePath)-globDir'0 opts pat dir = do- let (pat', drive) = driveSplit pat- dir' <- case drive of- Just "" -> fmap takeDrive getCurrentDirectory- Just d -> return d- Nothing -> if null dir then getCurrentDirectory else return dir- globDir' opts (separate pat') dir'--globDir' :: MatchOptions -> [TypedPattern] -> FilePath- -> IO (DList FilePath, DList FilePath)-globDir' opts pats@(_:_) dir = do- entries <- getDirectoryContents dir `catchIO` const (return [])-- results <- forM entries $ \e -> matchTypedAndGo opts pats e (dir </> e)-- let (matches, others) = unzip results-- return (DL.concat matches, DL.concat others)--globDir' _ [] dir =- -- We can only get here from matchTypedAndGo getting a [Dir _]: it means the- -- original pattern had a trailing PathSeparator. Reproduce it here.- return (DL.singleton (dir ++ [pathSeparator]), DL.empty)--matchTypedAndGo :: MatchOptions- -> [TypedPattern]- -> FilePath -> FilePath- -> IO (DList FilePath, DList FilePath)---- (Any p) is always the last element-matchTypedAndGo opts [Any p] path absPath =- if matchWith opts p path- then return (DL.singleton absPath, DL.empty)- else doesDirectoryExist absPath >>= didn'tMatch path absPath--matchTypedAndGo opts (Dir n p:ps) path absPath = do- isDir <- doesDirectoryExist absPath- if isDir && matchWith opts p path- then globDir' opts ps (absPath ++ replicate n pathSeparator)- else didn'tMatch path absPath isDir--matchTypedAndGo opts (AnyDir n p:ps) path absPath = do- if path `elem` [".",".."]- then didn'tMatch path absPath True- else do- isDir <- doesDirectoryExist absPath- let m = matchWith opts (unseparate ps)- unconditionalMatch =- null (unPattern p) && not (isExtSeparator $ head path)- p' = Pattern (unPattern p ++ [AnyNonPathSeparator])-- case unconditionalMatch || matchWith opts p' path of- True | isDir -> do- contents <- getRecursiveContents- (absPath ++ replicate n pathSeparator)- return $- -- foo**/ should match foo/ and nothing below it- -- relies on head contents == absPath- if null ps- then (DL.singleton $ DL.head contents, DL.tail contents)- else partitionDL (any m . pathParts) contents-- True | m path -> return (DL.singleton absPath, DL.empty)- _ -> didn'tMatch path absPath isDir--matchTypedAndGo _ _ _ _ = error "Glob.matchTypedAndGo :: internal error"---- To be called when a pattern didn't match a path: given the path and whether--- it was a directory, return all paths which didn't match (i.e. for a file,--- just the file, and for a directory, everything inside it).-didn'tMatch :: FilePath -> FilePath -> Bool- -> IO (DList FilePath, DList FilePath)-didn'tMatch path absPath isDir = (fmap $ (,) DL.empty) $- if isDir- then if path `elem` [".",".."]- then return DL.empty- else getRecursiveContents absPath- else return$ DL.singleton absPath--separate :: Pattern -> [TypedPattern]-separate = go DL.empty . unPattern- where- go gr [] | null (DL.toList gr) = []- go gr [] = [Any (pat gr)]- go gr (PathSeparator:ps) = slash gr Dir ps- go gr ( AnyDirectory:ps) = slash gr AnyDir ps- go gr ( p:ps) = go (gr `DL.snoc` p) ps-- pat = Pattern . DL.toList-- slash gr f ps = let (n,ps') = first length . span isSlash $ ps- in f (n+1) (pat gr) : go DL.empty ps'-- isSlash PathSeparator = True- isSlash _ = False--unseparate :: [TypedPattern] -> Pattern-unseparate = Pattern . foldr f []- where- f (AnyDir n p) ts = u p ++ AnyDirectory : replicate n PathSeparator ++ ts- f ( Dir n p) ts = u p ++ PathSeparator : replicate n PathSeparator ++ ts- f (Any p) ts = u p ++ ts-- u = unPattern---- Note that we consider "/foo" to specify a drive on Windows, even though it's--- relative to the current drive.------ Returns the [TypedPattern] of the Pattern (with the drive dropped if--- appropriate) and, if the Pattern specified a drive, a Maybe representing the--- drive to use. If it's a Just "", use the drive of the current working--- directory.-driveSplit :: Pattern -> (Pattern, Maybe FilePath)-driveSplit = check . split . unPattern- where- -- We can't just use something like commonDirectory because of Windows- -- drives being possibly longer than one "directory", like "//?/foo/bar/".- -- So just take as much as possible.- split (LongLiteral _ l : xs) = first (l++) (split xs)- split ( Literal l : xs) = first (l:) (split xs)- split (PathSeparator : xs) = first (pathSeparator:) (split xs)- split ( ExtSeparator : xs) = first ( extSeparator:) (split xs)- split xs = ([],xs)-- -- The isPathSeparator check is interesting in two ways:- --- -- 1. It's correct to return simply Just "" because there can't be more than- -- one path separator if splitDrive gave a null drive: "//x" is a shared- -- "drive" in Windows and starts with the root "drive" in Posix.- --- -- 2. The 'head' is safe because we have not (null d) && null drive.- check (d,ps)- | null d = (Pattern ps, Nothing)- | not (null drive) = (dirify rest ps, Just drive)- | isPathSeparator (head rest) = (Pattern ps, Just "")- | otherwise = (dirify d ps, Nothing)- where- (drive, rest) = splitDrive d-- dirify path = Pattern . (comp path++)-- comp s = let (p,l) = foldr f ([],[]) s in if null l then p else ll l p- where- f c (p,l) | isExtSeparator c = (ExtSeparator : ll l p, [])- | isPathSeparator c = (PathSeparator : ll l p, [])- | otherwise = (p, c:l)-- ll l p = if null l then p else LongLiteral (length l) l : p---- |Factors out the directory component of a 'Pattern'. Useful in conjunction--- with 'globDir'.------ Preserves the number of path separators: @commonDirectory (compile--- \"foo\/\/\/bar\")@ becomes @(\"foo\/\/\/\", compile \"bar\")@.-commonDirectory :: Pattern -> (FilePath, Pattern)-commonDirectory = second unseparate . splitP . separate- where- splitP pt@(Dir n p:ps) =- case fromConst DL.empty (unPattern p) of- Just d -> first ((d ++ replicate n pathSeparator) </>) (splitP ps)- Nothing -> ("", pt)-- splitP pt = ("", pt)-- fromConst d [] = Just (DL.toList d)- fromConst d (Literal c :xs) = fromConst (d `DL.snoc` c) xs- fromConst d (ExtSeparator :xs) = fromConst (d `DL.snoc` extSeparator) xs- fromConst d (LongLiteral _ s:xs) = fromConst (d `DL.append`DL.fromList s) xs- fromConst _ _ = Nothing+-- File created: 2008-10-16 12:12:50 + +module System.FilePath.Glob.Directory + ( GlobOptions(..), globDefault + , globDir, globDirWith, globDir1, glob + , commonDirectory + ) where + +import Control.Arrow (first, second) +import Control.Monad (forM) +import qualified Data.DList as DL +import Data.DList (DList) +import Data.List ((\\), find) +import System.Directory ( doesDirectoryExist, getDirectoryContents + , getCurrentDirectory + ) +import System.FilePath ( (</>), takeDrive, splitDrive + , isExtSeparator + , pathSeparator, isPathSeparator + , takeDirectory + ) + +import System.FilePath.Glob.Base ( Pattern(..), Token(..) + , MatchOptions, matchDefault + , compile + ) +import System.FilePath.Glob.Match (matchWith) +import System.FilePath.Glob.Utils ( getRecursiveContents + , nubOrd + , pathParts + , partitionDL, tailDL + , catchIO + ) +-- |Options which can be passed to the 'globDirWith' function. +data GlobOptions = GlobOptions + { matchOptions :: MatchOptions + -- ^Options controlling how matching is performed; see 'MatchOptions'. + , includeUnmatched :: Bool + -- ^Whether to include unmatched files in the result. + } + +-- |The default set of globbing options: uses the default matching options, and +-- does not include unmatched files. +globDefault :: GlobOptions +globDefault = GlobOptions matchDefault False + +-- The Patterns in TypedPattern don't contain PathSeparator or AnyDirectory +-- +-- We store the number of PathSeparators that Dir and AnyDir were followed by +-- so that "foo////*" can match "foo/bar" but return "foo////bar". It's the +-- exact number for convenience: (</>) doesn't add a path separator if one is +-- already there. This way, '\(Dir n _) -> replicate n pathSeparator </> "bar"' +-- results in the correct amount of slashes. +data TypedPattern + = Any Pattern -- pattern + | Dir Int Pattern -- pattern/ + | AnyDir Int Pattern -- pattern**/ + deriving Show + +-- |Matches each given 'Pattern' against the contents of the given 'FilePath', +-- recursively. The result contains the matched paths, grouped for each given +-- 'Pattern'. The results are not in any defined order. +-- +-- The given directory is prepended to all the matches: the returned paths are +-- all valid from the point of view of the current working directory. +-- +-- If multiple 'Pattern's match a single 'FilePath', that path will be included +-- in multiple groups. +-- +-- Two 'FilePath's which can be canonicalized to the same file (e.g. @\"foo\"@ +-- and @\"./foo\"@) may appear separately if explicit matching on paths +-- beginning with @\".\"@ is done. Looking for @\".*/*\"@, for instance, will +-- cause @\"./foo\"@ to return as a match but @\"foo\"@ to not be matched. +-- +-- This function is different from a simple 'filter' over all the contents of +-- the directory: the matching is performed relative to the directory, so that +-- for instance the following is true: +-- +-- > fmap head (globDir [compile "*"] dir) == getDirectoryContents dir +-- +-- (With the exception that that glob won't match anything beginning with @.@.) +-- +-- If the given 'FilePath' is @[]@, 'getCurrentDirectory' will be used. +-- +-- If the given 'Pattern' starts with a drive (as defined by +-- 'System.FilePath'), it is not relative to the given directory and the +-- 'FilePath' parameter is completely ignored! Similarly, if the given +-- 'Pattern' starts with a path separator, only the drive part of the +-- 'FilePath' is used. On Posix systems these behaviours are equivalent: +-- 'Pattern's starting with @\/@ work relative to @\/@. On Windows, 'Pattern's +-- starting with @\/@ or @\\@ work relative only to the drive part of the +-- 'FilePath' and 'Pattern's starting with absolute paths ignore the +-- 'FilePath'. +-- +-- Note that in some cases results outside the given directory may be returned: +-- for instance the @.*@ pattern matches the @..@ directory. +-- +-- Any results deeper than in the given directory are enumerated lazily, using +-- 'unsafeInterleaveIO'. +-- +-- Directories without read permissions are returned as entries but their +-- contents, of course, are not. +globDir :: [Pattern] -> FilePath -> IO [[FilePath]] +globDir pats dir = fmap fst (globDirWith globDefault pats dir) + +-- |Like 'globDir', but applies the given 'GlobOptions' instead of the +-- defaults when matching. The first component of the returned tuple contains +-- the matched paths, grouped for each given 'Pattern', and the second contains +-- Just the unmatched paths if the given 'GlobOptions' specified that unmatched +-- files should be included, or otherwise Nothing. +globDirWith :: GlobOptions -> [Pattern] -> FilePath + -> IO ([[FilePath]], Maybe [FilePath]) +globDirWith opts [pat] dir | not (includeUnmatched opts) = + -- This is an optimization for the case where only one pattern has been + -- passed and we are not including unmatched files: we can use + -- 'commonDirectory' to avoid some calls to 'getDirectoryContents'. + let (prefix, pat') = commonDirectory pat + in globDirWith' opts [pat'] (dir </> prefix) + +globDirWith opts pats dir = + globDirWith' opts pats dir + +-- See 'globDirWith'. +globDirWith' :: GlobOptions -> [Pattern] -> FilePath + -> IO ([[FilePath]], Maybe [FilePath]) +globDirWith' opts [] dir = + if includeUnmatched opts + then do + dir' <- if null dir then getCurrentDirectory else return dir + c <- getRecursiveContents dir' + return ([], Just (DL.toList c)) + else + return ([], Nothing) + +globDirWith' opts pats@(_:_) dir = do + results <- mapM (\p -> globDir'0 opts p dir) pats + + let (matches, others) = unzip results + allMatches = DL.toList . DL.concat $ matches + allOthers = DL.toList . DL.concat $ others + + return ( map DL.toList matches + , if includeUnmatched opts + then Just (nubOrd allOthers \\ allMatches) + else Nothing + ) + +-- |A convenience wrapper on top of 'globDir', for when you only have one +-- 'Pattern' you care about. Returns only the matched paths. +globDir1 :: Pattern -> FilePath -> IO [FilePath] +globDir1 p = fmap head . globDir [p] + +-- |The simplest IO function. Finds matches to the given pattern in the current +-- working directory. Takes a 'String' instead of a 'Pattern' to avoid the need +-- for a call to 'compile', simplifying usage further. +-- +-- Can also be seen as a convenience wrapper on top of 'globDir1', for when you +-- want to work in the current directory or have a pattern referring to an +-- absolute path. +glob :: String -> IO [FilePath] +glob = flip globDir1 "" . compile + +globDir'0 :: GlobOptions -> Pattern -> FilePath + -> IO (DList FilePath, DList FilePath) +globDir'0 opts pat dir = do + let (pat', drive) = driveSplit pat + dir' <- case drive of + Just "" -> fmap takeDrive getCurrentDirectory + Just d -> return d + Nothing -> if null dir then getCurrentDirectory else return dir + globDir' opts (separate pat') dir' + +globDir' :: GlobOptions -> [TypedPattern] -> FilePath + -> IO (DList FilePath, DList FilePath) +globDir' opts pats@(_:_) dir = do + entries <- getDirectoryContents dir `catchIO` const (return []) + + results <- forM entries $ \e -> matchTypedAndGo opts pats e (dir </> e) + + let (matches, others) = unzip results + + return (DL.concat matches, DL.concat others) + +globDir' _ [] dir = + -- We can only get here from matchTypedAndGo getting a [Dir _]: it means the + -- original pattern had a trailing PathSeparator. Reproduce it here. + return (DL.singleton (dir ++ [pathSeparator]), DL.empty) + +matchTypedAndGo :: GlobOptions + -> [TypedPattern] + -> FilePath -> FilePath + -> IO (DList FilePath, DList FilePath) + +-- (Any p) is always the last element +matchTypedAndGo opts [Any p] path absPath = + if matchWith (matchOptions opts) p path + then return (DL.singleton absPath, DL.empty) + else doesDirectoryExist absPath >>= didNotMatch opts path absPath + +matchTypedAndGo opts (Dir n p:ps) path absPath = do + isDir <- doesDirectoryExist absPath + if isDir && matchWith (matchOptions opts) p path + then globDir' opts ps (absPath ++ replicate n pathSeparator) + else didNotMatch opts path absPath isDir + +matchTypedAndGo opts (AnyDir n p:ps) path absPath = + if path `elem` [".",".."] + then didNotMatch opts path absPath True + else do + isDir <- doesDirectoryExist absPath + let m = matchWith (matchOptions opts) (unseparate ps) + unconditionalMatch = + null (unPattern p) && not (isExtSeparator $ head path) + p' = Pattern (unPattern p ++ [AnyNonPathSeparator]) + + case unconditionalMatch || matchWith (matchOptions opts) p' path of + True | isDir -> do + contents <- getRecursiveContents absPath + return $ + -- foo**/ should match foo/ and nothing below it + -- relies on head contents == absPath + if null ps + then ( DL.singleton $ + DL.head contents + ++ replicate n pathSeparator + , tailDL contents + ) + else let (matches, nonMatches) = + partitionDL fst + (fmap (recursiveMatch n m) contents) + in (fmap snd matches, fmap snd nonMatches) + + True | m path -> + return ( DL.singleton $ + takeDirectory absPath + ++ replicate n pathSeparator + ++ path + , DL.empty + ) + _ -> + didNotMatch opts path absPath isDir + +matchTypedAndGo _ _ _ _ = error "Glob.matchTypedAndGo :: internal error" + +-- To be called to check whether a filepath matches the part of a pattern +-- following an **/ (AnyDirectory) token and reconstruct the filepath with the +-- correct number of slashes. Arguments are: +-- +-- * Int: number of slashes in the AnyDirectory token, i.e. 1 for **/, 2 for +-- **//, and so on +-- +-- * FilePath -> Bool: matching function for the remainder of the pattern, to +-- determine whether the rest of the filepath following the AnyDirectory token +-- matches +-- +-- * FilePath: the (entire) filepath to be checked: some file which is in a +-- subdirectory of a directory which matches the prefix of the pattern up to +-- the AnyDirectory token. +-- +-- The returned tuple contains both the result, where True means the filepath +-- matches and should be included in the resulting list of matching files, and +-- False otherwise. We also include the filepath in the returned tuple, because +-- this function also takes care of including the correct number of slashes +-- in the result. For example, with a pattern **//foo/bar.txt, this function +-- would ensure that, if dir/foo/bar.txt exists, it would be returned as +-- dir//foo/bar.txt. +recursiveMatch :: Int -> (FilePath -> Bool) -> FilePath -> (Bool, FilePath) +recursiveMatch n isMatch path = + case find isMatch (pathParts path) of + Just matchedSuffix -> + let dir = take (length path - length matchedSuffix) path + in ( True + , dir + ++ replicate (n-1) pathSeparator + ++ matchedSuffix + ) + Nothing -> + (False, path) + +-- To be called when a pattern didn't match a path: given the path and whether +-- it was a directory, return all paths which didn't match (i.e. for a file, +-- just the file, and for a directory, everything inside it). +didNotMatch :: GlobOptions -> FilePath -> FilePath -> Bool + -> IO (DList FilePath, DList FilePath) +didNotMatch opts path absPath isDir = + if includeUnmatched opts + then fmap ((,) DL.empty) $ + if isDir + then if path `elem` [".",".."] + then return DL.empty + else getRecursiveContents absPath + else return$ DL.singleton absPath + else + return (DL.empty, DL.empty) + +separate :: Pattern -> [TypedPattern] +separate = go DL.empty . unPattern + where + go gr [] | null (DL.toList gr) = [] + go gr [] = [Any (pat gr)] + go gr (PathSeparator:ps) = slash gr Dir ps + go gr ( AnyDirectory:ps) = slash gr AnyDir ps + go gr ( p:ps) = go (gr `DL.snoc` p) ps + + pat = Pattern . DL.toList + + slash gr f ps = let (n,ps') = first length . span isSlash $ ps + in f (n+1) (pat gr) : go DL.empty ps' + + isSlash PathSeparator = True + isSlash _ = False + +unseparate :: [TypedPattern] -> Pattern +unseparate = Pattern . foldr f [] + where + f (AnyDir n p) ts = u p ++ AnyDirectory : replicate (n-1) PathSeparator ++ ts + f ( Dir n p) ts = u p ++ replicate n PathSeparator ++ ts + f (Any p) ts = u p ++ ts + + u = unPattern + +-- Note that we consider "/foo" to specify a drive on Windows, even though it's +-- relative to the current drive. +-- +-- Returns the [TypedPattern] of the Pattern (with the drive dropped if +-- appropriate) and, if the Pattern specified a drive, a Maybe representing the +-- drive to use. If it's a Just "", use the drive of the current working +-- directory. +driveSplit :: Pattern -> (Pattern, Maybe FilePath) +driveSplit = check . split . unPattern + where + -- We can't just use something like commonDirectory because of Windows + -- drives being possibly longer than one "directory", like "//?/foo/bar/". + -- So just take as much as possible. + split (LongLiteral _ l : xs) = first (l++) (split xs) + split ( Literal l : xs) = first (l:) (split xs) + split (PathSeparator : xs) = first (pathSeparator:) (split xs) + split xs = ([],xs) + + -- The isPathSeparator check is interesting in two ways: + -- + -- 1. It's correct to return simply Just "" because there can't be more than + -- one path separator if splitDrive gave a null drive: "//x" is a shared + -- "drive" in Windows and starts with the root "drive" in Posix. + -- + -- 2. The 'head' is safe because we have not (null d) && null drive. + check (d,ps) + | null d = (Pattern ps, Nothing) + | not (null drive) = (dirify rest ps, Just drive) + | isPathSeparator (head rest) = (Pattern ps, Just "") + | otherwise = (dirify d ps, Nothing) + where + (drive, rest) = splitDrive d + + dirify path = Pattern . (comp path++) + + comp s = let (p,l) = foldr f ([],[]) s in if null l then p else ll l p + where + f c (p,l) | isExtSeparator c = (Literal '.' : ll l p, []) + | isPathSeparator c = (PathSeparator : ll l p, []) + | otherwise = (p, c:l) + + ll l p = if null l then p else LongLiteral (length l) l : p + +-- |Factors out the directory component of a 'Pattern'. Useful in conjunction +-- with 'globDir'. +-- +-- Preserves the number of path separators: @commonDirectory (compile +-- \"foo\/\/\/bar\")@ becomes @(\"foo\/\/\/\", compile \"bar\")@. +commonDirectory :: Pattern -> (FilePath, Pattern) +commonDirectory = second unseparate . splitP . separate + where + splitP pt@(Dir n p:ps) = + case fromConst DL.empty (unPattern p) of + Just d -> first ((d ++ replicate n pathSeparator) </>) (splitP ps) + Nothing -> ("", pt) + + splitP pt = ("", pt) + + fromConst d [] = Just (DL.toList d) + fromConst d (Literal c :xs) = fromConst (d `DL.snoc` c) xs + fromConst d (LongLiteral _ s:xs) = fromConst (d `DL.append`DL.fromList s) xs + fromConst _ _ = Nothing
System/FilePath/Glob/Match.hs view
@@ -1,157 +1,178 @@--- File created: 2008-10-10 13:29:03--module System.FilePath.Glob.Match (match, matchWith) where--import Control.Exception (assert)-import Data.Char (isDigit, toLower, toUpper)-import Data.Monoid (mappend)-import System.FilePath (isPathSeparator, isExtSeparator)--import System.FilePath.Glob.Base ( Pattern(..), Token(..)- , MatchOptions(..), matchDefault- , tokToLower- )-import System.FilePath.Glob.Utils (dropLeadingZeroes, inRange, pathParts)---- |Matches the given 'Pattern' against the given 'FilePath', returning 'True'--- if the pattern matches and 'False' otherwise.-match :: Pattern -> FilePath -> Bool-match = matchWith matchDefault---- |Like 'match', but applies the given 'MatchOptions' instead of the defaults.-matchWith :: MatchOptions -> Pattern -> FilePath -> Bool-matchWith opts p f = begMatch opts (lcPat $ unPattern p) (lcPath f)- where- lcPath = if ignoreCase opts then map toLower else id- lcPat = if ignoreCase opts then map tokToLower else id---- begMatch takes care of some things at the beginning of a pattern or after /:--- - . needs to be matched explicitly--- - ./foo is equivalent to foo (for any number of /)------ .*/foo still needs to match ./foo though, and it won't match plain foo;--- special case that one------ and .**/foo should /not/ match ../foo; more special casing------ (All of the above is modulo options, of course)-begMatch, match' :: MatchOptions -> [Token] -> FilePath -> Bool-begMatch _ (ExtSeparator:AnyDirectory:_) (x:y:_)- | isExtSeparator x && isExtSeparator y = False--begMatch opts (ExtSeparator:PathSeparator:pat) s | ignoreDotSlash opts =- begMatch opts (dropWhile isSlash pat) s- where- isSlash PathSeparator = True- isSlash _ = False--begMatch opts pat (x:y:s)- | dotSlash && dotStarSlash = match' opts pat' s- | ignoreDotSlash opts && dotSlash = begMatch opts pat s- where- dotSlash = isExtSeparator x && isPathSeparator y- (dotStarSlash, pat') =- case pat of- ExtSeparator:AnyNonPathSeparator:PathSeparator:rest -> (True, rest)- _ -> (False, pat)--begMatch opts pat s =- if not (null s) && isExtSeparator (head s) && not (matchDotsImplicitly opts)- then case pat of- ExtSeparator:pat' -> match' opts pat' (tail s)- _ -> False- else match' opts pat s--match' _ [] s = null s-match' _ (AnyNonPathSeparator:s) "" = null s-match' _ _ "" = False-match' o (Literal l :xs) (c:cs) = l == c && match' o xs cs-match' o ( ExtSeparator :xs) (c:cs) = isExtSeparator c && match' o xs cs-match' o (NonPathSeparator:xs) (c:cs) =- not (isPathSeparator c) && match' o xs cs--match' o (PathSeparator :xs) (c:cs) =- isPathSeparator c && begMatch o xs (dropWhile isPathSeparator cs)--match' o (CharRange b rng :xs) (c:cs) =- let rangeMatch r =- either (== c) (`inRange` c) r ||- -- See comment near Base.tokToLower for an explanation of why we- -- do this- if ignoreCase o- then either (== toUpper c) (`inRange` toUpper c) r- else False- in not (isPathSeparator c) &&- any rangeMatch rng == b &&- match' o xs cs--match' o (OpenRange lo hi :xs) path =- let- (lzNum,cs) = span isDigit path- num = dropLeadingZeroes lzNum- numChoices =- tail . takeWhile (not.null.snd) . map (flip splitAt num) $ [0..]- in if null lzNum- then False -- no digits- else- -- So, given the path "123foo" what we've got is:- -- cs = "foo"- -- num = "123"- -- numChoices = [("1","23"),("12","3")]- --- -- We want to try matching x against each of 123, 12, and 1.- -- 12 and 1 are in numChoices already, but we need to add (num,"")- -- manually.- any (\(n,rest) -> inOpenRange lo hi n && match' o xs (rest ++ cs))- ((num,"") : numChoices)--match' o again@(AnyNonPathSeparator:xs) path@(c:cs) =- match' o xs path || (if isPathSeparator c then False else match' o again cs)--match' o again@(AnyDirectory:xs) path =- let parts = pathParts (dropWhile isPathSeparator path)- matches = any (match' o xs) parts || any (match' o again) (tail parts)- in if null xs && not (matchDotsImplicitly o)- -- **/ shouldn't match foo/.bar, so check that remaining bits don't- -- start with .- then all (not.isExtSeparator.head) (init parts) && matches- else matches--match' o (LongLiteral len s:xs) path =- let (pre,cs) = splitAt len path- in pre == s && match' o xs cs---- Does the actual open range matching: finds whether the third parameter--- is between the first two or not.------ It does this by keeping track of the Ordering so far (e.g. having--- looked at "12" and "34" the Ordering of the two would be LT: 12 < 34)--- and aborting if a String "runs out": a longer string is automatically--- greater.------ Assumes that the input strings contain only digits, and no leading zeroes.-inOpenRange :: Maybe String -> Maybe String -> String -> Bool-inOpenRange l_ h_ s_ = assert (all isDigit s_) $ go l_ h_ s_ EQ EQ- where- go Nothing Nothing _ _ _ = True -- no bounds- go (Just []) _ [] LT _ = False -- lesser than lower bound- go _ (Just []) _ _ GT = False -- greater than upper bound- go _ (Just []) (_:_) _ _ = False -- longer than upper bound- go (Just (_:_)) _ [] _ _ = False -- shorter than lower bound- go _ _ [] _ _ = True-- go (Just (l:ls)) (Just (h:hs)) (c:cs) ordl ordh =- let ordl' = ordl `mappend` compare c l- ordh' = ordh `mappend` compare c h- in go (Just ls) (Just hs) cs ordl' ordh'-- go Nothing (Just (h:hs)) (c:cs) _ ordh =- let ordh' = ordh `mappend` compare c h- in go Nothing (Just hs) cs GT ordh'-- go (Just (l:ls)) Nothing (c:cs) ordl _ =- let ordl' = ordl `mappend` compare c l- in go (Just ls) Nothing cs ordl' LT-- -- lower bound is shorter: s is greater- go (Just []) hi s _ ordh = go Nothing hi s GT ordh+-- File created: 2008-10-10 13:29:03 + +{-# LANGUAGE CPP #-} + +module System.FilePath.Glob.Match (match, matchWith) where + +import Control.Exception (assert) +import Data.Char (isDigit, toLower, toUpper) +import Data.List (findIndex) +import Data.Maybe (fromMaybe, isJust) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mappend) +#endif +import System.FilePath (isPathSeparator, isExtSeparator) + +import System.FilePath.Glob.Base ( Pattern(..), Token(..) + , MatchOptions(..), matchDefault + , isLiteral, tokToLower + ) +import System.FilePath.Glob.Utils (dropLeadingZeroes, inRange, pathParts) + +-- |Matches the given 'Pattern' against the given 'FilePath', returning 'True' +-- if the pattern matches and 'False' otherwise. +match :: Pattern -> FilePath -> Bool +match = matchWith matchDefault + +-- |Like 'match', but applies the given 'MatchOptions' instead of the defaults. +matchWith :: MatchOptions -> Pattern -> FilePath -> Bool +matchWith opts p f = begMatch opts (lcPat $ unPattern p) (lcPath f) + where + lcPath = if ignoreCase opts then map toLower else id + lcPat = if ignoreCase opts then map tokToLower else id + +-- begMatch takes care of some things at the beginning of a pattern or after /: +-- - . needs to be matched explicitly +-- - ./foo is equivalent to foo (for any number of /) +-- +-- .*/foo still needs to match ./foo though, and it won't match plain foo; +-- special case that one +-- +-- and .**/foo should /not/ match ../foo; more special casing +-- +-- (All of the above is modulo options, of course) +begMatch, match' :: MatchOptions -> [Token] -> FilePath -> Bool +begMatch _ (Literal '.' : AnyDirectory : _) (x:y:_) + | isExtSeparator x && isExtSeparator y = False + +begMatch opts (Literal '.' : PathSeparator : pat) s | ignoreDotSlash opts = + begMatch opts (dropWhile isSlash pat) (dropDotSlash s) + where + isSlash PathSeparator = True + isSlash _ = False + + dropDotSlash (x:y:ys) | isExtSeparator x && isPathSeparator y = + dropWhile isPathSeparator ys + dropDotSlash xs = xs + +begMatch opts pat (x:y:s) + | dotSlash && dotStarSlash = match' opts pat' s + | ignoreDotSlash opts && dotSlash = + begMatch opts pat (dropWhile isPathSeparator s) + where + dotSlash = isExtSeparator x && isPathSeparator y + (dotStarSlash, pat') = + case pat of + Literal '.': AnyNonPathSeparator : PathSeparator : rest -> (True, rest) + _ -> (False, pat) + +begMatch opts pat (e:_) + | isExtSeparator e + && not (matchDotsImplicitly opts) + && not (isLiteral . Pattern $ take 1 pat) = False + +begMatch opts pat s = match' opts pat s + +match' _ [] s = null s +match' _ (AnyNonPathSeparator:s) "" = null s +match' _ _ "" = False +match' o (Literal l :xs) (c:cs) = l == c && match' o xs cs +match' o (NonPathSeparator:xs) (c:cs) = + not (isPathSeparator c) && match' o xs cs + +match' o (PathSeparator :xs) (c:cs) = + isPathSeparator c && begMatch o (dropWhile (== PathSeparator) xs) + (dropWhile isPathSeparator cs) + +match' o (CharRange b rng :xs) (c:cs) = + let rangeMatch r = + either (== c) (`inRange` c) r || + -- See comment near Base.tokToLower for an explanation of why we + -- do this + ignoreCase o && either (== toUpper c) (`inRange` toUpper c) r + in not (isPathSeparator c) && + any rangeMatch rng == b && + match' o xs cs + +match' o (OpenRange lo hi :xs) path = + let getNumChoices n = + tail . takeWhile (not.null.snd) . map (`splitAt` n) $ [0..] + (lzNum,cs) = span isDigit path + num = dropLeadingZeroes lzNum + numChoices = getNumChoices num + zeroChoices = takeWhile (all (=='0') . fst) (getNumChoices lzNum) + in -- null lzNum means no digits: definitely not a match + not (null lzNum) && + -- So, given the path "00123foo" what we've got is: + -- lzNum = "00123" + -- cs = "foo" + -- num = "123" + -- numChoices = [("1","23"),("12","3")] + -- zeroChoices = [("0", "0123"), ("00", "123")] + -- + -- We want to try matching x against each of 123, 12, and 1. + -- 12 and 1 are in numChoices already, but we need to add (num,"") + -- manually. + -- + -- It's also possible that we only want to match the zeroes. Handle + -- that separately since inOpenRange doesn't like leading zeroes. + (any (\(n,rest) -> inOpenRange lo hi n && match' o xs (rest ++ cs)) + ((num,"") : numChoices) + || (not (null zeroChoices) && inOpenRange lo hi "0" + && any (\(_,rest) -> match' o xs (rest ++ cs)) zeroChoices)) + +match' o again@(AnyNonPathSeparator:xs) path@(c:cs) = + match' o xs path || (not (isPathSeparator c) && match' o again cs) + +match' o (AnyDirectory:xs) path = + if matchDotsImplicitly o + then hasMatch + -- **/baz shouldn't match foo/.bar/baz, so check that none of the + -- directories matched by **/ start with . + else hasMatch && all (not.isExtSeparator.head) matchedDirs + where parts = pathParts (dropWhile isPathSeparator path) + matchIndex = findIndex (match' o xs) parts + hasMatch = isJust matchIndex + matchedDirs = take (fromMaybe 0 matchIndex) parts + +match' o (LongLiteral len s:xs) path = + let (pre,cs) = splitAt len path + in pre == s && match' o xs cs + +match' _ (Unmatchable:_) _ = False +match' _ (ExtSeparator:_) _ = error "ExtSeparator survived optimization?" + +-- Does the actual open range matching: finds whether the third parameter +-- is between the first two or not. +-- +-- It does this by keeping track of the Ordering so far (e.g. having +-- looked at "12" and "34" the Ordering of the two would be LT: 12 < 34) +-- and aborting if a String "runs out": a longer string is automatically +-- greater. +-- +-- Assumes that the input strings contain only digits, and no leading zeroes. +inOpenRange :: Maybe String -> Maybe String -> String -> Bool +inOpenRange l_ h_ s_ = assert (all isDigit s_) $ go l_ h_ s_ EQ EQ + where + go Nothing Nothing _ _ _ = True -- no bounds + go (Just []) _ [] LT _ = False -- lesser than lower bound + go _ (Just []) _ _ GT = False -- greater than upper bound + go _ (Just []) (_:_) _ _ = False -- longer than upper bound + go (Just (_:_)) _ [] _ _ = False -- shorter than lower bound + go _ _ [] _ _ = True + + go (Just (l:ls)) (Just (h:hs)) (c:cs) ordl ordh = + let ordl' = ordl `mappend` compare c l + ordh' = ordh `mappend` compare c h + in go (Just ls) (Just hs) cs ordl' ordh' + + go Nothing (Just (h:hs)) (c:cs) _ ordh = + let ordh' = ordh `mappend` compare c h + in go Nothing (Just hs) cs GT ordh' + + go (Just (l:ls)) Nothing (c:cs) ordl _ = + let ordl' = ordl `mappend` compare c l + in go (Just ls) Nothing cs ordl' LT + + -- lower bound is shorter: s is greater + go (Just []) hi s _ ordh = go Nothing hi s GT ordh
System/FilePath/Glob/Primitive.hs view
@@ -1,57 +1,57 @@--- File created: 2009-01-17---- |A number of primitives from which complete 'Pattern's may be constructed.------ Using this together with the functions provided by the 'Monoid' instance of--- 'Pattern' allows for direct manipulation of 'Pattern's beyond what can be--- done with just the 'compile' family of functions. And of course you don't--- have to go via 'String's if you use these.-module System.FilePath.Glob.Primitive- ( literal- , singleWildcard, wildcard, recursiveWildcard- , charRange, numberRange- ) where--import System.FilePath (isPathSeparator, isExtSeparator)--import System.FilePath.Glob.Base (Pattern(..), Token(..), optimize)---- |A 'Pattern' which matches the given 'String' literally.------ Handles any embedded path and extension separators.-literal :: String -> Pattern-literal = optimize . Pattern . map f- where- f c | isPathSeparator c = PathSeparator- | isExtSeparator c = ExtSeparator- | otherwise = Literal c---- |Matches any single character except a path separator: corresponds to the--- @?@ operator.-singleWildcard :: Pattern-singleWildcard = Pattern [NonPathSeparator]---- |Matches any number of characters up to a path separator: corresponds to the--- @*@ operator.-wildcard :: Pattern-wildcard = Pattern [AnyNonPathSeparator]---- |Matches any number of characters including path separators: corresponds to--- the @**/@ operator.-recursiveWildcard :: Pattern-recursiveWildcard = Pattern [AnyDirectory]---- |Matches a single character if it is within the (inclusive) range in any--- 'Right' or if it is equal to the character in any 'Left'. Corresponds to the--- @[]@, @[^]@ and @[!]@ operators.------ If the given 'Bool' is 'False', the result of the match is inverted: the--- match succeeds if the character does /not/ match according to the above--- rules.-charRange :: Bool -> [Either Char (Char,Char)] -> Pattern-charRange b rs = optimize $ Pattern [CharRange b rs]---- |Matches a number in the given range, which may be open, half-open, or--- closed. Corresponds to the @\<\>@ operator.-numberRange :: Maybe Integer -> Maybe Integer -> Pattern-numberRange a b = Pattern [OpenRange (fmap show a) (fmap show b)]+-- File created: 2009-01-17 + +-- |A number of primitives from which complete 'Pattern's may be constructed. +-- +-- Using this together with the functions provided by the 'Monoid' instance of +-- 'Pattern' allows for direct manipulation of 'Pattern's beyond what can be +-- done with just the 'compile' family of functions. And of course you don't +-- have to go via 'String's if you use these. +module System.FilePath.Glob.Primitive + ( literal + , singleWildcard, wildcard, recursiveWildcard + , charRange, numberRange + ) where + +import System.FilePath (isPathSeparator, isExtSeparator) + +import System.FilePath.Glob.Base (Pattern(..), Token(..), optimize) + +-- |A 'Pattern' which matches the given 'String' literally. +-- +-- Handles any embedded path and extension separators. +literal :: String -> Pattern +literal = optimize . Pattern . map f + where + f c | isPathSeparator c = PathSeparator + | isExtSeparator c = ExtSeparator + | otherwise = Literal c + +-- |Matches any single character except a path separator: corresponds to the +-- @?@ operator. +singleWildcard :: Pattern +singleWildcard = Pattern [NonPathSeparator] + +-- |Matches any number of characters up to a path separator: corresponds to the +-- @*@ operator. +wildcard :: Pattern +wildcard = Pattern [AnyNonPathSeparator] + +-- |Matches any number of characters including path separators: corresponds to +-- the @**/@ operator. +recursiveWildcard :: Pattern +recursiveWildcard = Pattern [AnyDirectory] + +-- |Matches a single character if it is within the (inclusive) range in any +-- 'Right' or if it is equal to the character in any 'Left'. Corresponds to the +-- @[]@, @[^]@ and @[!]@ operators. +-- +-- If the given 'Bool' is 'False', the result of the match is inverted: the +-- match succeeds if the character does /not/ match according to the above +-- rules. +charRange :: Bool -> [Either Char (Char,Char)] -> Pattern +charRange b rs = optimize $ Pattern [CharRange b rs] + +-- |Matches a number in the given range, which may be open, half-open, or +-- closed. Corresponds to the @\<\>@ operator. +numberRange :: Maybe Integer -> Maybe Integer -> Pattern +numberRange a b = Pattern [OpenRange (fmap show a) (fmap show b)]
System/FilePath/Glob/Simplify.hs view
@@ -1,42 +1,42 @@--- File created: 2009-01-30 14:54:14--module System.FilePath.Glob.Simplify (simplify) where--import System.FilePath.Glob.Base (Pattern(..), Token(..), liftP)---- |Simplifies a 'Pattern' object: removes redundant @\"./\"@, for instance.--- The resulting 'Pattern' matches the exact same input as the original one,--- with some differences:------ * The output of 'globDir' will differ: for example, globbing for @\"./\*\"@--- gives @\"./foo\"@, but after simplification this'll be only @\"foo\"@.------ * Decompiling the simplified 'Pattern' will obviously not give the original.------ * The simplified 'Pattern' is a bit faster to match with and uses less--- memory, since some redundant data is removed.------ For the last of the above reasons, if you're performance-conscious and not--- using 'globDir', you should always 'simplify' after calling 'compile'.-simplify :: Pattern -> Pattern-simplify = liftP (go . pre)- where- -- ./ at beginning -> nothing (any number of /'s)- pre (ExtSeparator:PathSeparator:xs) = pre (dropWhile isSlash xs)- pre xs = xs-- go [] = []-- -- /./ -> /- go (PathSeparator:ExtSeparator:xs@(PathSeparator:_)) = go xs-- go (x:xs) =- if isSlash x- then let (compressed,ys) = span isSlash xs- in if null compressed- then x : go ys- else go (x : ys)- else x : go xs-- isSlash PathSeparator = True- isSlash _ = False+-- File created: 2009-01-30 14:54:14 + +module System.FilePath.Glob.Simplify (simplify) where + +import System.FilePath.Glob.Base (Pattern(..), Token(..), liftP) + +-- |Simplifies a 'Pattern' object: removes redundant @\"./\"@, for instance. +-- The resulting 'Pattern' matches the exact same input as the original one, +-- with some differences: +-- +-- * The output of 'globDir' will differ: for example, globbing for @\"./\*\"@ +-- gives @\"./foo\"@, but after simplification this'll be only @\"foo\"@. +-- +-- * Decompiling the simplified 'Pattern' will obviously not give the original. +-- +-- * The simplified 'Pattern' is a bit faster to match with and uses less +-- memory, since some redundant data is removed. +-- +-- For the last of the above reasons, if you're performance-conscious and not +-- using 'globDir', you should always 'simplify' after calling 'compile'. +simplify :: Pattern -> Pattern +simplify = liftP (go . pre) + where + -- ./ at beginning -> nothing (any number of /'s) + pre (ExtSeparator:PathSeparator:xs) = pre (dropWhile isSlash xs) + pre xs = xs + + go [] = [] + + -- /./ -> / + go (PathSeparator:ExtSeparator:xs@(PathSeparator:_)) = go xs + + go (x:xs) = + if isSlash x + then let (compressed,ys) = span isSlash xs + in if null compressed + then x : go ys + else go (x : ys) + else x : go xs + + isSlash PathSeparator = True + isSlash _ = False
System/FilePath/Glob/Utils.hs view
@@ -1,167 +1,186 @@-{-# LANGUAGE CPP #-}--- File created: 2008-10-10 13:40:35--module System.FilePath.Glob.Utils- ( isLeft, fromLeft- , increasingSeq- , addToRange, inRange, overlap- , dropLeadingZeroes- , pathParts- , nubOrd- , partitionDL- , getRecursiveContents- , catchIO- ) where--import Control.Monad (foldM)-import qualified Control.Exception as E-import Data.List ((\\))-import qualified Data.DList as DL-import Data.DList (DList)-import qualified Data.Set as Set-import System.Directory (getDirectoryContents)-import System.FilePath ((</>), isPathSeparator, dropDrive)-import System.IO.Unsafe (unsafeInterleaveIO)--#if mingw32_HOST_OS-import Data.Bits ((.&.))-import System.Win32.Types (withTString)-import System.Win32.File (c_GetFileAttributes, fILE_ATTRIBUTE_DIRECTORY)-#else-import Foreign.C.String (withCString)-import Foreign.Marshal.Alloc (allocaBytes)-import System.FilePath- (isDrive, dropTrailingPathSeparator, addTrailingPathSeparator)-import System.Posix.Internals (sizeof_stat, lstat, s_isdir, st_mode)-#endif--inRange :: Ord a => (a,a) -> a -> Bool-inRange (a,b) c = c >= a && c <= b---- returns Just (a range which covers both given ranges) or Nothing if they are--- disjoint.------ Assumes that the ranges are in the correct order, i.e. (fst x < snd x).-overlap :: Ord a => (a,a) -> (a,a) -> Maybe (a,a)-overlap (a,b) (c,d) =- if b >= c- then if b >= d- then if a <= c- then Just (a,b)- else Just (c,b)- else if a <= c- then Just (a,d)- else Just (c,d)- else Nothing--addToRange :: (Ord a, Enum a) => (a,a) -> a -> Maybe (a,a)-addToRange (a,b) c- | inRange (a,b) c = Just (a,b)- | c == pred a = Just (c,b)- | c == succ b = Just (a,c)- | otherwise = Nothing---- fst of result is in reverse order so that:------ If x = fst (increasingSeq (a:xs)), then--- x == reverse [a .. head x]-increasingSeq :: (Eq a, Enum a) => [a] -> ([a],[a])-increasingSeq [] = ([],[])-increasingSeq (x:xs) = go [x] xs- where- go is [] = (is,[])- go is@(i:_) (y:ys) =- if y == succ i- then go (y:is) ys- else (is, y:ys)- go _ _ = error "Glob.increasingSeq :: internal error"--isLeft :: Either a b -> Bool-isLeft (Left _) = True-isLeft _ = False--fromLeft :: Either a b -> a-fromLeft (Left x) = x-fromLeft _ = error "fromLeft :: Right"--dropLeadingZeroes :: String -> String-dropLeadingZeroes s =- let x = dropWhile (=='0') s- in if null x then "0" else x---- foo/bar/baz -> [foo/bar/baz,bar/baz,baz]-pathParts :: FilePath -> [FilePath]-pathParts p = p : let d = dropDrive p- in if null d || d == p- then f d- else d : f d- where- f [] = []- f (x:xs@(y:_)) | isPathSeparator x && isPathSeparator y = f xs- f (x:xs) =- if isPathSeparator x- then xs : f xs- else f xs---- Significantly speedier than System.Directory.doesDirectoryExist.-doesDirectoryExist :: FilePath -> IO Bool-#if mingw32_HOST_OS--- This one allocates more memory since it has to do a UTF-16 conversion, but--- that can't really be helped: the below version is locale-dependent.-doesDirectoryExist = flip withTString $ \s -> do- a <- c_GetFileAttributes s- return (a /= 0xffffffff && a.&.fILE_ATTRIBUTE_DIRECTORY /= 0)-#else-doesDirectoryExist s =- allocaBytes sizeof_stat $ \p ->- withCString- (if isDrive s- then addTrailingPathSeparator s- else dropTrailingPathSeparator s)- $ \c -> do- st <- lstat c p- if st == 0- then fmap s_isdir (st_mode p)- else return False-#endif--getRecursiveContents :: FilePath -> IO (DList FilePath)-getRecursiveContents dir =- flip catchIO (\_ -> return $ DL.singleton dir) $ do-- raw <- getDirectoryContents dir-- let entries = map (dir </>) (raw \\ [".",".."])- (dirs,files) <- partitionM doesDirectoryExist entries-- subs <- unsafeInterleaveIO . mapM getRecursiveContents $ dirs-- return$ DL.cons dir (DL.fromList files `DL.append` DL.concat subs)--partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a])-partitionM p_ = foldM (f p_) ([],[])- where- f p (ts,fs) x = p x >>= \b ->- if b- then return (x:ts, fs)- else return (ts, x:fs)--partitionDL :: (a -> Bool) -> DList a -> (DList a, DList a)-partitionDL p_ = DL.foldr (f p_) (DL.empty,DL.empty)- where- f p x (ts,fs) =- if p x- then (DL.cons x ts, fs)- else (ts, DL.cons x fs)--nubOrd :: Ord a => [a] -> [a]-nubOrd = go Set.empty- where- go _ [] = []- go set (x:xs) =- if Set.member x set- then go set xs- else x : go (Set.insert x set) xs--catchIO :: IO a -> (E.IOException -> IO a) -> IO a-catchIO = E.catch+{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +-- File created: 2008-10-10 13:40:35 + +module System.FilePath.Glob.Utils + ( isLeft, fromLeft + , increasingSeq + , addToRange, inRange, overlap + , dropLeadingZeroes + , pathParts + , nubOrd + , partitionDL, tailDL + , getRecursiveContents + , catchIO + ) where + +import Control.Monad (foldM) +import qualified Control.Exception as E +import Data.List ((\\)) +import qualified Data.DList as DL +import Data.DList (DList) +import qualified Data.Set as Set +import System.Directory (getDirectoryContents) +import System.FilePath ((</>), isPathSeparator, dropDrive) +import System.IO.Unsafe (unsafeInterleaveIO) + +#if mingw32_HOST_OS +import Data.Bits ((.&.)) +import System.Win32.Types (withTString) +import System.Win32.File (FileAttributeOrFlag, fILE_ATTRIBUTE_DIRECTORY) +import System.Win32.String (LPCTSTR) +#else +import Foreign.C.String (withCString) +import Foreign.Marshal.Alloc (allocaBytes) +import System.FilePath + (isDrive, dropTrailingPathSeparator, addTrailingPathSeparator) +import System.Posix.Internals (sizeof_stat, lstat, s_isdir, st_mode) +#endif + +inRange :: Ord a => (a,a) -> a -> Bool +inRange (a,b) c = c >= a && c <= b + +-- returns Just (a range which covers both given ranges) or Nothing if they are +-- disjoint. +-- +-- Assumes that the ranges are in the correct order, i.e. (fst x < snd x). +overlap :: Ord a => (a,a) -> (a,a) -> Maybe (a,a) +overlap (a,b) (c,d) = + if b >= c + then if b >= d + then if a <= c + then Just (a,b) + else Just (c,b) + else if a <= c + then Just (a,d) + else Just (c,d) + else Nothing + +addToRange :: (Ord a, Enum a) => (a,a) -> a -> Maybe (a,a) +addToRange (a,b) c + | inRange (a,b) c = Just (a,b) + | c == pred a = Just (c,b) + | c == succ b = Just (a,c) + | otherwise = Nothing + +-- fst of result is in reverse order so that: +-- +-- If x = fst (increasingSeq (a:xs)), then +-- x == reverse [a .. head x] +increasingSeq :: (Eq a, Enum a) => [a] -> ([a],[a]) +increasingSeq [] = ([],[]) +increasingSeq (x:xs) = go [x] xs + where + go is [] = (is,[]) + go is@(i:_) (y:ys) = + if y == succ i + then go (y:is) ys + else (is, y:ys) + go _ _ = error "Glob.increasingSeq :: internal error" + +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft _ = False + +fromLeft :: Either a b -> a +fromLeft (Left x) = x +fromLeft _ = error "fromLeft :: Right" + +dropLeadingZeroes :: String -> String +dropLeadingZeroes s = + let x = dropWhile (=='0') s + in if null x then "0" else x + +-- foo/bar/baz -> [foo/bar/baz,bar/baz,baz] +pathParts :: FilePath -> [FilePath] +pathParts p = p : let d = dropDrive p + in if null d || d == p + then f d + else d : f d + where + f [] = [] + f (x:xs@(y:_)) | isPathSeparator x && isPathSeparator y = f xs + f (x:xs) = + if isPathSeparator x + then xs : f xs + else f xs + +-- Significantly speedier than System.Directory.doesDirectoryExist. +doesDirectoryExist :: FilePath -> IO Bool +#if mingw32_HOST_OS +-- This one allocates more memory since it has to do a UTF-16 conversion, but +-- that can't really be helped: the below version is locale-dependent. +doesDirectoryExist = flip withTString $ \s -> do + a <- c_GetFileAttributes s + return (a /= 0xffffffff && a.&.fILE_ATTRIBUTE_DIRECTORY /= 0) +#else +doesDirectoryExist s = + allocaBytes sizeof_stat $ \p -> + withCString + (if isDrive s + then addTrailingPathSeparator s + else dropTrailingPathSeparator s) + $ \c -> do + st <- lstat c p + if st == 0 + then fmap s_isdir (st_mode p) + else return False +#endif + +#if mingw32_HOST_OS +#if defined(i386_HOST_ARCH) +foreign import stdcall unsafe "windows.h GetFileAttributesW" c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag +#elif defined(x86_64_HOST_ARCH) +foreign import ccall unsafe "windows.h GetFileAttributesW" c_GetFileAttributes :: LPCTSTR -> IO FileAttributeOrFlag +#else +#error Unknown mingw32 arch +#endif +#endif + +getRecursiveContents :: FilePath -> IO (DList FilePath) +getRecursiveContents dir = + flip catchIO (\_ -> return $ DL.singleton dir) $ do + + raw <- getDirectoryContents dir + + let entries = map (dir </>) (raw \\ [".",".."]) + (dirs,files) <- partitionM doesDirectoryExist entries + + subs <- unsafeInterleaveIO . mapM getRecursiveContents $ dirs + + return$ DL.cons dir (DL.fromList files `DL.append` DL.concat subs) + +partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM p_ = foldM (f p_) ([],[]) + where + f p (ts,fs) x = p x >>= \b -> + if b + then return (x:ts, fs) + else return (ts, x:fs) + +partitionDL :: (a -> Bool) -> DList a -> (DList a, DList a) +partitionDL p_ = DL.foldr (f p_) (DL.empty,DL.empty) + where + f p x (ts,fs) = + if p x + then (DL.cons x ts, fs) + else (ts, DL.cons x fs) + +tailDL :: DList a -> DList a +#if MIN_VERSION_dlist(1,0,0) +tailDL = DL.fromList . DL.tail +#else +tailDL = DL.tail +#endif + +nubOrd :: Ord a => [a] -> [a] +nubOrd = go Set.empty + where + go _ [] = [] + go set (x:xs) = + if Set.member x set + then go set xs + else x : go (Set.insert x set) xs + +catchIO :: IO a -> (E.IOException -> IO a) -> IO a +catchIO = E.catch
tests/Main.hs view
@@ -1,32 +1,36 @@--- File created: 2008-10-10 16:23:56--module Main (main) where--import System.Environment (getArgs)-import Test.Framework--import qualified Tests.Compiler as Compiler-import qualified Tests.Instances as Instances-import qualified Tests.Matcher as Matcher-import qualified Tests.Optimizer as Optimizer-import qualified Tests.Regression as Regression-import qualified Tests.Simplifier as Simplifier-import qualified Tests.Utils as Utils--main = do- args <- getArgs- defaultMainWithArgs tests . concat $- [ ["--timeout", show 10]- , ["--maximum-generated-tests", show 1000]- , args- ]--tests =- [ Regression.tests- , Utils.tests- , Compiler.tests- , Matcher.tests- , Optimizer.tests- , Simplifier.tests- , Instances.tests- ]+-- File created: 2008-10-10 16:23:56 + +module Main (main) where + +import System.Environment (getArgs) +import Test.Framework + +import qualified Tests.Compiler as Compiler +import qualified Tests.Directory as Directory +import qualified Tests.Instances as Instances +import qualified Tests.Matcher as Matcher +import qualified Tests.Optimizer as Optimizer +import qualified Tests.Regression as Regression +import qualified Tests.Simplifier as Simplifier +import qualified Tests.Utils as Utils + +main :: IO () +main = do + args <- getArgs + defaultMainWithArgs tests . concat $ + [ ["--timeout", show (10 :: Int)] + , ["--maximum-generated-tests", show (1000 :: Int)] + , args + ] + +tests :: [Test] +tests = + [ Regression.tests + , Utils.tests + , Compiler.tests + , Matcher.tests + , Optimizer.tests + , Simplifier.tests + , Instances.tests + , Directory.tests + ]
tests/Tests/Base.hs view
@@ -1,80 +1,91 @@--- File created: 2008-10-10 22:03:00--module Tests.Base ( PString(unPS), Path(unP), COpts(unCOpts)- , (-->), fromRight, isRight- ) where--import System.FilePath (extSeparator, pathSeparators)-import Test.QuickCheck--import System.FilePath.Glob.Base (CompOptions(..))--newtype PString = PatString { unPS :: String } deriving Show-newtype Path = Path { unP :: String } deriving Show-newtype COpts = COpts { unCOpts :: CompOptions } deriving Show--alpha0 = extSeparator : "-^!" ++ ['a'..'z'] ++ ['0'..'9']-alpha = pathSeparators ++ alpha0--instance Arbitrary PString where- arbitrary = sized $ \size -> do- let xs =- (1, return "**/") :- map (\(a,b) -> (a*100,b))- [ (40, plain alpha)- , (20, return "?")- , (20, charRange)- , (10, return "*")- , (10, openRange)- ]-- s <- mapM (const $ frequency xs) [1..size]- return.PatString $ concat s--instance Arbitrary Path where- arbitrary = sized $ \size -> do- s <- mapM (const $ plain alpha) [1..size `mod` 16]- return.Path $ concat s--instance Arbitrary COpts where- arbitrary = do- [a,b,c,d,e,f] <- vector 6- return.COpts $ CompOptions a b c d e f False--plain from = sized $ \size -> do- s <- mapM (const $ elements from) [0..size `mod` 3]- return s--charRange = do- s <- plain alpha0- if s `elem` ["^","!"]- then do- s' <- plain alpha0- return$ "[" ++ s ++ s' ++ "]"- else- return$ "[" ++ s ++ "]"--openRange = do- probA <- choose (0,1) :: Gen Float- probB <- choose (0,1) :: Gen Float- a <- if probA > 0.4- then fmap (Just .abs) arbitrary- else return Nothing- b <- if probB > 0.4- then fmap (Just .abs) arbitrary- else return Nothing- return.concat $- [ "<"- , maybe "" show (a :: Maybe Int)- , "-"- , maybe "" show (b :: Maybe Int)- , ">"- ]--fromRight (Right x) = x-fromRight _ = error "fromRight :: Left"--isRight (Right _) = True-isRight _ = False--a --> b = not a || b+-- File created: 2008-10-10 22:03:00 + +module Tests.Base ( PString(unPS), Path(unP), COpts(unCOpts) + , (-->), fromRight, isRight + ) where + +import System.FilePath (extSeparator, pathSeparators) +import Test.QuickCheck + +import System.FilePath.Glob.Base (CompOptions(..)) + +newtype PString = PatString { unPS :: String } deriving Show +newtype Path = Path { unP :: String } deriving Show +newtype COpts = COpts { unCOpts :: CompOptions } deriving Show + +alpha0, alpha :: String +alpha0 = extSeparator : "-^!" ++ ['a'..'z'] ++ ['0'..'9'] +alpha = pathSeparators ++ alpha0 + +instance Arbitrary PString where + arbitrary = sized $ \size -> do + let xs = + (1, return "**/") : + map (\(a,b) -> (a*100,b)) + [ (40, plain alpha) + , (20, return "?") + , (20, charRange) + , (10, return "*") + , (10, openRange) + ] + + s <- mapM (const $ frequency xs) [1..size] + return.PatString $ concat s + + shrink (PatString s) = map PatString (shrink s) + +instance Arbitrary Path where + arbitrary = sized $ \size -> do + s <- mapM (const $ plain alpha) [1..size `mod` 16] + return.Path $ concat s + + shrink (Path s) = map Path (shrink s) + +instance Arbitrary COpts where + arbitrary = do + (a,b,c,d,e,f) <- arbitrary + return.COpts $ CompOptions a b c d e f False + + +plain :: String -> Gen String +plain from = sized $ \size -> mapM (const $ elements from) [0..size `mod` 3] + +charRange :: Gen String +charRange = do + s <- plain alpha0 + if s `elem` ["^","!"] + then do + s' <- plain alpha0 + return$ "[" ++ s ++ s' ++ "]" + else + return$ "[" ++ s ++ "]" + +openRange :: Gen String +openRange = do + probA <- choose (0,1) :: Gen Float + probB <- choose (0,1) :: Gen Float + a <- if probA > 0.4 + then fmap (Just .abs) arbitrary + else return Nothing + b <- if probB > 0.4 + then fmap (Just .abs) arbitrary + else return Nothing + return.concat $ + [ "<" + , maybe "" show (a :: Maybe Int) + , "-" + , maybe "" show (b :: Maybe Int) + , ">" + ] + +-- Not in Data.Either until base-4.7 (GHC 7.8) +isRight :: Either a b -> Bool +isRight (Right _) = True +isRight _ = False + +fromRight :: Either a b -> b +fromRight (Right x) = x +fromRight _ = error "fromRight :: Left" + +(-->) :: Bool -> Bool -> Bool +a --> b = not a || b
tests/Tests/Compiler.hs view
@@ -1,22 +1,41 @@--- File created: 2009-01-30 13:26:51--module Tests.Compiler (tests) where--import Test.Framework-import Test.Framework.Providers.QuickCheck2--import System.FilePath.Glob.Base (tryCompileWith, compile, decompile)--import Tests.Base--tests = testGroup "Compiler"- [ testProperty "compile-decompile-1" prop_compileDecompile1- ]---- compile . decompile should be the identity function-prop_compileDecompile1 o s =- let opt = unCOpts o- epat1 = tryCompileWith opt (unPS s)- pat1 = fromRight epat1- pat2 = compile . decompile $ pat1- in isRight epat1 && pat1 == pat2+-- File created: 2009-01-30 13:26:51 + +module Tests.Compiler (tests) where + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck (Property, (==>)) + +import System.FilePath.Glob.Base + (CompOptions(..), compDefault, compile, decompile, isLiteral, tryCompileWith) + +import Tests.Base + +tests :: Test +tests = testGroup "Compiler" + [ testProperty "compile-decompile-1" prop_compileDecompile1 + , testProperty "isliteral" prop_isLiteral + ] + +-- compile . decompile should be the identity function +prop_compileDecompile1 :: COpts -> PString -> Property +prop_compileDecompile1 o s = + let opt = unCOpts o + epat1 = tryCompileWith opt (unPS s) + pat1 = fromRight epat1 + pat2 = compile . decompile $ pat1 + in isRight epat1 ==> pat1 == pat2 + +prop_isLiteral :: PString -> Property +prop_isLiteral p = + let epat = tryCompileWith noWildcardOptions (unPS p) + pat = fromRight epat + in isRight epat ==> (isLiteral . compile . decompile) pat + where + noWildcardOptions = compDefault + { characterClasses = False + , characterRanges = False + , numberRanges = False + , wildcards = False + , recursiveWildcards = False + }
+ tests/Tests/Directory.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE CPP #-} +module Tests.Directory where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck (Property, (===)) +import Test.HUnit.Base hiding (Test) +import Data.Function (on) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mappend) +#endif +import Data.List ((\\), sort) +import qualified Data.DList as DList + +import System.FilePath.Glob.Base +import System.FilePath.Glob.Directory +import System.FilePath.Glob.Primitive +import System.FilePath.Glob.Utils +import Tests.Base (PString, unPS) + +tests :: Test +tests = testGroup "Directory" + [ testCase "includeUnmatched" caseIncludeUnmatched + , testCase "onlyMatched" caseOnlyMatched + , testGroup "commonDirectory" + [ testGroup "edge-cases" testsCommonDirectoryEdgeCases + , testProperty "property" prop_commonDirectory + ] + , testCase "globDir1" caseGlobDir1 + , testGroup "repeated-path-separators" testsRepeatedPathSeparators + ] + +caseIncludeUnmatched :: Assertion +caseIncludeUnmatched = do + let pats = ["**/D*.hs", "**/[MU]*.hs"] + everything <- getRecursiveContentsDir "System" + let expectedMatches = + [ [ "System/FilePath/Glob/Directory.hs" ] + , [ "System/FilePath/Glob/Match.hs" + , "System/FilePath/Glob/Utils.hs" + ] + ] + let everythingElse = everything \\ concat expectedMatches + + result <- globDirWith (GlobOptions matchDefault True) + (map compile pats) + "System" + mapM_ (uncurry assertEqualUnordered) (zip expectedMatches (fst result)) + + case snd result of + Nothing -> assertFailure "Expected Just a list of unmatched files" + Just unmatched -> assertEqualUnordered everythingElse unmatched + +caseOnlyMatched :: Assertion +caseOnlyMatched = do + let pats = ["**/D*.hs", "**/[MU]*.hs"] + let expectedMatches = + [ [ "System/FilePath/Glob/Directory.hs" ] + , [ "System/FilePath/Glob/Match.hs" + , "System/FilePath/Glob/Utils.hs" + ] + ] + + result <- globDirWith globDefault + (map compile pats) + "System" + + mapM_ (uncurry assertEqualUnordered) (zip expectedMatches (fst result)) + assertEqual "" Nothing (snd result) + +caseGlobDir1 :: Assertion +caseGlobDir1 = do + -- this is little a bit of a hack; we pass the same pattern twice to ensure + -- that the optimization in the single pattern case is bypassed + let naiveGlobDir1 p = fmap head . globDir [p, p] + let pat = compile "FilePath/*/*.hs" + let dir = "System" + + actual <- globDir1 pat dir + expected <- naiveGlobDir1 pat dir + assertEqual "" expected actual + +assertEqualUnordered :: (Ord a, Show a) => [a] -> [a] -> Assertion +assertEqualUnordered = assertEqual "" `on` sort + +-- Like 'getRecursiveContents', except this function removes the root directory +-- from the returned list, so that it should match* the union of matched and +-- unmatched files returned from 'globDirWith', where the same directory was +-- given as the directory argument. +-- +-- * to be a little more precise, these files will only match up to +-- normalisation of paths e.g. some patterns will cause the list of matched +-- files to contain repeated slashes, whereas the list returned by this +-- function will not have repeated slashes. +getRecursiveContentsDir :: FilePath -> IO [FilePath] +getRecursiveContentsDir root = + fmap (filter (/= root) . DList.toList) (getRecursiveContents root) + +-- These two patterns should always be equal +prop_commonDirectory' :: String -> (Pattern, Pattern) +prop_commonDirectory' str = + let pat = compile str + (a, b) = commonDirectory pat + in (pat, literal a `mappend` b) + +prop_commonDirectory :: PString -> Property +prop_commonDirectory = uncurry (===) . prop_commonDirectory' . unPS + +testsCommonDirectoryEdgeCases :: [Test] +testsCommonDirectoryEdgeCases = zipWith mkTest [1 :: Int ..] testData + where + mkTest i (input, expected) = + testCase (show i) $ do + assertEqual "" expected (commonDirectory (compile input)) + uncurry (assertEqual "") (prop_commonDirectory' input) + + testData = + [ ("[.]/*", ("", compile "[.]")) + , ("foo/[.]bar/*", ("", compile "[.]")) + , ("[.]foo/bar/*", ("", compile "[.]foo/bar/*")) + , ("foo.bar/baz/*", ("foo.bar/baz/", compile "*")) + , ("[f]oo[.]/bar/*", ("foo./bar/", compile "*")) + , ("foo[.]bar/baz/*", ("foo.bar/baz/", compile "*")) + , (".[.]/foo/*", ("../foo/", compile "*")) + ] + +-- see #16 +testsRepeatedPathSeparators :: [Test] +testsRepeatedPathSeparators = zipWith mkTest [1 :: Int ..] testData + where + mkTest i (dir, pat, expected) = + testCase (show i) $ do + actual <- globDir1 (compile pat) dir + assertEqualUnordered expected actual + + testData = + [ ( "System" + , "*//Glob///[U]*.hs" + , [ "System/FilePath//Glob///Utils.hs" + ] + ) + , ( "System" + , "**//[GU]*.hs" + , [ "System/FilePath//Glob.hs" + , "System/FilePath/Glob//Utils.hs" + ] + ) + , ( "System" + , "File**/" + , [ "System/FilePath/" + ] + ) + , ( "System" + , "File**//" + , [ "System/FilePath//" + ] + ) + , ( "System" + , "File**///" + , [ "System/FilePath///" + ] + ) + , ( "System/FilePath" + , "**//Glob.hs" + , [ "System/FilePath//Glob.hs" + ] + ) + , ( "System" + , "**Path/Glob//Utils.hs" + , [ "System/FilePath/Glob//Utils.hs" + ] + ) + ]
tests/Tests/Instances.hs view
@@ -1,59 +1,69 @@--- File created: 2009-01-30 15:01:02--module Tests.Instances (tests) where--import Data.Monoid (mempty, mappend)-import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck ((==>))--import System.FilePath.Glob.Base (tryCompileWith)-import System.FilePath.Glob.Match-import System.FilePath.Glob.Simplify--import Tests.Base--tests = testGroup "Instances"- [ testProperty "monoid-law-1" prop_monoidLaw1- , testProperty "monoid-law-2" prop_monoidLaw2- , testProperty "monoid-law-3" prop_monoidLaw3- , testProperty "monoid-4" prop_monoid4- ]---- The monoid laws: associativity...-prop_monoidLaw1 opt x y z =- let o = unCOpts opt- es = map (tryCompileWith o . unPS) [x,y,z]- [a,b,c] = map fromRight es- in all isRight es && mappend a (mappend b c) == mappend (mappend a b) c---- ... left identity ...-prop_monoidLaw2 opt x =- let o = unCOpts opt- e = tryCompileWith o (unPS x)- a = fromRight e- in isRight e && mappend mempty a == a---- ... and right identity.-prop_monoidLaw3 opt x =- let o = unCOpts opt- e = tryCompileWith o (unPS x)- a = fromRight e- in isRight e && mappend a mempty == a---- mappending two Patterns should be equivalent to appending the original--- strings they came from and compiling that------ (notice: relies on the fact that our Arbitrary instance doesn't generate--- unclosed [] or <>; we only check for **/)-prop_monoid4 opt x y =- let o = unCOpts opt- es = map (tryCompileWith o . unPS) [x,y]- [a,b] = map fromRight es- cat1 = mappend a b- cat2 = tryCompileWith o (unPS x ++ unPS y)- last2 = take 2 . reverse . unPS $ x- head2 = take 2 . unPS $ y- in (last2 /= "**" && take 1 head2 /= "/")- && (take 1 last2 /= "*" && take 2 head2 /= "*/")- ==> all isRight es && isRight cat2 && cat1 == fromRight cat2+-- File created: 2009-01-30 15:01:02 + +{-# LANGUAGE CPP #-} + +module Tests.Instances (tests) where + +-- Monoid is re-exported from Prelude as of 4.8.0.0 +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mempty, mappend) +#endif +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck (Property, (==>)) + +import System.FilePath.Glob.Base (Token(Unmatchable), tryCompileWith, unPattern) + +import Tests.Base + +tests :: Test +tests = testGroup "Instances" + [ testProperty "monoid-law-1" prop_monoidLaw1 + , testProperty "monoid-law-2" prop_monoidLaw2 + , testProperty "monoid-law-3" prop_monoidLaw3 + , testProperty "monoid-4" prop_monoid4 + ] + +-- The monoid laws: associativity... +prop_monoidLaw1 :: COpts -> PString -> PString -> PString -> Property +prop_monoidLaw1 opt x y z = + let o = unCOpts opt + es = map (tryCompileWith o . unPS) [x,y,z] + [a,b,c] = map fromRight es + in all isRight es ==> mappend a (mappend b c) == mappend (mappend a b) c + +-- ... left identity ... +prop_monoidLaw2 :: COpts -> PString -> Property +prop_monoidLaw2 opt x = + let o = unCOpts opt + e = tryCompileWith o (unPS x) + a = fromRight e + in isRight e ==> mappend mempty a == a + +-- ... and right identity. +prop_monoidLaw3 :: COpts -> PString -> Property +prop_monoidLaw3 opt x = + let o = unCOpts opt + e = tryCompileWith o (unPS x) + a = fromRight e + in isRight e ==> mappend a mempty == a + +-- mappending two Patterns should be equivalent to appending the original +-- strings they came from and compiling that +-- +-- (notice: relies on the fact that our Arbitrary instance doesn't generate +-- unclosed [] or <>; we only check for **/ and Unmatchable) +prop_monoid4 :: COpts -> PString -> PString -> Property +prop_monoid4 opt x y = + let o = unCOpts opt + es = map (tryCompileWith o . unPS) [x,y] + [a,b] = map fromRight es + cat1 = mappend a b + cat2 = tryCompileWith o (unPS x ++ unPS y) + last2 = take 2 . reverse . unPS $ x + head2 = take 2 . unPS $ y + in (last2 /= "**" && take 1 head2 /= "/") + && (take 1 last2 /= "*" && take 2 head2 /= "*/") + && all isRight es && isRight cat2 + && take 1 (unPattern b) /= [Unmatchable] + ==> cat1 == fromRight cat2
tests/Tests/Matcher.hs view
@@ -1,50 +1,78 @@--- File created: 2008-10-16 16:16:06--module Tests.Matcher (tests) where--import Control.Monad (ap)-import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck ((==>))--import System.FilePath (isExtSeparator, isPathSeparator)-import System.FilePath.Glob.Base-import System.FilePath.Glob.Match--import Tests.Base--tests = testGroup "Matcher"- [ testProperty "match-1" prop_match1- , testProperty "match-2" prop_match2- , testProperty "match-3" prop_match3- ]---- ./foo should be equivalent to foo in both path and pattern--- ... but not for the pattern if it starts with /-prop_match1 o p_ s =- let p = dropWhile isPathSeparator (unPS p_)- ep = tryCompileWith (unCOpts o) p- ep' = tryCompileWith (unCOpts o) ("./" ++ p)- pat = fromRight ep- pat' = fromRight ep'- pth = unP s- pth' = "./" ++ pth- in and [ isRight ep, isRight ep'- , ( all (uncurry (==)) . (zip`ap`tail) $- [ match pat pth- , match pat pth'- , match pat' pth- , match pat' pth'- ]- ) || null p- ]---- [/] shouldn't match anything-prop_match2 = not . match (compile "[/]") . take 1 . unP---- [!/] is like ?-prop_match3 p_ =- let p = unP p_- ~(x:_) = p- in not (null p || isPathSeparator x || isExtSeparator x)- ==> match (compile "[!/]") [x]+-- File created: 2008-10-16 16:16:06 + +module Tests.Matcher (tests) where + +import Control.Monad (ap) +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck (Property, (==>)) + +import System.FilePath (isExtSeparator, isPathSeparator) +import System.FilePath.Glob.Base +import System.FilePath.Glob.Match + +import Tests.Base + +tests :: Test +tests = testGroup "Matcher" + [ testProperty "match-1" prop_match1 + , testProperty "match-2" prop_match2 + , testProperty "match-3" prop_match3 + , testProperty "match-4" prop_match4 + ] + +-- ./foo should be equivalent to foo in both path and pattern +-- ... but not when exactly one of the two starts with / +-- ... and when both start with /, not when adding ./ to only one of them +prop_match1 :: COpts -> PString -> Path -> Property +prop_match1 o p_ pth_ = + let p0 = unPS p_ + pth0 = unP pth_ + (p, pth) = + if (not (null p0) && isPathSeparator (head p0)) /= + (not (null pth0) && isPathSeparator (head pth0)) + then (dropWhile isPathSeparator p0, dropWhile isPathSeparator pth0) + else (p0, pth0) + ep = tryCompileWith (unCOpts o) p + ep' = tryCompileWith (unCOpts o) ("./" ++ p) + pat = fromRight ep + pat' = fromRight ep' + pth' = "./" ++ pth + in not (null p) && isRight ep && isRight ep' + ==> all (uncurry (==)) . (zip`ap`tail) $ + if isPathSeparator (head p) + && not (null pth) && isPathSeparator (head pth) + then [ match pat pth + , match pat' pth' + ] + else [ match pat pth + , match pat pth' + , match pat' pth + , match pat' pth' + ] + +-- [/] shouldn't match anything +prop_match2 :: Path -> Bool +prop_match2 = not . match (compile "[/]") . take 1 . unP + +-- [!/] is like ? +prop_match3 :: Path -> Property +prop_match3 p_ = + let p = unP p_ + ~(x:_) = p + in not (null p || isPathSeparator x || isExtSeparator x) + ==> match (compile "[!/]") [x] + +-- Anything should match itself, when compiled with everything disabled. +prop_match4 :: PString -> Bool +prop_match4 ps_ = + let ps = unPS ps_ + noOpts = CompOptions { characterClasses = False + , characterRanges = False + , numberRanges = False + , wildcards = False + , recursiveWildcards = False + , pathSepInRanges = False + , errorRecovery = True + } + in match (compileWith noOpts ps) ps
tests/Tests/Optimizer.hs view
@@ -1,29 +1,55 @@--- File created: 2008-10-11 11:18:31--module Tests.Optimizer (tests) where--import Test.Framework-import Test.Framework.Providers.QuickCheck2--import System.FilePath.Glob.Base (tokenize, optimize)-import System.FilePath.Glob.Match--import Tests.Base--tests = testGroup "Optimizer"- [ testProperty "optimize-1" prop_optimize1- , testProperty "optimize-2" prop_optimize2- ]---- Optimizing twice should give the same result as optimizing once-prop_optimize1 o s =- let pat = tokenize (unCOpts o) (unPS s)- xs = iterate optimize (fromRight pat)- in isRight pat && xs !! 1 == xs !! 2---- Optimizing shouldn't affect whether a match succeeds-prop_optimize2 o p s =- let x = tokenize (unCOpts o) (unPS p)- pat = fromRight x- pth = unP s- in isRight x && match pat pth == match (optimize pat) pth+-- File created: 2008-10-11 11:18:31 + +module Tests.Optimizer (tests) where + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck (Property, (==>)) + +import System.FilePath.Glob.Base + (Token(..), optimize, liftP, tokenize, unPattern) +import System.FilePath.Glob.Match + +import Tests.Base + +tests :: Test +tests = testGroup "Optimizer" + [ testProperty "optimize-1" prop_optimize1 + , testProperty "optimize-2" prop_optimize2 + , testProperty "optimize-3" prop_optimize3 + ] + +-- Optimizing twice should give the same result as optimizing once +prop_optimize1 :: COpts -> PString -> Property +prop_optimize1 o s = + let pat = tokenize (unCOpts o) (unPS s) + xs = iterate optimize (fromRight pat) + in isRight pat ==> xs !! 1 == xs !! 2 + +-- Optimizing shouldn't affect whether a match succeeds +-- +-- ...except for some things that are explicitly not handled in matching: +-- * ExtSeparator removal +-- * AnyNonPathSeparator flattening +prop_optimize2 :: COpts -> PString -> Path -> Property +prop_optimize2 o p s = + let x = tokenize (unCOpts o) (unPS p) + pat = fromRight x + pth = unP s + in isRight x ==> match (liftP miniOptimize pat) pth + == match (optimize pat) pth + where + miniOptimize = go + + go (ExtSeparator : xs) = Literal '.' : go xs + go (AnyNonPathSeparator : xs@(AnyNonPathSeparator : _)) = go xs + go (x:xs) = x : go xs + go [] = [] + +-- Optimizing should remove all ExtSeparators +prop_optimize3 :: COpts -> PString -> Property +prop_optimize3 o p = + let x = tokenize (unCOpts o) (unPS p) + pat = fromRight x + in isRight x && ExtSeparator `elem` unPattern pat + ==> ExtSeparator `notElem` unPattern (optimize pat)
tests/Tests/Regression.hs view
@@ -1,132 +1,156 @@--- File created: 2008-10-15 20:21:41--module Tests.Regression (tests) where--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit.Base--import System.FilePath.Glob.Base-import System.FilePath.Glob.Match--tests = testGroup "Regression"- [ testGroup "Matching/compiling" .- flip map matchCases $ \t@(b,p,s) ->- tc (nameMatchTest t) $- match (compile p) s == b- , testGroup "Specific options" .- flip map matchWithCases $ \t@(b,co,mo,p,s) ->- tc (nameMatchTest (b,p,s)) $- matchWith mo (compileWith co p) s == b- , testGroup "Decompilation" .- flip map decompileCases $ \(n,orig,s) ->- tc n $ decompile (compile orig) == s- ]- where- tc n = testCase n . assert--nameMatchTest (True ,p,s) = show p ++ " matches " ++ show s-nameMatchTest (False,p,s) = show p ++ " doesn't match " ++ show s--decompileCases =- [ ("range-compression-1", "[*]", "[*]")- , ("range-compression-2", "[.]", "[.]")- , ("range-compression-3", "**[/]", "*[/]")- , ("range-compression-4", "x[.]", "x[.]")- , ("range-compression-5", "[^~-]", "[^~-]")- , ("range-compression-6", "[^!-]", "[^!-]")- ]--matchCases =- [ (True , "*" , "")- , (True , "**" , "")- , (True , "asdf" , "asdf")- , (True , "a*f" , "asdf")- , (True , "a??f" , "asdf")- , (True , "*" , "asdf")- , (True , "a*bc" , "aXbaXbc")- , (True , "a**bc" , "aXbaXbc")- , (False, "a*b" , "aXc")- , (True , "foo/bar.*" , "foo/bar.baz")- , (True , "foo/*.baz" , "foo/bar.baz")- , (False, "*bar.*" , "foo/bar.baz")- , (False, "*.baz" , "foo/bar.baz")- , (False, "foo*" , "foo/bar.baz")- , (False, "foo?bar.baz", "foo/bar.baz")- , (True , "**/*.baz" , "foo/bar.baz")- , (True , "**/*" , "foo/bar.baz")- , (True , "**/*" , "foo/bar/baz")- , (True , "*/*.baz" , "foo/bar.baz")- , (True , "*/*" , "foo/bar.baz")- , (False, "*/*" , "foo/bar/baz")- , (False, "*.foo" , ".bar.foo")- , (False, "*.bar.foo" , ".bar.foo")- , (False, "?bar.foo" , ".bar.foo")- , (True , ".*.foo" , ".bar.foo")- , (True , ".*bar.foo" , ".bar.foo")- , (False, "foo.[ch]" , "foo.a")- , (True , "foo.[ch]" , "foo.c")- , (True , "foo.[ch]" , "foo.h")- , (False, "foo.[ch]" , "foo.d")- , (False, "foo.[c-h]" , "foo.b")- , (True , "foo.[c-h]" , "foo.c")- , (True , "foo.[c-h]" , "foo.e")- , (True , "foo.[c-h]" , "foo.f")- , (True , "foo.[c-h]" , "foo.h")- , (False, "foo.[c-h]" , "foo.i")- , (True , "<->3foo" , "123foo")- , (True , "<10-15>3foo", "123foo")- , (True , "<0-5>23foo" , "123foo")- , (True , "<94-200>foo", "123foo")- , (False, "[.]x" , ".x")- , (False, "foo[/]bar" , "foo/bar")- , (False, "foo[,-0]bar", "foo/bar")- , (True , "foo[,-0]bar", "foo.bar")- , (True , "[]x]" , "]")- , (True , "[]x]" , "x")- , (False, "[b-a]" , "a")- , (False, "<4-3>" , "3")- , (True , "[]-b]" , "]")- , (False, "[]-b]" , "-")- , (True , "[]-b]" , "b")- , (True , "[]-b]" , "a")- , (True , "[]-]" , "]")- , (True , "[]-]" , "-")- , (True , "[#-[]" , "&")- , (False, "[^x]" , "/")- , (False, "[/]" , "/")- , (True , "a[^x]" , "a.")- , (True , "a[.]" , "a.")- , (False, ".//a" , "/a")- , (True, ".//a" , "a")- , (True, ".//a" , "./a")- , (True , ".*/a" , "./a")- , (True , ".*/a" , "../a")- , (True , ".*/a" , ".foo/a")- , (True , ".**/a" , ".foo/a")- , (False, ".**/a" , "../a")- , (False, ".**/a" , "./a")- , (False, ".**/a" , "a")- , (True , ".**/a" , ".foo/a")- , (True , "f**/a" , "foo/a")- , (True , "f**/" , "f/")- , (True , "f**/" , "f///")- , (True , "f**/x" , "f///x")- , (True , "f/" , "f///")- , (True , "f/x" , "f///x")- , (True , "[]" , "[]")- , (True , "[!]" , "[!]")- , (True , "[^]" , "[^]")- , (True , "[abc" , "[abc")- , (True , "<abc" , "<abc")- , (True , "<1-" , "<1-")- , (True , "[^-~]" , "x")- , (False, "[^-~]" , "X")- , (False, "[^^-~]" , "x")- , (False, "[^-]" , "-")- ]--matchWithCases =- [ (True , compDefault, matchDefault { ignoreCase = True }, "[@-[]", "a")- , (True , compPosix , matchDefault , "a[/]b", "a[/]b")- ]+-- File created: 2008-10-15 20:21:41 + +module Tests.Regression (tests) where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit.Base hiding (Test) + +import System.FilePath.Glob.Base +import System.FilePath.Glob.Match + +tests :: Test +tests = testGroup "Regression" + [ testGroup "Matching/compiling" . + flip map matchCases $ \t@(b,p,s) -> + tc (nameMatchTest t) $ + match (compile p) s == b + , testGroup "Specific options" . + flip map matchWithCases $ \(b,co,mo,p,s) -> + tc (nameMatchTest (b,p,s)) $ + matchWith mo (compileWith co p) s == b + , testGroup "Decompilation" . + flip map decompileCases $ \(n,orig,s) -> + tc n $ decompile (compile orig) == s + ] + where + tc n = testCase n . assert + +nameMatchTest :: (Bool, String, FilePath) -> String +nameMatchTest (True ,p,s) = show p ++ " matches " ++ show s +nameMatchTest (False,p,s) = show p ++ " doesn't match " ++ show s + +decompileCases :: [(String, String, String)] +decompileCases = + [ ("range-compression-1", "[*]", "[*]") + , ("range-compression-2", "[.]", "[.]") + , ("range-compression-3", "**[/]", "[.]") + , ("range-compression-4", "x[.]", "x.") + , ("range-compression-5", "[^~-]", "[^~-]") + , ("range-compression-6", "[^!-]", "[^!-]") + , ("range-compression-7", "/[a.]", "/a") + , ("range-compression-8", "/[.!^]", "/[/^!]") + , ("range-compression-9", "[/!^]", "[/^!]") + , ("num-compression-1", "<->[0-9]<->", "[0-9][0-9]<->") + ] + +matchCases :: [(Bool, String, String)] +matchCases = + [ (True , "*" , "") + , (True , "**" , "") + , (True , "asdf" , "asdf") + , (True , "a*f" , "asdf") + , (True , "a??f" , "asdf") + , (True , "*" , "asdf") + , (True , "a*bc" , "aXbaXbc") + , (True , "a**bc" , "aXbaXbc") + , (False, "a*b" , "aXc") + , (True , "foo/bar.*" , "foo/bar.baz") + , (True , "foo/*.baz" , "foo/bar.baz") + , (False, "*bar.*" , "foo/bar.baz") + , (False, "*.baz" , "foo/bar.baz") + , (False, "foo*" , "foo/bar.baz") + , (False, "foo?bar.baz", "foo/bar.baz") + , (True , "**/*.baz" , "foo/bar.baz") + , (True , "**/*" , "foo/bar.baz") + , (True , "**/*" , "foo/bar/baz") + , (True , "*/*.baz" , "foo/bar.baz") + , (True , "*/*" , "foo/bar.baz") + , (False, "*/*" , "foo/bar/baz") + , (False, "*.foo" , ".bar.foo") + , (False, "*.bar.foo" , ".bar.foo") + , (False, "?bar.foo" , ".bar.foo") + , (True , ".*.foo" , ".bar.foo") + , (True , ".*bar.foo" , ".bar.foo") + , (False, "foo.[ch]" , "foo.a") + , (True , "foo.[ch]" , "foo.c") + , (True , "foo.[ch]" , "foo.h") + , (False, "foo.[ch]" , "foo.d") + , (False, "foo.[c-h]" , "foo.b") + , (True , "foo.[c-h]" , "foo.c") + , (True , "foo.[c-h]" , "foo.e") + , (True , "foo.[c-h]" , "foo.f") + , (True , "foo.[c-h]" , "foo.h") + , (False, "foo.[c-h]" , "foo.i") + , (True , "<->3foo" , "123foo") + , (True , "<10-15>3foo", "123foo") + , (True , "<0-5>23foo" , "123foo") + , (True , "<94-200>foo", "123foo") + , (False, "[.]x" , ".x") + , (False, "foo[/]bar" , "foo/bar") + , (False, "foo[,-0]bar", "foo/bar") + , (True , "foo[,-0]bar", "foo.bar") + , (True , "[]x]" , "]") + , (True , "[]x]" , "x") + , (False, "[b-a]" , "a") + , (False, "<4-3>" , "3") + , (True, "<0-1>" , "00") + , (True, "<0-1>" , "01") + , (True, "<1-1>" , "01") + , (True , "[]-b]" , "]") + , (False, "[]-b]" , "-") + , (True , "[]-b]" , "b") + , (True , "[]-b]" , "a") + , (True , "[]-]" , "]") + , (True , "[]-]" , "-") + , (True , "[#-[]" , "&") + , (False, "[^x]" , "/") + , (False, "[/]" , "/") + , (True , "a[^x]" , "a.") + , (True , "a[.]" , "a.") + , (False, ".//a" , "/a") + , (True, ".//a" , "a") + , (True, ".//a" , "./a") + , (True , ".*/a" , "./a") + , (True , ".*/a" , "../a") + , (True , ".*/a" , ".foo/a") + , (True , ".**/a" , ".foo/a") + , (False, ".**/a" , "../a") + , (False, ".**/a" , "./a") + , (False, ".**/a" , "a") + , (True , ".**/a" , ".foo/a") + , (True , "f**/a" , "foo/a") + , (True , "f**/" , "f/") + , (True , "f**/" , "f///") + , (True , "f**/x" , "f///x") + , (True , "f/" , "f///") + , (True , "f/x" , "f///x") + , (True , "[]" , "[]") + , (True , "[!]" , "[!]") + , (True , "[^]" , "[^]") + , (True , "[abc" , "[abc") + , (True , "<abc" , "<abc") + , (True , "<1-" , "<1-") + , (True , "[^-~]" , "x") + , (False, "[^-~]" , "X") + , (False, "[^^-~]" , "x") + , (False, "[^-]" , "-") + , (True, "//" , "//") + , (True, ".//" , ".//") + , (True, "?" , ".//a") + , (False, "<-><->" , "1") + , (True, "<0-0><1-1>" , "01") + , (True, "<0-1><0-1>" , "00") + , (False, "a/**/d" , "a/.b/c/d") + , (False, "a/**/d" , "a/b/.c/d") + , (True, "a/**/.d" , "a/b/c/.d") + , (True, "a/**/.c/d" , "a/b/.c/d") + , (True, "a/**/.c/.d" , "a/b/.c/.d") + , (True, "a/**/.d/.e" , "a/b/c/.d/.e") + ] + +matchWithCases :: [(Bool, CompOptions, MatchOptions, String, String)] +matchWithCases = + [ (True , compDefault, matchDefault { ignoreCase = True }, "[@-[]", "a") + , (True , compPosix , matchDefault , "a[/]b", "a[/]b") + ]
tests/Tests/Simplifier.hs view
@@ -1,30 +1,34 @@--- File created: 2009-01-24 13:02:48--module Tests.Simplifier (tests) where--import Test.Framework-import Test.Framework.Providers.QuickCheck2--import System.FilePath.Glob.Base (tryCompileWith)-import System.FilePath.Glob.Match-import System.FilePath.Glob.Simplify--import Tests.Base--tests = testGroup "Simplifier"- [ testProperty "simplify-1" prop_simplify1- , testProperty "simplify-2" prop_simplify2- ]---- Simplifying twice should give the same result as simplifying once-prop_simplify1 o s =- let pat = tryCompileWith (unCOpts o) (unPS s)- xs = iterate simplify (fromRight pat)- in isRight pat && xs !! 1 == xs !! 2---- Simplifying shouldn't affect whether a match succeeds-prop_simplify2 p o s =- let x = tryCompileWith (unCOpts o) (unPS p)- pat = fromRight x- pth = unP s- in isRight x && match pat pth == match (simplify pat) pth+-- File created: 2009-01-24 13:02:48 + +module Tests.Simplifier (tests) where + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck (Property, (==>)) + +import System.FilePath.Glob.Base (tryCompileWith) +import System.FilePath.Glob.Match +import System.FilePath.Glob.Simplify + +import Tests.Base + +tests :: Test +tests = testGroup "Simplifier" + [ testProperty "simplify-1" prop_simplify1 + , testProperty "simplify-2" prop_simplify2 + ] + +-- Simplifying twice should give the same result as simplifying once +prop_simplify1 :: COpts -> PString -> Property +prop_simplify1 o s = + let pat = tryCompileWith (unCOpts o) (unPS s) + xs = iterate simplify (fromRight pat) + in isRight pat ==> xs !! 1 == xs !! 2 + +-- Simplifying shouldn't affect whether a match succeeds +prop_simplify2 :: COpts -> PString -> Path -> Property +prop_simplify2 o p s = + let x = tryCompileWith (unCOpts o) (unPS p) + pat = fromRight x + pth = unP s + in isRight x ==> match pat pth == match (simplify pat) pth
tests/Tests/Utils.hs view
@@ -1,43 +1,54 @@--- File created: 2008-10-10 16:28:53--module Tests.Utils (tests) where--import Data.Maybe-import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck--import System.FilePath.Glob.Utils--import Tests.Base ((-->))--tests = testGroup "Utils"- [ testProperty "overlapperLosesNoInfo" prop_overlapperLosesNoInfo- , testProperty "increasingSeq" prop_increasingSeq- , testProperty "addToRange" prop_addToRange- ]--validateRange (a,b) = if b > a then (a,b) else (b,a)--prop_overlapperLosesNoInfo x1 x2 c =- let r1 = validateRange x1- r2 = validateRange x2- _ = c :: Float- in case overlap r1 r2 of-- -- if the ranges don't overlap, nothing should be in both ranges- Nothing -> not (inRange r1 c && inRange r2 c)-- -- if they do and something is in a range, it should be in the- -- overlapped one as well- Just o -> (inRange r1 c --> inRange o c) &&- (inRange r2 c --> inRange o c)--prop_increasingSeq a xs =- let s = fst . increasingSeq $ a:xs- in s == reverse [a :: Float .. head s]--prop_addToRange x c =- let r = validateRange x- r' = addToRange r c- in isJust r' ==> inRange (fromJust r') (c :: Float)+-- File created: 2008-10-10 16:28:53 + +module Tests.Utils (tests) where + +import Data.Maybe +import Data.List (isSuffixOf) +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck + +import System.FilePath.Glob.Utils + +import Tests.Base (Path, (-->), unP) + +tests :: Test +tests = testGroup "Utils" + [ testProperty "overlapperLosesNoInfo" prop_overlapperLosesNoInfo + , testProperty "increasingSeq" prop_increasingSeq + , testProperty "addToRange" prop_addToRange + , testProperty "pathParts" prop_pathParts + ] + +validateRange :: Ord a => (a, a) -> (a, a) +validateRange (a,b) = if b > a then (a,b) else (b,a) + +prop_overlapperLosesNoInfo :: (Int, Int) -> (Int, Int) -> Int -> Bool +prop_overlapperLosesNoInfo x1 x2 c = + let r1 = validateRange x1 + r2 = validateRange x2 + in case overlap r1 r2 of + + -- if the ranges don't overlap, nothing should be in both ranges + Nothing -> not (inRange r1 c && inRange r2 c) + + -- if they do and something is in a range, it should be in the + -- overlapped one as well + Just o -> (inRange r1 c --> inRange o c) && + (inRange r2 c --> inRange o c) + +prop_increasingSeq :: Int -> [Int] -> Bool +prop_increasingSeq a xs = + let s = fst . increasingSeq $ a:xs + in s == reverse [a .. head s] + +prop_addToRange :: (Int, Int) -> Int -> Property +prop_addToRange x c = + let r = validateRange x + r' = addToRange r c + in isJust r' ==> inRange (fromJust r') c + +prop_pathParts :: Path -> Bool +prop_pathParts pstr = + let p = unP pstr + in all (`isSuffixOf` p) (pathParts p)