Glob-0.7.12/0000755000000000000000000000000012775747277010703 5ustar0000000000000000Glob-0.7.12/CHANGELOG.txt0000644000000000000000000001353712775747277012744 0ustar00000000000000000.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. Glob-0.7.12/LICENSE.txt0000644000000000000000000000316312775747277012531 0ustar0000000000000000The code in Glob is released under the license below. Copyrights to parts of the code are held by whoever wrote the code in question: see CREDITS.txt for a list of authors. Copyright (c) 2008-2016 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. Glob-0.7.12/Setup.hs0000644000000000000000000000005612775747277012340 0ustar0000000000000000import Distribution.Simple main = defaultMain Glob-0.7.12/CREDITS.txt0000644000000000000000000000012012775747277012532 0ustar0000000000000000In alphabetical order by surname: Stephen Hicks Matti Niemenmaa Masahiro Sakai Glob-0.7.12/Glob.cabal0000644000000000000000000000536412775747277012562 0ustar0000000000000000Cabal-Version: >= 1.9.2 Name: Glob Version: 0.7.12 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.6 , directory < 1.3 , dlist >= 0.4 && < 0.9 , filepath >= 1.1 && < 1.5 , transformers >= 0.2 && < 0.6 , transformers-compat >= 0.3 && < 0.6 if impl(ghc < 8.0) Build-Depends: semigroups >= 0.18 && < 0.19 if os(windows) Build-Depends: Win32 == 2.* Exposed-Modules: System.FilePath.Glob System.FilePath.Glob.Primitive Other-Modules: System.FilePath.Glob.Base System.FilePath.Glob.Directory System.FilePath.Glob.Match System.FilePath.Glob.Simplify System.FilePath.Glob.Utils Test-Suite glob-tests type: exitcode-stdio-1.0 hs-source-dirs: ., tests main-is: Main.hs Build-Depends: base >= 4 && < 5 , containers < 0.6 , directory < 1.3 , dlist >= 0.4 && < 0.9 , filepath >= 1.1 && < 1.5 , transformers >= 0.2 && < 0.6 , transformers-compat >= 0.3 && < 0.6 , HUnit >= 1.2 && < 1.5 , QuickCheck >= 2 && < 3 , test-framework >= 0.2 && < 1 , test-framework-hunit >= 0.2 && < 1 , test-framework-quickcheck2 >= 0.3 && < 1 if impl(ghc < 8.0) Build-Depends: semigroups >= 0.18 && < 0.19 if os(windows) Build-Depends: Win32 == 2.* Other-Modules: System.FilePath.Glob.Base System.FilePath.Glob.Directory System.FilePath.Glob.Match System.FilePath.Glob.Simplify System.FilePath.Glob.Utils Tests.Base Tests.Compiler Tests.Instances Tests.Matcher Tests.Optimizer Tests.Regression Tests.Simplifier Tests.Utils Glob-0.7.12/README.txt0000644000000000000000000000135212775747277012402 0ustar0000000000000000This 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 Glob-0.7.12/tests/0000755000000000000000000000000012775747277012045 5ustar0000000000000000Glob-0.7.12/tests/Main.hs0000644000000000000000000000140612775747277013266 0ustar0000000000000000-- File created: 2008-10-10 16:23:56 module Main (main) where import System.Environment (getArgs) import Test.Framework import qualified Tests.Compiler as Compiler import qualified Tests.Instances as Instances import qualified Tests.Matcher as Matcher import qualified Tests.Optimizer as Optimizer import qualified Tests.Regression as Regression import qualified Tests.Simplifier as Simplifier import qualified Tests.Utils as Utils main = do args <- getArgs defaultMainWithArgs tests . concat $ [ ["--timeout", show 10] , ["--maximum-generated-tests", show 1000] , args ] tests = [ Regression.tests , Utils.tests , Compiler.tests , Matcher.tests , Optimizer.tests , Simplifier.tests , Instances.tests ] Glob-0.7.12/tests/Tests/0000755000000000000000000000000012775747277013147 5ustar0000000000000000Glob-0.7.12/tests/Tests/Utils.hs0000644000000000000000000000233212775747277014603 0ustar0000000000000000-- File created: 2008-10-10 16:28:53 module Tests.Utils (tests) where import Data.Maybe import Test.Framework import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck import System.FilePath.Glob.Utils import Tests.Base ((-->)) tests = testGroup "Utils" [ testProperty "overlapperLosesNoInfo" prop_overlapperLosesNoInfo , testProperty "increasingSeq" prop_increasingSeq , testProperty "addToRange" prop_addToRange ] validateRange (a,b) = if b > a then (a,b) else (b,a) prop_overlapperLosesNoInfo x1 x2 c = let r1 = validateRange x1 r2 = validateRange x2 _ = c :: Float in case overlap r1 r2 of -- if the ranges don't overlap, nothing should be in both ranges Nothing -> not (inRange r1 c && inRange r2 c) -- if they do and something is in a range, it should be in the -- overlapped one as well Just o -> (inRange r1 c --> inRange o c) && (inRange r2 c --> inRange o c) prop_increasingSeq a xs = let s = fst . increasingSeq $ a:xs in s == reverse [a :: Float .. head s] prop_addToRange x c = let r = validateRange x r' = addToRange r c in isJust r' ==> inRange (fromJust r') (c :: Float) Glob-0.7.12/tests/Tests/Instances.hs0000644000000000000000000000355212775747277015437 0ustar0000000000000000-- File created: 2009-01-30 15:01:02 module Tests.Instances (tests) where import Data.Monoid (mempty, mappend) import Test.Framework import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck ((==>)) import System.FilePath.Glob.Base (tryCompileWith) import System.FilePath.Glob.Match import System.FilePath.Glob.Simplify import Tests.Base tests = testGroup "Instances" [ testProperty "monoid-law-1" prop_monoidLaw1 , testProperty "monoid-law-2" prop_monoidLaw2 , testProperty "monoid-law-3" prop_monoidLaw3 , testProperty "monoid-4" prop_monoid4 ] -- The monoid laws: associativity... prop_monoidLaw1 opt x y z = let o = unCOpts opt es = map (tryCompileWith o . unPS) [x,y,z] [a,b,c] = map fromRight es in all isRight es && mappend a (mappend b c) == mappend (mappend a b) c -- ... left identity ... prop_monoidLaw2 opt x = let o = unCOpts opt e = tryCompileWith o (unPS x) a = fromRight e in isRight e && mappend mempty a == a -- ... and right identity. prop_monoidLaw3 opt x = let o = unCOpts opt e = tryCompileWith o (unPS x) a = fromRight e in isRight e && mappend a mempty == a -- mappending two Patterns should be equivalent to appending the original -- strings they came from and compiling that -- -- (notice: relies on the fact that our Arbitrary instance doesn't generate -- unclosed [] or <>; we only check for **/) prop_monoid4 opt x y = let o = unCOpts opt es = map (tryCompileWith o . unPS) [x,y] [a,b] = map fromRight es cat1 = mappend a b cat2 = tryCompileWith o (unPS x ++ unPS y) last2 = take 2 . reverse . unPS $ x head2 = take 2 . unPS $ y in (last2 /= "**" && take 1 head2 /= "/") && (take 1 last2 /= "*" && take 2 head2 /= "*/") ==> all isRight es && isRight cat2 && cat1 == fromRight cat2 Glob-0.7.12/tests/Tests/Matcher.hs0000644000000000000000000000262412775747277015072 0ustar0000000000000000-- File created: 2008-10-16 16:16:06 module Tests.Matcher (tests) where import Control.Monad (ap) import Test.Framework import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck ((==>)) import System.FilePath (isExtSeparator, isPathSeparator) import System.FilePath.Glob.Base import System.FilePath.Glob.Match import Tests.Base tests = testGroup "Matcher" [ testProperty "match-1" prop_match1 , testProperty "match-2" prop_match2 , testProperty "match-3" prop_match3 ] -- ./foo should be equivalent to foo in both path and pattern -- ... but not for the pattern if it starts with / prop_match1 o p_ s = let p = dropWhile isPathSeparator (unPS p_) ep = tryCompileWith (unCOpts o) p ep' = tryCompileWith (unCOpts o) ("./" ++ p) pat = fromRight ep pat' = fromRight ep' pth = unP s pth' = "./" ++ pth in and [ isRight ep, isRight ep' , ( all (uncurry (==)) . (zip`ap`tail) $ [ match pat pth , match pat pth' , match pat' pth , match pat' pth' ] ) || null p ] -- [/] shouldn't match anything prop_match2 = not . match (compile "[/]") . take 1 . unP -- [!/] is like ? prop_match3 p_ = let p = unP p_ ~(x:_) = p in not (null p || isPathSeparator x || isExtSeparator x) ==> match (compile "[!/]") [x] Glob-0.7.12/tests/Tests/Base.hs0000644000000000000000000000415712775747277014364 0ustar0000000000000000-- File created: 2008-10-10 22:03:00 module Tests.Base ( PString(unPS), Path(unP), COpts(unCOpts) , (-->), fromRight, isRight ) where import System.FilePath (extSeparator, pathSeparators) import Test.QuickCheck import System.FilePath.Glob.Base (CompOptions(..)) newtype PString = PatString { unPS :: String } deriving Show newtype Path = Path { unP :: String } deriving Show newtype COpts = COpts { unCOpts :: CompOptions } deriving Show alpha0 = extSeparator : "-^!" ++ ['a'..'z'] ++ ['0'..'9'] alpha = pathSeparators ++ alpha0 instance Arbitrary PString where arbitrary = sized $ \size -> do let xs = (1, return "**/") : map (\(a,b) -> (a*100,b)) [ (40, plain alpha) , (20, return "?") , (20, charRange) , (10, return "*") , (10, openRange) ] s <- mapM (const $ frequency xs) [1..size] return.PatString $ concat s instance Arbitrary Path where arbitrary = sized $ \size -> do s <- mapM (const $ plain alpha) [1..size `mod` 16] return.Path $ concat s instance Arbitrary COpts where arbitrary = do [a,b,c,d,e,f] <- vector 6 return.COpts $ CompOptions a b c d e f False plain from = sized $ \size -> do s <- mapM (const $ elements from) [0..size `mod` 3] return s charRange = do s <- plain alpha0 if s `elem` ["^","!"] then do s' <- plain alpha0 return$ "[" ++ s ++ s' ++ "]" else return$ "[" ++ s ++ "]" openRange = do probA <- choose (0,1) :: Gen Float probB <- choose (0,1) :: Gen Float a <- if probA > 0.4 then fmap (Just .abs) arbitrary else return Nothing b <- if probB > 0.4 then fmap (Just .abs) arbitrary else return Nothing return.concat $ [ "<" , maybe "" show (a :: Maybe Int) , "-" , maybe "" show (b :: Maybe Int) , ">" ] fromRight (Right x) = x fromRight _ = error "fromRight :: Left" isRight (Right _) = True isRight _ = False a --> b = not a || b Glob-0.7.12/tests/Tests/Optimizer.hs0000644000000000000000000000147212775747277015471 0ustar0000000000000000-- File created: 2008-10-11 11:18:31 module Tests.Optimizer (tests) where import Test.Framework import Test.Framework.Providers.QuickCheck2 import System.FilePath.Glob.Base (tokenize, optimize) import System.FilePath.Glob.Match import Tests.Base tests = testGroup "Optimizer" [ testProperty "optimize-1" prop_optimize1 , testProperty "optimize-2" prop_optimize2 ] -- Optimizing twice should give the same result as optimizing once prop_optimize1 o s = let pat = tokenize (unCOpts o) (unPS s) xs = iterate optimize (fromRight pat) in isRight pat && xs !! 1 == xs !! 2 -- Optimizing shouldn't affect whether a match succeeds prop_optimize2 o p s = let x = tokenize (unCOpts o) (unPS p) pat = fromRight x pth = unP s in isRight x && match pat pth == match (optimize pat) pth Glob-0.7.12/tests/Tests/Compiler.hs0000644000000000000000000000112012775747277015247 0ustar0000000000000000-- File created: 2009-01-30 13:26:51 module Tests.Compiler (tests) where import Test.Framework import Test.Framework.Providers.QuickCheck2 import System.FilePath.Glob.Base (tryCompileWith, compile, decompile) import Tests.Base tests = testGroup "Compiler" [ testProperty "compile-decompile-1" prop_compileDecompile1 ] -- compile . decompile should be the identity function prop_compileDecompile1 o s = let opt = unCOpts o epat1 = tryCompileWith opt (unPS s) pat1 = fromRight epat1 pat2 = compile . decompile $ pat1 in isRight epat1 && pat1 == pat2 Glob-0.7.12/tests/Tests/Simplifier.hs0000644000000000000000000000155312775747277015612 0ustar0000000000000000-- File created: 2009-01-24 13:02:48 module Tests.Simplifier (tests) where import Test.Framework import Test.Framework.Providers.QuickCheck2 import System.FilePath.Glob.Base (tryCompileWith) import System.FilePath.Glob.Match import System.FilePath.Glob.Simplify import Tests.Base tests = testGroup "Simplifier" [ testProperty "simplify-1" prop_simplify1 , testProperty "simplify-2" prop_simplify2 ] -- Simplifying twice should give the same result as simplifying once prop_simplify1 o s = let pat = tryCompileWith (unCOpts o) (unPS s) xs = iterate simplify (fromRight pat) in isRight pat && xs !! 1 == xs !! 2 -- Simplifying shouldn't affect whether a match succeeds prop_simplify2 p o s = let x = tryCompileWith (unCOpts o) (unPS p) pat = fromRight x pth = unP s in isRight x && match pat pth == match (simplify pat) pth Glob-0.7.12/tests/Tests/Regression.hs0000644000000000000000000001071212775747277015624 0ustar0000000000000000-- File created: 2008-10-15 20:21:41 module Tests.Regression (tests) where import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit.Base import System.FilePath.Glob.Base import System.FilePath.Glob.Match tests = testGroup "Regression" [ testGroup "Matching/compiling" . flip map matchCases $ \t@(b,p,s) -> tc (nameMatchTest t) $ match (compile p) s == b , testGroup "Specific options" . flip map matchWithCases $ \t@(b,co,mo,p,s) -> tc (nameMatchTest (b,p,s)) $ matchWith mo (compileWith co p) s == b , testGroup "Decompilation" . flip map decompileCases $ \(n,orig,s) -> tc n $ decompile (compile orig) == s ] where tc n = testCase n . assert nameMatchTest (True ,p,s) = show p ++ " matches " ++ show s nameMatchTest (False,p,s) = show p ++ " doesn't match " ++ show s decompileCases = [ ("range-compression-1", "[*]", "[*]") , ("range-compression-2", "[.]", "[.]") , ("range-compression-3", "**[/]", "*[/]") , ("range-compression-4", "x[.]", "x[.]") , ("range-compression-5", "[^~-]", "[^~-]") , ("range-compression-6", "[^!-]", "[^!-]") ] matchCases = [ (True , "*" , "") , (True , "**" , "") , (True , "asdf" , "asdf") , (True , "a*f" , "asdf") , (True , "a??f" , "asdf") , (True , "*" , "asdf") , (True , "a*bc" , "aXbaXbc") , (True , "a**bc" , "aXbaXbc") , (False, "a*b" , "aXc") , (True , "foo/bar.*" , "foo/bar.baz") , (True , "foo/*.baz" , "foo/bar.baz") , (False, "*bar.*" , "foo/bar.baz") , (False, "*.baz" , "foo/bar.baz") , (False, "foo*" , "foo/bar.baz") , (False, "foo?bar.baz", "foo/bar.baz") , (True , "**/*.baz" , "foo/bar.baz") , (True , "**/*" , "foo/bar.baz") , (True , "**/*" , "foo/bar/baz") , (True , "*/*.baz" , "foo/bar.baz") , (True , "*/*" , "foo/bar.baz") , (False, "*/*" , "foo/bar/baz") , (False, "*.foo" , ".bar.foo") , (False, "*.bar.foo" , ".bar.foo") , (False, "?bar.foo" , ".bar.foo") , (True , ".*.foo" , ".bar.foo") , (True , ".*bar.foo" , ".bar.foo") , (False, "foo.[ch]" , "foo.a") , (True , "foo.[ch]" , "foo.c") , (True , "foo.[ch]" , "foo.h") , (False, "foo.[ch]" , "foo.d") , (False, "foo.[c-h]" , "foo.b") , (True , "foo.[c-h]" , "foo.c") , (True , "foo.[c-h]" , "foo.e") , (True , "foo.[c-h]" , "foo.f") , (True , "foo.[c-h]" , "foo.h") , (False, "foo.[c-h]" , "foo.i") , (True , "<->3foo" , "123foo") , (True , "<10-15>3foo", "123foo") , (True , "<0-5>23foo" , "123foo") , (True , "<94-200>foo", "123foo") , (False, "[.]x" , ".x") , (False, "foo[/]bar" , "foo/bar") , (False, "foo[,-0]bar", "foo/bar") , (True , "foo[,-0]bar", "foo.bar") , (True , "[]x]" , "]") , (True , "[]x]" , "x") , (False, "[b-a]" , "a") , (False, "<4-3>" , "3") , (True , "[]-b]" , "]") , (False, "[]-b]" , "-") , (True , "[]-b]" , "b") , (True , "[]-b]" , "a") , (True , "[]-]" , "]") , (True , "[]-]" , "-") , (True , "[#-[]" , "&") , (False, "[^x]" , "/") , (False, "[/]" , "/") , (True , "a[^x]" , "a.") , (True , "a[.]" , "a.") , (False, ".//a" , "/a") , (True, ".//a" , "a") , (True, ".//a" , "./a") , (True , ".*/a" , "./a") , (True , ".*/a" , "../a") , (True , ".*/a" , ".foo/a") , (True , ".**/a" , ".foo/a") , (False, ".**/a" , "../a") , (False, ".**/a" , "./a") , (False, ".**/a" , "a") , (True , ".**/a" , ".foo/a") , (True , "f**/a" , "foo/a") , (True , "f**/" , "f/") , (True , "f**/" , "f///") , (True , "f**/x" , "f///x") , (True , "f/" , "f///") , (True , "f/x" , "f///x") , (True , "[]" , "[]") , (True , "[!]" , "[!]") , (True , "[^]" , "[^]") , (True , "[abc" , "[abc") , (True , " 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 Glob-0.7.12/System/FilePath/Glob/Base.hs0000644000000000000000000005556012775747277015767 0ustar0000000000000000-- File created: 2008-10-10 13:29:26 {-# LANGUAGE CPP #-} module System.FilePath.Glob.Base ( Token(..), Pattern(..) , CompOptions(..), MatchOptions(..) , compDefault, compPosix, matchDefault, matchPosix , decompile , compile , compileWith, tryCompileWith , tokenize -- for tests , optimize , liftP, tokToLower ) where import Control.Arrow (first) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Control.Monad.Trans.Writer.Strict (Writer, runWriter, tell) import Control.Exception (assert) import Data.Char (isDigit, isAlpha, toLower) import Data.List (find, sortBy) import Data.List.NonEmpty (toList) import Data.Maybe (fromMaybe) import Data.Monoid (Monoid, mappend, mempty, mconcat) import Data.Semigroup (Semigroup, (<>), sconcat, stimes) import System.FilePath ( pathSeparator, extSeparator , isExtSeparator, isPathSeparator ) import System.FilePath.Glob.Utils ( dropLeadingZeroes , isLeft, fromLeft , increasingSeq , addToRange, overlap ) #if __GLASGOW_HASKELL__ import Text.Read (readPrec, lexP, parens, prec, Lexeme(Ident)) #endif data Token -- primitives = Literal !Char | ExtSeparator -- . | PathSeparator -- / | NonPathSeparator -- ? | CharRange !Bool [Either Char (Char,Char)] -- [] | OpenRange (Maybe String) (Maybe String) -- <> | AnyNonPathSeparator -- * | AnyDirectory -- **/ -- after optimization only | LongLiteral !Int String deriving (Eq) -- Note: CharRanges aren't converted, because this is tricky in general. -- Consider for instance [@-[], which includes the range A-Z. This would need -- to become [@[a-z]: so essentially we'd need to either: -- -- 1) Have a list of ranges of uppercase Unicode. Check if our range -- overlaps with any of them and if it does, take the non-overlapping -- part and combine it with the toLower of the overlapping part. -- -- 2) Simply expand the entire range to a list and map toLower over it. -- -- In either case we'd need to re-optimize the CharRange—we can't assume that -- if the uppercase characters are consecutive, so are the lowercase. -- -- 1) might be feasible if someone bothered to get the latest data. -- -- 2) obviously isn't since you might have 'Right (minBound, maxBound)' in -- there somewhere. -- -- The current solution is to just check both the toUpper of the character and -- the toLower. tokToLower :: Token -> Token tokToLower (Literal c) = Literal (toLower c) tokToLower (LongLiteral n s) = LongLiteral n (map toLower s) tokToLower tok = tok -- |An abstract data type representing a compiled pattern. -- -- Note that the 'Eq' instance cannot tell you whether two patterns behave in -- the same way; only whether they compile to the same 'Pattern'. For instance, -- @'compile' \"x\"@ and @'compile' \"[x]\"@ may or may not compare equal, -- though a @'match'@ will behave the exact same way no matter which 'Pattern' -- is used. newtype Pattern = Pattern { unPattern :: [Token] } deriving (Eq) liftP :: ([Token] -> [Token]) -> Pattern -> Pattern liftP f (Pattern pat) = Pattern (f pat) instance Show Token where show (Literal c) | c `elem` "*?[<" || isExtSeparator c = ['[',c,']'] | otherwise = assert (not $ isPathSeparator c) [c] show ExtSeparator = [ extSeparator] show PathSeparator = [pathSeparator] show NonPathSeparator = "?" show AnyNonPathSeparator = "*" show AnyDirectory = "**/" show (LongLiteral _ s) = concatMap (show . Literal) s show (OpenRange a b) = '<' : fromMaybe "" a ++ "-" ++ fromMaybe "" b ++ ">" -- We have to be careful here with ^ and ! lest [a!b] become [!ab]. So we -- just put them at the end. -- -- Also, [^x-] was sorted and should not become [^-x]. show (CharRange b r) = let f = either (:[]) (\(x,y) -> [x,'-',y]) (caret,exclamation,fs) = foldr (\c (ca,ex,ss) -> case c of Left '^' -> ("^",ex,ss) Left '!' -> (ca,"!",ss) _ -> (ca, ex,(f c ++) . ss) ) ("", "", id) r (beg,rest) = let s' = fs [] (x,y) = splitAt 1 s' in if not b && x == "-" then (y,x) else (s',"") in concat [ "[" , if b then "" else "^" , beg, caret, exclamation, rest , "]" ] instance Show Pattern where showsPrec d p = showParen (d > 10) $ showString "compile " . showsPrec (d+1) (decompile p) instance Read Pattern where #if __GLASGOW_HASKELL__ readPrec = parens . prec 10 $ do Ident "compile" <- lexP fmap compile readPrec #else readsPrec d = readParen (d > 10) $ \r -> do ("compile",string) <- lex r (xs,rest) <- readsPrec (d+1) string [(compile xs, rest)] #endif instance Semigroup Pattern where Pattern a <> Pattern b = optimize $ Pattern (a <> b) sconcat = optimize . Pattern . concatMap unPattern . toList stimes n (Pattern a) = optimize $ Pattern (stimes n a) instance Monoid Pattern where mempty = Pattern [] mappend = (<>) mconcat = optimize . Pattern . concatMap unPattern -- |Options which can be passed to the 'tryCompileWith' or 'compileWith' -- functions: with these you can selectively toggle certain features at compile -- time. -- -- Note that some of these options depend on each other: classes can never -- occur if ranges aren't allowed, for instance. -- We could presumably put locale information in here, too. data CompOptions = CompOptions { characterClasses :: Bool -- ^Allow character classes, @[[:...:]]@. , characterRanges :: Bool -- ^Allow character ranges, @[...]@. , numberRanges :: Bool -- ^Allow open ranges, @\<...>@. , wildcards :: Bool -- ^Allow wildcards, @*@ and @?@. , recursiveWildcards :: Bool -- ^Allow recursive wildcards, @**/@. , pathSepInRanges :: Bool -- ^Allow path separators in character ranges. -- -- If true, @a[/]b@ never matches anything (since character ranges can't -- match path separators); if false and 'errorRecovery' is enabled, -- @a[/]b@ matches itself, i.e. a file named @]b@ in the subdirectory -- @a[@. , errorRecovery :: Bool -- ^If the input is invalid, recover by turning any invalid part into -- literals. For instance, with 'characterRanges' enabled, @[abc@ is an -- error by default (unclosed character range); with 'errorRecovery', the -- @[@ is turned into a literal match, as though 'characterRanges' were -- disabled. } deriving (Show,Read,Eq) -- |The default set of compilation options: closest to the behaviour of the -- @zsh@ shell, with 'errorRecovery' enabled. -- -- All options are enabled. compDefault :: CompOptions compDefault = CompOptions { characterClasses = True , characterRanges = True , numberRanges = True , wildcards = True , recursiveWildcards = True , pathSepInRanges = True , errorRecovery = True } -- |Options for POSIX-compliance, as described in @man 7 glob@. -- -- 'numberRanges', 'recursiveWildcards', and 'pathSepInRanges' are disabled. compPosix :: CompOptions compPosix = CompOptions { characterClasses = True , characterRanges = True , numberRanges = False , wildcards = True , recursiveWildcards = False , pathSepInRanges = False , errorRecovery = True } -- |Options which can be passed to the 'matchWith' or 'globDirWith' functions: -- with these you can selectively toggle certain features at matching time. data MatchOptions = MatchOptions { matchDotsImplicitly :: Bool -- ^Allow @*@, @?@, and @**/@ to match @.@ at the beginning of paths. , ignoreCase :: Bool -- ^Case-independent matching. , ignoreDotSlash :: Bool -- ^Treat @./@ as a no-op in both paths and patterns. -- -- (Of course e.g. @../@ means something different and will not be -- ignored.) } -- |The default set of execution options: closest to the behaviour of the @zsh@ -- shell. -- -- Currently identical to 'matchPosix'. matchDefault :: MatchOptions matchDefault = matchPosix -- |Options for POSIX-compliance, as described in @man 7 glob@. -- -- 'ignoreDotSlash' is enabled, the rest are disabled. matchPosix :: MatchOptions matchPosix = MatchOptions { matchDotsImplicitly = False , ignoreCase = False , ignoreDotSlash = True } -- |Decompiles a 'Pattern' object into its textual representation: essentially -- the inverse of 'compile'. -- -- Note, however, that due to internal optimization, @decompile . compile@ is -- not the identity function. Instead, @compile . decompile@ is. -- -- Be careful with 'CompOptions': 'decompile' always produces a 'String' which -- can be passed to 'compile' to get back the same 'Pattern'. @compileWith -- options . decompile@ is /not/ the identity function unless @options@ is -- 'compDefault'. decompile :: Pattern -> String decompile = concatMap show . unPattern ------------------------------------------ -- COMPILATION ------------------------------------------ -- |Compiles a glob pattern from its textual representation into a 'Pattern' -- object. -- -- For the most part, a character matches itself. Recognized operators are as -- follows: -- -- [@?@] Matches any character except path separators. -- -- [@*@] Matches any number of characters except path separators, -- including the empty string. -- -- [@[..\]@] Matches any of the enclosed characters. Ranges of characters can -- be specified by separating the endpoints with a @\'-'@. @\'-'@ or -- @']'@ can be matched by including them as the first character(s) -- in the list. Never matches path separators: @[\/]@ matches -- nothing at all. Named character classes can also be matched: -- @[:x:]@ within @[]@ specifies the class named @x@, which matches -- certain predefined characters. See below for a full list. -- -- [@[^..\]@ or @[!..\]@] Like @[..]@, but matches any character /not/ listed. -- Note that @[^-x]@ is not the inverse of @[-x]@, but -- the range @[^-x]@. -- -- [@\@] 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 = liftP (fin . go) where fin [] = [] -- Literals to LongLiteral -- Has to be done here: we can't backtrack in go, but some cases might -- result in consecutive Literals being generated. -- E.g. "a[b]". fin (x:y:xs) | isLiteral x && isLiteral y = let (ls,rest) = span isLiteral xs in fin $ LongLiteral (length ls + 2) (foldr (\(Literal a) -> (a:)) [] (x:y:ls)) : rest -- concatenate LongLiterals -- Has to be done here because LongLiterals are generated above. -- -- So one could say that we have one pass (go) which flattens everything as -- much as it can and one pass (fin) which concatenates what it can. fin (LongLiteral l1 s1 : LongLiteral l2 s2 : xs) = fin $ LongLiteral (l1+l2) (s1++s2) : xs fin (LongLiteral l s : Literal c : xs) = fin $ LongLiteral (l+1) (s++[c]) : xs fin (LongLiteral 1 s : xs) = Literal (head s) : fin xs fin (Literal c : LongLiteral l s : xs) = fin $ LongLiteral (l+1) (c:s) : xs fin (x:xs) = x : fin xs go [] = [] go (x@(CharRange _ _) : xs) = case optimizeCharRange x of x'@(CharRange _ _) -> x' : go xs x' -> go (x':xs) -- -> a go (OpenRange (Just a) (Just b):xs) | a == b = LongLiteral (length a) a : go xs -- -> [a-b] -- a and b are guaranteed non-null go (OpenRange (Just [a]) (Just [b]):xs) | b > a = go $ CharRange True [Right (a,b)] : xs go (x:xs) = case find ($ x) compressors of Just c -> let (compressed,ys) = span c xs in if null compressed then x : go ys else go (x : ys) Nothing -> x : go xs compressors = [isStar, isStarSlash, isAnyNumber] isLiteral (Literal _) = True isLiteral _ = False isStar AnyNonPathSeparator = True isStar _ = False isStarSlash AnyDirectory = True isStarSlash _ = False isAnyNumber (OpenRange Nothing Nothing) = True isAnyNumber _ = False optimizeCharRange :: Token -> Token optimizeCharRange (CharRange b_ rs) = fin b_ . go . sortCharRange $ rs where -- [/] is interesting, it actually matches nothing at all -- [.] can be Literalized though, just don't make it into an ExtSeparator so -- that it doesn't match a leading dot fin True [Left c] | not (isPathSeparator c) = Literal c fin True [Right r] | r == (minBound,maxBound) = NonPathSeparator fin b x = CharRange b x go [] = [] go (x@(Left c) : xs) = case xs of [] -> [x] y@(Left d) : ys -- [aaaaa] -> [a] | c == d -> go$ Left c : ys | d == succ c -> let (ls,rest) = span isLeft xs -- start from y (catable,others) = increasingSeq (map fromLeft ls) range = (c, head catable) in -- three (or more) Lefts make a Right if null catable || null (tail catable) then x : y : go ys -- [abcd] -> [a-d] else go$ Right range : map Left others ++ rest | otherwise -> x : go xs Right r : ys -> case addToRange r c of -- [da-c] -> [a-d] Just r' -> go$ Right r' : ys Nothing -> x : go xs go (x@(Right r) : xs) = case xs of [] -> [x] Left c : ys -> case addToRange r c of -- [a-cd] -> [a-d] Just r' -> go$ Right r' : ys Nothing -> x : go xs Right r' : ys -> case overlap r r' of -- [a-cb-d] -> [a-d] Just o -> go$ Right o : ys Nothing -> x : go xs optimizeCharRange _ = error "Glob.optimizeCharRange :: internal error" sortCharRange :: [Either Char (Char,Char)] -> [Either Char (Char,Char)] sortCharRange = sortBy cmp where cmp (Left a) (Left b) = compare a b cmp (Left a) (Right (b,_)) = compare a b cmp (Right (a,_)) (Left b) = compare a b cmp (Right (a,_)) (Right (b,_)) = compare a b Glob-0.7.12/System/FilePath/Glob/Primitive.hs0000644000000000000000000000420712775747277017055 0ustar0000000000000000-- 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)] Glob-0.7.12/System/FilePath/Glob/Match.hs0000644000000000000000000001437712775747277016152 0ustar0000000000000000-- File created: 2008-10-10 13:29:03 module System.FilePath.Glob.Match (match, matchWith) where import Control.Exception (assert) import Data.Char (isDigit, toLower, toUpper) import Data.Monoid (mappend) import System.FilePath (isPathSeparator, isExtSeparator) import System.FilePath.Glob.Base ( Pattern(..), Token(..) , MatchOptions(..), matchDefault , tokToLower ) import System.FilePath.Glob.Utils (dropLeadingZeroes, inRange, pathParts) -- |Matches the given 'Pattern' against the given 'FilePath', returning 'True' -- if the pattern matches and 'False' otherwise. match :: Pattern -> FilePath -> Bool match = matchWith matchDefault -- |Like 'match', but applies the given 'MatchOptions' instead of the defaults. matchWith :: MatchOptions -> Pattern -> FilePath -> Bool matchWith opts p f = begMatch opts (lcPat $ unPattern p) (lcPath f) where lcPath = if ignoreCase opts then map toLower else id lcPat = if ignoreCase opts then map tokToLower else id -- begMatch takes care of some things at the beginning of a pattern or after /: -- - . needs to be matched explicitly -- - ./foo is equivalent to foo (for any number of /) -- -- .*/foo still needs to match ./foo though, and it won't match plain foo; -- special case that one -- -- and .**/foo should /not/ match ../foo; more special casing -- -- (All of the above is modulo options, of course) begMatch, match' :: MatchOptions -> [Token] -> FilePath -> Bool begMatch _ (ExtSeparator:AnyDirectory:_) (x:y:_) | isExtSeparator x && isExtSeparator y = False begMatch opts (ExtSeparator:PathSeparator:pat) s | ignoreDotSlash opts = begMatch opts (dropWhile isSlash pat) s where isSlash PathSeparator = True isSlash _ = False begMatch opts pat (x:y:s) | dotSlash && dotStarSlash = match' opts pat' s | ignoreDotSlash opts && dotSlash = begMatch opts pat s where dotSlash = isExtSeparator x && isPathSeparator y (dotStarSlash, pat') = case pat of ExtSeparator:AnyNonPathSeparator:PathSeparator:rest -> (True, rest) _ -> (False, pat) begMatch opts pat s = if not (null s) && isExtSeparator (head s) && not (matchDotsImplicitly opts) then case pat of ExtSeparator:pat' -> match' opts pat' (tail s) _ -> False else match' opts pat s match' _ [] s = null s match' _ (AnyNonPathSeparator:s) "" = null s match' _ _ "" = False match' o (Literal l :xs) (c:cs) = l == c && match' o xs cs match' o ( ExtSeparator :xs) (c:cs) = isExtSeparator c && match' o xs cs match' o (NonPathSeparator:xs) (c:cs) = not (isPathSeparator c) && match' o xs cs match' o (PathSeparator :xs) (c:cs) = isPathSeparator c && begMatch o xs (dropWhile isPathSeparator cs) match' o (CharRange b rng :xs) (c:cs) = let rangeMatch r = either (== c) (`inRange` c) r || -- See comment near Base.tokToLower for an explanation of why we -- do this if ignoreCase o then either (== toUpper c) (`inRange` toUpper c) r else False in not (isPathSeparator c) && any rangeMatch rng == b && match' o xs cs match' o (OpenRange lo hi :xs) path = let (lzNum,cs) = span isDigit path num = dropLeadingZeroes lzNum numChoices = tail . takeWhile (not.null.snd) . map (flip splitAt num) $ [0..] in if null lzNum then False -- no digits else -- So, given the path "123foo" what we've got is: -- cs = "foo" -- num = "123" -- numChoices = [("1","23"),("12","3")] -- -- We want to try matching x against each of 123, 12, and 1. -- 12 and 1 are in numChoices already, but we need to add (num,"") -- manually. any (\(n,rest) -> inOpenRange lo hi n && match' o xs (rest ++ cs)) ((num,"") : numChoices) match' o again@(AnyNonPathSeparator:xs) path@(c:cs) = match' o xs path || (if isPathSeparator c then False else match' o again cs) match' o again@(AnyDirectory:xs) path = let parts = pathParts (dropWhile isPathSeparator path) matches = any (match' o xs) parts || any (match' o again) (tail parts) in if null xs && not (matchDotsImplicitly o) -- **/ shouldn't match foo/.bar, so check that remaining bits don't -- start with . then all (not.isExtSeparator.head) (init parts) && matches else matches match' o (LongLiteral len s:xs) path = let (pre,cs) = splitAt len path in pre == s && match' o xs cs -- Does the actual open range matching: finds whether the third parameter -- is between the first two or not. -- -- It does this by keeping track of the Ordering so far (e.g. having -- looked at "12" and "34" the Ordering of the two would be LT: 12 < 34) -- and aborting if a String "runs out": a longer string is automatically -- greater. -- -- Assumes that the input strings contain only digits, and no leading zeroes. inOpenRange :: Maybe String -> Maybe String -> String -> Bool inOpenRange l_ h_ s_ = assert (all isDigit s_) $ go l_ h_ s_ EQ EQ where go Nothing Nothing _ _ _ = True -- no bounds go (Just []) _ [] LT _ = False -- lesser than lower bound go _ (Just []) _ _ GT = False -- greater than upper bound go _ (Just []) (_:_) _ _ = False -- longer than upper bound go (Just (_:_)) _ [] _ _ = False -- shorter than lower bound go _ _ [] _ _ = True go (Just (l:ls)) (Just (h:hs)) (c:cs) ordl ordh = let ordl' = ordl `mappend` compare c l ordh' = ordh `mappend` compare c h in go (Just ls) (Just hs) cs ordl' ordh' go Nothing (Just (h:hs)) (c:cs) _ ordh = let ordh' = ordh `mappend` compare c h in go Nothing (Just hs) cs GT ordh' go (Just (l:ls)) Nothing (c:cs) ordl _ = let ordl' = ordl `mappend` compare c l in go (Just ls) Nothing cs ordl' LT -- lower bound is shorter: s is greater go (Just []) hi s _ ordh = go Nothing hi s GT ordh Glob-0.7.12/System/FilePath/Glob/Directory.hs0000644000000000000000000003045612775747277017056 0ustar0000000000000000-- File created: 2008-10-16 12:12:50 module System.FilePath.Glob.Directory ( globDir, globDirWith, globDir1, glob , commonDirectory ) where import Control.Arrow (first, second) import Control.Monad (forM) import qualified Data.DList as DL import Data.DList (DList) import Data.List ((\\)) import System.Directory ( doesDirectoryExist, getDirectoryContents , getCurrentDirectory ) import System.FilePath ( (), takeDrive, splitDrive , extSeparator, isExtSeparator , pathSeparator, isPathSeparator ) import System.FilePath.Glob.Base ( Pattern(..), Token(..) , MatchOptions, matchDefault , compile ) import System.FilePath.Glob.Match (matchWith) import System.FilePath.Glob.Utils ( getRecursiveContents , nubOrd , pathParts , partitionDL , catchIO ) -- The Patterns in TypedPattern don't contain PathSeparator or AnyDirectory -- -- We store the number of PathSeparators that Dir and AnyDir were followed by -- so that "foo////*" can match "foo/bar" but return "foo////bar". It's the -- exact number for convenience: () doesn't add a path separator if one is -- already there. This way, '\(Dir n _) -> replicate n pathSeparator "bar"' -- results in the correct amount of slashes. data TypedPattern = Any Pattern -- pattern | Dir Int Pattern -- pattern/ | AnyDir Int Pattern -- pattern**/ deriving Show -- |Matches each given 'Pattern' against the contents of the given 'FilePath', -- recursively. The result pair\'s first component contains the matched paths, -- grouped for each given 'Pattern', and the second contains all paths which -- were not matched by any 'Pattern'. The results are not in any defined order. -- -- The given directory is prepended to all the matches: the returned paths are -- all valid from the point of view of the current working directory. -- -- If multiple 'Pattern's match a single 'FilePath', that path will be included -- in multiple groups. -- -- Two 'FilePath's which can be canonicalized to the same file (e.g. @\"foo\"@ -- and @\"./foo\"@) may appear separately if explicit matching on paths -- beginning with @\".\"@ is done. Looking for @\".*/*\"@, for instance, will -- cause @\"./foo\"@ to return as a match but @\"foo\"@ to not be matched. -- -- This function is different from a simple 'filter' over all the contents of -- the directory: the matching is performed relative to the directory, so that -- for instance the following is true: -- -- > fmap (head.fst) (globDir [compile "*"] dir) == getDirectoryContents dir -- -- (With the exception that that glob won't match anything beginning with @.@.) -- -- If the given 'FilePath' is @[]@, 'getCurrentDirectory' will be used. -- -- If the given 'Pattern' starts with a drive (as defined by -- 'System.FilePath'), it is not relative to the given directory and the -- 'FilePath' parameter is completely ignored! Similarly, if the given -- 'Pattern' starts with a path separator, only the drive part of the -- 'FilePath' is used. On Posix systems these behaviours are equivalent: -- 'Pattern's starting with @\/@ work relative to @\/@. On Windows, 'Pattern's -- starting with @\/@ or @\\@ work relative only to the drive part of the -- 'FilePath' and 'Pattern's starting with absolute paths ignore the -- 'FilePath'. -- -- Note that in some cases results outside the given directory may be returned: -- for instance the @.*@ pattern matches the @..@ directory. -- -- Any results deeper than in the given directory are enumerated lazily, using -- 'unsafeInterleaveIO'. -- -- Directories without read permissions are returned as entries but their -- contents, of course, are not. globDir :: [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath]) globDir = globDirWith matchDefault -- |Like 'globDir', but applies the given 'MatchOptions' instead of the -- defaults when matching. globDirWith :: MatchOptions -> [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath]) globDirWith _ [] dir = do dir' <- if null dir then getCurrentDirectory else return dir c <- getRecursiveContents dir' return ([], DL.toList c) globDirWith opts pats@(_:_) dir = do results <- mapM (\p -> globDir'0 opts p dir) pats let (matches, others) = unzip results allMatches = DL.toList . DL.concat $ matches allOthers = DL.toList . DL.concat $ others return ( map DL.toList matches , nubOrd allOthers \\ allMatches ) -- |A convenience wrapper on top of 'globDir', for when you only have one -- 'Pattern' you care about. Returns only the matched paths. globDir1 :: Pattern -> FilePath -> IO [FilePath] globDir1 p = fmap (head . fst) . globDir [p] -- |The simplest IO function. Finds matches to the given pattern in the current -- working directory. Takes a 'String' instead of a 'Pattern' to avoid the need -- for a call to 'compile', simplifying usage further. -- -- Can also be seen as a convenience wrapper on top of 'globDir1', for when you -- want to work in the current directory or have a pattern referring to an -- absolute path. glob :: String -> IO [FilePath] glob = flip globDir1 "" . compile globDir'0 :: MatchOptions -> Pattern -> FilePath -> IO (DList FilePath, DList FilePath) globDir'0 opts pat dir = do let (pat', drive) = driveSplit pat dir' <- case drive of Just "" -> fmap takeDrive getCurrentDirectory Just d -> return d Nothing -> if null dir then getCurrentDirectory else return dir globDir' opts (separate pat') dir' globDir' :: MatchOptions -> [TypedPattern] -> FilePath -> IO (DList FilePath, DList FilePath) globDir' opts pats@(_:_) dir = do entries <- getDirectoryContents dir `catchIO` const (return []) results <- forM entries $ \e -> matchTypedAndGo opts pats e (dir e) let (matches, others) = unzip results return (DL.concat matches, DL.concat others) globDir' _ [] dir = -- We can only get here from matchTypedAndGo getting a [Dir _]: it means the -- original pattern had a trailing PathSeparator. Reproduce it here. return (DL.singleton (dir ++ [pathSeparator]), DL.empty) matchTypedAndGo :: MatchOptions -> [TypedPattern] -> FilePath -> FilePath -> IO (DList FilePath, DList FilePath) -- (Any p) is always the last element matchTypedAndGo opts [Any p] path absPath = if matchWith opts p path then return (DL.singleton absPath, DL.empty) else doesDirectoryExist absPath >>= didn'tMatch path absPath matchTypedAndGo opts (Dir n p:ps) path absPath = do isDir <- doesDirectoryExist absPath if isDir && matchWith opts p path then globDir' opts ps (absPath ++ replicate n pathSeparator) else didn'tMatch path absPath isDir matchTypedAndGo opts (AnyDir n p:ps) path absPath = do if path `elem` [".",".."] then didn'tMatch path absPath True else do isDir <- doesDirectoryExist absPath let m = matchWith opts (unseparate ps) unconditionalMatch = null (unPattern p) && not (isExtSeparator $ head path) p' = Pattern (unPattern p ++ [AnyNonPathSeparator]) case unconditionalMatch || matchWith opts p' path of True | isDir -> do contents <- getRecursiveContents (absPath ++ replicate n pathSeparator) return $ -- foo**/ should match foo/ and nothing below it -- relies on head contents == absPath if null ps then (DL.singleton $ DL.head contents, DL.tail contents) else partitionDL (any m . pathParts) contents True | m path -> return (DL.singleton absPath, DL.empty) _ -> didn'tMatch path absPath isDir matchTypedAndGo _ _ _ _ = error "Glob.matchTypedAndGo :: internal error" -- To be called when a pattern didn't match a path: given the path and whether -- it was a directory, return all paths which didn't match (i.e. for a file, -- just the file, and for a directory, everything inside it). didn'tMatch :: FilePath -> FilePath -> Bool -> IO (DList FilePath, DList FilePath) didn'tMatch path absPath isDir = (fmap $ (,) DL.empty) $ if isDir then if path `elem` [".",".."] then return DL.empty else getRecursiveContents absPath else return$ DL.singleton absPath separate :: Pattern -> [TypedPattern] separate = go DL.empty . unPattern where go gr [] | null (DL.toList gr) = [] go gr [] = [Any (pat gr)] go gr (PathSeparator:ps) = slash gr Dir ps go gr ( AnyDirectory:ps) = slash gr AnyDir ps go gr ( p:ps) = go (gr `DL.snoc` p) ps pat = Pattern . DL.toList slash gr f ps = let (n,ps') = first length . span isSlash $ ps in f (n+1) (pat gr) : go DL.empty ps' isSlash PathSeparator = True isSlash _ = False unseparate :: [TypedPattern] -> Pattern unseparate = Pattern . foldr f [] where f (AnyDir n p) ts = u p ++ AnyDirectory : replicate n PathSeparator ++ ts f ( Dir n p) ts = u p ++ PathSeparator : replicate n PathSeparator ++ ts f (Any p) ts = u p ++ ts u = unPattern -- Note that we consider "/foo" to specify a drive on Windows, even though it's -- relative to the current drive. -- -- Returns the [TypedPattern] of the Pattern (with the drive dropped if -- appropriate) and, if the Pattern specified a drive, a Maybe representing the -- drive to use. If it's a Just "", use the drive of the current working -- directory. driveSplit :: Pattern -> (Pattern, Maybe FilePath) driveSplit = check . split . unPattern where -- We can't just use something like commonDirectory because of Windows -- drives being possibly longer than one "directory", like "//?/foo/bar/". -- So just take as much as possible. split (LongLiteral _ l : xs) = first (l++) (split xs) split ( Literal l : xs) = first (l:) (split xs) split (PathSeparator : xs) = first (pathSeparator:) (split xs) split ( ExtSeparator : xs) = first ( extSeparator:) (split xs) split xs = ([],xs) -- The isPathSeparator check is interesting in two ways: -- -- 1. It's correct to return simply Just "" because there can't be more than -- one path separator if splitDrive gave a null drive: "//x" is a shared -- "drive" in Windows and starts with the root "drive" in Posix. -- -- 2. The 'head' is safe because we have not (null d) && null drive. check (d,ps) | null d = (Pattern ps, Nothing) | not (null drive) = (dirify rest ps, Just drive) | isPathSeparator (head rest) = (Pattern ps, Just "") | otherwise = (dirify d ps, Nothing) where (drive, rest) = splitDrive d dirify path = Pattern . (comp path++) comp s = let (p,l) = foldr f ([],[]) s in if null l then p else ll l p where f c (p,l) | isExtSeparator c = (ExtSeparator : ll l p, []) | isPathSeparator c = (PathSeparator : ll l p, []) | otherwise = (p, c:l) ll l p = if null l then p else LongLiteral (length l) l : p -- |Factors out the directory component of a 'Pattern'. Useful in conjunction -- with 'globDir'. -- -- Preserves the number of path separators: @commonDirectory (compile -- \"foo\/\/\/bar\")@ becomes @(\"foo\/\/\/\", compile \"bar\")@. commonDirectory :: Pattern -> (FilePath, Pattern) commonDirectory = second unseparate . splitP . separate where splitP pt@(Dir n p:ps) = case fromConst DL.empty (unPattern p) of Just d -> first ((d ++ replicate n pathSeparator) ) (splitP ps) Nothing -> ("", pt) splitP pt = ("", pt) fromConst d [] = Just (DL.toList d) fromConst d (Literal c :xs) = fromConst (d `DL.snoc` c) xs fromConst d (ExtSeparator :xs) = fromConst (d `DL.snoc` extSeparator) xs fromConst d (LongLiteral _ s:xs) = fromConst (d `DL.append`DL.fromList s) xs fromConst _ _ = Nothing Glob-0.7.12/System/FilePath/Glob/Utils.hs0000644000000000000000000001145712775747277016212 0ustar0000000000000000{-# 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