diff --git a/Glob.cabal b/Glob.cabal new file mode 100644 --- /dev/null +++ b/Glob.cabal @@ -0,0 +1,36 @@ +Cabal-Version: >= 1.2 + +Name: Glob +Version: 0.1 +Homepage: http://iki.fi/matti.niemenmaa/glob/ +Synopsis: Globbing library +Category: System +Stability: provisional +Description: + A library for globbing: matching patterns against file paths. + +Author: Matti Niemenmaa +Maintainer: Matti Niemenmaa +License: BSD3 +License-File: LICENSE.txt + +Build-Type: Simple + +Extra-Source-Files: tests/README.txt + tests/*.hs + tests/Tests/*.hs + +Library + Build-Depends: base >= 3 && < 5 + , containers == 0.* + , directory == 1.* + , filepath == 1.* + , mtl == 1.* + + Exposed-Modules: System.FilePath.Glob + 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.Utils diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,24 @@ +Copyright (c) 2008, Matti Niemenmaa +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the project nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/FilePath/Glob.hs b/System/FilePath/Glob.hs new file mode 100644 --- /dev/null +++ b/System/FilePath/Glob.hs @@ -0,0 +1,22 @@ +-- File created: 2008-10-10 13:37:42 + +-- | A library for globbing: matching patterns against file paths. +-- +-- Basic usage: @'match' ('compile' pattern) filepath@. +-- +-- Basic usage in IO: @'globDir' ['compile' pattern] directory@. +module System.FilePath.Glob + ( -- * Data type + Pattern + -- * Functions + -- ** Compilation + , tryCompile, compile + -- ** Matching + , match + , globDir + ) 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) diff --git a/System/FilePath/Glob/Base.hs b/System/FilePath/Glob/Base.hs new file mode 100644 --- /dev/null +++ b/System/FilePath/Glob/Base.hs @@ -0,0 +1,60 @@ +-- File created: 2008-10-10 13:29:26 + +module System.FilePath.Glob.Base where + +import Data.Maybe (fromMaybe) +import System.FilePath (pathSeparator, extSeparator) + +-- Todo? data Options = Options { allow_dots :: Bool } + +data Token + -- primitives + = Literal !Char + | ExtSeparator -- . + | PathSeparator -- / + | NonPathSeparator -- ? + | CharRange !Bool [Either Char (Char,Char)] -- [] + | OpenRange (Maybe String) (Maybe String) -- <> + | AnyNonPathSeparator -- * + | AnyDirectory -- **/ + + -- after optimization only + | LongLiteral !Int String + deriving (Eq) + +-- |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, +-- @'compile' \"x\"@ and @'compile' \"[x]\"@ may or may not compare equal, +-- though a @'match'@ will behave the exact same way no matter which 'Pattern' +-- is used. +newtype Pattern = Pattern { unPattern :: [Token] } deriving (Eq) + +liftP :: ([Token] -> [Token]) -> Pattern -> Pattern +liftP f (Pattern pat) = Pattern (f pat) + +instance Show Token where + show (Literal c) = [c] + 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 (OpenRange a b) = + '<' : fromMaybe "" a ++ "-" ++ + fromMaybe "" b ++ ">" + + showList = showList . concatMap show + +instance Show Pattern where + showsPrec d (Pattern ts) = + showParen (d > 10) $ showString "compile " . shows ts diff --git a/System/FilePath/Glob/Compile.hs b/System/FilePath/Glob/Compile.hs new file mode 100644 --- /dev/null +++ b/System/FilePath/Glob/Compile.hs @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/System/FilePath/Glob/Directory.hs @@ -0,0 +1,114 @@ +-- File created: 2008-10-16 12:12:50 + +module System.FilePath.Glob.Directory (globDir) where + +import Control.Monad (forM) +import Data.List ((\\), partition) +import System.Directory (doesDirectoryExist, getDirectoryContents) +import System.FilePath (()) + +import System.FilePath.Glob.Base +import System.FilePath.Glob.Match (match) +import System.FilePath.Glob.Utils (getRecursiveContents, nubOrd, pathParts) + +-- The Patterns in TypedPattern don't contain PathSeparator or AnyDirectory +data TypedPattern + = Any Pattern -- pattern + | Dir Pattern -- pattern/ + | AnyDir 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'. +-- +-- If multiple 'Pattern's match a single 'FilePath', that path will be included +-- in multiple groups. +-- +-- 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'. +-- +-- Any results deeper than in the given directory are enumerated lazily, using +-- 'unsafeInterleaveIO'. +globDir :: [Pattern] -> FilePath -> IO ([[FilePath]], [FilePath]) +globDir pats dir = do + results <- mapM (\p -> globDir' (separate p) dir) pats + + let (matches, others) = unzip results + + return (matches, nubOrd (concat others) \\ concat matches) + +globDir' :: [TypedPattern] -> FilePath -> IO ([FilePath], [FilePath]) +globDir' pats dir = do + raw <- getDirectoryContents dir + + let entries = raw \\ [".",".."] + + results <- forM entries $ \e -> matchTypedAndGo pats e (dir e) + + let (matches, others) = unzip results + + return (concat matches, concat others) + +matchTypedAndGo :: [TypedPattern] + -> FilePath -> FilePath + -> IO ([FilePath], [FilePath]) + +matchTypedAndGo [] _ _ = return ([], []) + +-- (Any p) is always the last element +matchTypedAndGo [Any p] path absPath = + if match p path + then return ([absPath], []) + else doesDirectoryExist absPath >>= didn'tMatch absPath + +matchTypedAndGo (Dir p:ps) path absPath = do + isDir <- doesDirectoryExist absPath + if isDir && match p path + then globDir' ps absPath + else didn'tMatch absPath isDir + +matchTypedAndGo (AnyDir p:ps) path absPath = do + isDir <- doesDirectoryExist absPath + let pat = unseparate ps + + case null (unPattern p) || match p path of + True | isDir -> fmap (partition (any (match pat) . pathParts)) + (getRecursiveContents absPath) + True | match pat path -> return ([absPath], []) + _ -> didn'tMatch absPath isDir + +matchTypedAndGo _ _ _ = error "Glob.matchTypedAndGo :: internal error" + +didn'tMatch :: FilePath -> Bool -> IO ([FilePath], [FilePath]) +didn'tMatch absPath isDir = (fmap $ (,) []) $ + if isDir + then getRecursiveContents absPath + else return [absPath] + +separate :: Pattern -> [TypedPattern] +separate = go [] . 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 + + f = Pattern . reverse + +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 diff --git a/System/FilePath/Glob/Match.hs b/System/FilePath/Glob/Match.hs new file mode 100644 --- /dev/null +++ b/System/FilePath/Glob/Match.hs @@ -0,0 +1,114 @@ +-- File created: 2008-10-10 13:29:03 + +module System.FilePath.Glob.Match (match) where + +import Control.Exception (assert) +import Data.Char (isDigit) +import Data.Monoid (mappend) +import System.FilePath (isPathSeparator, isExtSeparator) + +import System.FilePath.Glob.Base +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 + +-- 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) + then case pat of + ExtSeparator:pat' -> match' pat' (tail s) + _ -> False + else match' 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' (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' 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' again@(AnyDirectory:xs) path = + let parts = pathParts path + matches = any (match' xs) parts || any (match' again) (tail parts) + in if null xs + -- **/ 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 = + let (pre,cs) = splitAt len path + in pre == s && match' xs cs + +-- Does the actual open range matching: finds whether the third parameter +-- is between the first two or not. +-- +-- It does this by keeping track of the Ordering so far (e.g. having +-- looked at "12" and "34" the Ordering of the two would be LT: 12 < 34) +-- and aborting if a String "runs out": a longer string is automatically +-- greater. +-- +-- Assumes that the input strings contain only digits, and no leading zeroes. +inOpenRange :: Maybe String -> Maybe String -> String -> Bool +inOpenRange l_ h_ s_ = assert (all isDigit s_) $ go l_ h_ s_ EQ EQ + where + go Nothing Nothing _ _ _ = True -- no bounds + go (Just []) _ [] LT _ = False -- lesser than lower bound + go _ (Just []) _ _ GT = False -- greater than upper bound + go _ (Just []) (_:_) _ _ = False -- longer than upper bound + go (Just (_:_)) _ [] _ _ = False -- shorter than lower bound + go _ _ [] _ _ = True + + go (Just (l:ls)) (Just (h:hs)) (c:cs) ordl ordh = + let ordl' = ordl `mappend` compare c l + ordh' = ordh `mappend` compare c h + in go (Just ls) (Just hs) cs ordl' ordh' + + go Nothing (Just (h:hs)) (c:cs) _ ordh = + let ordh' = ordh `mappend` compare c h + in go Nothing (Just hs) cs GT ordh' + + go (Just (l:ls)) Nothing (c:cs) ordl _ = + let ordl' = ordl `mappend` compare c l + in go (Just ls) Nothing cs ordl' LT + + -- lower bound is shorter: s is greater + go (Just []) hi s _ ordh = go Nothing hi s GT ordh diff --git a/System/FilePath/Glob/Optimize.hs b/System/FilePath/Glob/Optimize.hs new file mode 100644 --- /dev/null +++ b/System/FilePath/Glob/Optimize.hs @@ -0,0 +1,138 @@ +-- 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/Utils.hs b/System/FilePath/Glob/Utils.hs new file mode 100644 --- /dev/null +++ b/System/FilePath/Glob/Utils.hs @@ -0,0 +1,100 @@ +-- File created: 2008-10-10 13:40:35 + +module System.FilePath.Glob.Utils where + +import Data.List ((\\), tails) +import qualified Data.Set as Set +import System.Directory (doesDirectoryExist, getDirectoryContents) +import System.FilePath ((), joinPath, splitPath) +import System.IO.Unsafe (unsafeInterleaveIO) + +inRange :: Ord a => (a,a) -> a -> Bool +inRange (a,b) c = c >= a && c <= b + +-- returns Just (a range which covers both given ranges) or Nothing if they are +-- disjoint. +-- +-- Assumes that the ranges are in the correct order, i.e. (fst x < snd x). +overlap :: Ord a => (a,a) -> (a,a) -> Maybe (a,a) +overlap (a,b) (c,d) = + if b >= c + then if b >= d + then if a <= c + then Just (a,b) + else Just (c,b) + else if a <= c + then Just (a,d) + else Just (c,d) + else Nothing + +addToRange :: (Ord a, Enum a) => (a,a) -> a -> Maybe (a,a) +addToRange (a,b) c + | inRange (a,b) c = Just (a,b) + | c == pred a = Just (c,b) + | c == succ b = Just (a,c) + | otherwise = Nothing + +-- fst of result is in reverse order so that: +-- +-- If x = fst (increasingSeq (a:xs)), then +-- x == reverse [a .. head x] +increasingSeq :: (Eq a, Enum a) => [a] -> ([a],[a]) +increasingSeq [] = ([],[]) +increasingSeq (x:xs) = go [x] xs + where + go is [] = (is,[]) + go is@(i:_) (y:ys) = + if y == succ i + then go (y:is) ys + else (is, y:ys) + go _ _ = error "Glob.increasingSeq :: internal error" + +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft _ = False + +fromLeft :: Either a b -> a +fromLeft (Left x) = x +fromLeft _ = error "fromLeft :: Right" + +dropLeadingZeroes :: String -> String +dropLeadingZeroes s = + let x = dropWhile (=='0') s + in if null x then "0" else x + +pathParts :: FilePath -> [FilePath] +pathParts = map joinPath . tails . splitPath + +getRecursiveContents :: FilePath -> IO [FilePath] +getRecursiveContents dir = flip catch (const $ return []) $ do + raw <- getDirectoryContents dir + + let entries = raw \\ [".",".."] + absEntries = + if dir == "." + then entries + else map (dir ) entries + + (dirs,files) <- partitionM doesDirectoryExist absEntries + + subs <- unsafeInterleaveIO . mapM getRecursiveContents $ dirs + + return$ dir : files ++ concat subs + +partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = return ([],[]) +partitionM p (x:xs) = do + ~(ts,fs) <- partitionM p xs + b <- p x + return $ if b + then (x:ts, fs) + else (ts, x:fs) + +nubOrd :: Ord a => [a] -> [a] +nubOrd = go Set.empty + where + go _ [] = [] + go set (x:xs) = + if Set.member x set + then go set xs + else x : go (Set.insert x set) xs diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,26 @@ +-- File created: 2008-10-10 16:23:56 + +module Main (main) where + +import System.Environment (getArgs) +import Test.Framework + +import qualified Tests.Matcher as Matcher +import qualified Tests.Optimizer as Optimizer +import qualified Tests.Regression as Regression +import qualified Tests.Utils as Utils + +main = do + args <- getArgs + defaultMainWithArgs tests . concat $ + [ ["--timeout", show 10] + , ["--maximum-generated-tests", show 1000] + , args + ] + +tests = concat + [ Regression.tests + , Matcher.tests + , Optimizer.tests + , Utils.tests + ] diff --git a/tests/README.txt b/tests/README.txt new file mode 100644 --- /dev/null +++ b/tests/README.txt @@ -0,0 +1,15 @@ +These are the tests for the Glob library by Matti Niemenmaa, and should reside +in a subdirectory of the Glob distribution. + +To run the tests, run 'Main.hs'. + +You'll need the following packages: + + base >= 3.* && < 5 +, Glob == 0.* +, filepath == 1.* +, HUnit == 1.2.* +, QuickCheck >= 1.1 && < 2 +, test-framework >= 0.2 && < 1 +, test-framework-hunit >= 0.2 && < 1 +, test-framework-quickcheck >= 0.2 && < 1 diff --git a/tests/Tests/Base.hs b/tests/Tests/Base.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Base.hs @@ -0,0 +1,64 @@ +-- File created: 2008-10-10 22:03:00 + +module Tests.Base (PString(unPS), Path(unP), fromRight, isRight) where + +import Test.QuickCheck + +import System.FilePath (extSeparator, pathSeparators) + +import Utils (fromRight, isRight) + +newtype PString = PatString { unPS :: String } deriving Show +newtype Path = Path { unP :: String } deriving Show + +alpha = extSeparator : pathSeparators ++ "-^!" ++ ['a'..'z'] ++ ['0'..'9'] + +instance Arbitrary PString where + arbitrary = sized $ \size -> do + let xs = + (1, return "**/") : + map (\(a,b) -> (a*100,b)) + [ (40, plain) + , (20, return "?") + , (20, charRange) + , (10, return "*") + , (10, openRange) + ] + + s <- mapM (const $ frequency xs) [1..size] + return.PatString $ concat s + +instance Arbitrary Path where + arbitrary = sized $ \size -> do + s <- mapM (const plain) [1..size `mod` 16] + return.Path $ concat s + +plain = sized $ \size -> do + s <- mapM (const $ elements alpha) [0..size `mod` 3] + return s + +charRange = do + s <- plain + if s `elem` ["^","!"] + then do + s' <- plain + return$ "[" ++ s ++ s' ++ "]" + else + return$ "[" ++ s ++ "]" + +openRange = do + probA <- choose (0,1) :: Gen Float + probB <- choose (0,1) :: Gen Float + a <- if probA > 0.4 + then fmap (Just .abs) arbitrary + else return Nothing + b <- if probB > 0.4 + then fmap (Just .abs) arbitrary + else return Nothing + return.concat $ + [ "<" + , maybe "" show (a :: Maybe Int) + , "-" + , maybe "" show (b :: Maybe Int) + , ">" + ] diff --git a/tests/Tests/Matcher.hs b/tests/Tests/Matcher.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Matcher.hs @@ -0,0 +1,36 @@ +-- File created: 2008-10-16 16:16:06 + +module Tests.Matcher (tests) where + +import Control.Monad (ap) +import Test.Framework +import Test.Framework.Providers.QuickCheck + +import System.FilePath.Glob.Compile +import System.FilePath.Glob.Match + +import Tests.Base + +tests = + [ testGroup "Matcher" + [ testProperty "match-1" prop_match1 + ] + ] + +-- ./foo should be equivalent to foo in both path and pattern +prop_match1 p s = + let ep = tryCompile (unPS p) + ep' = tryCompile ("./" ++ unPS 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 (unPS p) + ] diff --git a/tests/Tests/Optimizer.hs b/tests/Tests/Optimizer.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Optimizer.hs @@ -0,0 +1,32 @@ +-- File created: 2008-10-11 11:18:31 + +module Tests.Optimizer (tests) where + +import Test.Framework +import Test.Framework.Providers.QuickCheck + +import System.FilePath.Glob.Compile +import System.FilePath.Glob.Optimize +import System.FilePath.Glob.Match + +import Tests.Base + +tests = + [ testGroup "Optimizer" + [ testProperty "optimize-1" prop_optimize1 + , testProperty "optimize-2" prop_optimize2 + ] + ] + +-- Optimizing twice should give the same result as optimizing once +prop_optimize1 s = + let pat = tokenize (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) + 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 new file mode 100644 --- /dev/null +++ b/tests/Tests/Regression.hs @@ -0,0 +1,79 @@ +-- File created: 2008-10-15 20:21:41 + +module Tests.Regression (tests) where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit.Base + +import System.FilePath.Glob.Compile +import System.FilePath.Glob.Match + +tests = + [ testGroup "Regression" $ + flip map testCases $ \t@(b,p,s) -> + testCase (nameTest t) . assertBool "failed" $ + match (compile p) s == b + ] + +nameTest (True ,p,s) = show p ++ " matches " ++ show s +nameTest (False,p,s) = show p ++ " doesn't match " ++ show s + +testCases = + [ (True , "*" , "") + , (True , "**" , "") + , (True , "asdf" , "asdf") + , (True , "a*f" , "asdf") + , (True , "a??f" , "asdf") + , (True , "*" , "asdf") + , (True , "a*bc" , "aXbaXbc") + , (True , "a**bc" , "aXbaXbc") + , (False, "a*b" , "aXc") + , (True , "foo/bar.*" , "foo/bar.baz") + , (True , "foo/*.baz" , "foo/bar.baz") + , (False, "*bar.*" , "foo/bar.baz") + , (False, "*.baz" , "foo/bar.baz") + , (False, "foo*" , "foo/bar.baz") + , (False, "foo?bar.baz", "foo/bar.baz") + , (True , "**/*.baz" , "foo/bar.baz") + , (True , "**/*" , "foo/bar.baz") + , (True , "**/*" , "foo/bar/baz") + , (True , "*/*.baz" , "foo/bar.baz") + , (True , "*/*" , "foo/bar.baz") + , (False, "*/*" , "foo/bar/baz") + , (False, "*.foo" , ".bar.foo") + , (False, "*.bar.foo" , ".bar.foo") + , (False, "?bar.foo" , ".bar.foo") + , (True , ".*.foo" , ".bar.foo") + , (True , ".*bar.foo" , ".bar.foo") + , (False, "foo.[ch]" , "foo.a") + , (True , "foo.[ch]" , "foo.c") + , (True , "foo.[ch]" , "foo.h") + , (False, "foo.[ch]" , "foo.d") + , (False, "foo.[c-h]" , "foo.b") + , (True , "foo.[c-h]" , "foo.c") + , (True , "foo.[c-h]" , "foo.e") + , (True , "foo.[c-h]" , "foo.f") + , (True , "foo.[c-h]" , "foo.h") + , (False, "foo.[c-h]" , "foo.i") + , (True , "<->3foo" , "123foo") + , (True , "<10-15>3foo", "123foo") + , (True , "<0-5>23foo" , "123foo") + , (True , "<94-200>foo", "123foo") + , (False, "[.]x" , ".x") + , (False, "foo[/]bar" , "foo/bar") + , (False, "foo[,-0]bar", "foo/bar") + , (True , "foo[,-0]bar", "foo.bar") + , (True , "[]x]" , "]") + , (True , "[]x]" , "x") + , (False, "[b-a]" , "a") + , (False, "<4-3>" , "3") + , (True , "[]-b]" , "]") + , (True , "[]-b]" , "-") + , (True , "[]-b]" , "b") + , (False, "[]-b]" , "a") + , (False, "[^x]" , "/") + , (False, "[/]" , "/") + , (True , "a[^x]" , "a.") + , (True , "a[.]" , "a.") + ] diff --git a/tests/Tests/Utils.hs b/tests/Tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Utils.hs @@ -0,0 +1,45 @@ +-- File created: 2008-10-10 16:28:53 + +module Tests.Utils (tests) where + +import Data.Maybe +import Test.Framework +import Test.Framework.Providers.QuickCheck +import Test.QuickCheck + +import System.FilePath.Glob.Utils + +import Utils + +tests = + [ testGroup "Utils" + [ testProperty "overlapperLosesNoInfo" prop_overlapperLosesNoInfo + , testProperty "increasingSeq" prop_increasingSeq + , testProperty "addToRange" prop_addToRange + ] + ] + +validateRange (a,b) = if b > a then (a,b) else (b,a) + +prop_overlapperLosesNoInfo x1 x2 c = + let r1 = validateRange x1 + r2 = validateRange x2 + _ = c :: Float + in case overlap r1 r2 of + + -- if the ranges don't overlap, nothing should be in both ranges + Nothing -> not (inRange r1 c && inRange r2 c) + + -- if they do and something is in a range, it should be in the + -- overlapped one as well + Just o -> (inRange r1 c --> inRange o c) && + (inRange r2 c --> inRange o c) + +prop_increasingSeq a xs = + let s = fst . increasingSeq $ a:xs + in s == reverse [a :: Float .. head s] + +prop_addToRange x c = + let r = validateRange x + r' = addToRange r c + in isJust r' ==> inRange (fromJust r') (c :: Float) diff --git a/tests/Utils.hs b/tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Utils.hs @@ -0,0 +1,11 @@ +-- File created: 2008-10-15 20:50:31 + +module Utils where + +fromRight (Right x) = x +fromRight _ = error "fromRight :: Left" + +isRight (Right _) = True +isRight _ = False + +a --> b = not a || b