ghc-mod/Language/Haskell/GhcMod/Utils.hs

202 lines
6.7 KiB
Haskell
Raw Normal View History

2015-03-03 19:28:34 +00:00
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP #-}
2015-06-01 14:54:50 +00:00
{-# LANGUAGE DoAndIfThenElse #-}
module Language.Haskell.GhcMod.Utils (
module Language.Haskell.GhcMod.Utils
, module Utils
, readProcess
) where
2014-04-19 06:20:16 +00:00
import Control.Applicative
2014-11-02 18:00:25 +00:00
import Data.Char
2015-07-04 14:49:48 +00:00
import qualified Data.Map as M
import Data.Maybe (mapMaybe, fromMaybe)
2015-06-01 14:54:50 +00:00
import Exception
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Types
2015-03-04 20:48:21 +00:00
import Language.Haskell.GhcMod.Monad.Types
2015-04-14 19:39:11 +00:00
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist,
getTemporaryDirectory, canonicalizePath, removeFile)
2015-06-01 14:54:50 +00:00
import System.Environment
import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
2015-07-04 14:49:48 +00:00
(</>), makeRelative)
import System.IO.Temp (createTempDirectory, openTempFile)
import System.IO (hPutStr, hClose)
2015-06-01 14:54:50 +00:00
import System.Process (readProcess)
import Text.Printf
import Paths_ghc_mod (getLibexecDir)
import Utils
2015-08-03 01:09:56 +00:00
import Prelude
2014-04-30 23:48:03 +00:00
2014-04-19 06:20:16 +00:00
-- dropWhileEnd is not provided prior to base 4.5.0.0.
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
2014-05-01 00:10:42 +00:00
withDirectory_ dir action =
2015-06-01 14:54:50 +00:00
gbracket
(liftIO getCurrentDirectory)
(liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action)
2014-11-02 18:00:25 +00:00
uniqTempDirName :: FilePath -> FilePath
2015-06-01 14:54:50 +00:00
uniqTempDirName dir =
"ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
where
(drive, path) = splitDrive dir
escapeDriveChar :: Char -> Char
2014-11-02 18:00:25 +00:00
escapeDriveChar c
2015-06-01 14:54:50 +00:00
| isAlphaNum c = c
| otherwise = '-'
escapePathChar :: Char -> Char
2014-11-02 18:00:25 +00:00
escapePathChar c
2015-06-01 14:54:50 +00:00
| c `elem` pathSeparators = '-'
| otherwise = c
2014-11-02 18:00:25 +00:00
newTempDir :: FilePath -> IO FilePath
newTempDir dir =
2015-06-01 14:54:50 +00:00
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
2014-11-02 18:00:25 +00:00
whenM :: Monad m => m Bool -> m () -> m ()
whenM mb ma = mb >>= flip when ma
2014-11-01 21:02:47 +00:00
-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
-- this is a guess but >=7.6 uses 'getExecutablePath'.
ghcModExecutable :: IO FilePath
#ifndef SPEC
ghcModExecutable = do
dir <- takeDirectory <$> getExecutablePath'
return $ (if dir == "." then "" else dir) </> "ghc-mod"
2014-10-06 06:29:05 +00:00
#else
ghcModExecutable = fmap (</> "dist/build/ghc-mod/ghc-mod") getCurrentDirectory
#endif
findLibexecExe :: String -> IO FilePath
findLibexecExe "cabal-helper-wrapper" = do
2015-06-01 14:54:50 +00:00
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
2015-03-05 15:50:06 +00:00
exe <- getExecutablePath'
dir <- case takeFileName exe of
2015-06-01 14:54:50 +00:00
"ghc" -> getCurrentDirectory -- we're probably in ghci; try CWD
_ -> return $ (!!4) $ iterate takeDirectory exe
exists <- doesFileExist $ dir </> "ghc-mod.cabal"
return $ if exists
2015-06-01 14:54:50 +00:00
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
2015-06-01 14:54:50 +00:00
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
2014-10-06 06:29:05 +00:00
#endif
2015-04-13 22:51:03 +00:00
2015-04-14 19:39:11 +00:00
canonFilePath :: FilePath -> IO FilePath
2015-04-13 22:51:03 +00:00
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 (RedirectedMapping to)) = action to
runWithFile (Just (MemoryMapping (Just src))) = do
crdl <- cradle
(fp,hndl) <- liftIO $ openTempFile (cradleTempDir crdl) (takeFileName file)
liftIO $ hPutStr hndl src
liftIO $ hClose hndl
result <- action fp
liftIO $ removeFile fp
return result
runWithFile _ = action file
getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath
getCanonicalFileNameSafe fn = do
crdl <- cradle
let ccfn = cradleCurrentDir crdl </> fn
fex <- liftIO $ doesFileExist ccfn
if fex
then liftIO $ canonicalizePath ccfn
else return ccfn
2015-07-04 14:49:48 +00:00
mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath)
mkRevRedirMapFunc = do
rm <- M.fromList <$> mapMaybe (uncurry mf) <$> M.toList <$> getMMappedFiles
crdl <- cradle
return $ \key ->
fromMaybe key
$ makeRelative (cradleRootDir crdl)
<$> M.lookup key rm
where
mf :: FilePath -> FileMapping -> Maybe (FilePath, FilePath)
mf from (RedirectedMapping to)
= Just (to, from)
mf _ _ = Nothing