diff --git a/CHANGELOG.txt b/CHANGELOG.txt --- a/CHANGELOG.txt +++ b/CHANGELOG.txt @@ -1,3 +1,59 @@ +0.4, 2009-01-31: + New functions: + System.FilePath.Glob.commonDirectory :: Pattern -> (FilePath, Pattern) + + System.FilePath.Glob.simplify :: Pattern -> Pattern + System.FilePath.Glob.decompile :: Pattern -> String + + System.FilePath.Glob.tryCompileWith :: CompOptions -> String -> Either String Pattern + System.FilePath.Glob.compileWith :: CompOptions -> String -> Pattern + System.FilePath.Glob.compDefault :: CompOptions + System.FilePath.Glob.compPosix :: CompOptions + + System.FilePath.Glob.matchWith :: MatchOptions -> Pattern -> FilePath -> Bool + System.FilePath.Glob.globDirWith :: MatchOptions -> [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath]) + System.FilePath.Glob.matchDefault :: MatchOptions + System.FilePath.Glob.matchPosix :: MatchOptions + + System.FilePath.Glob.Primitives.literal :: String -> Pattern + System.FilePath.Glob.Primitives.singleWildcard :: Pattern + System.FilePath.Glob.Primitives.wildcard :: Pattern + System.FilePath.Glob.Primitives.recursiveWildcard :: Pattern + System.FilePath.Glob.Primitives.charRange :: Bool -> [Either Char (Char,Char)] -> Pattern + System.FilePath.Glob.Primitives.numberRange :: Maybe Integer -> Maybe Integer -> Pattern + + Removed functions: + System.FilePath.Glob.tryCompile (no longer needed / superceded by tryCompileWith) + + New instances: + Monoid Pattern + Read Pattern + + Change: ".." can now be matched, by patterns such as ".*". + Change: globDir, given "" as the directory, uses getCurrentDirectory. + Change: globDir now keeps track of the number of path separators, thus + "a//*" will return "a//b" instead of "a/b" as a match result. + Change: if character ranges begin with ! or ^, these characters are now + considered the start of the range: [^-~] is the range ^ through ~, + not the inverse of [-~]. + + Regression fix: handle directories without read permissions even more + properly. + + Bug fix: globDir doesn't convert patterns like "a./b" to "ab". + Bug fix: the Show instance used to show "[?]" as the very different "?" (and + a few similar cases). + Bug fix: "//./" wasn't getting optimized properly. + Bug fix: ".//a" matched "/a" and not "a" or "./a". + Bug fix: "f**/a" didn't match "foo/a". + Bug fix: ".**/a" didn't match ".foo/a". + Bug fix: ".**/a" matched "../a". + Bug fixes: globDir and match, in general, handled patterns starting with + ".*" or ".**/" quite differently. + Bug fix: globDir never matched "foo/" to the directory "foo". + Bug fix: globDir never matched "foo**/" to the directory "foo". + Bug fix: show (compile "[a!b]") resulted in "[!ab]". + 0.3.2, 2008-12-20: Regression fix: handle directories without read permissions properly. @@ -24,5 +80,5 @@ System.FilePath.Glob.compile :: String -> Pattern System.FilePath.Glob.match :: Pattern -> FilePath -> Bool System.FilePath.Glob.globDir :: [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath]) - + Dependencies: base, containers, directory, filepath, mtl. diff --git a/CREDITS.txt b/CREDITS.txt new file mode 100644 --- /dev/null +++ b/CREDITS.txt @@ -0,0 +1,4 @@ +In alphabetical order by surname: + +Stephen Hicks +Matti Niemenmaa diff --git a/Glob.cabal b/Glob.cabal --- a/Glob.cabal +++ b/Glob.cabal @@ -1,7 +1,7 @@ Cabal-Version: >= 1.6 Name: Glob -Version: 0.3.2 +Version: 0.4 Homepage: http://iki.fi/matti.niemenmaa/glob/ Synopsis: Globbing library Category: System @@ -17,6 +17,7 @@ Build-Type: Simple Extra-Source-Files: CHANGELOG.txt + CREDITS.txt tests/README.txt tests/*.hs tests/Tests/*.hs @@ -33,9 +34,9 @@ Build-Depends: Win32 == 2.* Exposed-Modules: System.FilePath.Glob + System.FilePath.Glob.Primitive Other-Modules: System.FilePath.Glob.Base - System.FilePath.Glob.Compile System.FilePath.Glob.Directory System.FilePath.Glob.Match - System.FilePath.Glob.Optimize + System.FilePath.Glob.Simplify System.FilePath.Glob.Utils diff --git a/LICENSE.txt b/LICENSE.txt --- a/LICENSE.txt +++ b/LICENSE.txt @@ -1,4 +1,8 @@ -Copyright (c) 2008, Matti Niemenmaa +The code in Glob is released under the license below. Copyrights to parts of +the code are held by whoever wrote the code in question: see CREDITS.txt for a +list of authors. + +Copyright (c) 2008-2009 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 @@ -10,13 +10,32 @@ Pattern -- * Functions -- ** Compilation - , tryCompile, compile + , compile, decompile, simplify + -- *** Options + , CompOptions(..) + , compileWith, tryCompileWith + -- **** Predefined option sets + , compDefault, compPosix -- ** Matching , match , globDir + -- *** Options + , MatchOptions(..) + , matchWith + , globDirWith + -- **** Predefined option sets + , matchDefault, matchPosix + -- ** Miscellaneous + , commonDirectory ) where -import System.FilePath.Glob.Base (Pattern) -import System.FilePath.Glob.Compile (compile, tryCompile) -import System.FilePath.Glob.Directory (globDir) -import System.FilePath.Glob.Match (match) +import System.FilePath.Glob.Base ( Pattern + , CompOptions(..), MatchOptions(..) + , compDefault, compPosix + , matchDefault, matchPosix + , compile, compileWith, tryCompileWith + , decompile + ) +import System.FilePath.Glob.Directory (globDir, globDirWith, commonDirectory) +import System.FilePath.Glob.Match (match, matchWith) +import System.FilePath.Glob.Simplify (simplify) diff --git a/System/FilePath/Glob/Base.hs b/System/FilePath/Glob/Base.hs --- a/System/FilePath/Glob/Base.hs +++ b/System/FilePath/Glob/Base.hs @@ -1,12 +1,46 @@ -- File created: 2008-10-10 13:29:26 -module System.FilePath.Glob.Base where +{-# LANGUAGE CPP #-} -import Data.Maybe (fromMaybe) -import System.FilePath (pathSeparator, extSeparator) +module System.FilePath.Glob.Base + ( Token(..), Pattern(..) --- Todo? data Options = Options { allow_dots :: Bool } + , CompOptions(..), MatchOptions(..) + , compDefault, compPosix, matchDefault, matchPosix + , decompile + + , compile + , compileWith, tryCompileWith + , tokenize -- for tests + + , optimize + + , liftP, tokToLower + ) where + +import Control.Arrow (first) +import Control.Monad.Error (ErrorT, runErrorT, throwError) +import Control.Monad.Writer.Strict (Writer, runWriter, tell) +import Control.Exception (assert) +import Data.Char (isDigit, isAlpha, toLower) +import Data.List (find, sortBy) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid, mappend, mempty, mconcat) +import System.FilePath ( pathSeparator, extSeparator + , isExtSeparator, isPathSeparator + ) + +import System.FilePath.Glob.Utils ( dropLeadingZeroes + , isLeft, fromLeft + , increasingSeq + , addToRange, overlap + ) + +#if __GLASGOW_HASKELL__ +import Text.Read (readPrec, lexP, parens, prec, Lexeme(Ident)) +#endif + data Token -- primitives = Literal !Char @@ -22,11 +56,32 @@ | LongLiteral !Int String deriving (Eq) +-- Note: CharRanges aren't converted, because this is tricky in general. +-- Consider for instance [@-[], which includes the range A-Z. This would need +-- to become [@[a-z]: so essentially we'd need to either: +-- +-- 1) Have a list of ranges of uppercase Unicode. Check if our range +-- overlaps with any of them and if it does, take the non-overlapping +-- part and combine it with the toLower of the overlapping part. +-- +-- 2) Simply expand the entire range to a list and map toLower over it. +-- +-- In either case we'd need to re-optimize the CharRange—we can't assume that +-- if the uppercase characters are consecutive, so are the lowercase. +-- +-- 1) might be feasible if someone bothered to get the latest data. +-- +-- 2) obviously isn't since you might have 'Right (minBound, maxBound)' in +-- there somewhere. +-- +-- The current solution is to just check both the toUpper of the character and +-- the toLower. +tokToLower :: Token -> Token +tokToLower (Literal c) = Literal (toLower c) +tokToLower (LongLiteral n s) = LongLiteral n (map toLower s) +tokToLower tok = tok + -- |An abstract data type representing a compiled pattern. --- --- The 'Show' instance is essentially the inverse of @'compile'@. Though it may --- not return exactly what was given to @'compile'@ it will return code which --- produces the same 'Pattern'. -- -- Note that the 'Eq' instance cannot tell you whether two patterns behave in -- the same way; only whether they compile to the same 'Pattern'. For instance, @@ -39,22 +94,533 @@ liftP f (Pattern pat) = Pattern (f pat) instance Show Token where - show (Literal c) = [c] + show (Literal c) + | c `elem` "*?[<" || isExtSeparator c + = ['[',c,']'] + | otherwise = assert (not $ isPathSeparator c) [c] show ExtSeparator = [ extSeparator] show PathSeparator = [pathSeparator] show NonPathSeparator = "?" show AnyNonPathSeparator = "*" show AnyDirectory = "**/" - show (LongLiteral _ s) = s - show (CharRange b r) = - '[' : (if b then "" else "^") ++ - concatMap (either (:[]) (\(x,y) -> [x,'-',y])) r ++ "]" + show (LongLiteral _ s) = concatMap (show . Literal) s show (OpenRange a b) = '<' : fromMaybe "" a ++ "-" ++ fromMaybe "" b ++ ">" - showList = showList . concatMap show + -- We have to be careful here with ^ and ! lest [a!b] become [!ab]. So we + -- just put them at the end. + -- + -- Also, [^x-] was sorted and should not become [^-x]. + show (CharRange b r) = + let f = either (:[]) (\(x,y) -> [x,'-',y]) + (caret,exclamation,fs) = + foldr (\c (ca,ex,ss) -> + case c of + Left '^' -> ("^",ex,ss) + Left '!' -> (ca,"!",ss) + _ -> (ca, ex,(f c ++) . ss) + ) + ("", "", id) + r + (beg,rest) = let s' = fs [] + (x,y) = splitAt 1 s' + in if not b && x == "-" + then (y,x) + else (s',"") + in concat [ "[" + , if b then "" else "^" + , beg, caret, exclamation, rest + , "]" + ] instance Show Pattern where - showsPrec d (Pattern ts) = - showParen (d > 10) $ showString "compile " . shows ts + showsPrec d p = showParen (d > 10) $ + showString "compile " . showsPrec (d+1) (decompile p) + +instance Read Pattern where +#if __GLASGOW_HASKELL__ + readPrec = parens . prec 10 $ do + Ident "compile" <- lexP + fmap compile readPrec +#else + readsPrec d = readParen (d > 10) $ \r -> do + ("compile",string) <- lex r + (xs,rest) <- readsPrec (d+1) string + [(compile xs, rest)] +#endif + +instance Monoid Pattern where + mempty = Pattern [] + mappend (Pattern a) (Pattern b) = optimize . Pattern $ (a ++ b) + mconcat = optimize . Pattern . concatMap unPattern + +-- |Options which can be passed to the 'tryCompileWith' or 'compileWith' +-- functions: with these you can selectively toggle certain features at compile +-- time. +-- +-- Note that some of these options depend on each other: classes can never +-- occur if ranges aren't allowed, for instance. + +-- We could presumably put locale information in here, too. +data CompOptions = CompOptions + { characterClasses :: Bool -- ^Allow character classes, @[[:...:]]@. + , characterRanges :: Bool -- ^Allow character ranges, @[...]@. + , numberRanges :: Bool -- ^Allow open ranges, @\<...>@. + , wildcards :: Bool -- ^Allow wildcards, @*@ and @?@. + , recursiveWildcards :: Bool -- ^Allow recursive wildcards, @**/@. + + , pathSepInRanges :: Bool + -- ^Allow path separators in character ranges. + -- + -- If true, @a[/]b@ never matches anything (since character ranges can't + -- match path separators); if false and 'errorRecovery' is enabled, + -- @a[/]b@ matches itself, i.e. a file named @]b@ in the subdirectory + -- @a[@. + + , errorRecovery :: Bool + -- ^If the input is invalid, recover by turning any invalid part into + -- literals. For instance, with 'characterRanges' enabled, @[abc@ is an + -- error by default (unclosed character range); with 'errorRecovery', the + -- @[@ is turned into a literal match, as though 'characterRanges' were + -- disabled. + } deriving (Show,Read,Eq) + +-- |The default set of compilation options: closest to the behaviour of the +-- @zsh@ shell, with 'errorRecovery' enabled. +-- +-- All options are enabled. +compDefault :: CompOptions +compDefault = CompOptions + { characterClasses = True + , characterRanges = True + , numberRanges = True + , wildcards = True + , recursiveWildcards = True + , pathSepInRanges = True + , errorRecovery = True + } + +-- |Options for POSIX-compliance, as described in @man 7 glob@. +-- +-- 'numberRanges', 'recursiveWildcards', and 'pathSepInRanges' are disabled. +compPosix :: CompOptions +compPosix = CompOptions + { characterClasses = True + , characterRanges = True + , numberRanges = False + , wildcards = True + , recursiveWildcards = False + , pathSepInRanges = False + , errorRecovery = True + } + +-- |Options which can be passed to the 'matchWith' or 'globDirWith' functions: +-- with these you can selectively toggle certain features at matching time. +data MatchOptions = MatchOptions + { matchDotsImplicitly :: Bool + -- ^Allow @*@, @?@, and @**/@ to match @.@ at the beginning of paths. + + , ignoreCase :: Bool + -- ^Case-independent matching. + + , ignoreDotSlash :: Bool + -- ^Treat @./@ as a no-op in both paths and patterns. + -- + -- (Of course e.g. @../@ means something different and will not be + -- ignored.) + } + +-- |The default set of execution options: closest to the behaviour of the @zsh@ +-- shell. +-- +-- Currently identical to 'matchPosix'. +matchDefault :: MatchOptions +matchDefault = matchPosix + +-- |Options for POSIX-compliance, as described in @man 7 glob@. +-- +-- 'ignoreDotSlash' is enabled, the rest are disabled. +matchPosix :: MatchOptions +matchPosix = MatchOptions + { matchDotsImplicitly = False + , ignoreCase = False + , ignoreDotSlash = True + } + +-- |Decompiles a 'Pattern' object into its textual representation: essentially +-- the inverse of 'compile'. +-- +-- Note, however, that due to internal optimization, @decompile . compile@ is +-- not the identity function. Instead, @compile . decompile@ is. +-- +-- Be careful with 'CompOptions': 'decompile' always produces a 'String' which +-- can be passed to 'compile' to get back the same 'Pattern'. @compileWith +-- options . decompile@ is /not/ the identity function unless @options@ is +-- 'compDefault'. +decompile :: Pattern -> String +decompile = concatMap show . unPattern + +------------------------------------------ +-- COMPILATION +------------------------------------------ + + +-- |Compiles a glob pattern from its textual representation into a 'Pattern' +-- object. +-- +-- For the most part, a character matches itself. Recognized operators are as +-- follows: +-- +-- [@?@] Matches any character except path separators. +-- +-- [@*@] Matches any number of characters except path separators, +-- including the empty string. +-- +-- [@[..\]@] Matches any of the enclosed characters. Ranges of characters can +-- be specified by separating the endpoints with a @\'-'@. @\'-'@ or +-- @']'@ can be matched by including them as the first character(s) +-- in the list. Never matches path separators: @[\/]@ matches +-- nothing at all. Named character classes can also be matched: +-- @[:x:]@ within @[]@ specifies the class named @x@, which matches +-- certain predefined characters. See below for a full list. +-- +-- [@[^..\]@ or @[!..\]@] Like @[..]@, but matches any character /not/ listed. +-- Note that @[^-x]@ is not the inverse of @[-x]@, but +-- the range @[^-x]@. +-- +-- [@\@] Matches any integer in the range m to n, inclusive. The range may +-- be open-ended by leaving out either number: @\"\<->\"@, for +-- instance, matches any integer. +-- +-- [@**/@] Matches any number of characters, including path separators, +-- excluding the empty string. +-- +-- Supported character classes: +-- +-- [@[:alnum:\]@] Equivalent to @\"0-9A-Za-z\"@. +-- +-- [@[:alpha:\]@] Equivalent to @\"A-Za-z\"@. +-- +-- [@[:blank:\]@] Equivalent to @\"\\t \"@. +-- +-- [@[:cntrl:\]@] Equivalent to @\"\\0-\\x1f\\x7f\"@. +-- +-- [@[:digit:\]@] Equivalent to @\"0-9\"@. +-- +-- [@[:graph:\]@] Equivalent to @\"!-~\"@. +-- +-- [@[:lower:\]@] Equivalent to @\"a-z\"@. +-- +-- [@[:print:\]@] Equivalent to @\" -~\"@. +-- +-- [@[:punct:\]@] Equivalent to @\"!-\/:-\@[-`{-~\"@. +-- +-- [@[:space:\]@] Equivalent to @\"\\t-\\r \"@. +-- +-- [@[:upper:\]@] Equivalent to @\"A-Z\"@. +-- +-- [@[:xdigit:\]@] Equivalent to @\"0-9A-Fa-f\"@. +-- +-- Note that path separators (typically @\'/\'@) have to be matched explicitly +-- or using the @**/@ pattern. In addition, extension separators (typically +-- @\'.\'@) have to be matched explicitly at the beginning of the pattern or +-- after any path separator. +-- +-- If a system supports multiple path separators, any one of them will match +-- any of them. For instance, on Windows, @\'/\'@ will match itself as well as +-- @\'\\\'@. +-- +-- Error recovery will be performed: erroneous operators will not be considered +-- operators, but matched as literal strings. Such operators include: +-- +-- * An empty @[]@ or @[^]@ or @[!]@ +-- +-- * A @[@ or @\<@ without a matching @]@ or @>@ +-- +-- * A malformed @\<>@: e.g. nonnumeric characters or no hyphen +-- +-- So, e.g. @[]@ will match the string @\"[]\"@. +compile :: String -> Pattern +compile = compileWith compDefault + +-- |Like 'compile', but recognizes operators according to the given +-- 'CompOptions' instead of the defaults. +-- +-- If an error occurs and 'errorRecovery' is disabled, 'error' will be called. +compileWith :: CompOptions -> String -> Pattern +compileWith opts = either error id . tryCompileWith opts + +-- |A safe version of 'compileWith'. +-- +-- If an error occurs and 'errorRecovery' is disabled, the error message will +-- be returned in a 'Left'. +tryCompileWith :: CompOptions -> String -> Either String Pattern +tryCompileWith opts = fmap optimize . tokenize opts + +tokenize :: CompOptions -> String -> Either String Pattern +tokenize opts = fmap Pattern . sequence . go + where + err _ c cs | errorRecovery opts = Right (Literal c) : go cs + err s _ _ = [Left s] + + go :: String -> [Either String Token] + go [] = [] + go ('?':cs) | wcs = Right NonPathSeparator : go cs + go ('*':cs) | wcs = + case cs of + '*':p:xs | rwcs && isPathSeparator p + -> Right AnyDirectory : go xs + _ -> Right AnyNonPathSeparator : go cs + + go ('[':cs) | crs = let (range,rest) = charRange opts cs + in case range of + Left s -> err s '[' cs + r -> r : go rest + + go ('<':cs) | ors = + let (range, rest) = break (=='>') cs + in if null rest + then err "compile :: unclosed <> in pattern" '<' cs + else case openRange range of + Left s -> err s '<' cs + r -> r : go (tail rest) + go (c:cs) + | isPathSeparator c = Right PathSeparator : go cs + | isExtSeparator c = Right ExtSeparator : go cs + | otherwise = Right (Literal c) : go cs + + wcs = wildcards opts + rwcs = recursiveWildcards opts + crs = characterRanges opts + ors = numberRanges opts + +-- where a > b can never match anything; this is not considered an error +openRange :: String -> Either String Token +openRange ['-'] = Right $ OpenRange Nothing Nothing +openRange ('-':s) = + case span isDigit s of + (b,"") -> Right $ OpenRange Nothing (openRangeNum b) + _ -> Left $ "compile :: bad <>, expected number, got " ++ s +openRange s = + case span isDigit s of + (a,"-") -> Right $ OpenRange (openRangeNum a) Nothing + (a,'-':s') -> + case span isDigit s' of + (b,"") -> Right $ OpenRange (openRangeNum a) (openRangeNum b) + _ -> Left $ "compile :: bad <>, expected number, got " ++ s' + _ -> Left $ "compile :: bad <>, expected number followed by - in " ++ s + +openRangeNum :: String -> Maybe String +openRangeNum = Just . dropLeadingZeroes + +type CharRange = [Either Char (Char,Char)] + +charRange :: CompOptions -> String -> (Either String Token, String) +charRange opts zs = + case zs of + y:ys | y `elem` "^!" -> + case ys of + -- [!-#] is not the inverse of [-#], it is the range ! through + -- # + '-':']':xs -> (Right (CharRange False [Left '-']), xs) + '-' :_ -> first (fmap (CharRange True )) (start zs) + xs -> first (fmap (CharRange False)) (start xs) + _ -> first (fmap (CharRange True )) (start zs) + where + start :: String -> (Either String CharRange, String) + start (']':xs) = run $ char ']' xs + start ('-':xs) = run $ char '-' xs + start xs = run $ go xs + + run :: ErrorT String (Writer CharRange) String + -> (Either String CharRange, String) + run m = case runWriter.runErrorT $ m of + (Left err, _) -> (Left err, []) + (Right rest, cs) -> (Right cs, rest) + + go :: String -> ErrorT String (Writer CharRange) String + go ('[':':':xs) | characterClasses opts = readClass xs + go ( ']':xs) = return xs + go ( c:xs) = + if not (pathSepInRanges opts) && isPathSeparator c + then throwError "compile :: path separator within []" + else char c xs + go [] = throwError "compile :: unclosed [] in pattern" + + char :: Char -> String -> ErrorT String (Writer CharRange) String + char c ('-':x:xs) = + if x == ']' + then tell [Left c, Left '-'] >> return xs + else tell [Right (c,x)] >> go xs + + char c xs = tell [Left c] >> go xs + + readClass :: String -> ErrorT String (Writer CharRange) String + readClass xs = let (name,end) = span isAlpha xs + in case end of + ':':']':rest -> charClass name >> go rest + _ -> tell [Left '[',Left ':'] >> go xs + + charClass :: String -> ErrorT String (Writer CharRange) () + charClass name = + -- The POSIX classes + -- + -- TODO: this is ASCII-only, not sure how this should be extended + -- Unicode, or with a locale as input, or something else? + case name of + "alnum" -> tell [digit,upper,lower] + "alpha" -> tell [upper,lower] + "blank" -> tell blanks + "cntrl" -> tell [Right ('\0','\x1f'), Left '\x7f'] + "digit" -> tell [digit] + "graph" -> tell [Right ('!','~')] + "lower" -> tell [lower] + "print" -> tell [Right (' ','~')] + "punct" -> tell punct + "space" -> tell spaces + "upper" -> tell [upper] + "xdigit" -> tell [digit, Right ('A','F'), Right ('a','f')] + _ -> + throwError ("compile :: unknown character class '" ++name++ "'") + + digit = Right ('0','9') + upper = Right ('A','Z') + lower = Right ('a','z') + punct = map Right [('!','/'), (':','@'), ('[','`'), ('{','~')] + blanks = [Left '\t', Left ' '] + spaces = [Right ('\t','\r'), Left ' '] + + +------------------------------------------ +-- OPTIMIZATION +------------------------------------------ + + +optimize :: Pattern -> Pattern +optimize = liftP (fin . go) + where + fin [] = [] + + -- Literals to LongLiteral + -- Has to be done here: we can't backtrack in go, but some cases might + -- result in consecutive Literals being generated. + -- E.g. "a[b]". + fin (x:y:xs) | isLiteral x && isLiteral y = + let (ls,rest) = span isLiteral xs + in fin $ LongLiteral (length ls + 2) + (foldr (\(Literal a) -> (a:)) [] (x:y:ls)) + : rest + + -- concatenate LongLiterals + -- Has to be done here because LongLiterals are generated above. + -- + -- So one could say that we have one pass (go) which flattens everything as + -- much as it can and one pass (fin) which concatenates what it can. + fin (LongLiteral l1 s1 : LongLiteral l2 s2 : xs) = + fin $ LongLiteral (l1+l2) (s1++s2) : xs + + fin (LongLiteral l s : Literal c : xs) = + fin $ LongLiteral (l+1) (s++[c]) : xs + + fin (LongLiteral 1 s : xs) = Literal (head s) : fin xs + + fin (Literal c : LongLiteral l s : xs) = + fin $ LongLiteral (l+1) (c:s) : xs + + fin (x:xs) = x : fin xs + + go [] = [] + go (x@(CharRange _ _) : xs) = + case optimizeCharRange x of + x'@(CharRange _ _) -> x' : go xs + x' -> go (x':xs) + + -- -> a + go (OpenRange (Just a) (Just b):xs) + | a == b = LongLiteral (length a) a : go xs + + -- -> [a-b] + -- a and b are guaranteed non-null + go (OpenRange (Just [a]) (Just [b]):xs) + | b > a = go $ CharRange True [Right (a,b)] : xs + + go (x:xs) = + case find ($ x) compressors of + Just c -> let (compressed,ys) = span c xs + in if null compressed + then x : go ys + else go (x : ys) + Nothing -> x : go xs + + compressors = [isStar, isStarSlash, isAnyNumber] + + isLiteral (Literal _) = True + isLiteral _ = False + isStar AnyNonPathSeparator = True + isStar _ = False + isStarSlash AnyDirectory = True + isStarSlash _ = False + isAnyNumber (OpenRange Nothing Nothing) = True + isAnyNumber _ = False + +optimizeCharRange :: Token -> Token +optimizeCharRange (CharRange b_ rs) = fin b_ . go . sortCharRange $ rs + where + -- [/] is interesting, it actually matches nothing at all + -- [.] can be Literalized though, just don't make it into an ExtSeparator so + -- that it doesn't match a leading dot + fin True [Left c] | not (isPathSeparator c) = Literal c + fin True [Right r] | r == (minBound,maxBound) = NonPathSeparator + fin b x = CharRange b x + + go [] = [] + + go (x@(Left c) : xs) = + case xs of + [] -> [x] + y@(Left d) : ys + -- [aaaaa] -> [a] + | c == d -> go$ Left c : ys + | d == succ c -> + let (ls,rest) = span isLeft xs -- start from y + (catable,others) = increasingSeq (map fromLeft ls) + range = (c, head catable) + + in -- three (or more) Lefts make a Right + if null catable || null (tail catable) + then x : y : go ys + -- [abcd] -> [a-d] + else go$ Right range : map Left others ++ rest + + | otherwise -> x : go xs + + Right r : ys -> + case addToRange r c of + -- [da-c] -> [a-d] + Just r' -> go$ Right r' : ys + Nothing -> x : go xs + + go (x@(Right r) : xs) = + case xs of + [] -> [x] + Left c : ys -> + case addToRange r c of + -- [a-cd] -> [a-d] + Just r' -> go$ Right r' : ys + Nothing -> x : go xs + + Right r' : ys -> + case overlap r r' of + -- [a-cb-d] -> [a-d] + Just o -> go$ Right o : ys + Nothing -> x : go xs +optimizeCharRange _ = error "Glob.optimizeCharRange :: internal error" + +sortCharRange :: [Either Char (Char,Char)] -> [Either Char (Char,Char)] +sortCharRange = sortBy cmp + where + cmp (Left a) (Left b) = compare a b + cmp (Left a) (Right (b,_)) = compare a b + cmp (Right (a,_)) (Left b) = compare a b + cmp (Right (a,_)) (Right (b,_)) = compare a b diff --git a/System/FilePath/Glob/Compile.hs b/System/FilePath/Glob/Compile.hs deleted file mode 100644 --- a/System/FilePath/Glob/Compile.hs +++ /dev/null @@ -1,128 +0,0 @@ --- File created: 2008-10-10 13:29:13 - -module System.FilePath.Glob.Compile - ( compile, tryCompile - , tokenize - ) where - -import Control.Monad.Error () -import Data.Char (isDigit) -import System.FilePath (isPathSeparator, isExtSeparator) - -import System.FilePath.Glob.Base -import System.FilePath.Glob.Optimize (optimize) -import System.FilePath.Glob.Utils (dropLeadingZeroes) - --- |Like 'tryCompile', but calls 'error' if an error results. -compile :: String -> Pattern -compile = either error id . tryCompile - --- |Compiles a glob pattern from its textual representation into a 'Pattern' --- object, giving an error message in a 'Left' if the pattern is erroneous. --- --- For the most part, a character matches itself. Recognized operators are as --- follows: --- --- [@?@] Matches any character except path separators. --- --- [@*@] Matches any number of characters except path separators, --- including the empty string. --- --- [@[..\]@] Matches any of the enclosed characters. Ranges of characters can --- be specified by separating the endpoints with a \'-'. \'-' or ']' --- can be matched by including them as the first character(s) in the --- list. --- --- [@[^..\]@ or @[!..\]@] Like [..], but matches any character /not/ listed. --- --- [@\@] Matches any integer in the range m to n, inclusive. The range may --- be open-ended by leaving out either number: \"\<->\", for --- instance, matches any integer. --- --- [@**/@] Matches any number of characters, including path separators, --- excluding the empty string. --- --- Note that path separators (typically @\'/\'@) have to be matched explicitly --- or using the @**/@ pattern. In addition, extension separators (typically --- @\'.\'@) have to be matched explicitly at the beginning of the pattern or --- after any path separator. --- --- If a system supports multiple path separators, any one of them will match --- any of them. For instance, on Windows, @\'/\'@ will match itself as well as --- @\'\\\'@. --- --- Erroneous patterns include: --- --- * An empty @[]@ or @[^]@ or @[!]@ --- --- * A @[@ or @\<@ without a matching @]@ or @>@ --- --- * A malformed @\<>@: e.g. nonnumeric characters or no hyphen -tryCompile :: String -> Either String Pattern -tryCompile = fmap optimize . tokenize - -tokenize :: String -> Either String Pattern -tokenize = fmap Pattern . sequence . go - where - err s = [Left s] - - go :: String -> [Either String Token] - go [] = [] - go ('?':cs) = Right NonPathSeparator : go cs - go ('*':cs) = - case cs of - '*':p:xs | isPathSeparator p -> Right AnyDirectory : go xs - _ -> Right AnyNonPathSeparator : go cs - go ('[':cs) = - let (range, rest) = break (==']') cs - in if null rest - then err "compile :: unclosed [] in pattern" - else if null range - then let (range', rest') = break (==']') (tail rest) - in if null rest' - then err "compile :: empty [] in pattern" - else charRange (']':range') : go (tail rest') - else charRange range : go (tail rest) - go ('<':cs) = - let (range, rest) = break (=='>') cs - in if null rest - then err "compile :: unclosed <> in pattern" - else openRange range : go (tail rest) - go (c:cs) - | isPathSeparator c = Right PathSeparator : go cs - | isExtSeparator c = Right ExtSeparator : go cs - | otherwise = Right (Literal c) : go cs - --- where a > b can never match anything; this is not considered an error -openRange :: String -> Either String Token -openRange ['-'] = Right $ OpenRange Nothing Nothing -openRange ('-':s) = - case span isDigit s of - (b,"") -> Right $ OpenRange Nothing (openRangeNum b) - _ -> Left $ "compile :: bad <>, expected number, got " ++ s -openRange s = - case span isDigit s of - (a,"-") -> Right $ OpenRange (openRangeNum a) Nothing - (a,'-':s') -> - case span isDigit s' of - (b,"") -> Right $ OpenRange (openRangeNum a) (openRangeNum b) - _ -> Left $ "compile :: bad <>, expected number, got " ++ s' - _ -> Left $ "compile :: bad <>, expected number followed by - in " ++ s - -openRangeNum :: String -> Maybe String -openRangeNum = Just . dropLeadingZeroes - -charRange :: String -> Either String Token -charRange [x] | x `elem` "^!" = Left ("compile :: empty [" ++ [x] - ++ "] in pattern") -charRange x = - if head x `elem` "^!" - then Right . CharRange False . f $ tail x - else Right . CharRange True . f $ x - where - f (']':s) = Left ']' : go s - f s = go s - - go [] = [] - go (a:'-':b:cs) = (if a == b then Left a else Right (a,b)) : go cs - go (c:cs) = Left c : go cs 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,55 +1,92 @@ -- File created: 2008-10-16 12:12:50 -module System.FilePath.Glob.Directory (globDir) where +module System.FilePath.Glob.Directory + ( globDir, globDirWith + , commonDirectory + ) where +import Control.Arrow (first, second) import Control.Monad (forM) import qualified Data.DList as DL import Data.DList (DList) import Data.List ((\\)) -import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.FilePath (()) +import System.Directory ( doesDirectoryExist, getDirectoryContents + , getCurrentDirectory + ) +import System.FilePath ((), extSeparator, isExtSeparator, pathSeparator) -import System.FilePath.Glob.Base -import System.FilePath.Glob.Match (match) -import System.FilePath.Glob.Utils - (getRecursiveContents, nubOrd, pathParts, partitionDL) +import System.FilePath.Glob.Base ( Pattern(..), Token(..) + , MatchOptions, matchDefault + ) +import System.FilePath.Glob.Match (matchWith) +import System.FilePath.Glob.Utils ( getRecursiveContents + , nubOrd + , pathParts + , partitionDL + ) -- The Patterns in TypedPattern don't contain PathSeparator or AnyDirectory +-- +-- We store the number of PathSeparators that Dir and AnyDir were followed by +-- so that "foo////*" can match "foo/bar" but return "foo////bar". It's the +-- exact number for convenience: () doesn't add a path separator if one is +-- already there. This way, '\(Dir n _) -> replicate n pathSeparator "bar"' +-- results in the correct amount of slashes. data TypedPattern - = Any Pattern -- pattern - | Dir Pattern -- pattern/ - | AnyDir Pattern -- pattern**/ + = Any Pattern -- pattern + | Dir Int Pattern -- pattern/ + | AnyDir Int Pattern -- pattern**/ deriving Show -- |Matches each given 'Pattern' against the contents of the given 'FilePath', -- recursively. The result pair\'s first component contains the matched paths, -- grouped for each given 'Pattern', and the second contains all paths which --- were not matched by any 'Pattern'. +-- were not matched by any 'Pattern'. The results are not in any defined order. -- +-- The given directory is prepended to all the matches: the returned paths are +-- all valid from the point of view of the current working directory. +-- -- If multiple 'Pattern's match a single 'FilePath', that path will be included -- in multiple groups. -- +-- Two 'FilePath's which can be canonicalized to the same file (e.g. @\"foo\"@ +-- and @\"./foo\"@) may appear separately if explicit matching on paths +-- beginning with @\".\"@ is done. Looking for @\".*/*\"@, for instance, will +-- cause @\"./foo\"@ to return as a match but @\"foo\"@ to not be matched. +-- -- This function is different from a simple 'filter' over all the contents of -- the directory: the matching is performed relative to the directory, so that -- for instance the following is true: -- -- > fmap (head.fst) (globDir [compile "*"] dir) == getDirectoryContents dir -- --- If @dir@ is @\"foo\"@ the pattern should be @\"foo/*\"@ to get the same --- results with a plain 'filter'. +-- (With the exception that that glob won't match anything beginning with @.@.) -- +-- If the given 'FilePath' is @[]@, 'getCurrentDirectory' will be used. +-- +-- Note that in some cases results outside the given directory may be returned: +-- for instance the @.*@ pattern matches the @..@ directory. +-- -- Any results deeper than in the given directory are enumerated lazily, using -- 'unsafeInterleaveIO'. -- -- Directories without read permissions are returned as entries but their -- contents, of course, are not. globDir :: [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath]) -globDir [] dir = do - c <- getRecursiveContents dir +globDir = globDirWith matchDefault + +-- |Like 'globDir', but applies the given 'MatchOptions' instead of the +-- defaults when matching. +globDirWith :: MatchOptions -> [Pattern] -> FilePath + -> IO ([[FilePath]], [FilePath]) +globDirWith _ [] dir = do + dir' <- if null dir then getCurrentDirectory else return dir + c <- getRecursiveContents dir' return ([], DL.toList c) -globDir pats dir = do - results <- mapM (\p -> globDir' (separate p) dir) pats +globDirWith opts pats dir = do + results <- mapM (\p -> globDir' opts (separate p) dir) pats + let (matches, others) = unzip results allMatches = DL.toList . DL.concat $ matches allOthers = DL.toList . DL.concat $ others @@ -58,69 +95,121 @@ , nubOrd allOthers \\ allMatches ) -globDir' :: [TypedPattern] -> FilePath -> IO (DList FilePath, DList FilePath) -globDir' [] dir = didn'tMatch dir True -globDir' pats dir = do - raw <- getDirectoryContents dir - - let entries = raw \\ [".",".."] +globDir' :: MatchOptions -> [TypedPattern] -> FilePath + -> IO (DList FilePath, DList FilePath) +globDir' opts pats@(_:_) dir = do + dir' <- if null dir then getCurrentDirectory else return dir + entries <- getDirectoryContents dir' `catch` const (return []) - results <- forM entries $ \e -> matchTypedAndGo pats e (dir e) + results <- forM entries $ \e -> matchTypedAndGo opts pats e (dir e) let (matches, others) = unzip results return (DL.concat matches, DL.concat others) -matchTypedAndGo :: [TypedPattern] +globDir' _ [] dir = + -- We can only get here from matchTypedAndGo getting a [Dir _]: it means the + -- original pattern had a trailing PathSeparator. Reproduce it here. + return (DL.singleton (dir ++ [pathSeparator]), DL.empty) + +matchTypedAndGo :: MatchOptions + -> [TypedPattern] -> FilePath -> FilePath -> IO (DList FilePath, DList FilePath) -- (Any p) is always the last element -matchTypedAndGo [Any p] path absPath = - if match p path +matchTypedAndGo opts [Any p] path absPath = + if matchWith opts p path then return (DL.singleton absPath, DL.empty) - else doesDirectoryExist absPath >>= didn'tMatch absPath + else doesDirectoryExist absPath >>= didn'tMatch path absPath -matchTypedAndGo (Dir p:ps) path absPath = do +matchTypedAndGo opts (Dir n p:ps) path absPath = do isDir <- doesDirectoryExist absPath - if isDir && match p path - then globDir' ps absPath - else didn'tMatch absPath isDir + if isDir && matchWith opts p path + then globDir' opts ps (absPath ++ replicate n pathSeparator) + else didn'tMatch path absPath isDir -matchTypedAndGo (AnyDir p:ps) path absPath = do - isDir <- doesDirectoryExist absPath - let m = match (unseparate ps) +matchTypedAndGo opts (AnyDir n p:ps) path absPath = do + if path `elem` [".",".."] + then didn'tMatch path absPath True + else do + isDir <- doesDirectoryExist absPath + let m = matchWith opts (unseparate ps) + unconditionalMatch = + null (unPattern p) && not (isExtSeparator $ head path) + p' = Pattern (unPattern p ++ [AnyNonPathSeparator]) - case null (unPattern p) || match p path of - True | isDir -> fmap (partitionDL (any m . pathParts)) - (getRecursiveContents absPath) - True | m path -> return (DL.singleton absPath, DL.empty) - _ -> didn'tMatch absPath isDir + case unconditionalMatch || matchWith opts p' path of + True | isDir -> do + contents <- getRecursiveContents + (absPath ++ replicate n pathSeparator) + return $ + -- foo**/ should match foo/ and nothing below it + -- relies on head contents == absPath + if null ps + then (DL.singleton $ DL.head contents, DL.tail contents) + else partitionDL (any m . pathParts) contents -matchTypedAndGo _ _ _ = error "Glob.matchTypedAndGo :: internal error" + True | m path -> return (DL.singleton absPath, DL.empty) + _ -> didn'tMatch path absPath isDir -didn'tMatch :: FilePath -> Bool -> IO (DList FilePath, DList FilePath) -didn'tMatch absPath isDir = (fmap $ (,) DL.empty) $ +matchTypedAndGo _ _ _ _ = error "Glob.matchTypedAndGo :: internal error" + +-- To be called when a pattern didn't match a path: given the path and whether +-- it was a directory, return all paths which didn't match (i.e. for a file, +-- just the file, and for a directory, everything inside it). +didn'tMatch :: FilePath -> FilePath -> Bool + -> IO (DList FilePath, DList FilePath) +didn'tMatch path absPath isDir = (fmap $ (,) DL.empty) $ if isDir - then getRecursiveContents absPath + then if path `elem` [".",".."] + then return DL.empty + else getRecursiveContents absPath else return$ DL.singleton absPath separate :: Pattern -> [TypedPattern] -separate = go [] . unPattern +separate = go DL.empty . unPattern where - go [] [] = [] - go gr [] = [Any $ f gr] - -- ./foo should not be split into [. , foo], it's just foo - go gr (ExtSeparator:PathSeparator:ps) = go gr ps - go gr ( PathSeparator:ps) = ( Dir $ f gr) : go [] ps - go gr ( AnyDirectory:ps) = (AnyDir $ f gr) : go [] ps - go gr ( p:ps) = go (p:gr) ps + go gr [] | null (DL.toList gr) = [] + go gr [] = [Any (pat gr)] + go gr (PathSeparator:ps) = slash gr Dir ps + go gr ( AnyDirectory:ps) = slash gr AnyDir ps + go gr ( p:ps) = go (gr `DL.snoc` p) ps - f = Pattern . reverse + pat = Pattern . DL.toList + slash gr f ps = let (n,ps') = first length . span isSlash $ ps + in f (n+1) (pat gr) : go DL.empty ps' + + isSlash PathSeparator = True + isSlash _ = False + unseparate :: [TypedPattern] -> Pattern unseparate = Pattern . foldr f [] where - f (AnyDir p) ts = unPattern p ++ AnyDirectory : ts - f ( Dir p) ts = unPattern p ++ PathSeparator : ts - f (Any p) ts = unPattern p ++ ts + f (AnyDir n p) ts = u p ++ AnyDirectory : replicate n PathSeparator ++ ts + f ( Dir n p) ts = u p ++ PathSeparator : replicate n PathSeparator ++ ts + f (Any p) ts = u p ++ ts + + u = unPattern + +-- |Factors out the directory component of a 'Pattern'. Useful in conjunction +-- with 'globDir'. +-- +-- Preserves the number of path separators: @commonDirectory (compile +-- \"foo\/\/\/bar\")@ becomes @(\"foo\/\/\/\", compile \"bar\")@. +commonDirectory :: Pattern -> (FilePath, Pattern) +commonDirectory = second unseparate . splitP . separate + where + splitP pt@(Dir n p:ps) = + case fromConst DL.empty (unPattern p) of + Just d -> first ((d ++ replicate n pathSeparator) ) (splitP ps) + Nothing -> ("", pt) + + splitP pt = ("", pt) + + fromConst d [] = Just (DL.toList d) + fromConst d (Literal c :xs) = fromConst (d `DL.snoc` c) xs + fromConst d (ExtSeparator :xs) = fromConst (d `DL.snoc` extSeparator) xs + fromConst d (LongLiteral _ s:xs) = fromConst (d `DL.append`DL.fromList s) xs + fromConst _ _ = Nothing 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,48 +1,91 @@ -- File created: 2008-10-10 13:29:03 -module System.FilePath.Glob.Match (match) where +module System.FilePath.Glob.Match (match, matchWith) where import Control.Exception (assert) -import Data.Char (isDigit) +import Data.Char (isDigit, toLower, toUpper) import Data.Monoid (mappend) import System.FilePath (isPathSeparator, isExtSeparator) -import System.FilePath.Glob.Base +import System.FilePath.Glob.Base ( Pattern(..), Token(..) + , MatchOptions(..), matchDefault + , tokToLower + ) import System.FilePath.Glob.Utils (dropLeadingZeroes, inRange, pathParts) -- |Matches the given 'Pattern' against the given 'FilePath', returning 'True' -- if the pattern matches and 'False' otherwise. match :: Pattern -> FilePath -> Bool -match = begMatch . unPattern +match = matchWith matchDefault +-- |Like 'match', but applies the given 'MatchOptions' instead of the defaults. +matchWith :: MatchOptions -> Pattern -> FilePath -> Bool +matchWith opts p f = begMatch opts (lcPat $ unPattern p) (lcPath f) + where + lcPath = if ignoreCase opts then map toLower else id + lcPat = if ignoreCase opts then map tokToLower else id + -- begMatch takes care of some things at the beginning of a pattern or after /: -- - . needs to be matched explicitly --- - ./foo is equivalent to foo -begMatch, match' :: [Token] -> FilePath -> Bool -begMatch _ "." = False -begMatch _ ".." = False -begMatch (ExtSeparator:PathSeparator:pat) s = begMatch pat s -begMatch pat (x:y:s) | isExtSeparator x && isPathSeparator y = begMatch pat s -begMatch pat s = - if not (null s) && isExtSeparator (head s) +-- - ./foo is equivalent to foo (for any number of /) +-- +-- .*/foo still needs to match ./foo though, and it won't match plain foo; +-- special case that one +-- +-- and .**/foo should /not/ match ../foo; more special casing +-- +-- (All of the above is modulo options, of course) +begMatch, match' :: MatchOptions -> [Token] -> FilePath -> Bool +begMatch _ (ExtSeparator:AnyDirectory:_) (x:y:_) + | isExtSeparator x && isExtSeparator y = False + +begMatch opts (ExtSeparator:PathSeparator:pat) s | ignoreDotSlash opts = + begMatch opts (dropWhile isSlash pat) s + where + isSlash PathSeparator = True + isSlash _ = False + +begMatch opts pat (x:y:s) + | dotSlash && dotStarSlash = match' opts pat' s + | ignoreDotSlash opts && dotSlash = begMatch opts pat s + where + dotSlash = isExtSeparator x && isPathSeparator y + (dotStarSlash, pat') = + case pat of + ExtSeparator:AnyNonPathSeparator:PathSeparator:rest -> (True, rest) + _ -> (False, pat) + +begMatch opts pat s = + if not (null s) && isExtSeparator (head s) && not (matchDotsImplicitly opts) then case pat of - ExtSeparator:pat' -> match' pat' (tail s) + ExtSeparator:pat' -> match' opts pat' (tail s) _ -> False - else match' pat s + else match' opts pat s -match' [] s = null s -match' (AnyNonPathSeparator:s) "" = null s -match' _ "" = False -match' (Literal l :xs) (c:cs) = l == c && match' xs cs -match' ( ExtSeparator :xs) (c:cs) = isExtSeparator c && match' xs cs -match' (PathSeparator :xs) (c:cs) = isPathSeparator c && begMatch xs cs -match' (NonPathSeparator:xs) (c:cs) = not (isPathSeparator c) && match' xs cs -match' (CharRange b rng :xs) (c:cs) = - not (isPathSeparator c) && - any (either (== c) (`inRange` c)) rng == b && - match' xs cs +match' _ [] s = null s +match' _ (AnyNonPathSeparator:s) "" = null s +match' _ _ "" = False +match' o (Literal l :xs) (c:cs) = l == c && match' o xs cs +match' o ( ExtSeparator :xs) (c:cs) = isExtSeparator c && match' o xs cs +match' o (NonPathSeparator:xs) (c:cs) = + not (isPathSeparator c) && match' o xs cs -match' (OpenRange lo hi :xs) path = +match' o (PathSeparator :xs) (c:cs) = + isPathSeparator c && begMatch o xs (dropWhile isPathSeparator cs) + +match' o (CharRange b rng :xs) (c:cs) = + let rangeMatch r = + either (== c) (`inRange` c) r || + -- See comment near Base.tokToLower for an explanation of why we + -- do this + if ignoreCase o + then either (== toUpper c) (`inRange` toUpper c) r + else False + in not (isPathSeparator c) && + any rangeMatch rng == b && + match' o xs cs + +match' o (OpenRange lo hi :xs) path = let (lzNum,cs) = span isDigit path num = dropLeadingZeroes lzNum @@ -59,24 +102,24 @@ -- 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' xs (rest ++ cs)) + any (\(n,rest) -> inOpenRange lo hi n && match' o xs (rest ++ cs)) ((num,"") : numChoices) -match' again@(AnyNonPathSeparator:xs) path@(c:cs) = - match' xs path || (if isPathSeparator c then False else match' again cs) +match' o again@(AnyNonPathSeparator:xs) path@(c:cs) = + match' o xs path || (if isPathSeparator c then False else match' o again cs) -match' again@(AnyDirectory:xs) path = - let parts = pathParts path - matches = any (match' xs) parts || any (match' again) (tail parts) - in if null xs +match' o again@(AnyDirectory:xs) path = + let parts = pathParts (dropWhile isPathSeparator path) + matches = any (match' o xs) parts || any (match' o again) (tail parts) + in if null xs && not (matchDotsImplicitly o) -- **/ shouldn't match foo/.bar, so check that remaining bits don't -- start with . then all (not.isExtSeparator.head) (init parts) && matches else matches -match' (LongLiteral len s:xs) path = +match' o (LongLiteral len s:xs) path = let (pre,cs) = splitAt len path - in pre == s && match' xs cs + in pre == s && match' o xs cs -- Does the actual open range matching: finds whether the third parameter -- is between the first two or not. diff --git a/System/FilePath/Glob/Optimize.hs b/System/FilePath/Glob/Optimize.hs deleted file mode 100644 --- a/System/FilePath/Glob/Optimize.hs +++ /dev/null @@ -1,138 +0,0 @@ --- File created: 2008-10-10 13:29:17 - -module System.FilePath.Glob.Optimize (optimize) where - -import Data.List (find, sortBy) -import System.FilePath (isPathSeparator, isExtSeparator) - -import System.FilePath.Glob.Base -import System.FilePath.Glob.Utils - ( isLeft, fromLeft - , increasingSeq - , addToRange, overlap) - -optimize :: Pattern -> Pattern -optimize = liftP (fin . go . pre) - where - -- ./ at beginning -> nothing - pre (ExtSeparator:PathSeparator:xs) = pre xs - pre xs = xs - - fin [] = [] - - -- Literals to LongLiteral - -- Has to be done here: we can't backtrack in go, but some cases might - -- result in consecutive Literals being generated. - -- E.g. "a[b]". - fin (x:y:xs) | isLiteral x && isLiteral y = - let (ls,rest) = span isLiteral xs - in fin $ LongLiteral (length ls + 2) - (foldr (\(Literal a) -> (a:)) [] (x:y:ls)) - : rest - - -- concatenate LongLiterals - -- Has to be done here because LongLiterals are generated above. - -- - -- So one could say that we have one pass (go) which flattens everything as - -- much as it can and one pass (fin) which concatenates what it can. - fin (LongLiteral l1 s1 : LongLiteral l2 s2 : xs) = - fin $ LongLiteral (l1+l2) (s1++s2) : xs - - fin (LongLiteral l s : Literal c : xs) = - fin $ LongLiteral (l+1) (s++[c]) : xs - - fin (x:xs) = x : fin xs - - go [] = [] - go (x@(CharRange _ _) : xs) = - case optimizeCharRange x of - x'@(CharRange _ _) -> x' : go xs - x' -> go (x':xs) - - -- /./ -> / - go (PathSeparator:ExtSeparator:xs@(PathSeparator:_)) = go xs - - -- -> a - go (OpenRange (Just a) (Just b):xs) - | a == b = LongLiteral (length a) a : go xs - - -- -> [a-b] - -- a and b are guaranteed non-null - go (OpenRange (Just [a]) (Just [b]):xs) - | b > a = go $ CharRange True [Right (a,b)] : xs - - go (x:xs) = - case find ($ x) compressors of - Just c -> x : go (dropWhile c xs) - Nothing -> x : go xs - - compressors = [isStar, isSlash, isStarSlash, isAnyNumber] - - isLiteral (Literal _) = True - isLiteral _ = False - isStar AnyNonPathSeparator = True - isStar _ = False - isSlash PathSeparator = True - isSlash _ = False - isStarSlash AnyDirectory = True - isStarSlash _ = False - isAnyNumber (OpenRange Nothing Nothing) = True - isAnyNumber _ = False - -optimizeCharRange :: Token -> Token -optimizeCharRange (CharRange b_ rs) = fin b_ . go . sortCharRange $ rs - where - fin True [Left c] | not (isPathSeparator c || isExtSeparator c) = Literal c - fin True [Right r] | r == (minBound,maxBound) = NonPathSeparator - fin b x = CharRange b x - - go [] = [] - - go (x@(Left c) : xs) = - case xs of - [] -> [x] - y@(Left d) : ys - -- [aaaaa] -> [a] - | c == d -> go$ Left c : ys - | d == succ c -> - let (ls,rest) = span isLeft xs -- start from y - (catable,others) = increasingSeq (map fromLeft ls) - range = (c, head catable) - - in -- three (or more) Lefts make a Right - if null catable || null (tail catable) - then x : y : go ys - -- [abcd] -> [a-d] - else go$ Right range : map Left others ++ rest - - | otherwise -> x : go xs - - Right r : ys -> - case addToRange r c of - -- [da-c] -> [a-d] - Just r' -> go$ Right r' : ys - Nothing -> x : go xs - - go (x@(Right r) : xs) = - case xs of - [] -> [x] - Left c : ys -> - case addToRange r c of - -- [a-cd] -> [a-d] - Just r' -> go$ Right r' : ys - Nothing -> x : go xs - - Right r' : ys -> - case overlap r r' of - -- [a-cb-d] -> [a-d] - Just o -> go$ Right o : ys - Nothing -> x : go xs -optimizeCharRange _ = error "Glob.optimizeCharRange :: internal error" - -sortCharRange :: [Either Char (Char,Char)] -> [Either Char (Char,Char)] -sortCharRange = sortBy cmp - where - cmp (Left a) (Left b) = compare a b - cmp (Left a) (Right (b,_)) = compare a b - cmp (Right (a,_)) (Left b) = compare a b - cmp (Right (a,_)) (Right (b,_)) = compare a b diff --git a/System/FilePath/Glob/Primitive.hs b/System/FilePath/Glob/Primitive.hs new file mode 100644 --- /dev/null +++ b/System/FilePath/Glob/Primitive.hs @@ -0,0 +1,57 @@ +-- File created: 2009-01-17 + +-- |A number of primitives from which complete 'Pattern's may be constructed. +-- +-- Using this together with the functions provided by the 'Monoid' instance of +-- 'Pattern' allows for direct manipulation of 'Pattern's beyond what can be +-- done with just the 'compile' family of functions. And of course you don't +-- have to go via 'String's if you use these. +module System.FilePath.Glob.Primitive + ( literal + , singleWildcard, wildcard, recursiveWildcard + , charRange, numberRange + ) where + +import System.FilePath (isPathSeparator, isExtSeparator) + +import System.FilePath.Glob.Base (Pattern(..), Token(..), optimize) + +-- |A 'Pattern' which matches the given 'String' literally. +-- +-- Handles any embedded path and extension separators. +literal :: String -> Pattern +literal = optimize . Pattern . map f + where + f c | isPathSeparator c = PathSeparator + | isExtSeparator c = ExtSeparator + | otherwise = Literal c + +-- |Matches any single character except a path separator: corresponds to the +-- @?@ operator. +singleWildcard :: Pattern +singleWildcard = Pattern [NonPathSeparator] + +-- |Matches any number of characters up to a path separator: corresponds to the +-- @*@ operator. +wildcard :: Pattern +wildcard = Pattern [AnyNonPathSeparator] + +-- |Matches any number of characters including path separators: corresponds to +-- the @**/@ operator. +recursiveWildcard :: Pattern +recursiveWildcard = Pattern [AnyDirectory] + +-- |Matches a single character if it is within the (inclusive) range in any +-- 'Right' or if it is equal to the character in any 'Left'. Corresponds to the +-- @[]@, @[^]@ and @[!]@ operators. +-- +-- If the given 'Bool' is 'False', the result of the match is inverted: the +-- match succeeds if the character does /not/ match according to the above +-- rules. +charRange :: Bool -> [Either Char (Char,Char)] -> Pattern +charRange b rs = optimize $ Pattern [CharRange b rs] + +-- |Matches a number in the given range, which may be open, half-open, or +-- closed. Corresponds to the @\<\>@ operator. +numberRange :: Maybe Integer -> Maybe Integer -> Pattern +numberRange a b = Pattern [OpenRange (fmap show a) (fmap show b)] diff --git a/System/FilePath/Glob/Simplify.hs b/System/FilePath/Glob/Simplify.hs new file mode 100644 --- /dev/null +++ b/System/FilePath/Glob/Simplify.hs @@ -0,0 +1,42 @@ +-- File created: 2009-01-30 14:54:14 + +module System.FilePath.Glob.Simplify (simplify) where + +import System.FilePath.Glob.Base (Pattern(..), Token(..), liftP) + +-- |Simplifies a 'Pattern' object: removes redundant @\"./\"@, for instance. +-- The resulting 'Pattern' matches the exact same input as the original one, +-- with some differences: +-- +-- * The output of 'globDir' will differ: for example, globbing for @\"./\*\"@ +-- gives @\"./foo\"@, but after simplification this'll be only @\"foo\"@. +-- +-- * Decompiling the simplified 'Pattern' will obviously not give the original. +-- +-- * The simplified 'Pattern' is a bit faster to match with and uses less +-- memory, since some redundant data is removed. +-- +-- For the last of the above reasons, if you're performance-conscious and not +-- using 'globDir', you should always 'simplify' after calling 'compile'. +simplify :: Pattern -> Pattern +simplify = liftP (go . pre) + where + -- ./ at beginning -> nothing (any number of /'s) + pre (ExtSeparator:PathSeparator:xs) = pre (dropWhile isSlash xs) + pre xs = xs + + go [] = [] + + -- /./ -> / + go (PathSeparator:ExtSeparator:xs@(PathSeparator:_)) = go xs + + go (x:xs) = + if isSlash x + then let (compressed,ys) = span isSlash xs + in if null compressed + then x : go ys + else go (x : ys) + else x : go xs + + isSlash PathSeparator = True + isSlash _ = False diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -5,9 +5,12 @@ import System.Environment (getArgs) import Test.Framework +import qualified Tests.Compiler as Compiler +import qualified Tests.Instances as Instances import qualified Tests.Matcher as Matcher import qualified Tests.Optimizer as Optimizer import qualified Tests.Regression as Regression +import qualified Tests.Simplifier as Simplifier import qualified Tests.Utils as Utils main = do @@ -18,9 +21,12 @@ , args ] -tests = concat +tests = [ Regression.tests + , Utils.tests + , Compiler.tests , Matcher.tests , Optimizer.tests - , Utils.tests + , Simplifier.tests + , Instances.tests ] diff --git a/tests/Tests/Base.hs b/tests/Tests/Base.hs --- a/tests/Tests/Base.hs +++ b/tests/Tests/Base.hs @@ -1,24 +1,29 @@ -- File created: 2008-10-10 22:03:00 -module Tests.Base (PString(unPS), Path(unP), fromRight, isRight) where +module Tests.Base ( PString(unPS), Path(unP), COpts(unCOpts) + , fromRight, isRight + ) where +import System.FilePath (extSeparator, pathSeparators) import Test.QuickCheck -import System.FilePath (extSeparator, pathSeparators) +import System.FilePath.Glob.Base (CompOptions(..)) import Utils (fromRight, isRight) -newtype PString = PatString { unPS :: String } deriving Show -newtype Path = Path { unP :: String } deriving Show +newtype PString = PatString { unPS :: String } deriving Show +newtype Path = Path { unP :: String } deriving Show +newtype COpts = COpts { unCOpts :: CompOptions } deriving Show -alpha = extSeparator : pathSeparators ++ "-^!" ++ ['a'..'z'] ++ ['0'..'9'] +alpha0 = extSeparator : "-^!" ++ ['a'..'z'] ++ ['0'..'9'] +alpha = pathSeparators ++ alpha0 instance Arbitrary PString where arbitrary = sized $ \size -> do let xs = (1, return "**/") : map (\(a,b) -> (a*100,b)) - [ (40, plain) + [ (40, plain alpha) , (20, return "?") , (20, charRange) , (10, return "*") @@ -30,18 +35,23 @@ instance Arbitrary Path where arbitrary = sized $ \size -> do - s <- mapM (const plain) [1..size `mod` 16] + s <- mapM (const $ plain alpha) [1..size `mod` 16] return.Path $ concat s -plain = sized $ \size -> do - s <- mapM (const $ elements alpha) [0..size `mod` 3] +instance Arbitrary COpts where + arbitrary = do + [a,b,c,d,e,f] <- vector 6 + return.COpts $ CompOptions a b c d e f False + +plain from = sized $ \size -> do + s <- mapM (const $ elements from) [0..size `mod` 3] return s charRange = do - s <- plain + s <- plain alpha0 if s `elem` ["^","!"] then do - s' <- plain + s' <- plain alpha0 return$ "[" ++ s ++ s' ++ "]" else return$ "[" ++ s ++ "]" diff --git a/tests/Tests/Compiler.hs b/tests/Tests/Compiler.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Compiler.hs @@ -0,0 +1,22 @@ +-- File created: 2009-01-30 13:26:51 + +module Tests.Compiler (tests) where + +import Test.Framework +import Test.Framework.Providers.QuickCheck + +import System.FilePath.Glob.Base (tryCompileWith, compile, decompile) + +import Tests.Base + +tests = testGroup "Compiler" + [ testProperty "compile-decompile-1" prop_compileDecompile1 + ] + +-- compile . decompile should be the identity function +prop_compileDecompile1 o s = + let opt = unCOpts o + epat1 = tryCompileWith opt (unPS s) + pat1 = fromRight epat1 + pat2 = compile . decompile $ pat1 + in isRight epat1 && pat1 == pat2 diff --git a/tests/Tests/Instances.hs b/tests/Tests/Instances.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Instances.hs @@ -0,0 +1,59 @@ +-- File created: 2009-01-30 15:01:02 + +module Tests.Instances (tests) where + +import Data.Monoid (mempty, mappend) +import Test.Framework +import Test.Framework.Providers.QuickCheck +import Test.QuickCheck ((==>)) + +import System.FilePath.Glob.Base (tryCompileWith) +import System.FilePath.Glob.Match +import System.FilePath.Glob.Simplify + +import Tests.Base + +tests = testGroup "Instances" + [ testProperty "monoid-law-1" prop_monoidLaw1 + , testProperty "monoid-law-2" prop_monoidLaw2 + , testProperty "monoid-law-3" prop_monoidLaw3 + , testProperty "monoid-4" prop_monoid4 + ] + +-- The monoid laws: associativity... +prop_monoidLaw1 opt x y z = + let o = unCOpts opt + es = map (tryCompileWith o . unPS) [x,y,z] + [a,b,c] = map fromRight es + in all isRight es && mappend a (mappend b c) == mappend (mappend a b) c + +-- ... left identity ... +prop_monoidLaw2 opt x = + let o = unCOpts opt + e = tryCompileWith o (unPS x) + a = fromRight e + in isRight e && mappend mempty a == a + +-- ... and right identity. +prop_monoidLaw3 opt x = + let o = unCOpts opt + e = tryCompileWith o (unPS x) + a = fromRight e + in isRight e && mappend a mempty == a + +-- mappending two Patterns should be equivalent to appending the original +-- strings they came from and compiling that +-- +-- (notice: relies on the fact that our Arbitrary instance doesn't generate +-- unclosed [] or <>; we only check for **/) +prop_monoid4 opt x y = + let o = unCOpts opt + es = map (tryCompileWith o . unPS) [x,y] + [a,b] = map fromRight es + cat1 = mappend a b + cat2 = tryCompileWith o (unPS x ++ unPS y) + last2 = take 2 . reverse . unPS $ x + head2 = take 2 . unPS $ y + in (last2 /= "**" && take 1 head2 /= "/") + && (take 1 last2 /= "*" && take 2 head2 /= "*/") + ==> all isRight es && isRight cat2 && cat1 == fromRight cat2 diff --git a/tests/Tests/Matcher.hs b/tests/Tests/Matcher.hs --- a/tests/Tests/Matcher.hs +++ b/tests/Tests/Matcher.hs @@ -5,22 +5,26 @@ import Control.Monad (ap) import Test.Framework import Test.Framework.Providers.QuickCheck +import Test.QuickCheck ((==>)) -import System.FilePath.Glob.Compile +import System.FilePath (isExtSeparator, isPathSeparator) +import System.FilePath.Glob.Base import System.FilePath.Glob.Match import Tests.Base -tests = - [ testGroup "Matcher" - [ testProperty "match-1" prop_match1 - ] +tests = testGroup "Matcher" + [ testProperty "match-1" prop_match1 + , testProperty "match-2" prop_match2 + , testProperty "match-3" prop_match3 ] -- ./foo should be equivalent to foo in both path and pattern -prop_match1 p s = - let ep = tryCompile (unPS p) - ep' = tryCompile ("./" ++ unPS p) +-- ... but not for the pattern if it starts with / +prop_match1 o p_ s = + let p = dropWhile isPathSeparator (unPS p_) + ep = tryCompileWith (unCOpts o) p + ep' = tryCompileWith (unCOpts o) ("./" ++ p) pat = fromRight ep pat' = fromRight ep' pth = unP s @@ -28,9 +32,19 @@ in and [ isRight ep, isRight ep' , ( all (uncurry (==)) . (zip`ap`tail) $ [ match pat pth - , match pat pth' + , match pat pth' , match pat' pth , match pat' pth' ] - ) || null (unPS p) + ) || null p ] + +-- [/] shouldn't match anything +prop_match2 = not . match (compile "[/]") . take 1 . unP + +-- [!/] is like ? +prop_match3 p_ = + let p = unP p_ + ~(x:_) = p + in not (null p || isPathSeparator x || isExtSeparator x) + ==> match (compile "[!/]") [x] diff --git a/tests/Tests/Optimizer.hs b/tests/Tests/Optimizer.hs --- a/tests/Tests/Optimizer.hs +++ b/tests/Tests/Optimizer.hs @@ -5,28 +5,25 @@ import Test.Framework import Test.Framework.Providers.QuickCheck -import System.FilePath.Glob.Compile -import System.FilePath.Glob.Optimize +import System.FilePath.Glob.Base (tokenize, optimize) import System.FilePath.Glob.Match import Tests.Base -tests = - [ testGroup "Optimizer" - [ testProperty "optimize-1" prop_optimize1 - , testProperty "optimize-2" prop_optimize2 - ] +tests = testGroup "Optimizer" + [ testProperty "optimize-1" prop_optimize1 + , testProperty "optimize-2" prop_optimize2 ] -- Optimizing twice should give the same result as optimizing once -prop_optimize1 s = - let pat = tokenize (unPS s) +prop_optimize1 o s = + let pat = tokenize (unCOpts o) (unPS s) xs = iterate optimize (fromRight pat) in isRight pat && xs !! 1 == xs !! 2 -- Optimizing shouldn't affect whether a match succeeds -prop_optimize2 p s = - let x = tokenize (unPS p) +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 diff --git a/tests/Tests/Regression.hs b/tests/Tests/Regression.hs --- a/tests/Tests/Regression.hs +++ b/tests/Tests/Regression.hs @@ -6,20 +6,38 @@ import Test.Framework.Providers.HUnit import Test.HUnit.Base -import System.FilePath.Glob.Compile +import System.FilePath.Glob.Base import System.FilePath.Glob.Match -tests = - [ testGroup "Regression" $ - flip map testCases $ \t@(b,p,s) -> - testCase (nameTest t) . assertBool "failed" $ +tests = testGroup "Regression" + [ testGroup "Matching/compiling" . + flip map matchCases $ \t@(b,p,s) -> + tc (nameMatchTest t) $ match (compile p) s == b + , testGroup "Specific options" . + flip map matchWithCases $ \t@(b,co,mo,p,s) -> + tc (nameMatchTest (b,p,s)) $ + matchWith mo (compileWith co p) s == b + , testGroup "Decompilation" . + flip map decompileCases $ \(n,orig,s) -> + tc n $ decompile (compile orig) == s ] + where + tc n = testCase n . assert -nameTest (True ,p,s) = show p ++ " matches " ++ show s -nameTest (False,p,s) = show p ++ " doesn't match " ++ show s +nameMatchTest (True ,p,s) = show p ++ " matches " ++ show s +nameMatchTest (False,p,s) = show p ++ " doesn't match " ++ show s -testCases = +decompileCases = + [ ("range-compression-1", "[*]", "[*]") + , ("range-compression-2", "[.]", "[.]") + , ("range-compression-3", "**[/]", "*[/]") + , ("range-compression-4", "x[.]", "x[.]") + , ("range-compression-5", "[^~-]", "[^~-]") + , ("range-compression-6", "[^!-]", "[^!-]") + ] + +matchCases = [ (True , "*" , "") , (True , "**" , "") , (True , "asdf" , "asdf") @@ -69,11 +87,46 @@ , (False, "[b-a]" , "a") , (False, "<4-3>" , "3") , (True , "[]-b]" , "]") - , (True , "[]-b]" , "-") + , (False, "[]-b]" , "-") , (True , "[]-b]" , "b") - , (False, "[]-b]" , "a") + , (True , "[]-b]" , "a") + , (True , "[]-]" , "]") + , (True , "[]-]" , "-") + , (True , "[#-[]" , "&") , (False, "[^x]" , "/") , (False, "[/]" , "/") , (True , "a[^x]" , "a.") , (True , "a[.]" , "a.") + , (False, ".//a" , "/a") + , (True, ".//a" , "a") + , (True, ".//a" , "./a") + , (True , ".*/a" , "./a") + , (True , ".*/a" , "../a") + , (True , ".*/a" , ".foo/a") + , (True , ".**/a" , ".foo/a") + , (False, ".**/a" , "../a") + , (False, ".**/a" , "./a") + , (False, ".**/a" , "a") + , (True , ".**/a" , ".foo/a") + , (True , "f**/a" , "foo/a") + , (True , "f**/" , "f/") + , (True , "f**/" , "f///") + , (True , "f**/x" , "f///x") + , (True , "f/" , "f///") + , (True , "f/x" , "f///x") + , (True , "[]" , "[]") + , (True , "[!]" , "[!]") + , (True , "[^]" , "[^]") + , (True , "[abc" , "[abc") + , (True , " a then (a,b) else (b,a)