content: {- |
  This module follows the convention found in <https://git-scm.com/docs/gitignore>
  -}
  module Cryptol.Project.WildMatch (wildmatch) where
  
  import Data.Char
  import System.FilePath
  
  -- | `wildmatch p x` checks if file `x` matches pattern `p`.
  wildmatch :: String -> FilePath -> Bool
  wildmatch mbNegP x
    -- When a pattern contains a path separator, it matches the whole path
    | '/' `elem` p = mbNeg (matchP (ensureLeadingSlash p) (ensureLeadingSlash x))
    -- When the pattern contains no path separator it only matches the filename
    | otherwise    = mbNeg (matchP p (takeFileName x))
    where
    (mbNeg,p) =
      case mbNegP of
        '!':rest -> (not,rest)
        _        -> (id,mbNegP)
  
  
  -- | Normalize a path pattern to start with a leading slash for consistency later
  ensureLeadingSlash :: String -> String
  ensureLeadingSlash ('/':p) = '/':p
  ensureLeadingSlash p       = '/':p
  
  ------------------
  -- Path processing
  ------------------
  
  matchP :: String -> FilePath -> Bool
  
  matchP "/**" _ = True -- Accepts everything
  
  matchP ('/':'*':'*':'/':p) ('/':xs) =
    matchP ('/':p) ('/':xs) ||
    matchP ('/':'*':'*':'/':p) (dropWhile ('/'/=) xs)
  
  matchP ('/':'*':'*':'/':_p) _ = False
  
  -- escaped characters match literally
  matchP ('\\':a:p) (x:xs) = a==x && matchP p xs
  matchP ('\\':_)   ""     = False
  
  -- match zero or more component characters
  matchP ('*':p) (x:xs) = matchP p (x:xs) || ('/' /= x) && matchP ('*':p) xs
  matchP ('*':p) ""     = matchP p ""
  
  -- match zero or one component characters
  matchP ('?':p) (x : xs) = matchP p (x : xs) || ('/' /= x) && matchP p xs
  matchP ('?':p) ""       = matchP p ""
  
  -- process a character class
  matchP ('[':p) (x:xs)
    | x == '/'                         = False
    | Just (f, p') <- parseCharClass p = f x && matchP p' xs
  matchP ('[':_) _                     = False
  
  -- literal match
  matchP (a:p) (x:xs) = a==x && matchP p xs
  matchP (_a:_p) ""   = False
  
  matchP "" xs        = null xs
  
  -----------------------------
  -- Character class processing
  -----------------------------
  
  parseCharClass :: String -> Maybe (Char -> Bool, String)
  
  -- leading ! negates a character class
  parseCharClass ('!':p) =
   do (f, p') <- parseCharClass1 True p
      Just (not . f, p')
  parseCharClass p = parseCharClass1 True p
  
  -- A ] in the first position is a literal match
  parseCharClass1 :: Bool -> [Char] -> Maybe (Char -> Bool, [Char])
  parseCharClass1 False (']':p) =
    Just (const False, p)
  
  parseCharClass1 first (x:'-':y:p)
    | first || x /= ']', y /= ']' = cc (\c -> x <= c && c <= y) p
  
  parseCharClass1 _ ('[':':':p) =
    case span (\x -> 'a' <= x && x <= 'z') p of
      ("alnum", ':':']':p1) -> cc isAlphaNum p1
      ("cntrl", ':':']':p1) -> cc isControl p1
      ("lower", ':':']':p1) -> cc isLower p1
      ("space", ':':']':p1) -> cc isSpace p1
      ("alpha", ':':']':p1) -> cc isAlpha p1
      ("digit", ':':']':p1) -> cc isDigit p1
      ("print", ':':']':p1) -> cc isPrint p1
      ("upper", ':':']':p1) -> cc isUpper p1
      ("blank", ':':']':p1) -> cc (`elem` " \t") p1
      ("graph", ':':']':p1) -> cc (\x -> isAlphaNum x || isPunctuation x) p1
      ("punct", ':':']':p1) -> cc isPunctuation p1
      ("xdigit", ':':']':p1) -> cc isHexDigit p1
      (_       , ':':']':_) -> Nothing
      _ -> cc ('['==) (':':p)
  
  parseCharClass1 _ (x:p) = cc (x==) p
  parseCharClass1 _ ""    = Nothing
  
  -- Helper for continuing to build a character class matcher
  cc :: (Char -> Bool) -> [Char] -> Maybe (Char -> Bool, [Char])
  cc f p =
   do (g, p') <- parseCharClass1 False p
      Just (\x -> f x || g x, p')
  