{-# LANGUAGE CPP #-}
{-# LANGUAGE DoAndIfThenElse #-}
module Language.Haskell.GhcMod.Utils (
module Language.Haskell.GhcMod.Utils
, module Utils
, readProcess
) where
import Control.Applicative
import Data.Char
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Either (rights)
import Data.List (inits)
import Exception
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import System.Directory
import System.Environment
import System.FilePath
import System.IO.Temp (createTempDirectory)
import System.Process (readProcess)
import Text.Printf
import Paths_ghc_mod (getLibexecDir)
import Utils
import Prelude
dropWhileEnd :: (a -> Bool) -> [a] -> [a]
dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
withDirectory_ dir action =
gbracket
(liftIO getCurrentDirectory)
(liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action)
uniqTempDirName :: FilePath -> FilePath
uniqTempDirName dir =
"ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
where
(drive, path) = splitDrive dir
escapeDriveChar :: Char -> Char
escapeDriveChar c
| isAlphaNum c = c
| otherwise = '-'
escapePathChar :: Char -> Char
escapePathChar c
| c `elem` pathSeparators = '-'
| otherwise = c
newTempDir :: FilePath -> IO FilePath
newTempDir _dir =
flip createTempDirectory "ghc-mod" =<< getTemporaryDirectory
whenM :: Monad m => m Bool -> m () -> m ()
whenM mb ma = mb >>= flip when ma
ghcModExecutable :: IO FilePath
#ifndef SPEC
ghcModExecutable = do
dir <- takeDirectory <$> getExecutablePath'
return $ (if dir == "." then "" else dir) </> "ghc-mod"
#else
ghcModExecutable = fmap (</> "dist/build/ghc-mod/ghc-mod") getCurrentDirectory
#endif
findLibexecExe :: String -> IO FilePath
findLibexecExe "cabal-helper-wrapper" = do
libexecdir <- getLibexecDir
let exeName = "cabal-helper-wrapper"
exe = libexecdir </> exeName
exists <- doesFileExist exe
if exists
then return exe
else do
mdir <- tryFindGhcModTreeDataDir
case mdir of
Nothing ->
error $ libexecNotExitsError exeName libexecdir
Just dir ->
return $ dir </> "dist" </> "build" </> exeName </> exeName
findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe
libexecNotExitsError :: String -> FilePath -> String
libexecNotExitsError exe dir = printf
( "Could not find $libexecdir/%s\n"
++"\n"
++"If you are a developer set the environment variable `ghc_mod_libexecdir'\n"
++"to override $libexecdir[1] the following will work in the ghc-mod tree:\n"
++"\n"
++" $ export ghc_mod_libexecdir=$PWD/dist/build/%s\n"
++"\n"
++"[1]: %s\n"
++"\n"
++"If you don't know what I'm talking about something went wrong with your\n"
++"installation. Please report this problem here:\n"
++"\n"
++" https://github.com/kazu-yamamoto/ghc-mod/issues") exe exe dir
tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath)
tryFindGhcModTreeLibexecDir = do
exe <- getExecutablePath'
dir <- case takeFileName exe of
"ghc" -> getCurrentDirectory
_ -> return $ (!!4) $ iterate takeDirectory exe
exists <- doesFileExist $ dir </> "ghc-mod.cabal"
return $ if exists
then Just dir
else Nothing
tryFindGhcModTreeDataDir :: IO (Maybe FilePath)
tryFindGhcModTreeDataDir = do
dir <- (!!4) . iterate takeDirectory <$> getExecutablePath'
exists <- doesFileExist $ dir </> "ghc-mod.cabal"
return $ if exists
then Just dir
else Nothing
readLibExecProcess' :: (MonadIO m, ExceptionMonad m)
=> String -> [String] -> m String
readLibExecProcess' cmd args = do
exe <- liftIO $ findLibexecExe cmd
liftIO $ readProcess exe args ""
getExecutablePath' :: IO FilePath
#if __GLASGOW_HASKELL__ >= 706
getExecutablePath' = getExecutablePath
#else
getExecutablePath' = getProgName
#endif
canonFilePath :: FilePath -> IO FilePath
canonFilePath f = do
p <- canonicalizePath f
e <- doesFileExist p
when (not e) $ error $ "canonFilePath: not a file: " ++ p
return p
withMappedFile :: (IOish m, GmState m, GmEnv m) =>
forall a. FilePath -> (FilePath -> m a) -> m a
withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile >>= runWithFile
where
runWithFile (Just to) = action $ fmPath to
runWithFile _ = action file
getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath
getCanonicalFileNameSafe fn = do
let fn' = normalise fn
pl <- liftIO $ rights <$> (mapM ((try :: IO FilePath -> IO (Either SomeException FilePath)) . canonicalizePath . joinPath) $ reverse $ inits $ splitPath' fn')
return $
if (length pl > 0)
then joinPath $ (head pl):(drop (length pl - 1) (splitPath fn'))
else error "Current dir doesn't seem to exist?"
where
#if __GLASGOW_HASKELL__ < 710
splitPath' = (".":) . splitPath
#else
splitPath' = splitPath
#endif
mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath)
mkRevRedirMapFunc = do
rm <- M.fromList <$> map (uncurry mf) <$> M.toList <$> getMMappedFiles
crdl <- cradle
return $ \key ->
fromMaybe key
$ makeRelative (cradleRootDir crdl)
<$> M.lookup key rm
where
mf :: FilePath -> FileMapping -> (FilePath, FilePath)
mf from to = (fmPath to, from)
findFilesWith' :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath]
findFilesWith' _ [] _ = return []
findFilesWith' f (d:ds) fileName = do
let file = d </> fileName
exist <- doesFileExist file
b <- if exist then f file else return False
if b then do
files <- findFilesWith' f ds fileName
return $ file : files
else findFilesWith' f ds fileName
makeAbsolute' :: FilePath -> IO FilePath
makeAbsolute' = (normalise <$>) . absolutize
where absolutize path
| isRelative path = (</> path) <$> getCurrentDirectory
| otherwise = return path