ghc-mod/core/GhcMod/Stack.hs
Daniel Gröber 35690941aa Reorganize module namespace
- Remove Language.Haskell prefix from all modules
- Move 'GHCMod.*' to 'GhcMod.Exe'
- Move 'GhcModExe' to 'GhcMod.Exe'
2017-05-28 04:23:37 +02:00

98 lines
3.4 KiB
Haskell

-- ghc-mod: Happy Haskell Hacking
-- 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/>.
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