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

95 lines
3.0 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
2014-04-19 06:17:36 +00:00
module Language.Haskell.GhcMod.Utils where
2014-04-19 06:20:16 +00:00
2014-11-02 18:00:25 +00:00
import Control.Arrow
import Data.Char
import Language.Haskell.GhcMod.Error
import MonadUtils (MonadIO, liftIO)
2014-11-01 21:02:47 +00:00
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist)
2014-04-30 23:48:03 +00:00
import System.Exit (ExitCode(..))
import System.Process (readProcessWithExitCode)
2014-11-02 18:00:25 +00:00
import System.Directory (getTemporaryDirectory)
2014-11-02 18:27:40 +00:00
import System.FilePath (splitDrive, pathSeparators)
2014-11-02 18:00:25 +00:00
import System.IO.Temp (createTempDirectory)
#ifndef SPEC
2014-10-06 06:55:16 +00:00
import Control.Applicative ((<$>))
import System.Environment
import System.FilePath ((</>), takeDirectory)
#endif
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) []
extractParens :: String -> String
extractParens str = extractParens' str 0
where
extractParens' :: String -> Int -> String
extractParens' [] _ = []
extractParens' (s:ss) level
| s `elem` "([{" = s : extractParens' ss (level+1)
| level == 0 = extractParens' ss 0
2014-07-17 08:16:44 +00:00
| s `elem` "}])" && level == 1 = [s]
| s `elem` "}])" = s : extractParens' ss (level-1)
| otherwise = s : extractParens' ss level
readProcess' :: (MonadIO m, MonadError GhcModError m)
=> String
-> [String]
-> m String
2014-04-30 23:48:03 +00:00
readProcess' cmd opts = do
(rv,output,err) <- liftIO (readProcessWithExitCode cmd opts "")
`modifyError'` GMEProcess ([cmd] ++ opts)
2014-04-30 23:48:03 +00:00
case rv of
ExitFailure val -> do
throwError $ GMEProcess ([cmd] ++ opts) $ strMsg $
cmd ++ " " ++ unwords opts ++ " (exit " ++ show val ++ ")"
++ "\n" ++ err
2014-04-30 23:48:03 +00:00
ExitSuccess ->
return output
2014-05-01 00:10:42 +00:00
withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
2014-05-01 00:10:42 +00:00
withDirectory_ dir action =
gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action)
2014-11-02 18:00:25 +00:00
uniqTempDirName :: FilePath -> FilePath
2014-12-17 16:53:09 +00:00
uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++)
2014-11-02 18:00:25 +00:00
$ map escapeDriveChar *** map escapePathChar
$ splitDrive dir
where
escapeDriveChar c
| isAlphaNum c = c
| otherwise = '-'
escapePathChar c
| c `elem` pathSeparators = '-'
| otherwise = c
newTempDir :: FilePath -> IO FilePath
newTempDir dir =
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
2014-11-01 21:02:47 +00:00
mightExist :: FilePath -> IO (Maybe FilePath)
mightExist f = do
exists <- doesFileExist f
return $ if exists then (Just f) else (Nothing)
-- | 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 <- getExecutablePath'
return $ dir </> "ghc-mod"
where
getExecutablePath' :: IO FilePath
# if __GLASGOW_HASKELL__ >= 706
getExecutablePath' = takeDirectory <$> getExecutablePath
# else
getExecutablePath' = return ""
# endif
2014-10-06 06:29:05 +00:00
#else
ghcModExecutable = return "dist/build/ghc-mod/ghc-mod"
#endif