diff --git a/CHANGELOG.txt b/CHANGELOG.txt --- a/CHANGELOG.txt +++ b/CHANGELOG.txt @@ -1,248 +1,263 @@ -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. +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. diff --git a/CREDITS.txt b/CREDITS.txt --- a/CREDITS.txt +++ b/CREDITS.txt @@ -1,6 +1,7 @@ -In alphabetical order by surname: - -Harry Garrood -Stephen Hicks -Matti Niemenmaa -Masahiro Sakai +In alphabetical order by surname: + +Harry Garrood +Stephen Hicks +Matti Niemenmaa +Masahiro Sakai +Travis Sunderland diff --git a/Glob.cabal b/Glob.cabal --- a/Glob.cabal +++ b/Glob.cabal @@ -1,93 +1,97 @@ -Cabal-Version: >= 1.9.2 - -Name: Glob -Version: 0.9.3 -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 -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 && < 0.9 - , filepath >= 1.1 && < 1.5 - , transformers >= 0.2 && < 0.6 - , transformers-compat >= 0.3 && < 0.7 - - 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 - - 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 && < 0.9 - , filepath >= 1.1 && < 1.5 - , transformers >= 0.2 && < 0.6 - , transformers-compat >= 0.3 && < 0.7 - , 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.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.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 +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 +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 diff --git a/LICENSE.txt b/LICENSE.txt --- a/LICENSE.txt +++ b/LICENSE.txt @@ -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-2018 -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 +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. diff --git a/README.txt b/README.txt --- a/README.txt +++ b/README.txt @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/System/FilePath/Glob.hs b/System/FilePath/Glob.hs --- a/System/FilePath/Glob.hs +++ b/System/FilePath/Glob.hs @@ -1,79 +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 - , 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) +-- 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) diff --git a/System/FilePath/Glob/Base.hs b/System/FilePath/Glob/Base.hs --- a/System/FilePath/Glob/Base.hs +++ b/System/FilePath/Glob/Base.hs @@ -1,690 +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 - - , 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 -import Data.Semigroup (Semigroup, (<>), sconcat, stimes) -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]@. --- --- [@\@] 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 - --- 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) | isCharLiteral x && isCharLiteral y = - let (ls,rest) = span isCharLiteral 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 [] = [] - - -- 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 _) = True - isCharLiteral _ = False - - anyDigit = CharRange True [Right ('0', '9')] - -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 +-- 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]@. +-- +-- [@\@] 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 + +-- 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 diff --git a/System/FilePath/Glob/Directory.hs b/System/FilePath/Glob/Directory.hs --- a/System/FilePath/Glob/Directory.hs +++ b/System/FilePath/Glob/Directory.hs @@ -1,383 +1,383 @@ --- 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 - , 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 - , DL.tail 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 +-- 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 diff --git a/System/FilePath/Glob/Match.hs b/System/FilePath/Glob/Match.hs --- a/System/FilePath/Glob/Match.hs +++ b/System/FilePath/Glob/Match.hs @@ -1,174 +1,178 @@ --- 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) -#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 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 - -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 +-- 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 diff --git a/System/FilePath/Glob/Primitive.hs b/System/FilePath/Glob/Primitive.hs --- a/System/FilePath/Glob/Primitive.hs +++ b/System/FilePath/Glob/Primitive.hs @@ -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)] diff --git a/System/FilePath/Glob/Simplify.hs b/System/FilePath/Glob/Simplify.hs --- a/System/FilePath/Glob/Simplify.hs +++ b/System/FilePath/Glob/Simplify.hs @@ -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 diff --git a/System/FilePath/Glob/Utils.hs b/System/FilePath/Glob/Utils.hs --- a/System/FilePath/Glob/Utils.hs +++ b/System/FilePath/Glob/Utils.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,36 +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.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 - ] +-- 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 + ] diff --git a/tests/Tests/Base.hs b/tests/Tests/Base.hs --- a/tests/Tests/Base.hs +++ b/tests/Tests/Base.hs @@ -1,91 +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, 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 +-- 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 diff --git a/tests/Tests/Compiler.hs b/tests/Tests/Compiler.hs --- a/tests/Tests/Compiler.hs +++ b/tests/Tests/Compiler.hs @@ -1,41 +1,41 @@ --- 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 - } +-- 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 + } diff --git a/tests/Tests/Directory.hs b/tests/Tests/Directory.hs --- a/tests/Tests/Directory.hs +++ b/tests/Tests/Directory.hs @@ -1,171 +1,174 @@ -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) -import Data.Monoid ((<>)) -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 <> 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" - ] - ) - ] +{-# 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" + ] + ) + ] diff --git a/tests/Tests/Instances.hs b/tests/Tests/Instances.hs --- a/tests/Tests/Instances.hs +++ b/tests/Tests/Instances.hs @@ -1,69 +1,69 @@ --- 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 +-- 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 diff --git a/tests/Tests/Matcher.hs b/tests/Tests/Matcher.hs --- a/tests/Tests/Matcher.hs +++ b/tests/Tests/Matcher.hs @@ -1,78 +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 (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 +-- 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 diff --git a/tests/Tests/Optimizer.hs b/tests/Tests/Optimizer.hs --- a/tests/Tests/Optimizer.hs +++ b/tests/Tests/Optimizer.hs @@ -1,55 +1,55 @@ --- 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) +-- 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) diff --git a/tests/Tests/Regression.hs b/tests/Tests/Regression.hs --- a/tests/Tests/Regression.hs +++ b/tests/Tests/Regression.hs @@ -1,150 +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 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 , "<->" , "1") - , (True, "<0-0><1-1>" , "01") - , (True, "<0-1><0-1>" , "00") - ] - -matchWithCases :: [(Bool, CompOptions, MatchOptions, String, String)] -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 , "<->" , "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") + ] diff --git a/tests/Tests/Simplifier.hs b/tests/Tests/Simplifier.hs --- a/tests/Tests/Simplifier.hs +++ b/tests/Tests/Simplifier.hs @@ -1,34 +1,34 @@ --- 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 +-- 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 diff --git a/tests/Tests/Utils.hs b/tests/Tests/Utils.hs --- a/tests/Tests/Utils.hs +++ b/tests/Tests/Utils.hs @@ -1,54 +1,54 @@ --- 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) +-- 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)