{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Simple.Glob.Internal
-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
-- License     :  BSD3
--                portions Copyright (c) 2007, Galois Inc.
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Internal module for simple file globbing.
-- Please import "Distribution.Simple.Glob" instead.
module Distribution.Simple.Glob.Internal where

import Distribution.Compat.Prelude
import Prelude ()

import qualified Distribution.Compat.CharParsing as P
import Distribution.Parsec
import Distribution.Pretty
import qualified Text.PrettyPrint as Disp

--------------------------------------------------------------------------------

-- | A filepath specified by globbing.
data Glob
  = -- | @<dirGlob>/<glob>@
    GlobDir !GlobPieces !Glob
  | -- | @**/<glob>@, where @**@ denotes recursively traversing
    -- all directories and matching filenames on <glob>.
    GlobDirRecursive !GlobPieces
  | -- | A file glob.
    GlobFile !GlobPieces
  | -- | Trailing dir; a glob ending in @/@.
    GlobDirTrailing
  deriving (Glob -> Glob -> Bool
(Glob -> Glob -> Bool) -> (Glob -> Glob -> Bool) -> Eq Glob
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Glob -> Glob -> Bool
== :: Glob -> Glob -> Bool
$c/= :: Glob -> Glob -> Bool
/= :: Glob -> Glob -> Bool
Eq, Int -> Glob -> ShowS
[Glob] -> ShowS
Glob -> String
(Int -> Glob -> ShowS)
-> (Glob -> String) -> ([Glob] -> ShowS) -> Show Glob
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Glob -> ShowS
showsPrec :: Int -> Glob -> ShowS
$cshow :: Glob -> String
show :: Glob -> String
$cshowList :: [Glob] -> ShowS
showList :: [Glob] -> ShowS
Show, (forall x. Glob -> Rep Glob x)
-> (forall x. Rep Glob x -> Glob) -> Generic Glob
forall x. Rep Glob x -> Glob
forall x. Glob -> Rep Glob x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Glob -> Rep Glob x
from :: forall x. Glob -> Rep Glob x
$cto :: forall x. Rep Glob x -> Glob
to :: forall x. Rep Glob x -> Glob
Generic)

instance Binary Glob
instance Structured Glob

-- | A single directory or file component of a globbed path
type GlobPieces = [GlobPiece]

-- | A piece of a globbing pattern
data GlobPiece
  = -- | A wildcard @*@
    WildCard
  | -- | A literal string @dirABC@
    Literal String
  | -- | A union of patterns, e.g. @dir/{a,*.txt,c}/...@
    Union [GlobPieces]
  deriving (GlobPiece -> GlobPiece -> Bool
(GlobPiece -> GlobPiece -> Bool)
-> (GlobPiece -> GlobPiece -> Bool) -> Eq GlobPiece
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GlobPiece -> GlobPiece -> Bool
== :: GlobPiece -> GlobPiece -> Bool
$c/= :: GlobPiece -> GlobPiece -> Bool
/= :: GlobPiece -> GlobPiece -> Bool
Eq, Int -> GlobPiece -> ShowS
GlobPieces -> ShowS
GlobPiece -> String
(Int -> GlobPiece -> ShowS)
-> (GlobPiece -> String) -> (GlobPieces -> ShowS) -> Show GlobPiece
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GlobPiece -> ShowS
showsPrec :: Int -> GlobPiece -> ShowS
$cshow :: GlobPiece -> String
show :: GlobPiece -> String
$cshowList :: GlobPieces -> ShowS
showList :: GlobPieces -> ShowS
Show, (forall x. GlobPiece -> Rep GlobPiece x)
-> (forall x. Rep GlobPiece x -> GlobPiece) -> Generic GlobPiece
forall x. Rep GlobPiece x -> GlobPiece
forall x. GlobPiece -> Rep GlobPiece x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GlobPiece -> Rep GlobPiece x
from :: forall x. GlobPiece -> Rep GlobPiece x
$cto :: forall x. Rep GlobPiece x -> GlobPiece
to :: forall x. Rep GlobPiece x -> GlobPiece
Generic)

instance Binary GlobPiece
instance Structured GlobPiece

--------------------------------------------------------------------------------
-- Parsing & pretty-printing

instance Pretty Glob where
  pretty :: Glob -> Doc
pretty (GlobDir GlobPieces
glob Glob
pathglob) =
    GlobPieces -> Doc
dispGlobPieces GlobPieces
glob
      Doc -> Doc -> Doc
Disp.<> Char -> Doc
Disp.char Char
'/'
      Doc -> Doc -> Doc
Disp.<> Glob -> Doc
forall a. Pretty a => a -> Doc
pretty Glob
pathglob
  pretty (GlobDirRecursive GlobPieces
glob) =
    String -> Doc
Disp.text String
"**/"
      Doc -> Doc -> Doc
Disp.<> GlobPieces -> Doc
dispGlobPieces GlobPieces
glob
  pretty (GlobFile GlobPieces
glob) = GlobPieces -> Doc
dispGlobPieces GlobPieces
glob
  pretty Glob
GlobDirTrailing = Doc
Disp.empty

instance Parsec Glob where
  parsec :: forall (m :: * -> *). CabalParsing m => m Glob
parsec = m Glob
forall (m :: * -> *). CabalParsing m => m Glob
parsecPath
    where
      parsecPath :: CabalParsing m => m Glob
      parsecPath :: forall (m :: * -> *). CabalParsing m => m Glob
parsecPath = do
        GlobPieces
glob <- m GlobPieces
forall (m :: * -> *). CabalParsing m => m GlobPieces
parsecGlob
        m ()
forall (m :: * -> *). CabalParsing m => m ()
dirSep m () -> m Glob -> m Glob
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (GlobPieces -> Glob -> Glob
GlobDir GlobPieces
glob (Glob -> Glob) -> m Glob -> m Glob
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Glob
forall (m :: * -> *). CabalParsing m => m Glob
parsecPath m Glob -> m Glob -> m Glob
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Glob -> m Glob
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobPieces -> Glob -> Glob
GlobDir GlobPieces
glob Glob
GlobDirTrailing)) m Glob -> m Glob -> m Glob
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Glob -> m Glob
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GlobPieces -> Glob
GlobFile GlobPieces
glob)
      -- We could support parsing recursive directory search syntax
      -- @**@ here too, rather than just in 'parseFileGlob'

      dirSep :: CabalParsing m => m ()
      dirSep :: forall (m :: * -> *). CabalParsing m => m ()
dirSep =
        () () -> m Char -> m ()
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'/'
          m () -> m () -> m ()
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m () -> m ()
forall a. m a -> m a
forall (m :: * -> *) a. Parsing m => m a -> m a
P.try
            ( do
                Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'\\'
                -- check this isn't an escape code
                m Char -> m ()
forall a. Show a => m a -> m ()
forall (m :: * -> *) a. (Parsing m, Show a) => m a -> m ()
P.notFollowedBy ((Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy Char -> Bool
isGlobEscapedChar)
            )

      parsecGlob :: CabalParsing m => m GlobPieces
      parsecGlob :: forall (m :: * -> *). CabalParsing m => m GlobPieces
parsecGlob = m GlobPiece -> m GlobPieces
forall a. m a -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some m GlobPiece
parsecPiece
        where
          parsecPiece :: m GlobPiece
parsecPiece = [m GlobPiece] -> m GlobPiece
forall (m :: * -> *) a. Alternative m => [m a] -> m a
P.choice [m GlobPiece
literal, m GlobPiece
wildcard, m GlobPiece
union]

          wildcard :: m GlobPiece
wildcard = GlobPiece
WildCard GlobPiece -> m Char -> m GlobPiece
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'*'
          union :: m GlobPiece
union = [GlobPieces] -> GlobPiece
Union ([GlobPieces] -> GlobPiece)
-> (NonEmpty GlobPieces -> [GlobPieces])
-> NonEmpty GlobPieces
-> GlobPiece
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty GlobPieces -> [GlobPieces]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty GlobPieces -> GlobPiece)
-> m (NonEmpty GlobPieces) -> m GlobPiece
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char
-> m Char -> m (NonEmpty GlobPieces) -> m (NonEmpty GlobPieces)
forall (m :: * -> *) bra ket a.
Applicative m =>
m bra -> m ket -> m a -> m a
P.between (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'{') (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'}') (m GlobPieces -> m Char -> m (NonEmpty GlobPieces)
forall (m :: * -> *) a sep.
Alternative m =>
m a -> m sep -> m (NonEmpty a)
P.sepByNonEmpty m GlobPieces
forall (m :: * -> *). CabalParsing m => m GlobPieces
parsecGlob (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
','))
          literal :: m GlobPiece
literal = String -> GlobPiece
Literal (String -> GlobPiece) -> m String -> m GlobPiece
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char -> m String
forall a. m a -> m [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some m Char
litchar

          litchar :: m Char
litchar = m Char
normal m Char -> m Char -> m Char
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Char
escape

          normal :: m Char
normal = (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy (\Char
c -> Bool -> Bool
not (Char -> Bool
isGlobEscapedChar Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\')
          escape :: m Char
escape = m Char -> m Char
forall a. m a -> m a
forall (m :: * -> *) a. Parsing m => m a -> m a
P.try (m Char -> m Char) -> m Char -> m Char
forall a b. (a -> b) -> a -> b
$ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'\\' m Char -> m Char -> m Char
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> m Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy Char -> Bool
isGlobEscapedChar

dispGlobPieces :: GlobPieces -> Disp.Doc
dispGlobPieces :: GlobPieces -> Doc
dispGlobPieces = [Doc] -> Doc
Disp.hcat ([Doc] -> Doc) -> (GlobPieces -> [Doc]) -> GlobPieces -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobPiece -> Doc) -> GlobPieces -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map GlobPiece -> Doc
dispPiece
  where
    dispPiece :: GlobPiece -> Doc
dispPiece GlobPiece
WildCard = Char -> Doc
Disp.char Char
'*'
    dispPiece (Literal String
str) = String -> Doc
Disp.text (ShowS
escape String
str)
    dispPiece (Union [GlobPieces]
globs) =
      Doc -> Doc
Disp.braces
        ( [Doc] -> Doc
Disp.hcat
            ( Doc -> [Doc] -> [Doc]
Disp.punctuate
                (Char -> Doc
Disp.char Char
',')
                ((GlobPieces -> Doc) -> [GlobPieces] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map GlobPieces -> Doc
dispGlobPieces [GlobPieces]
globs)
            )
        )
    escape :: ShowS
escape [] = []
    escape (Char
c : String
cs)
      | Char -> Bool
isGlobEscapedChar Char
c = Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape String
cs
      | Bool
otherwise = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
escape String
cs

isGlobEscapedChar :: Char -> Bool
isGlobEscapedChar :: Char -> Bool
isGlobEscapedChar Char
'*' = Bool
True
isGlobEscapedChar Char
'{' = Bool
True
isGlobEscapedChar Char
'}' = Bool
True
isGlobEscapedChar Char
',' = Bool
True
isGlobEscapedChar Char
_ = Bool
False