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

165 lines
5.5 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 (fromMaybe)
import Data.Either (rights)
import Data.List (inits)
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-09-08 03:20:26 +00:00
import System.Directory
2015-06-01 14:54:50 +00:00
import System.Environment
2015-09-08 03:20:26 +00:00
import System.FilePath
import System.IO.Temp (createTempDirectory)
2015-06-01 14:54:50 +00:00
import System.Process (readProcess)
import Text.Printf
2016-08-03 11:14:31 +00:00
import Paths_ghc_mod (getLibexecDir, getBinDir)
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
2015-12-30 13:24:56 +00:00
newTempDir _dir =
flip createTempDirectory "ghc-mod" =<< 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
2016-08-03 11:14:31 +00:00
ghcModExecutable = do
gpp <- lookupEnv "STACK_EXE"
case gpp of
Just _ -> fmap (</> "ghc-mod") getBinDir
_ -> fmap (</> "dist/build/ghc-mod/ghc-mod") getCurrentDirectory
#endif
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 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
2015-07-04 14:49:48 +00:00
mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath)
mkRevRedirMapFunc = do
rm <- M.fromList <$> map (uncurry mf) <$> M.toList <$> getMMappedFiles
2015-07-04 14:49:48 +00:00
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
2015-09-08 03:20:26 +00:00
-- Copyright : (c) The University of Glasgow 2001
-- | Make a path absolute by prepending the current directory (if it isn't
-- already absolute) and applying 'normalise' to the result.
--
-- If the path is already absolute, the operation never fails. Otherwise, the
-- operation may fail with the same exceptions as 'getCurrentDirectory'.
makeAbsolute' :: FilePath -> IO FilePath
makeAbsolute' = (normalise <$>) . absolutize
where absolutize path -- avoid the call to `getCurrentDirectory` if we can
| isRelative path = (</> path) <$> getCurrentDirectory
2015-09-08 03:20:26 +00:00
| otherwise = return path