Glob 0.8.0 → 0.9.0

raw patch · 18 files changed

+696/−173 lines, 18 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.txt +56/−0
• CREDITS.txt +1/−0
• Glob.cabal +7/−1
• LICENSE.txt +1/−1
• System/FilePath/Glob.hs +6/−1
• System/FilePath/Glob/Base.hs +85/−35
• System/FilePath/Glob/Directory.hs +136/−50
• System/FilePath/Glob/Match.hs +55/−38
• tests/Main.hs +6/−2
• tests/Tests/Base.hs +17/−6
• tests/Tests/Compiler.hs +21/−2
• tests/Tests/Directory.hs +171/−0
• tests/Tests/Instances.hs +19/−9
• tests/Tests/Matcher.hs +42/−14
• tests/Tests/Optimizer.hs +29/−3
• tests/Tests/Regression.hs +22/−4
• tests/Tests/Simplifier.hs +7/−3
• tests/Tests/Utils.hs +15/−4

@@ -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. 

@@ -1,5 +1,6 @@ In alphabetical order by surname: +Harry Garrood Stephen Hicks Matti Niemenmaa Masahiro Sakai

@@ -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

@@ -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 <authors>+Copyright (c) 2008-2017 <authors> All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -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)

@@ -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-a> -> a-   go (OpenRange (Just a) (Just b):xs)-      | a == b = LongLiteral (length a) a : go xs--   -- <a-b> -> [a-b]-   -- a and b are guaranteed non-null-   go (OpenRange (Just [a]) (Just [b]):xs)-      | b > a = go $ CharRange True [Right (a,b)] : xs+   -- 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

@@ -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

@@ -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.

@@ -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    ]

@@ -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

@@ -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+      }

@@ -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"+          ]+        )+      ]

@@ -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

@@ -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

@@ -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)

@@ -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")

@@ -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

@@ -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)