Cabal/src/Distribution/Simple/Glob/Internal.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE LambdaCase #-}
   4
   5 -----------------------------------------------------------------------------
   6
   7 -- |
   8 -- Module      :  Distribution.Simple.Glob.Internal
   9 -- Copyright   :  Isaac Jones, Simon Marlow 2003-2004
  10 -- License     :  BSD3
  11 --                portions Copyright (c) 2007, Galois Inc.
  12 --
  13 -- Maintainer  :  cabal-devel@haskell.org
  14 -- Portability :  portable
  15 --
  16 -- Internal module for simple file globbing.
  17 -- Please import "Distribution.Simple.Glob" instead.
  18 module Distribution.Simple.Glob.Internal where
  19
  20 import Distribution.Compat.Prelude
  21 import Prelude ()
  22
  23 import qualified Distribution.Compat.CharParsing as P
  24 import Distribution.Parsec
  25 import Distribution.Pretty
  26 import qualified Text.PrettyPrint as Disp
  27
  28 --------------------------------------------------------------------------------
  29
  30 -- | A filepath specified by globbing.
  31 data Glob
  32   = -- | @<dirGlob>/<glob>@
  33     GlobDir !GlobPieces !Glob
  34   | -- | @**/<glob>@, where @**@ denotes recursively traversing
  35     -- all directories and matching filenames on <glob>.
  36     GlobDirRecursive !GlobPieces
  37   | -- | A file glob.
  38     GlobFile !GlobPieces
  39   | -- | Trailing dir; a glob ending in @/@.
  40     GlobDirTrailing
  41   deriving (Eq, Show, Generic)
  42
  43 instance Binary Glob
  44 instance Structured Glob
  45
  46 -- | A single directory or file component of a globbed path
  47 type GlobPieces = [GlobPiece]
  48
  49 -- | A piece of a globbing pattern
  50 data GlobPiece
  51   = -- | A wildcard @*@
  52     WildCard
  53   | -- | A literal string @dirABC@
  54     Literal String
  55   | -- | A union of patterns, e.g. @dir/{a,*.txt,c}/...@
  56     Union [GlobPieces]
  57   deriving (Eq, Show, Generic)
  58
  59 instance Binary GlobPiece
  60 instance Structured GlobPiece
  61
  62 --------------------------------------------------------------------------------
  63 -- Parsing & pretty-printing
  64
  65 instance Pretty Glob where
  66   pretty (GlobDir glob pathglob) =
  67     dispGlobPieces glob
  68       Disp.<> Disp.char '/'
  69       Disp.<> pretty pathglob
  70   pretty (GlobDirRecursive glob) =
  71     Disp.text "**/"
  72       Disp.<> dispGlobPieces glob
  73   pretty (GlobFile glob) = dispGlobPieces glob
  74   pretty GlobDirTrailing = Disp.empty
  75
  76 instance Parsec Glob where
  77   parsec = parsecPath
  78     where
  79       parsecPath :: CabalParsing m => m Glob
  80       parsecPath = do
  81         glob <- parsecGlob
  82         dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)
  83       -- We could support parsing recursive directory search syntax
  84       -- @**@ here too, rather than just in 'parseFileGlob'
  85
  86       dirSep :: CabalParsing m => m ()
  87       dirSep =
  88         () <$ P.char '/'
  89           <|> P.try
  90             ( do
  91                 _ <- P.char '\\'
  92                 -- check this isn't an escape code
  93                 P.notFollowedBy (P.satisfy isGlobEscapedChar)
  94             )
  95
  96       parsecGlob :: CabalParsing m => m GlobPieces
  97       parsecGlob = some parsecPiece
  98         where
  99           parsecPiece = P.choice [literal, wildcard, union]
 100
 101           wildcard = WildCard <$ P.char '*'
 102           union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ','))
 103           literal = Literal <$> some litchar
 104
 105           litchar = normal <|> escape
 106
 107           normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\')
 108           escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar
 109
 110 dispGlobPieces :: GlobPieces -> Disp.Doc
 111 dispGlobPieces = Disp.hcat . map dispPiece
 112   where
 113     dispPiece WildCard = Disp.char '*'
 114     dispPiece (Literal str) = Disp.text (escape str)
 115     dispPiece (Union globs) =
 116       Disp.braces
 117         ( Disp.hcat
 118             ( Disp.punctuate
 119                 (Disp.char ',')
 120                 (map dispGlobPieces globs)
 121             )
 122         )
 123     escape [] = []
 124     escape (c : cs)
 125       | isGlobEscapedChar c = '\\' : c : escape cs
 126       | otherwise = c : escape cs
 127
 128 isGlobEscapedChar :: Char -> Bool
 129 isGlobEscapedChar '*' = True
 130 isGlobEscapedChar '{' = True
 131 isGlobEscapedChar '}' = True
 132 isGlobEscapedChar ',' = True
 133 isGlobEscapedChar _ = False