blob: fb6549195e4fc2922c87fa0c88ff9ef75e941608 (
plain)
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
|
module Coolbal.FindRoot (
findCabalSpec,
FoundCabalSpec(..),
findDist,
FoundRootDir(..),
) where
import Data.List (unfoldr)
import System.Directory
import System.Exit (exitFailure)
import System.FilePath ((</>))
import System.IO (hPutStrLn, stderr)
data FoundCabalSpec = FoundCabalSpec
{ foundcsRootDir :: FilePath
, foundcsCabal :: FilePath }
deriving (Show)
findCabalSpec :: IO FoundCabalSpec
findCabalSpec = do
cwd <- getCurrentDirectory >>= makeAbsolute
mfound <- findThingInDirs "cabal file" (`endsWith` ".cabal") doesFileExist FoundCabalSpec (ancestors cwd)
case mfound of
Just found -> do
hPutStrLn stderr ("Found .cabal file: " ++ foundcsCabal found)
return found
Nothing -> do
hPutStrLn stderr (".cabal file not found in ancestors of PWD: " ++ cwd)
exitFailure
data FoundRootDir = FoundRootDir FilePath
deriving (Show)
findDist :: IO FoundRootDir
findDist = do
cwd <- getCurrentDirectory >>= makeAbsolute
mfound <- findThingInDirs "dist-coolbal directory" (== "dist-coolbal") doesDirectoryExist (\p _ -> FoundRootDir p) (ancestors cwd)
case mfound of
Just found -> return found
Nothing -> do
hPutStrLn stderr ("dist-coolbal directory not found in ancestors of PWD: " ++ cwd)
exitFailure
-- | Argument semantics are the same as 'findThingInDir'.
findThingInDirs :: String -> (FilePath -> Bool) -> (FilePath -> IO Bool) -> (FilePath -> FilePath -> a) -> [FilePath] -> IO (Maybe a)
findThingInDirs _ _ _ _ [] = return Nothing
findThingInDirs description namePred typePred constructor (p:ps) =
findThingInDir description namePred typePred constructor p
>>= maybe (findThingInDirs description namePred typePred constructor ps)
(return . Just)
-- | 'namePred' gets the file name, 'typePred' gets the full path.
-- 'constructor' gets the root dir path and the name of the file found.
findThingInDir :: String -> (FilePath -> Bool) -> (FilePath -> IO Bool) -> (FilePath -> FilePath -> a) -> FilePath -> IO (Maybe a)
findThingInDir description namePred typePred constructor dir = do
files <- filter namePred <$> listDirectory dir
case files of
[fname] -> do
ok <- typePred (dir </> fname)
return (if ok then Just (constructor dir (dir </> fname))
else Nothing)
[] -> return Nothing
_ -> do
hPutStrLn stderr ("Ambiguity when searching for " ++ description ++ "! Found files:")
mapM_ (\p -> hPutStrLn stderr ("- " ++ (dir </> p))) files
exitFailure
parentDir :: FilePath -> Maybe FilePath
parentDir s = case reverse s of
"/" -> Nothing
'/' : s' -> Just (reverse (dropWhile (/= '/') s'))
s' -> case dropWhile (/= '/') s' of
"/" -> Just "/"
_ : s'' -> Just (reverse s'')
"" -> Nothing
-- Includes the path itself as first element
ancestors :: FilePath -> [FilePath]
ancestors p = p : unfoldr (fmap (\x -> (x,x)) . parentDir) p
endsWith :: String -> String -> Bool
s `endsWith` s' = reverse (take (length s') (reverse s)) == s'
|
