4f6406c66dd028729b03ed8cbe2beafb7635cc03
[ghc.git] / src / Hadrian / Oracles / Path.hs
1 {-# LANGUAGE TypeFamilies #-}
2 module Hadrian.Oracles.Path (
3 lookupInPath, bashPath, fixAbsolutePathOnWindows, pathOracle
4 ) where
5
6 import Control.Monad
7 import Data.Maybe
8 import Data.Char
9 import Data.List.Extra
10 import Development.Shake
11 import Development.Shake.Classes
12 import Development.Shake.FilePath
13 import System.Directory
14 import System.Info.Extra
15
16 import Hadrian.Utilities
17
18 -- | Lookup a specified 'FilePath' in the system @PATH@.
19 lookupInPath :: FilePath -> Action FilePath
20 lookupInPath name
21 | name == takeFileName name = askOracle $ LookupInPath name
22 | otherwise = return name
23
24 -- | Lookup the path to the @bash@ interpreter.
25 bashPath :: Action FilePath
26 bashPath = lookupInPath "bash"
27
28 -- | Fix an absolute path on Windows:
29 -- * "/c/" => "C:/"
30 -- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe"
31 fixAbsolutePathOnWindows :: FilePath -> Action FilePath
32 fixAbsolutePathOnWindows path = do
33 if isWindows
34 then do
35 let (dir, file) = splitFileName path
36 winDir <- askOracle $ WindowsPath dir
37 return $ winDir -/- file
38 else
39 return path
40
41 newtype LookupInPath = LookupInPath String
42 deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
43 type instance RuleResult LookupInPath = String
44
45 newtype WindowsPath = WindowsPath FilePath
46 deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
47 type instance RuleResult WindowsPath = String
48
49 -- | Oracles for looking up paths. These are slow and require caching.
50 pathOracle :: Rules ()
51 pathOracle = do
52 void $ addOracle $ \(WindowsPath path) -> do
53 Stdout out <- quietly $ cmd ["cygpath", "-m", path]
54 let windowsPath = unifyPath $ dropWhileEnd isSpace out
55 putLoud $ "| Windows path mapping: " ++ path ++ " => " ++ windowsPath
56 return windowsPath
57
58 void $ addOracle $ \(LookupInPath name) -> do
59 let unpack = fromMaybe . error $ "Cannot find executable " ++ quote name
60 path <- unifyPath <$> unpack <$> liftIO (findExecutable name)
61 putLoud $ "| Executable found: " ++ name ++ " => " ++ path
62 return path