Move stack code into seperate module

This commit is contained in:
Daniel Gröber 2015-09-15 05:25:00 +02:00
parent 545f0557f2
commit 0b2a3458fd
7 changed files with 94 additions and 52 deletions

View File

@ -42,6 +42,7 @@ import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Output
import Language.Haskell.GhcMod.CustomPackageDb
import Language.Haskell.GhcMod.Stack
import System.FilePath
import System.Process
import System.Exit
@ -137,16 +138,6 @@ prepareCabalHelper = do
when (isCabalHelperProject $ cradleProject crdl) $
withCabal $ liftIO $ prepare readProc projdir distdir
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
withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a
withCabal action = do
crdl <- cradle

View File

@ -14,6 +14,7 @@ import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.Stack
import Control.Applicative
import Control.Monad

View File

@ -14,8 +14,8 @@ import Language.Haskell.GhcMod.Internal
import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.Pretty
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.Stack
----------------------------------------------------------------

View File

@ -23,6 +23,7 @@ import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.CabalHelper
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.CustomPackageDb
import Language.Haskell.GhcMod.Stack
ghcVersion :: Int
ghcVersion = read cProjectVersionInt
@ -72,7 +73,6 @@ getGhcPkgProgram = do
_ ->
return $ ghcPkgProgram progs
getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb]
getPackageDbStack = do
crdl <- cradle

View File

@ -86,46 +86,6 @@ findStackConfigFile dir = do
Just (d, Just a) -> return $ Just $ d </> a
Just (_, Nothing) -> error "findStackConfigFile"
getStackEnv :: (IOish m, GmOut m) => FilePath -> m (Maybe StackEnv)
getStackEnv projdir = U.withDirectory_ projdir $ runMaybeT $ do
env <- map (liToTup . splitOn ": ") . lines <$> readStack ["path"]
let look k = fromJust $ 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 _ = 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) => [String] -> MaybeT m String
readStack args = do
stack <- MaybeT $ liftIO $ findExecutable "stack"
readProc <- lift gmReadProcess
liftIO $ flip E.catch (\(e :: IOError) -> throw $ GMEStackBootrap $ show e) $ do
evaluate =<< readProc stack args ""
-- | Get path to sandbox config file
getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)
getSandboxDb crdl = do

View File

@ -0,0 +1,89 @@
-- 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/>.
module Language.Haskell.GhcMod.Stack where
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 Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Output
import qualified Language.Haskell.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) => FilePath -> m (Maybe StackEnv)
getStackEnv projdir = U.withDirectory_ projdir $ runMaybeT $ do
env <- map (liToTup . splitOn ": ") . lines <$> readStack ["path"]
let look k = fromJust $ 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 _ = 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) => [String] -> MaybeT m String
readStack args = do
stack <- MaybeT $ liftIO $ findExecutable "stack"
readProc <- lift gmReadProcess
lift $ flip gcatch (\(e :: IOError) -> exToErr e) $ do
liftIO $ evaluate =<< readProc stack args ""
where
exToErr = throw . GMEStackBootrap . show

View File

@ -138,6 +138,7 @@ Library
Language.Haskell.GhcMod.Pretty
Language.Haskell.GhcMod.Read
Language.Haskell.GhcMod.SrcUtils
Language.Haskell.GhcMod.Stack
Language.Haskell.GhcMod.Target
Language.Haskell.GhcMod.Types
Language.Haskell.GhcMod.Utils