    -- File created: 2008-10-10 13:29:03

    module System.FilePath.Glob.Match (match, matchWith) where

    import Control.Exception (assert)
    import Data.Char         (isDigit, toLower, toUpper)
    import Data.Monoid       (mappend)
    import System.FilePath   (isPathSeparator, isExtSeparator)

    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 = 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 (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' opts pat' (tail s)
                    _                 -> False
          else match' opts pat s

    match' _ []                        s  = null s
    match' _ (AnyNonPathSeparator:s)   "" = null s
    match' _ _                         "" = False
    match' o (Literal l       :xs) (c:cs) =           l == c  && match' o xs cs
    match' o ( ExtSeparator   :xs) (c:cs) = isExtSeparator c  && match' o xs cs
    match' o (NonPathSeparator:xs) (c:cs) =
       not (isPathSeparator c) && match' o xs cs

    match' o (PathSeparator   :xs) (c:cs) =
       isPathSeparator c && begMatch o xs (dropWhile isPathSeparator cs)

    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
          numChoices =
             tail . takeWhile (not.null.snd) . map (flip splitAt num) $ [0..]
        in if null lzNum
              then False -- no digits
              else
                -- So, given the path "123foo" what we've got is:
                --    cs         = "foo"
                --    num        = "123"
                --    numChoices = [("1","23"),("12","3")]
                --
                -- We want to try matching x against each of 123, 12, and 1.
                -- 12 and 1 are in numChoices already, but we need to add (num,"")
                -- manually.
                any (\(n,rest) -> inOpenRange lo hi n && match' o xs (rest ++ cs))
                    ((num,"") : numChoices)

    match' o again@(AnyNonPathSeparator:xs) path@(c:cs) =
       match' o xs path || (if isPathSeparator c then False else match' o again cs)

    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' o (LongLiteral len s:xs) path =
       let (pre,cs) = splitAt len path
        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.
    --
    -- 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