content: {-# LANGUAGE DeriveGeneric #-}
  
  --TODO: [code cleanup] plausibly much of this module should be merged with
  -- similar functionality in Cabal.
  module Distribution.Client.Glob
      ( FilePathGlob(..)
      , FilePathRoot(..)
      , FilePathGlobRel(..)
      , Glob
      , GlobPiece(..)
      , matchFileGlob
      , matchFileGlobRel
      , matchGlob
      , isTrivialFilePathGlob
      , getFilePathRootDirectory
      ) where
  
  import Prelude ()
  import Distribution.Client.Compat.Prelude
  
  import           Data.List (stripPrefix)
  import           Control.Monad (mapM)
  
  import           Distribution.Text
  import           Distribution.Compat.ReadP (ReadP, (<++), (+++))
  import qualified Distribution.Compat.ReadP as Parse
  import qualified Text.PrettyPrint as Disp
  
  import           System.FilePath
  import           System.Directory
  
  
  -- | A file path specified by globbing
  --
  data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel
    deriving (Eq, Show, Generic)
  
  data FilePathGlobRel
     = GlobDir  !Glob !FilePathGlobRel
     | GlobFile !Glob
     | GlobDirTrailing                -- ^ trailing dir, a glob ending in @/@
    deriving (Eq, Show, Generic)
  
  -- | A single directory or file component of a globbed path
  type Glob = [GlobPiece]
  
  -- | A piece of a globbing pattern
  data GlobPiece = WildCard
                 | Literal String
                 | Union [Glob]
    deriving (Eq, Show, Generic)
  
  data FilePathRoot
     = FilePathRelative
     | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive'
     | FilePathHomeDir
    deriving (Eq, Show, Generic)
  
  instance Binary FilePathGlob
  instance Binary FilePathRoot
  instance Binary FilePathGlobRel
  instance Binary GlobPiece
  
  
  -- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and
  -- is in fact equivalent to a non-glob 'FilePath'.
  --
  -- If it is trivial in this sense then the result is the equivalent constant
  -- 'FilePath'. On the other hand if it is not trivial (so could in principle
  -- match more than one file) then the result is @Nothing@.
  --
  isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath
  isTrivialFilePathGlob (FilePathGlob root pathglob) =
      case root of
        FilePathRelative       -> go []      pathglob
        FilePathRoot root'     -> go [root'] pathglob
        FilePathHomeDir        -> Nothing
    where
      go paths (GlobDir  [Literal path] globs) = go (path:paths) globs
      go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths)))
      go paths  GlobDirTrailing          = Just (addTrailingPathSeparator
                                                   (joinPath (reverse paths)))
      go _ _ = Nothing
  
  -- | Get the 'FilePath' corresponding to a 'FilePathRoot'.
  --
  -- The 'FilePath' argument is required to supply the path for the
  -- 'FilePathRelative' case.
  --
  getFilePathRootDirectory :: FilePathRoot
                           -> FilePath      -- ^ root for relative paths
                           -> IO FilePath
  getFilePathRootDirectory  FilePathRelative   root = return root
  getFilePathRootDirectory (FilePathRoot root) _    = return root
  getFilePathRootDirectory  FilePathHomeDir    _    = getHomeDirectory
  
  
  ------------------------------------------------------------------------------
  -- Matching
  --
  
  -- | Match a 'FilePathGlob' against the file system, starting from a given
  -- root directory for relative paths. The results of relative globs are
  -- relative to the given root. Matches for absolute globs are absolute.
  --
  matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath]
  matchFileGlob relroot (FilePathGlob globroot glob) = do
      root <- getFilePathRootDirectory globroot relroot
      matches <- matchFileGlobRel root glob
      case globroot of
        FilePathRelative -> return matches
        _                -> return (map (root </>) matches)
  
  -- | Match a 'FilePathGlobRel' against the file system, starting from a
  -- given root directory. The results are all relative to the given root.
  --
  matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath]
  matchFileGlobRel root glob0 = go glob0 ""
    where
      go (GlobFile glob) dir = do
        entries <- getDirectoryContents (root </> dir)
        let files = filter (matchGlob glob) entries
        return (map (dir </>) files)
  
      go (GlobDir glob globPath) dir = do
        entries <- getDirectoryContents (root </> dir)
        subdirs <- filterM (\subdir -> doesDirectoryExist
                                         (root </> dir </> subdir))
                 $ filter (matchGlob glob) entries
        concat <$> mapM (\subdir -> go globPath (dir </> subdir)) subdirs
  
      go GlobDirTrailing dir = return [dir]
  
  
  -- | Match a globbing pattern against a file path component
  --
  matchGlob :: Glob -> String -> Bool
  matchGlob = goStart
    where
      -- From the man page, glob(7):
      --   "If a filename starts with a '.', this character must be
      --    matched explicitly."
  
      go, goStart :: [GlobPiece] -> String -> Bool
  
      goStart (WildCard:_) ('.':_)  = False
      goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs)
                                          globs
      goStart rest               cs = go rest cs
  
      go []                 ""    = True
      go (Literal lit:rest) cs
        | Just cs' <- stripPrefix lit cs
                                  = go rest cs'
        | otherwise               = False
      go [WildCard]         ""    = True
      go (WildCard:rest)   (c:cs) = go rest (c:cs) || go (WildCard:rest) cs
      go (Union globs:rest)   cs  = any (\glob -> go (glob ++ rest) cs) globs
      go []                (_:_)  = False
      go (_:_)              ""    = False
  
  
  ------------------------------------------------------------------------------
  -- Parsing & printing
  --
  
  instance Text FilePathGlob where
    disp (FilePathGlob root pathglob) = disp root Disp.<> disp pathglob
    parse =
      parse >>= \root ->
          (FilePathGlob root <$> parse)
      <++ (when (root == FilePathRelative) Parse.pfail >>
           return (FilePathGlob root GlobDirTrailing))
  
  instance Text FilePathRoot where
    disp  FilePathRelative    = Disp.empty
    disp (FilePathRoot root)  = Disp.text root
    disp FilePathHomeDir      = Disp.char '~' Disp.<> Disp.char '/'
  
    parse =
          (     (Parse.char '/' >> return (FilePathRoot "/"))
            +++ (Parse.char '~' >> Parse.char '/' >> return FilePathHomeDir)
            +++ (do drive <- Parse.satisfy (\c -> (c >= 'a' && c <= 'z')
                                               || (c >= 'A' && c <= 'Z'))
                    _ <- Parse.char ':'
                    _ <- Parse.char '/' +++ Parse.char '\\'
                    return (FilePathRoot (toUpper drive : ":\\")))
          )
      <++ return FilePathRelative
  
  instance Text FilePathGlobRel where
    disp (GlobDir  glob pathglob) = dispGlob glob
                            Disp.<> Disp.char '/'
                            Disp.<> disp pathglob
    disp (GlobFile glob)          = dispGlob glob
    disp  GlobDirTrailing         = Disp.empty
  
    parse = parsePath
      where
        parsePath :: ReadP r FilePathGlobRel
        parsePath =
          parseGlob >>= \globpieces ->
              asDir globpieces
          <++ asTDir globpieces
          <++ asFile globpieces
  
        asDir  glob = do dirSep
                         globs <- parsePath
                         return (GlobDir glob globs)
        asTDir glob = do dirSep
                         return (GlobDir glob GlobDirTrailing)
        asFile glob = return (GlobFile glob)
  
        dirSep = (Parse.char '/' >> return ())
             +++ (do _ <- Parse.char '\\'
                     -- check this isn't an escape code
                     following <- Parse.look
                     case following of
                       (c:_) | isGlobEscapedChar c -> Parse.pfail
                       _                           -> return ())
  
  
  dispGlob :: Glob -> Disp.Doc
  dispGlob = Disp.hcat . map dispPiece
    where
      dispPiece WildCard      = Disp.char '*'
      dispPiece (Literal str) = Disp.text (escape str)
      dispPiece (Union globs) = Disp.braces
                                  (Disp.hcat (Disp.punctuate
                                               (Disp.char ',')
                                               (map dispGlob globs)))
      escape []               = []
      escape (c:cs)
        | isGlobEscapedChar c = '\\' : c : escape cs
        | otherwise           =        c : escape cs
  
  parseGlob :: ReadP r Glob
  parseGlob = Parse.many1 parsePiece
    where
      parsePiece = literal +++ wildcard +++ union
  
      wildcard = Parse.char '*' >> return WildCard
  
      union = Parse.between (Parse.char '{') (Parse.char '}') $
                fmap Union (Parse.sepBy1 parseGlob (Parse.char ','))
  
      literal = Literal `fmap` litchars1
  
      litchar = normal +++ escape
  
      normal  = Parse.satisfy (\c -> not (isGlobEscapedChar c)
                                  && c /= '/' && c /= '\\')
      escape  = Parse.char '\\' >> Parse.satisfy isGlobEscapedChar
  
      litchars1 :: ReadP r [Char]
      litchars1 = liftM2 (:) litchar litchars
  
      litchars :: ReadP r [Char]
      litchars = litchars1 <++ return []
  
  isGlobEscapedChar :: Char -> Bool
  isGlobEscapedChar '*'  = True
  isGlobEscapedChar '{'  = True
  isGlobEscapedChar '}'  = True
  isGlobEscapedChar ','  = True
  isGlobEscapedChar _    = False
  