Glob-0.9.3/0000755000000000000000000000000013351410565010577 5ustar0000000000000000Glob-0.9.3/CREDITS.txt0000644000000000000000000000013613351410565012435 0ustar0000000000000000In alphabetical order by surname: Harry Garrood Stephen Hicks Matti Niemenmaa Masahiro Sakai Glob-0.9.3/CHANGELOG.txt0000644000000000000000000002157113351410565012635 0ustar00000000000000000.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. Glob-0.9.3/Setup.hs0000644000000000000000000000005613351410565012234 0ustar0000000000000000import Distribution.Simple main = defaultMain Glob-0.9.3/README.txt0000644000000000000000000000135213351410565012276 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.9.3/LICENSE.txt0000644000000000000000000000316313351410565012425 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-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. Glob-0.9.3/Glob.cabal0000644000000000000000000000556413351410565012460 0ustar0000000000000000Cabal-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 Glob-0.9.3/System/0000755000000000000000000000000013351410565012063 5ustar0000000000000000Glob-0.9.3/System/FilePath/0000755000000000000000000000000013351410565013557 5ustar0000000000000000Glob-0.9.3/System/FilePath/Glob.hs0000644000000000000000000000451213351410565015000 0ustar0000000000000000-- 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) Glob-0.9.3/System/FilePath/Glob/0000755000000000000000000000000013351410565014442 5ustar0000000000000000Glob-0.9.3/System/FilePath/Glob/Directory.hs0000644000000000000000000003744013351410565016752 0ustar0000000000000000-- 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 Glob-0.9.3/System/FilePath/Glob/Match.hs0000644000000000000000000001573213351410565016042 0ustar0000000000000000-- 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 Glob-0.9.3/System/FilePath/Glob/Simplify.hs0000644000000000000000000000270513351410565016576 0ustar0000000000000000-- 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 Glob-0.9.3/System/FilePath/Glob/Base.hs0000644000000000000000000006170213351410565015656 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 , 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 Glob-0.9.3/System/FilePath/Glob/Utils.hs0000644000000000000000000001145713351410565016106 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 Glob-0.9.3/System/FilePath/Glob/Primitive.hs0000644000000000000000000000420713351410565016751 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.9.3/tests/0000755000000000000000000000000013351410565011741 5ustar0000000000000000Glob-0.9.3/tests/Main.hs0000644000000000000000000000157213351410565013166 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.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 ] Glob-0.9.3/tests/Tests/0000755000000000000000000000000013351410565013043 5ustar0000000000000000Glob-0.9.3/tests/Tests/Directory.hs0000644000000000000000000001266113351410565015351 0ustar0000000000000000module 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" ] ) ] Glob-0.9.3/tests/Tests/Compiler.hs0000644000000000000000000000230513351410565015151 0ustar0000000000000000-- 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 } Glob-0.9.3/tests/Tests/Base.hs0000644000000000000000000000463613351410565014262 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, 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 Glob-0.9.3/tests/Tests/Regression.hs0000644000000000000000000001225213351410565015521 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 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") ] Glob-0.9.3/tests/Tests/Utils.hs0000644000000000000000000000314013351410565014475 0ustar0000000000000000-- 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) Glob-0.9.3/tests/Tests/Simplifier.hs0000644000000000000000000000201213351410565015475 0ustar0000000000000000-- 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 Glob-0.9.3/tests/Tests/Matcher.hs0000644000000000000000000000521613351410565014766 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 (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 Glob-0.9.3/tests/Tests/Instances.hs0000644000000000000000000000436213351410565015333 0ustar0000000000000000-- 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 Glob-0.9.3/tests/Tests/Optimizer.hs0000644000000000000000000000327413351410565015367 0ustar0000000000000000-- 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)