1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
-- Modify the type signature of namesMatching so that it encodes the possibility
-- of a bad pattern, and make it use your rewritten globToRegex function.
{-- From examples/examples/ch08/Glob.hs modified according to the assignment --}
--
-- An error in the listMatches function has been fixed as described in the
-- solution of 8_a_2.hs.
--}
import Module_8_c_1 (GlobError, globToRegex)
import Text.Regex.Posix ((=~))
import Control.Exception
import Control.Monad (forM)
import System.Directory (doesDirectoryExist, doesFileExist,
getCurrentDirectory, getDirectoryContents)
import System.FilePath (dropTrailingPathSeparator, splitFileName, (</>))
{-- From examples/examples/ch08/GlobRegex.hs modified according to the assignment --}
matchesGlob :: FilePath -> String -> Either GlobError Bool
name `matchesGlob` pat = propagateError regex
where regex = globToRegex pat
propagateError (Left e) = Left e
propagateError (Right s) = Right (name =~ s)
{-- End of code from examples --}
namesMatching :: String -> IO (Either GlobError [FilePath])
isPattern :: String -> Bool
isPattern = any (`elem` "[*?")
namesMatching pat
| not (isPattern pat) = do
exists <- doesNameExist pat
return (Right (if exists then [pat] else []))
| otherwise = do
case splitFileName pat of
("", baseName) -> do
curDir <- getCurrentDirectory
listMatches curDir baseName
(dirName, baseName) -> do
dirs <- if isPattern dirName
then namesMatching (dropTrailingPathSeparator dirName)
else return (Right [dirName])
let listDir = if isPattern baseName
then listMatches
else listPlain
propagateErrorDirs dirs listDir baseName
where
propagateErrorDirs (Left e) _ _ = return (Left e)
propagateErrorDirs (Right dirs) listDir baseName =
propagateErrorListDirs dirs listDir baseName
propagateErrorListDirs [] _ _ = return (Right [])
propagateErrorListDirs (d:ds) listDir baseName = do
baseNames <- listDir d baseName
rest <- propagateErrorListDirs ds listDir baseName
propagateError d baseNames rest
where propagateError _ (Left e) _ = return (Left e)
propagateError _ _ (Left e) = return (Left e)
propagateError dir (Right baseNames) (Right rest)= do
let dirBaseNames = map (dir </>) baseNames
return (Right (dirBaseNames ++ rest))
listMatches :: FilePath -> String -> IO (Either GlobError [String])
listMatches dirName pat = do
dirName' <- if null dirName
then getCurrentDirectory
else return dirName
handle (\(SomeException _) -> return (Right [])) $ do
names <- getDirectoryContents dirName'
let names' = if isHidden pat
then filter isHidden names
else filter (not . isHidden) names
return (filterGlobError names' pat)
filterGlobError :: [String] -> String -> Either GlobError [String]
filterGlobError [] _ = Right []
filterGlobError (n:ns) pat = propagateErrorConcat match filteredRest
where match = matchesGlob n pat
filteredRest = filterGlobError ns pat
propagateErrorConcat (Left e) _ = Left e
propagateErrorConcat _ (Left e) = Left e
propagateErrorConcat (Right matches) (Right rs) = Right (if matches then n:rs else rs)
isHidden ('.':_) = True
isHidden _ = False
listPlain :: FilePath -> String -> IO (Either GlobError [String])
listPlain dirName baseName = do
exists <- if null baseName
then doesDirectoryExist dirName
else doesNameExist (dirName </> baseName)
return (Right (if exists then [baseName] else []))
doesNameExist :: FilePath -> IO Bool
doesNameExist name = do
fileExists <- doesFileExist name
if fileExists
then return True
else doesDirectoryExist name
{-- End of code from examples --}
-- ghci> :l 8_c_2.hs
-- [1 of 2] Compiling Module_8_c_1 ( Module_8_c_1.hs, interpreted )
-- [2 of 2] Compiling Main ( 8_c_2.hs, interpreted )
-- Ok, two modules loaded.
-- ghci> namesMatching "*.hs"
-- Right ["./8_b_3.hs","./8_a_2.hs","./8_a_1.hs","./GlobRegex.hs","./8_c_2.hs","./Module_8_c_1.hs"]
-- ghci> namesMatching "*/[d]*/*.c"
-- Right ["./test-8_b_3/dir1/A.c","./test-8_b_3/dir1/B.c"]
-- ghci> namesMatching "*/[/*.c"
-- Left "unterminated character class"
-- ghci> namesMatching "*/[]/*.c"
-- Left "unterminated character class"
|
