packages feed

Glob (empty) → 0.1

raw patch · 18 files changed

+1046/−0 lines, 18 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, filepath, mtl

Files

+ Glob.cabal view
@@ -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 <matti.niemenmaa+glob@iki.fi>+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
+ LICENSE.txt view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/FilePath/Glob.hs view
@@ -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)
+ System/FilePath/Glob/Base.hs view
@@ -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
+ System/FilePath/Glob/Compile.hs view
@@ -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.+-- +-- [@\<m-n>@]  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++-- <a-b> 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
+ System/FilePath/Glob/Directory.hs view
@@ -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
+ System/FilePath/Glob/Match.hs view
@@ -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
+ System/FilePath/Glob/Optimize.hs view
@@ -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-a> -> a+   go (OpenRange (Just a) (Just b):xs)+      | a == b = LongLiteral (length a) a : go xs++   -- <a-b> -> [a-b]+   -- a and b are guaranteed non-null+   go (OpenRange (Just [a]) (Just [b]):xs)+      | b > a = go $ CharRange True [Right (a,b)] : xs++   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
+ System/FilePath/Glob/Utils.hs view
@@ -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
+ tests/Main.hs view
@@ -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+   ]
+ tests/README.txt view
@@ -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
+ tests/Tests/Base.hs view
@@ -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)+      , ">"+      ]
+ tests/Tests/Matcher.hs view
@@ -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)+           ]
+ tests/Tests/Optimizer.hs view
@@ -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
+ tests/Tests/Regression.hs view
@@ -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.")+   ]
+ tests/Tests/Utils.hs view
@@ -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)
+ tests/Utils.hs view
@@ -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