-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- 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 . {-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.Utils ( module Language.Haskell.GhcMod.Utils , module Utils , readProcess ) where import Control.Arrow import Control.Applicative import Data.Char import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Monad.Types import Exception import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist) import System.Process (readProcess) import System.Directory (getTemporaryDirectory) import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators, ()) import System.IO.Temp (createTempDirectory) import System.Environment import System.Directory import Text.Printf import Paths_ghc_mod (getLibexecDir) import Utils -- 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 | s `elem` "}])" && level == 1 = [s] | s `elem` "}])" = s : extractParens' ss (level-1) | otherwise = s : extractParens' ss level 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"++) $ uncurry (++) $ 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 whenM :: IO Bool -> IO () -> IO () whenM mb ma = mb >>= flip when ma -- | 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" #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" -> do -- we're probably in ghci; try CWD 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 f = do p <- canonicalizePath f e <- doesFileExist p when (not e) $ error $ "canonFilePath: not a file: " ++ p return p