content: module GlobPattern (parseGlobPattern, matchGlobPattern, getGlobErr,
                      GlobPattern) where
  
  import Control.Monad(msum)
  import Data.List(isPrefixOf, tails)
  
  -- import Debug.Trace
  
  data CharClass = CharRange Char Char
                 | CharList [Char]
                 | BadCharClass String
    deriving (Eq)
  
  instance Show CharClass where
    show (CharRange lo hi) = [lo,'-',hi]
    show (CharList cs) = cs
    show (BadCharClass s) = "<BADCHARCLASS: " ++ s ++ ">"
  
  data GlobPattern = GlobEnd
                   | GlobMatch String GlobPattern
                   | GlobOneChar GlobPattern
                   | GlobAnyChars GlobPattern
                   | GlobOneOf [CharClass] GlobPattern
                   | GlobNotOneOf [CharClass] GlobPattern
                   | GlobBadPattern String
    deriving (Eq)
  
  instance Show GlobPattern where
    show GlobEnd = ""
    show (GlobMatch s p) = s ++ (show p)
    show (GlobOneChar p) = "?" ++ (show p)
    show (GlobAnyChars p) = "*" ++ (show p)
    show (GlobOneOf cs p) = "[" ++ (concatMap show cs) ++ "]" ++ (show p)
    show (GlobNotOneOf cs p) = "[!" ++ (concatMap show cs) ++ "]" ++ (show p)
    show (GlobBadPattern s) = "<BADPATTERN: " ++ s ++ ">"
  
  globSeparator :: Char
  globSeparator = '.'
  
  -- Parse a string into a GlobPattern
  parseGlobPattern :: String -> GlobPattern
  parseGlobPattern "" = GlobEnd
  parseGlobPattern ('*':rest) = GlobAnyChars (parseGlobPattern rest)
  parseGlobPattern ('?':rest) = GlobOneChar (parseGlobPattern rest)
  parseGlobPattern ('[':'!':rest) =
      let (cs,xs) = parseCharClasses rest
      in case (msum (map getClassErr cs)) of
           (Just err) -> GlobBadPattern err
           Nothing    -> GlobNotOneOf cs (parseGlobPattern xs)
  parseGlobPattern ('[':rest) =
      let (cs,xs) = parseCharClasses rest
      in case (msum (map getClassErr cs)) of
           (Just err) -> GlobBadPattern err
           Nothing    -> GlobOneOf cs (parseGlobPattern xs)
  parseGlobPattern ['\\'] = GlobBadPattern $ "escape character ends pattern"
  parseGlobPattern ('\\':c:rest) =
      if (c == globSeparator)
      then GlobBadPattern $ "illegal escaped separator character at '" ++ (c:rest) ++ "'"
      else GlobMatch [c] (parseGlobPattern rest)
  parseGlobPattern s =
      let (exact,rest) = break (`elem` (globSeparator:"*?[\\")) s
      in if ([globSeparator] `isPrefixOf` exact)
         then GlobBadPattern $ "illegal separator character at '" ++ exact ++ "'"
         else GlobMatch exact (parseGlobPattern rest)
  
  -- Parse character class specifications
  parseCharClasses :: String -> ([CharClass],String)
  parseCharClasses "" = ([BadCharClass "no terminating ']'"],"")
  parseCharClasses (x:s) =
      let (xs,rest) = break (== ']') s
      in if (null rest)
         then ([BadCharClass "no terminating ']'"],"")
         else (parseCC (x:xs), tail rest)
    where parseCC "" = []
          parseCC (c1:'-':c2:rest) = (CharRange c1 c2):(parseCC rest)
          parseCC ('-':rest) = (CharList ['-']) `combineCC` (parseCC rest)
          parseCC [c] = [CharList [c]]
          parseCC s = let (first,rest) = break (== '-') s
                      in (CharList (init first)) `combineCC` (parseCC ((last first):rest))
          combineCC (CharList []) xs = xs
          combineCC (CharList xs) ((CharList ys):cs) = (CharList (xs ++ ys)):cs
          combineCC x xs = x:xs
  
  -- Test if a pattern contains GlobBadPattern
  getGlobErr :: GlobPattern -> Maybe String
  getGlobErr GlobEnd            = Nothing
  getGlobErr (GlobMatch _ p)    = getGlobErr p
  getGlobErr (GlobOneChar p)    = getGlobErr p
  getGlobErr (GlobAnyChars p)   = getGlobErr p
  getGlobErr (GlobOneOf _ p)    = getGlobErr p
  getGlobErr (GlobNotOneOf _ p) = getGlobErr p
  getGlobErr (GlobBadPattern s) = Just s
  
  -- Test if a character class is a BadCharClass
  getClassErr :: CharClass -> Maybe String
  getClassErr (BadCharClass s) = Just s
  getClassErr _                = Nothing
  
  -- Test is a character is in a class
  classContains :: CharClass -> Char -> Bool
  classContains (CharRange lo hi) c = (c >= lo) && (c <= hi)
  classContains (CharList cs) c     = c `elem` cs
  classContains (BadCharClass _) _  = False
  
  -- Match a string against a glob pattern
  matchGlobPattern :: GlobPattern -> String -> Bool
  matchGlobPattern GlobEnd s = null s
  matchGlobPattern (GlobMatch m p) s =
      if (m `isPrefixOf` s)
      then matchGlobPattern p (drop (length m) s)
      else False
  matchGlobPattern (GlobOneChar p) [] = False
  matchGlobPattern (GlobOneChar p) (_:s) = matchGlobPattern p s
  matchGlobPattern (GlobAnyChars p) s =
      let (s',rest) = break ( == globSeparator) s
      in any (matchGlobPattern p) (map (++ rest) (tails s'))
  matchGlobPattern (GlobOneOf xs p) [] = False
  matchGlobPattern (GlobOneOf xs p) (c:s) = if (any (`classContains` c) xs)
                                            then matchGlobPattern p s
                                            else False
  matchGlobPattern (GlobNotOneOf xs p) [] = False
  matchGlobPattern (GlobNotOneOf xs p) (c:s) = if (any (`classContains` c) xs)
                                               then False
                                               else matchGlobPattern p s
  matchGlobPattern (GlobBadPattern _) _ = False
  