diff --git a/CHANGELOG.txt b/CHANGELOG.txt --- a/CHANGELOG.txt +++ b/CHANGELOG.txt @@ -1,3 +1,59 @@ +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. diff --git a/CREDITS.txt b/CREDITS.txt --- a/CREDITS.txt +++ b/CREDITS.txt @@ -1,5 +1,6 @@ In alphabetical order by surname: +Harry Garrood Stephen Hicks Matti Niemenmaa Masahiro Sakai diff --git a/Glob.cabal b/Glob.cabal --- a/Glob.cabal +++ b/Glob.cabal @@ -1,7 +1,7 @@ Cabal-Version: >= 1.9.2 Name: Glob -Version: 0.8.0 +Version: 0.9.0 Homepage: http://iki.fi/matti.niemenmaa/glob/ Synopsis: Globbing library Category: System @@ -47,6 +47,8 @@ System.FilePath.Glob.Simplify System.FilePath.Glob.Utils + GHC-Options: -Wall + Test-Suite glob-tests type: exitcode-stdio-1.0 @@ -75,13 +77,17 @@ Other-Modules: System.FilePath.Glob.Base System.FilePath.Glob.Directory System.FilePath.Glob.Match + System.FilePath.Glob.Primitive System.FilePath.Glob.Simplify System.FilePath.Glob.Utils Tests.Base Tests.Compiler + Tests.Directory Tests.Instances Tests.Matcher Tests.Optimizer Tests.Regression Tests.Simplifier Tests.Utils + + GHC-Options: -Wall diff --git a/LICENSE.txt b/LICENSE.txt --- a/LICENSE.txt +++ b/LICENSE.txt @@ -2,7 +2,7 @@ the code are held by whoever wrote the code in question: see CREDITS.txt for a list of authors. -Copyright (c) 2008-2016 +Copyright (c) 2008-2017 All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/System/FilePath/Glob.hs b/System/FilePath/Glob.hs --- a/System/FilePath/Glob.hs +++ b/System/FilePath/Glob.hs @@ -53,11 +53,14 @@ -- *** Options , MatchOptions(..) , matchWith + , GlobOptions(..) , globDirWith -- **** Predefined option sets , matchDefault, matchPosix + , globDefault -- ** Miscellaneous , commonDirectory + , isLiteral ) where import System.FilePath.Glob.Base ( Pattern @@ -66,8 +69,10 @@ , matchDefault, matchPosix , compile, compileWith, tryCompileWith , decompile + , isLiteral ) -import System.FilePath.Glob.Directory ( globDir, globDirWith, globDir1, glob +import System.FilePath.Glob.Directory ( GlobOptions(..), globDefault + , globDir, globDirWith, globDir1, glob , commonDirectory ) import System.FilePath.Glob.Match (match, matchWith) diff --git a/System/FilePath/Glob/Base.hs b/System/FilePath/Glob/Base.hs --- a/System/FilePath/Glob/Base.hs +++ b/System/FilePath/Glob/Base.hs @@ -17,6 +17,8 @@ , optimize , liftP, tokToLower + + , isLiteral ) where import Control.Arrow (first) @@ -28,7 +30,10 @@ 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 @@ -48,7 +53,7 @@ data Token -- primitives = Literal !Char - | ExtSeparator -- . + | ExtSeparator -- . optimized away to Literal | PathSeparator -- / | NonPathSeparator -- ? | CharRange !Bool [Either Char (Char,Char)] -- [] @@ -58,6 +63,7 @@ -- 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. @@ -99,8 +105,7 @@ instance Show Token where show (Literal c) - | c `elem` "*?[<" || isExtSeparator c - = ['[',c,']'] + | c `elem` "*?[<" = ['[',c,']'] | otherwise = assert (not $ isPathSeparator c) [c] show ExtSeparator = [ extSeparator] show PathSeparator = [pathSeparator] @@ -116,6 +121,9 @@ -- 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) = @@ -134,10 +142,13 @@ 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) @@ -512,7 +523,18 @@ optimize :: Pattern -> Pattern -optimize = liftP (fin . go) +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 [] = [] @@ -520,8 +542,8 @@ -- 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 + 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 @@ -545,49 +567,67 @@ 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 x of + case optimizeCharRange False 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 + -- 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) compressors of - Just c -> let (compressed,ys) = span c xs - in if null compressed - then x : go ys - else go (x : ys) + 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 - compressors = [isStar, isStarSlash, isAnyNumber] + checkUnmatchable f ts = if Unmatchable `elem` ts then [Unmatchable] else f ts - isLiteral (Literal _) = True - isLiteral _ = False - isStar AnyNonPathSeparator = True - isStar _ = False - isStarSlash AnyDirectory = True - isStarSlash _ = False - isAnyNumber (OpenRange Nothing Nothing) = True - isAnyNumber _ = False + compressables = [ (AnyNonPathSeparator, const []) + , (AnyDirectory, const []) + , (OpenRange Nothing Nothing, \n -> replicate n anyDigit) + ] -optimizeCharRange :: Token -> Token -optimizeCharRange (CharRange b_ rs) = fin b_ . go . sortCharRange $ rs + 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 True [Left c] | not (isPathSeparator c) = Literal c - fin True [Right r] | r == (minBound,maxBound) = NonPathSeparator - fin b x = CharRange b x + 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) = @@ -629,7 +669,7 @@ -- [a-cb-d] -> [a-d] Just o -> go$ Right o : ys Nothing -> x : go xs -optimizeCharRange _ = error "Glob.optimizeCharRange :: internal error" +optimizeCharRange _ _ = error "Glob.optimizeCharRange :: internal error" sortCharRange :: [Either Char (Char,Char)] -> [Either Char (Char,Char)] sortCharRange = sortBy cmp @@ -638,3 +678,13 @@ cmp (Left a) (Right (b,_)) = compare a b cmp (Right (a,_)) (Left b) = compare a b cmp (Right (a,_)) (Right (b,_)) = compare a b + +-- |Returns `True` iff the given `Pattern` is a literal file path, i.e. it has +-- no wildcards, character ranges, etc. +isLiteral :: Pattern -> Bool +isLiteral = all lit . unPattern + where + lit (Literal _) = True + lit (LongLiteral _ _) = True + lit PathSeparator = True + lit _ = False diff --git a/System/FilePath/Glob/Directory.hs b/System/FilePath/Glob/Directory.hs --- a/System/FilePath/Glob/Directory.hs +++ b/System/FilePath/Glob/Directory.hs @@ -1,7 +1,8 @@ -- File created: 2008-10-16 12:12:50 module System.FilePath.Glob.Directory - ( globDir, globDirWith, globDir1, glob + ( GlobOptions(..), globDefault + , globDir, globDirWith, globDir1, glob , commonDirectory ) where @@ -9,13 +10,14 @@ import Control.Monad (forM) import qualified Data.DList as DL import Data.DList (DList) -import Data.List ((\\)) +import Data.List ((\\), find) import System.Directory ( doesDirectoryExist, getDirectoryContents , getCurrentDirectory ) import System.FilePath ( (), takeDrive, splitDrive - , extSeparator, isExtSeparator + , isExtSeparator , pathSeparator, isPathSeparator + , takeDirectory ) import System.FilePath.Glob.Base ( Pattern(..), Token(..) @@ -29,6 +31,19 @@ , 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 @@ -43,9 +58,8 @@ 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. +-- 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. @@ -62,7 +76,7 @@ -- 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 +-- > fmap head (globDir [compile "*"] dir) == getDirectoryContents dir -- -- (With the exception that that glob won't match anything beginning with @.@.) -- @@ -86,19 +100,39 @@ -- -- Directories without read permissions are returned as entries but their -- contents, of course, are not. -globDir :: [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath]) -globDir = globDirWith matchDefault +globDir :: [Pattern] -> FilePath -> IO [[FilePath]] +globDir pats dir = fmap fst (globDirWith globDefault pats dir) --- |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) +-- |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 = do +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 @@ -106,13 +140,15 @@ allOthers = DL.toList . DL.concat $ others return ( map DL.toList matches - , nubOrd allOthers \\ allMatches + , 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 . fst) . globDir [p] +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 @@ -124,7 +160,7 @@ glob :: String -> IO [FilePath] glob = flip globDir1 "" . compile -globDir'0 :: MatchOptions -> Pattern -> FilePath +globDir'0 :: GlobOptions -> Pattern -> FilePath -> IO (DList FilePath, DList FilePath) globDir'0 opts pat dir = do let (pat', drive) = driveSplit pat @@ -134,7 +170,7 @@ Nothing -> if null dir then getCurrentDirectory else return dir globDir' opts (separate pat') dir' -globDir' :: MatchOptions -> [TypedPattern] -> FilePath +globDir' :: GlobOptions -> [TypedPattern] -> FilePath -> IO (DList FilePath, DList FilePath) globDir' opts pats@(_:_) dir = do entries <- getDirectoryContents dir `catchIO` const (return []) @@ -150,60 +186,112 @@ -- original pattern had a trailing PathSeparator. Reproduce it here. return (DL.singleton (dir ++ [pathSeparator]), DL.empty) -matchTypedAndGo :: MatchOptions +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 opts p path + if matchWith (matchOptions opts) p path then return (DL.singleton absPath, DL.empty) - else doesDirectoryExist absPath >>= didn'tMatch path absPath + else doesDirectoryExist absPath >>= didNotMatch opts path absPath matchTypedAndGo opts (Dir n p:ps) path absPath = do isDir <- doesDirectoryExist absPath - if isDir && matchWith opts p path + if isDir && matchWith (matchOptions opts) p path then globDir' opts ps (absPath ++ replicate n pathSeparator) - else didn'tMatch path absPath isDir + else didNotMatch opts path absPath isDir -matchTypedAndGo opts (AnyDir n p:ps) path absPath = do +matchTypedAndGo opts (AnyDir n p:ps) path absPath = if path `elem` [".",".."] - then didn'tMatch path absPath True + then didNotMatch opts path absPath True else do isDir <- doesDirectoryExist absPath - let m = matchWith opts (unseparate ps) + let m = matchWith (matchOptions 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) + 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, DL.tail contents) - else partitionDL (any m . pathParts) contents + 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 absPath, DL.empty) - _ -> didn'tMatch path absPath isDir + 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). -didn'tMatch :: FilePath -> FilePath -> Bool +didNotMatch :: GlobOptions -> 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 +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 @@ -225,8 +313,8 @@ 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 (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 @@ -247,7 +335,6 @@ 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: @@ -269,7 +356,7 @@ 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, []) + f c (p,l) | isExtSeparator c = (Literal '.' : ll l p, []) | isPathSeparator c = (PathSeparator : ll l p, []) | otherwise = (p, c:l) @@ -292,6 +379,5 @@ 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 diff --git a/System/FilePath/Glob/Match.hs b/System/FilePath/Glob/Match.hs --- a/System/FilePath/Glob/Match.hs +++ b/System/FilePath/Glob/Match.hs @@ -1,15 +1,19 @@ -- 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 - , tokToLower + , isLiteral, tokToLower ) import System.FilePath.Glob.Utils (dropLeadingZeroes, inRange, pathParts) @@ -36,77 +40,87 @@ -- -- (All of the above is modulo options, of course) begMatch, match' :: MatchOptions -> [Token] -> FilePath -> Bool -begMatch _ (ExtSeparator:AnyDirectory:_) (x:y:_) +begMatch _ (Literal '.' : AnyDirectory : _) (x:y:_) | isExtSeparator x && isExtSeparator y = False -begMatch opts (ExtSeparator:PathSeparator:pat) s | ignoreDotSlash opts = - begMatch opts (dropWhile isSlash pat) s +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 s + | ignoreDotSlash opts && dotSlash = + begMatch opts pat (dropWhile isPathSeparator s) where dotSlash = isExtSeparator x && isPathSeparator y (dotStarSlash, pat') = case pat of - ExtSeparator:AnyNonPathSeparator:PathSeparator:rest -> (True, rest) - _ -> (False, pat) + Literal '.': 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 +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 ( ExtSeparator :xs) (c:cs) = isExtSeparator c && match' o xs cs +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 xs (dropWhile isPathSeparator 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 - if ignoreCase o - then either (== toUpper c) (`inRange` toUpper c) r - else False + 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 - (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) + 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 || (if isPathSeparator c then False else match' o again cs) + match' o xs path || (not (isPathSeparator c) && match' o again cs) match' o again@(AnyDirectory:xs) path = let parts = pathParts (dropWhile isPathSeparator path) @@ -120,6 +134,9 @@ 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. diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -6,6 +6,7 @@ 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 @@ -13,14 +14,16 @@ import qualified Tests.Simplifier as Simplifier import qualified Tests.Utils as Utils +main :: IO () main = do args <- getArgs defaultMainWithArgs tests . concat $ - [ ["--timeout", show 10] - , ["--maximum-generated-tests", show 1000] + [ ["--timeout", show (10 :: Int)] + , ["--maximum-generated-tests", show (1000 :: Int)] , args ] +tests :: [Test] tests = [ Regression.tests , Utils.tests @@ -29,4 +32,5 @@ , Optimizer.tests , Simplifier.tests , Instances.tests + , Directory.tests ] diff --git a/tests/Tests/Base.hs b/tests/Tests/Base.hs --- a/tests/Tests/Base.hs +++ b/tests/Tests/Base.hs @@ -13,6 +13,7 @@ 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 @@ -31,20 +32,25 @@ 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] <- 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 +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` ["^","!"] @@ -54,6 +60,7 @@ else return$ "[" ++ s ++ "]" +openRange :: Gen String openRange = do probA <- choose (0,1) :: Gen Float probB <- choose (0,1) :: Gen Float @@ -71,10 +78,14 @@ , ">" ] +-- 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" -isRight (Right _) = True -isRight _ = False - +(-->) :: Bool -> Bool -> Bool a --> b = not a || b diff --git a/tests/Tests/Compiler.hs b/tests/Tests/Compiler.hs --- a/tests/Tests/Compiler.hs +++ b/tests/Tests/Compiler.hs @@ -4,19 +4,38 @@ import Test.Framework import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck (Property, (==>)) -import System.FilePath.Glob.Base (tryCompileWith, compile, decompile) +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 + in isRight epat1 ==> pat1 == pat2 + +prop_isLiteral :: PString -> Property +prop_isLiteral p = + let epat = tryCompileWith noWildcardOptions (unPS p) + pat = fromRight epat + in isRight epat ==> (isLiteral . compile . decompile) pat + where + noWildcardOptions = compDefault + { characterClasses = False + , characterRanges = False + , numberRanges = False + , wildcards = False + , recursiveWildcards = False + } diff --git a/tests/Tests/Directory.hs b/tests/Tests/Directory.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Directory.hs @@ -0,0 +1,171 @@ +module Tests.Directory where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck (Property, (===)) +import Test.HUnit.Base hiding (Test) +import Data.Function (on) +import Data.Monoid ((<>)) +import Data.List ((\\), sort) +import qualified Data.DList as DList + +import System.FilePath.Glob.Base +import System.FilePath.Glob.Directory +import System.FilePath.Glob.Primitive +import System.FilePath.Glob.Utils +import Tests.Base (PString, unPS) + +tests :: Test +tests = testGroup "Directory" + [ testCase "includeUnmatched" caseIncludeUnmatched + , testCase "onlyMatched" caseOnlyMatched + , testGroup "commonDirectory" + [ testGroup "edge-cases" testsCommonDirectoryEdgeCases + , testProperty "property" prop_commonDirectory + ] + , testCase "globDir1" caseGlobDir1 + , testGroup "repeated-path-separators" testsRepeatedPathSeparators + ] + +caseIncludeUnmatched :: Assertion +caseIncludeUnmatched = do + let pats = ["**/D*.hs", "**/[MU]*.hs"] + everything <- getRecursiveContentsDir "System" + let expectedMatches = + [ [ "System/FilePath/Glob/Directory.hs" ] + , [ "System/FilePath/Glob/Match.hs" + , "System/FilePath/Glob/Utils.hs" + ] + ] + let everythingElse = everything \\ concat expectedMatches + + result <- globDirWith (GlobOptions matchDefault True) + (map compile pats) + "System" + mapM_ (uncurry assertEqualUnordered) (zip expectedMatches (fst result)) + + case snd result of + Nothing -> assertFailure "Expected Just a list of unmatched files" + Just unmatched -> assertEqualUnordered everythingElse unmatched + +caseOnlyMatched :: Assertion +caseOnlyMatched = do + let pats = ["**/D*.hs", "**/[MU]*.hs"] + let expectedMatches = + [ [ "System/FilePath/Glob/Directory.hs" ] + , [ "System/FilePath/Glob/Match.hs" + , "System/FilePath/Glob/Utils.hs" + ] + ] + + result <- globDirWith globDefault + (map compile pats) + "System" + + mapM_ (uncurry assertEqualUnordered) (zip expectedMatches (fst result)) + assertEqual "" Nothing (snd result) + +caseGlobDir1 :: Assertion +caseGlobDir1 = do + -- this is little a bit of a hack; we pass the same pattern twice to ensure + -- that the optimization in the single pattern case is bypassed + let naiveGlobDir1 p = fmap head . globDir [p, p] + let pat = compile "FilePath/*/*.hs" + let dir = "System" + + actual <- globDir1 pat dir + expected <- naiveGlobDir1 pat dir + assertEqual "" expected actual + +assertEqualUnordered :: (Ord a, Show a) => [a] -> [a] -> Assertion +assertEqualUnordered = assertEqual "" `on` sort + +-- Like 'getRecursiveContents', except this function removes the root directory +-- from the returned list, so that it should match* the union of matched and +-- unmatched files returned from 'globDirWith', where the same directory was +-- given as the directory argument. +-- +-- * to be a little more precise, these files will only match up to +-- normalisation of paths e.g. some patterns will cause the list of matched +-- files to contain repeated slashes, whereas the list returned by this +-- function will not have repeated slashes. +getRecursiveContentsDir :: FilePath -> IO [FilePath] +getRecursiveContentsDir root = + fmap (filter (/= root) . DList.toList) (getRecursiveContents root) + +-- These two patterns should always be equal +prop_commonDirectory' :: String -> (Pattern, Pattern) +prop_commonDirectory' str = + let pat = compile str + (a, b) = commonDirectory pat + in (pat, literal a <> b) + +prop_commonDirectory :: PString -> Property +prop_commonDirectory = uncurry (===) . prop_commonDirectory' . unPS + +testsCommonDirectoryEdgeCases :: [Test] +testsCommonDirectoryEdgeCases = zipWith mkTest [1 :: Int ..] testData + where + mkTest i (input, expected) = + testCase (show i) $ do + assertEqual "" expected (commonDirectory (compile input)) + uncurry (assertEqual "") (prop_commonDirectory' input) + + testData = + [ ("[.]/*", ("", compile "[.]")) + , ("foo/[.]bar/*", ("", compile "[.]")) + , ("[.]foo/bar/*", ("", compile "[.]foo/bar/*")) + , ("foo.bar/baz/*", ("foo.bar/baz/", compile "*")) + , ("[f]oo[.]/bar/*", ("foo./bar/", compile "*")) + , ("foo[.]bar/baz/*", ("foo.bar/baz/", compile "*")) + , (".[.]/foo/*", ("../foo/", compile "*")) + ] + +-- see #16 +testsRepeatedPathSeparators :: [Test] +testsRepeatedPathSeparators = zipWith mkTest [1 :: Int ..] testData + where + mkTest i (dir, pat, expected) = + testCase (show i) $ do + actual <- globDir1 (compile pat) dir + assertEqualUnordered expected actual + + testData = + [ ( "System" + , "*//Glob///[U]*.hs" + , [ "System/FilePath//Glob///Utils.hs" + ] + ) + , ( "System" + , "**//[GU]*.hs" + , [ "System/FilePath//Glob.hs" + , "System/FilePath/Glob//Utils.hs" + ] + ) + , ( "System" + , "File**/" + , [ "System/FilePath/" + ] + ) + , ( "System" + , "File**//" + , [ "System/FilePath//" + ] + ) + , ( "System" + , "File**///" + , [ "System/FilePath///" + ] + ) + , ( "System/FilePath" + , "**//Glob.hs" + , [ "System/FilePath//Glob.hs" + ] + ) + , ( "System" + , "**Path/Glob//Utils.hs" + , [ "System/FilePath/Glob//Utils.hs" + ] + ) + ] diff --git a/tests/Tests/Instances.hs b/tests/Tests/Instances.hs --- a/tests/Tests/Instances.hs +++ b/tests/Tests/Instances.hs @@ -1,18 +1,22 @@ -- 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 ((==>)) +import Test.QuickCheck (Property, (==>)) -import System.FilePath.Glob.Base (tryCompileWith) -import System.FilePath.Glob.Match -import System.FilePath.Glob.Simplify +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 @@ -21,31 +25,35 @@ ] -- 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 + 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 + 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 + 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 **/) +-- 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] @@ -56,4 +64,6 @@ head2 = take 2 . unPS $ y in (last2 /= "**" && take 1 head2 /= "/") && (take 1 last2 /= "*" && take 2 head2 /= "*/") - ==> all isRight es && isRight cat2 && cat1 == fromRight cat2 + && all isRight es && isRight cat2 + && take 1 (unPattern b) /= [Unmatchable] + ==> cat1 == fromRight cat2 diff --git a/tests/Tests/Matcher.hs b/tests/Tests/Matcher.hs --- a/tests/Tests/Matcher.hs +++ b/tests/Tests/Matcher.hs @@ -5,7 +5,7 @@ import Control.Monad (ap) import Test.Framework import Test.Framework.Providers.QuickCheck2 -import Test.QuickCheck ((==>)) +import Test.QuickCheck (Property, (==>)) import System.FilePath (isExtSeparator, isPathSeparator) import System.FilePath.Glob.Base @@ -13,38 +13,66 @@ 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 for the pattern if it starts with / -prop_match1 o p_ s = - let p = dropWhile isPathSeparator (unPS p_) +-- ... 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 = 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 - ] + in not (null p) && isRight ep && isRight ep' + ==> all (uncurry (==)) . (zip`ap`tail) $ + if isPathSeparator (head p) + && not (null pth) && isPathSeparator (head pth) + then [ match pat pth + , match pat' pth' + ] + else [ match pat pth + , match pat pth' + , match pat' pth + , match pat' pth' + ] -- [/] shouldn't match anything +prop_match2 :: Path -> Bool prop_match2 = not . match (compile "[/]") . take 1 . unP -- [!/] is like ? +prop_match3 :: Path -> Property prop_match3 p_ = let p = unP p_ ~(x:_) = p in not (null p || isPathSeparator x || isExtSeparator x) ==> match (compile "[!/]") [x] + +-- Anything should match itself, when compiled with everything disabled. +prop_match4 :: PString -> Bool +prop_match4 ps_ = + let ps = unPS ps_ + noOpts = CompOptions { characterClasses = False + , characterRanges = False + , numberRanges = False + , wildcards = False + , recursiveWildcards = False + , pathSepInRanges = False + , errorRecovery = True + } + in match (compileWith noOpts ps) ps diff --git a/tests/Tests/Optimizer.hs b/tests/Tests/Optimizer.hs --- a/tests/Tests/Optimizer.hs +++ b/tests/Tests/Optimizer.hs @@ -4,26 +4,52 @@ import Test.Framework import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck (Property, (==>)) -import System.FilePath.Glob.Base (tokenize, optimize) +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 + 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 pat pth == match (optimize pat) pth + in isRight x ==> match (liftP miniOptimize pat) pth + == match (optimize pat) pth + where + miniOptimize = go + + go (ExtSeparator : xs) = Literal '.' : go xs + go (AnyNonPathSeparator : xs@(AnyNonPathSeparator : _)) = go xs + go (x:xs) = x : go xs + go [] = [] + +-- Optimizing should remove all ExtSeparators +prop_optimize3 :: COpts -> PString -> Property +prop_optimize3 o p = + let x = tokenize (unCOpts o) (unPS p) + pat = fromRight x + in isRight x && ExtSeparator `elem` unPattern pat + ==> ExtSeparator `notElem` unPattern (optimize pat) diff --git a/tests/Tests/Regression.hs b/tests/Tests/Regression.hs --- a/tests/Tests/Regression.hs +++ b/tests/Tests/Regression.hs @@ -4,18 +4,19 @@ import Test.Framework import Test.Framework.Providers.HUnit -import Test.HUnit.Base +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 $ \t@(b,co,mo,p,s) -> + flip map matchWithCases $ \(b,co,mo,p,s) -> tc (nameMatchTest (b,p,s)) $ matchWith mo (compileWith co p) s == b , testGroup "Decompilation" . @@ -25,18 +26,25 @@ 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-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 , "**" , "") @@ -86,6 +94,9 @@ , (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") @@ -124,8 +135,15 @@ , (False, "[^-~]" , "X") , (False, "[^^-~]" , "x") , (False, "[^-]" , "-") + , (True, "//" , "//") + , (True, ".//" , ".//") + , (True, "?" , ".//a") + , (False, "<-><->" , "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") diff --git a/tests/Tests/Simplifier.hs b/tests/Tests/Simplifier.hs --- a/tests/Tests/Simplifier.hs +++ b/tests/Tests/Simplifier.hs @@ -4,6 +4,7 @@ import Test.Framework import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck (Property, (==>)) import System.FilePath.Glob.Base (tryCompileWith) import System.FilePath.Glob.Match @@ -11,20 +12,23 @@ 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 + in isRight pat ==> xs !! 1 == xs !! 2 -- Simplifying shouldn't affect whether a match succeeds -prop_simplify2 p o s = +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 + in isRight x ==> match pat pth == match (simplify pat) pth diff --git a/tests/Tests/Utils.hs b/tests/Tests/Utils.hs --- a/tests/Tests/Utils.hs +++ b/tests/Tests/Utils.hs @@ -3,26 +3,30 @@ 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 ((-->)) +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 :: (Float, Float) -> (Float, Float) -> Float -> Bool 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 @@ -33,11 +37,18 @@ Just o -> (inRange r1 c --> inRange o c) && (inRange r2 c --> inRange o c) +prop_increasingSeq :: Float -> [Float] -> Property prop_increasingSeq a xs = let s = fst . increasingSeq $ a:xs - in s == reverse [a :: Float .. head s] + in abs a <= 2^(23 :: Int) ==> s == reverse [a .. head s] +prop_addToRange :: (Float, Float) -> Float -> Property prop_addToRange x c = let r = validateRange x r' = addToRange r c - in isJust r' ==> inRange (fromJust r') (c :: Float) + in isJust r' ==> inRange (fromJust r') c + +prop_pathParts :: Path -> Bool +prop_pathParts pstr = + let p = unP pstr + in all (`isSuffixOf` p) (pathParts p)