module GhcMod.Stack where
import Safe
import Control.Applicative
import Control.Exception as E
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class
import Data.List
import Data.List.Split
import Data.Maybe
import System.Directory
import System.FilePath
import System.Info.Extra
import Exception
import GhcMod.Types
import GhcMod.Monad.Types
import GhcMod.Output
import GhcMod.Logging
import GhcMod.Error
import qualified GhcMod.Utils as U
import Prelude
patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs
patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do
Just ghc <- getStackGhcPath senv
Just ghcPkg <- getStackGhcPkgPath senv
return $ progs {
ghcProgram = ghc
, ghcPkgProgram = ghcPkg
}
patchStackPrograms _crdl progs = return progs
getStackEnv :: (IOish m, GmOut m, GmLog m)
=> FilePath -> FilePath -> m (Maybe StackEnv)
getStackEnv projdir stackProg = U.withDirectory_ projdir $ runMaybeT $ do
env <- map (liToTup . splitOn ": ") . lines <$> readStack stackProg ["path"]
let look k = fromJustNote "getStackEnv" $ lookup k env
return StackEnv {
seDistDir = look "dist-dir"
, seBinPath = splitSearchPath $ look "bin-path"
, seSnapshotPkgDb = look "snapshot-pkg-db"
, seLocalPkgDb = look "local-pkg-db"
}
where
liToTup [k,v] = (k,v)
liToTup [k] = (k, error "getStackEnv: missing key '"++k++"'")
liToTup _ = error "getStackEnv"
getStackGhcPath :: IOish m => StackEnv -> m (Maybe FilePath)
getStackGhcPath = findExecutablesInStackBinPath "ghc"
getStackGhcPkgPath :: IOish m => StackEnv -> m (Maybe FilePath)
getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg"
findExecutablesInStackBinPath :: IOish m => String -> StackEnv -> m (Maybe FilePath)
findExecutablesInStackBinPath exe StackEnv {..} =
liftIO $ listToMaybe <$> findExecutablesInDirectories' seBinPath exe
findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath]
findExecutablesInDirectories' path binary =
U.findFilesWith' isExecutable path (binary <.> exeExtension')
where isExecutable file = do
perms <- getPermissions file
return $ executable perms
exeExtension' = if isWindows then "exe" else ""
readStack :: (IOish m, GmOut m, GmLog m)
=> FilePath -> [String] -> MaybeT m String
readStack exe args = do
stack <- MaybeT $ liftIO $ findExecutable exe
readProc <- lift gmReadProcess
flip gcatch handler $ do
liftIO $ evaluate =<< readProc stack args ""
where
handler (e :: IOError) = do
gmLog GmWarning "readStack" $ gmeDoc $ exToErr e
mzero
exToErr = GMEStackBootstrap . GMEString . show