never executed always true always false
1 {-# LANGUAGE DeriveGeneric #-}
2
3 --TODO: [code cleanup] plausibly much of this module should be merged with
4 -- similar functionality in Cabal.
5 module Distribution.Client.Glob
6 ( FilePathGlob(..)
7 , FilePathRoot(..)
8 , FilePathGlobRel(..)
9 , Glob
10 , GlobPiece(..)
11 , matchFileGlob
12 , matchFileGlobRel
13 , matchGlob
14 , isTrivialFilePathGlob
15 , getFilePathRootDirectory
16 ) where
17
18 import Distribution.Client.Compat.Prelude
19 import Prelude ()
20
21 import Data.List (stripPrefix)
22 import System.Directory
23 import System.FilePath
24
25 import qualified Distribution.Compat.CharParsing as P
26 import qualified Text.PrettyPrint as Disp
27
28
29 -- | A file path specified by globbing
30 --
31 data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel
32 deriving (Eq, Show, Generic)
33
34 data FilePathGlobRel
35 = GlobDir !Glob !FilePathGlobRel
36 | GlobFile !Glob
37 | GlobDirTrailing -- ^ trailing dir, a glob ending in @/@
38 deriving (Eq, Show, Generic)
39
40 -- | A single directory or file component of a globbed path
41 type Glob = [GlobPiece]
42
43 -- | A piece of a globbing pattern
44 data GlobPiece = WildCard
45 | Literal String
46 | Union [Glob]
47 deriving (Eq, Show, Generic)
48
49 data FilePathRoot
50 = FilePathRelative
51 | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive'
52 | FilePathHomeDir
53 deriving (Eq, Show, Generic)
54
55 instance Binary FilePathGlob
56 instance Binary FilePathRoot
57 instance Binary FilePathGlobRel
58 instance Binary GlobPiece
59
60 instance Structured FilePathGlob
61 instance Structured FilePathRoot
62 instance Structured FilePathGlobRel
63 instance Structured GlobPiece
64
65 -- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and
66 -- is in fact equivalent to a non-glob 'FilePath'.
67 --
68 -- If it is trivial in this sense then the result is the equivalent constant
69 -- 'FilePath'. On the other hand if it is not trivial (so could in principle
70 -- match more than one file) then the result is @Nothing@.
71 --
72 isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath
73 isTrivialFilePathGlob (FilePathGlob root pathglob) =
74 case root of
75 FilePathRelative -> go [] pathglob
76 FilePathRoot root' -> go [root'] pathglob
77 FilePathHomeDir -> Nothing
78 where
79 go paths (GlobDir [Literal path] globs) = go (path:paths) globs
80 go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths)))
81 go paths GlobDirTrailing = Just (addTrailingPathSeparator
82 (joinPath (reverse paths)))
83 go _ _ = Nothing
84
85 -- | Get the 'FilePath' corresponding to a 'FilePathRoot'.
86 --
87 -- The 'FilePath' argument is required to supply the path for the
88 -- 'FilePathRelative' case.
89 --
90 getFilePathRootDirectory :: FilePathRoot
91 -> FilePath -- ^ root for relative paths
92 -> IO FilePath
93 getFilePathRootDirectory FilePathRelative root = return root
94 getFilePathRootDirectory (FilePathRoot root) _ = return root
95 getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory
96
97
98 ------------------------------------------------------------------------------
99 -- Matching
100 --
101
102 -- | Match a 'FilePathGlob' against the file system, starting from a given
103 -- root directory for relative paths. The results of relative globs are
104 -- relative to the given root. Matches for absolute globs are absolute.
105 --
106 matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath]
107 matchFileGlob relroot (FilePathGlob globroot glob) = do
108 root <- getFilePathRootDirectory globroot relroot
109 matches <- matchFileGlobRel root glob
110 case globroot of
111 FilePathRelative -> return matches
112 _ -> return (map (root </>) matches)
113
114 -- | Match a 'FilePathGlobRel' against the file system, starting from a
115 -- given root directory. The results are all relative to the given root.
116 --
117 matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath]
118 matchFileGlobRel root glob0 = go glob0 ""
119 where
120 go (GlobFile glob) dir = do
121 entries <- getDirectoryContents (root </> dir)
122 let files = filter (matchGlob glob) entries
123 return (map (dir </>) files)
124
125 go (GlobDir glob globPath) dir = do
126 entries <- getDirectoryContents (root </> dir)
127 subdirs <- filterM (\subdir -> doesDirectoryExist
128 (root </> dir </> subdir))
129 $ filter (matchGlob glob) entries
130 concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs
131
132 go GlobDirTrailing dir = return [dir]
133
134
135 -- | Match a globbing pattern against a file path component
136 --
137 matchGlob :: Glob -> String -> Bool
138 matchGlob = goStart
139 where
140 -- From the man page, glob(7):
141 -- "If a filename starts with a '.', this character must be
142 -- matched explicitly."
143
144 go, goStart :: [GlobPiece] -> String -> Bool
145
146 goStart (WildCard:_) ('.':_) = False
147 goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs)
148 globs
149 goStart rest cs = go rest cs
150
151 go [] "" = True
152 go (Literal lit:rest) cs
153 | Just cs' <- stripPrefix lit cs
154 = go rest cs'
155 | otherwise = False
156 go [WildCard] "" = True
157 go (WildCard:rest) (c:cs) = go rest (c:cs) || go (WildCard:rest) cs
158 go (Union globs:rest) cs = any (\glob -> go (glob ++ rest) cs) globs
159 go [] (_:_) = False
160 go (_:_) "" = False
161
162
163 ------------------------------------------------------------------------------
164 -- Parsing & printing
165 --
166
167 instance Pretty FilePathGlob where
168 pretty (FilePathGlob root pathglob) = pretty root Disp.<> pretty pathglob
169
170 instance Parsec FilePathGlob where
171 parsec = do
172 root <- parsec
173 case root of
174 FilePathRelative -> FilePathGlob root <$> parsec
175 _ -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing)
176
177 instance Pretty FilePathRoot where
178 pretty FilePathRelative = Disp.empty
179 pretty (FilePathRoot root) = Disp.text root
180 pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/'
181
182 instance Parsec FilePathRoot where
183 parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative where
184 root = FilePathRoot "/" <$ P.char '/'
185 home = FilePathHomeDir <$ P.string "~/"
186 drive = do
187 dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
188 _ <- P.char ':'
189 _ <- P.char '/' <|> P.char '\\'
190 return (FilePathRoot (toUpper dr : ":\\"))
191
192 instance Pretty FilePathGlobRel where
193 pretty (GlobDir glob pathglob) = dispGlob glob
194 Disp.<> Disp.char '/'
195 Disp.<> pretty pathglob
196 pretty (GlobFile glob) = dispGlob glob
197 pretty GlobDirTrailing = Disp.empty
198
199 instance Parsec FilePathGlobRel where
200 parsec = parsecPath where
201 parsecPath :: CabalParsing m => m FilePathGlobRel
202 parsecPath = do
203 glob <- parsecGlob
204 dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)
205
206 dirSep :: CabalParsing m => m ()
207 dirSep = () <$ P.char '/' <|> P.try (do
208 _ <- P.char '\\'
209 -- check this isn't an escape code
210 P.notFollowedBy (P.satisfy isGlobEscapedChar))
211
212 dispGlob :: Glob -> Disp.Doc
213 dispGlob = Disp.hcat . map dispPiece
214 where
215 dispPiece WildCard = Disp.char '*'
216 dispPiece (Literal str) = Disp.text (escape str)
217 dispPiece (Union globs) = Disp.braces
218 (Disp.hcat (Disp.punctuate
219 (Disp.char ',')
220 (map dispGlob globs)))
221 escape [] = []
222 escape (c:cs)
223 | isGlobEscapedChar c = '\\' : c : escape cs
224 | otherwise = c : escape cs
225
226 parsecGlob :: CabalParsing m => m Glob
227 parsecGlob = some parsecPiece where
228 parsecPiece = P.choice [ literal, wildcard, union ]
229
230 wildcard = WildCard <$ P.char '*'
231 union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ','))
232 literal = Literal <$> some litchar
233
234 litchar = normal <|> escape
235
236 normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\')
237 escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar
238
239 isGlobEscapedChar :: Char -> Bool
240 isGlobEscapedChar '*' = True
241 isGlobEscapedChar '{' = True
242 isGlobEscapedChar '}' = True
243 isGlobEscapedChar ',' = True
244 isGlobEscapedChar _ = False