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

{-# LANGUAGE CPP #-}

module System.FilePath.Glob.Base
   ( Token(..), Pattern(..)

   , CompOptions(..), MatchOptions(..)
   , compDefault, compPosix, matchDefault, matchPosix

   , decompile

   , compile
   , compileWith, tryCompileWith
   , tokenize -- for tests

   , optimize

   , liftP, tokToLower
   ) where

import Control.Arrow                     (first)
import Control.Monad.Trans.Class         (lift)
import Control.Monad.Trans.Error         (ErrorT, runErrorT, throwError)
import Control.Monad.Trans.Writer.Strict (Writer, runWriter, tell)
import Control.Exception                 (assert)
import Data.Char                         (isDigit, isAlpha, toLower)
import Data.List                         (find, sortBy)
import Data.Maybe                        (fromMaybe)
import Data.Monoid                       (Monoid, mappend, mempty, mconcat)
import System.FilePath                   ( pathSeparator, extSeparator
                                         , isExtSeparator, isPathSeparator
                                         )

import System.FilePath.Glob.Utils ( dropLeadingZeroes
                                  , isLeft, fromLeft
                                  , increasingSeq
                                  , addToRange, overlap
                                  )

#if __GLASGOW_HASKELL__
import Text.Read (readPrec, lexP, parens, prec, Lexeme(Ident))
#endif

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)

-- Note: CharRanges aren't converted, because this is tricky in general.
-- Consider for instance [@-[], which includes the range A-Z. This would need
-- to become [@[a-z]: so essentially we'd need to either:
--
--    1) Have a list of ranges of uppercase Unicode. Check if our range
--       overlaps with any of them and if it does, take the non-overlapping
--       part and combine it with the toLower of the overlapping part.
--
--    2) Simply expand the entire range to a list and map toLower over it.
--
-- In either case we'd need to re-optimize the CharRange—we can't assume that
-- if the uppercase characters are consecutive, so are the lowercase.
--
-- 1) might be feasible if someone bothered to get the latest data.
--
-- 2) obviously isn't since you might have 'Right (minBound, maxBound)' in
-- there somewhere.
--
-- The current solution is to just check both the toUpper of the character and
-- the toLower.
tokToLower :: Token -> Token
tokToLower (Literal     c)   = Literal       (toLower c)
tokToLower (LongLiteral n s) = LongLiteral n (map toLower s)
tokToLower tok               = tok

-- |An abstract data type representing a compiled 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 `elem` "*?[<" || isExtSeparator c
                            = ['[',c,']']
      | otherwise           = assert (not $ isPathSeparator c) [c]
   show ExtSeparator        = [ extSeparator]
   show PathSeparator       = [pathSeparator]
   show NonPathSeparator    = "?"
   show AnyNonPathSeparator = "*"
   show AnyDirectory        = "**/"
   show (LongLiteral _ s)   = concatMap (show . Literal) s
   show (OpenRange a b)     =
      '<' : fromMaybe "" a ++ "-" ++
            fromMaybe "" b ++ ">"

   -- We have to be careful here with ^ and ! lest [a!b] become [!ab]. So we
   -- just put them at the end.
   --
   -- Also, [^x-] was sorted and should not become [^-x].
   show (CharRange b r)     =
      let f = either (:[]) (\(x,y) -> [x,'-',y])
          (caret,exclamation,fs) =
             foldr (\c (ca,ex,ss) ->
                case c of
                     Left '^' -> ("^",ex,ss)
                     Left '!' -> (ca,"!",ss)
                     _        -> (ca,  ex,(f c ++) . ss)
                   )
                   ("", "", id)
                   r
          (beg,rest) = let s' = fs []
                           (x,y) = splitAt 1 s'
                           in if not b && x == "-"
                                 then (y,x)
                                 else (s',"")
       in concat [ "["
                 , if b then "" else "^"
                 , beg, caret, exclamation, rest
                 , "]"
                 ]

instance Show Pattern where
   showsPrec d p = showParen (d > 10) $
      showString "compile " . showsPrec (d+1) (decompile p)

instance Read Pattern where
#if __GLASGOW_HASKELL__
   readPrec = parens . prec 10 $ do
      Ident "compile" <- lexP
      fmap compile readPrec
#else
   readsPrec d = readParen (d > 10) $ \r -> do
      ("compile",string) <- lex r
      (xs,rest) <- readsPrec (d+1) string
      [(compile xs, rest)]
#endif

instance Monoid Pattern where
   mempty                          = Pattern []
   mappend (Pattern a) (Pattern b) = optimize . Pattern $ (a ++ b)
   mconcat                         = optimize . Pattern . concatMap unPattern

-- |Options which can be passed to the 'tryCompileWith' or 'compileWith'
-- functions: with these you can selectively toggle certain features at compile
-- time.
--
-- Note that some of these options depend on each other: classes can never
-- occur if ranges aren't allowed, for instance.

-- We could presumably put locale information in here, too.
data CompOptions = CompOptions
    { characterClasses   :: Bool -- ^Allow character classes, @[[:...:]]@.
    , characterRanges    :: Bool -- ^Allow character ranges, @[...]@.
    , numberRanges       :: Bool -- ^Allow open ranges, @\<...>@.
    , wildcards          :: Bool -- ^Allow wildcards, @*@ and @?@.
    , recursiveWildcards :: Bool -- ^Allow recursive wildcards, @**/@.

    , pathSepInRanges    :: Bool
      -- ^Allow path separators in character ranges.
      --
      -- If true, @a[/]b@ never matches anything (since character ranges can't
      -- match path separators); if false and 'errorRecovery' is enabled,
      -- @a[/]b@ matches itself, i.e. a file named @]b@ in the subdirectory
      -- @a[@.

    , errorRecovery      :: Bool
      -- ^If the input is invalid, recover by turning any invalid part into
      -- literals. For instance, with 'characterRanges' enabled, @[abc@ is an
      -- error by default (unclosed character range); with 'errorRecovery', the
      -- @[@ is turned into a literal match, as though 'characterRanges' were
      -- disabled.
    } deriving (Show,Read,Eq)

-- |The default set of compilation options: closest to the behaviour of the
-- @zsh@ shell, with 'errorRecovery' enabled.
--
-- All options are enabled.
compDefault :: CompOptions
compDefault = CompOptions
   { characterClasses   = True
   , characterRanges    = True
   , numberRanges       = True
   , wildcards          = True
   , recursiveWildcards = True
   , pathSepInRanges    = True
   , errorRecovery      = True
   }

-- |Options for POSIX-compliance, as described in @man 7 glob@.
--
-- 'numberRanges', 'recursiveWildcards', and 'pathSepInRanges' are disabled.
compPosix :: CompOptions
compPosix = CompOptions
   { characterClasses   = True
   , characterRanges    = True
   , numberRanges       = False
   , wildcards          = True
   , recursiveWildcards = False
   , pathSepInRanges    = False
   , errorRecovery      = True
   }

-- |Options which can be passed to the 'matchWith' or 'globDirWith' functions:
-- with these you can selectively toggle certain features at matching time.
data MatchOptions = MatchOptions
    { matchDotsImplicitly :: Bool
      -- ^Allow @*@, @?@, and @**/@ to match @.@ at the beginning of paths.

    , ignoreCase          :: Bool
      -- ^Case-independent matching.

    , ignoreDotSlash      :: Bool
      -- ^Treat @./@ as a no-op in both paths and patterns.
      --
      -- (Of course e.g. @../@ means something different and will not be
      -- ignored.)
    }

-- |The default set of execution options: closest to the behaviour of the @zsh@
-- shell.
--
-- Currently identical to 'matchPosix'.
matchDefault :: MatchOptions
matchDefault = matchPosix

-- |Options for POSIX-compliance, as described in @man 7 glob@.
--
-- 'ignoreDotSlash' is enabled, the rest are disabled.
matchPosix :: MatchOptions
matchPosix = MatchOptions
   { matchDotsImplicitly = False
   , ignoreCase          = False
   , ignoreDotSlash      = True
   }

-- |Decompiles a 'Pattern' object into its textual representation: essentially
-- the inverse of 'compile'.
--
-- Note, however, that due to internal optimization, @decompile . compile@ is
-- not the identity function. Instead, @compile . decompile@ is.
--
-- Be careful with 'CompOptions': 'decompile' always produces a 'String' which
-- can be passed to 'compile' to get back the same 'Pattern'. @compileWith
-- options . decompile@ is /not/ the identity function unless @options@ is
-- 'compDefault'.
decompile :: Pattern -> String
decompile = concatMap show . unPattern

------------------------------------------
-- COMPILATION
------------------------------------------


-- |Compiles a glob pattern from its textual representation into a 'Pattern'
-- object.
--
-- 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. Never matches path separators: @[\/]@ matches
--            nothing at all. Named character classes can also be matched:
--            @[:x:]@ within @[]@ specifies the class named @x@, which matches
--            certain predefined characters. See below for a full list.
--
-- [@[^..\]@ or @[!..\]@] Like @[..]@, but matches any character /not/ listed.
--                        Note that @[^-x]@ is not the inverse of @[-x]@, but
--                        the range @[^-x]@.
--
-- [@\<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.
--
-- Supported character classes:
--
-- [@[:alnum:\]@]  Equivalent to @\"0-9A-Za-z\"@.
--
-- [@[:alpha:\]@]  Equivalent to @\"A-Za-z\"@.
--
-- [@[:blank:\]@]  Equivalent to @\"\\t \"@.
--
-- [@[:cntrl:\]@]  Equivalent to @\"\\0-\\x1f\\x7f\"@.
--
-- [@[:digit:\]@]  Equivalent to @\"0-9\"@.
--
-- [@[:graph:\]@]  Equivalent to @\"!-~\"@.
--
-- [@[:lower:\]@]  Equivalent to @\"a-z\"@.
--
-- [@[:print:\]@]  Equivalent to @\" -~\"@.
--
-- [@[:punct:\]@]  Equivalent to @\"!-\/:-\@[-`{-~\"@.
--
-- [@[:space:\]@]  Equivalent to @\"\\t-\\r \"@.
--
-- [@[:upper:\]@]  Equivalent to @\"A-Z\"@.
--
-- [@[:xdigit:\]@] Equivalent to @\"0-9A-Fa-f\"@.
--
-- 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
-- @\'\\\'@.
--
-- Error recovery will be performed: erroneous operators will not be considered
-- operators, but matched as literal strings. Such operators include:
--
-- * An empty @[]@ or @[^]@ or @[!]@
--
-- * A @[@ or @\<@ without a matching @]@ or @>@
--
-- * A malformed @\<>@: e.g. nonnumeric characters or no hyphen
--
-- So, e.g. @[]@ will match the string @\"[]\"@.
compile :: String -> Pattern
compile = compileWith compDefault

-- |Like 'compile', but recognizes operators according to the given
-- 'CompOptions' instead of the defaults.
--
-- If an error occurs and 'errorRecovery' is disabled, 'error' will be called.
compileWith :: CompOptions -> String -> Pattern
compileWith opts = either error id . tryCompileWith opts

-- |A safe version of 'compileWith'.
--
-- If an error occurs and 'errorRecovery' is disabled, the error message will
-- be returned in a 'Left'.
tryCompileWith :: CompOptions -> String -> Either String Pattern
tryCompileWith opts = fmap optimize . tokenize opts

tokenize :: CompOptions -> String -> Either String Pattern
tokenize opts = fmap Pattern . sequence . go
 where
   err _ c cs | errorRecovery opts = Right (Literal c) : go cs
   err s _ _                       = [Left s]

   go :: String -> [Either String Token]
   go [] = []
   go ('?':cs) | wcs = Right NonPathSeparator : go cs
   go ('*':cs) | wcs =
      case cs of
           '*':p:xs | rwcs && isPathSeparator p
              -> Right AnyDirectory        : go xs
           _  -> Right AnyNonPathSeparator : go cs

   go ('[':cs) | crs = let (range,rest) = charRange opts cs
                        in case range of
                                Left s -> err s '[' cs
                                r      -> r : go rest

   go ('<':cs) | ors =
      let (range, rest) = break (=='>') cs
       in if null rest
             then err "compile :: unclosed <> in pattern" '<' cs
             else case openRange range of
                       Left s -> err s '<' cs
                       r      -> r : go (tail rest)
   go (c:cs)
      | isPathSeparator c = Right PathSeparator : go cs
      | isExtSeparator  c = Right  ExtSeparator : go cs
      | otherwise         = Right (Literal c)   : go cs

   wcs  = wildcards          opts
   rwcs = recursiveWildcards opts
   crs  = characterRanges    opts
   ors  = numberRanges       opts

-- <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

type CharRange = [Either Char (Char,Char)]

charRange :: CompOptions -> String -> (Either String Token, String)
charRange opts zs =
   case zs of
        y:ys | y `elem` "^!" ->
           case ys of
                -- [!-#] is not the inverse of [-#], it is the range ! through
                -- #
                '-':']':xs -> (Right (CharRange False [Left '-']), xs)
                '-'    :_  -> first (fmap (CharRange True )) (start zs)
                xs         -> first (fmap (CharRange False)) (start xs)
        _                  -> first (fmap (CharRange True )) (start zs)
 where
   start :: String -> (Either String CharRange, String)
   start (']':xs) = run $ char ']' xs
   start ('-':xs) = run $ char '-' xs
   start xs       = run $ go xs

   run :: ErrorT String (Writer CharRange) String
       -> (Either String CharRange, String)
   run m = case runWriter.runErrorT $ m of
                (Left   err,  _) -> (Left err, [])
                (Right rest, cs) -> (Right cs, rest)

   go :: String -> ErrorT String (Writer CharRange) String
   go ('[':':':xs) | characterClasses opts = readClass xs
   go (    ']':xs) = return xs
   go (      c:xs) =
      if not (pathSepInRanges opts) && isPathSeparator c
         then throwError "compile :: path separator within []"
         else char c xs
   go []           = throwError "compile :: unclosed [] in pattern"

   char :: Char -> String -> ErrorT String (Writer CharRange) String
   char c ('-':x:xs) =
      if x == ']'
         then ltell [Left c, Left '-'] >> return xs
         else ltell [Right (c,x)]      >>     go xs

   char c xs = ltell [Left c] >> go xs

   readClass :: String -> ErrorT String (Writer CharRange) String
   readClass xs = let (name,end) = span isAlpha xs
                   in case end of
                           ':':']':rest -> charClass name            >> go rest
                           _            -> ltell [Left '[',Left ':'] >> go xs

   charClass :: String -> ErrorT String (Writer CharRange) ()
   charClass name =
      -- The POSIX classes
      --
      -- TODO: this is ASCII-only, not sure how this should be extended
      --       Unicode, or with a locale as input, or something else?
      case name of
           "alnum"  -> ltell [digit,upper,lower]
           "alpha"  -> ltell [upper,lower]
           "blank"  -> ltell blanks
           "cntrl"  -> ltell [Right ('\0','\x1f'), Left '\x7f']
           "digit"  -> ltell [digit]
           "graph"  -> ltell [Right ('!','~')]
           "lower"  -> ltell [lower]
           "print"  -> ltell [Right (' ','~')]
           "punct"  -> ltell punct
           "space"  -> ltell spaces
           "upper"  -> ltell [upper]
           "xdigit" -> ltell [digit, Right ('A','F'), Right ('a','f')]
           _        ->
              throwError ("compile :: unknown character class '" ++name++ "'")

   digit  = Right ('0','9')
   upper  = Right ('A','Z')
   lower  = Right ('a','z')
   punct  = map Right [('!','/'), (':','@'), ('[','`'), ('{','~')]
   blanks = [Left '\t',         Left ' ']
   spaces = [Right ('\t','\r'), Left ' ']

   ltell = lift . tell


------------------------------------------
-- OPTIMIZATION
------------------------------------------


optimize :: Pattern -> Pattern
optimize = liftP (fin . go)
 where
   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 (LongLiteral 1 s : xs) = Literal (head s) : fin xs

   fin (Literal c : LongLiteral l s : xs) =
      fin $ LongLiteral (l+1) (c:s) : 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)

   -- <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  -> let (compressed,ys) = span c xs
                       in if null compressed
                             then x : go ys
                             else go (x : ys)
           Nothing -> x : go xs

   compressors = [isStar, isStarSlash, isAnyNumber]

   isLiteral   (Literal _)                 = True
   isLiteral   _                           = False
   isStar      AnyNonPathSeparator         = True
   isStar      _                           = 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
   -- [/] is interesting, it actually matches nothing at all
   -- [.] can be Literalized though, just don't make it into an ExtSeparator so
   --     that it doesn't match a leading dot
   fin True [Left  c] | not (isPathSeparator 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