From 0b2a3458fdba4b2fa60d58ab8124b38e77031408 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Tue, 15 Sep 2015 05:25:00 +0200 Subject: [PATCH] Move `stack` code into seperate module --- Language/Haskell/GhcMod/CabalHelper.hs | 11 +-- Language/Haskell/GhcMod/Cradle.hs | 1 + Language/Haskell/GhcMod/Debug.hs | 2 +- Language/Haskell/GhcMod/GhcPkg.hs | 2 +- Language/Haskell/GhcMod/PathsAndFiles.hs | 40 ----------- Language/Haskell/GhcMod/Stack.hs | 89 ++++++++++++++++++++++++ ghc-mod.cabal | 1 + 7 files changed, 94 insertions(+), 52 deletions(-) create mode 100644 Language/Haskell/GhcMod/Stack.hs diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index f9db18b..b95258c 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index c294d11..51d2afa 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index d5accbf..c1dcc02 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -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 ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index 9bff334..db2581d 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -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 diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 959e2b6..5a02c4b 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Stack.hs b/Language/Haskell/GhcMod/Stack.hs new file mode 100644 index 0000000..567fdda --- /dev/null +++ b/Language/Haskell/GhcMod/Stack.hs @@ -0,0 +1,89 @@ +-- 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 . + +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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 2d62ac1..827a5f4 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -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