From 2a0414f368ee62dfb0f32ce0fb6527f5d5e5c770 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 28 Aug 2015 09:44:20 +0200 Subject: [PATCH] Pass stack ghc paths down to cabal-helper --- Language/Haskell/GhcMod/CabalHelper.hs | 77 ++++++++++++++++++------ Language/Haskell/GhcMod/Debug.hs | 1 + Language/Haskell/GhcMod/Error.hs | 3 + Language/Haskell/GhcMod/PathsAndFiles.hs | 37 +++++++++++- Language/Haskell/GhcMod/Types.hs | 41 +++++++++---- Language/Haskell/GhcMod/Utils.hs | 11 ++++ ghc-mod.cabal | 14 +++-- src/GHCMod.hs | 15 +++-- 8 files changed, 154 insertions(+), 45 deletions(-) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index fac9d1a..9603805 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -34,10 +34,10 @@ import Data.Maybe import Data.Monoid import Data.Serialize (Serialize) import Data.Traversable -import Distribution.Helper +import Distribution.Helper hiding (Programs(..)) +import qualified Distribution.Helper as CH import qualified Language.Haskell.GhcMod.Types as T -import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram, - cabalProgram) +import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.PathsAndFiles @@ -45,6 +45,8 @@ import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Output import System.FilePath import System.Directory (findExecutable) +import System.Process +import System.Exit import Prelude hiding ((.)) import Paths_ghc_mod as GhcMod @@ -145,6 +147,18 @@ getStackPackageDbStack = do localDb <- liftIO $ readProcess stack ["path", "--local-pkg-db"] "" return $ map (PackageDb . takeWhile (/='\n')) [snapshotDb, localDb] +patchStackPrograms :: IOish m => Cradle -> Programs -> m Programs +patchStackPrograms crdl progs + | cradleProjectType crdl /= StackProject = return progs +patchStackPrograms crdl progs = do + let projdir = cradleRootDir crdl + Just ghc <- liftIO $ getStackGhcPath projdir + Just ghcPkg <- liftIO $ getStackGhcPkgPath projdir + return $ progs { + ghcProgram = ghc + , ghcPkgProgram = ghcPkg + } + withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a withCabal action = do crdl <- cradle @@ -163,7 +177,7 @@ withCabal action = do pkgDbStackOutOfSync <- case mCusPkgDbStack of Just cusPkgDbStack -> do - pkgDb <- runQuery'' readProc (helperProgs opts) projdir distdir $ + pkgDb <- runQuery'' readProc (helperProgs $ programs opts) projdir distdir $ map chPkgToGhcPkg <$> packageDbStack return $ pkgDb /= cusPkgDbStack @@ -185,31 +199,54 @@ withCabal action = do || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ case projType of CabalProject -> - cabalReconfigure readProc opts crdl projdir distdir + cabalReconfigure readProc (programs opts) crdl projdir distdir StackProject -> - -- https://github.com/commercialhaskell/stack/issues/820 - gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build'" + + stackReconfigure crdl (programs opts) _ -> error $ "withCabal: unsupported project type: " ++ show projType action where - cabalReconfigure readProc opts crdl projdir distdir = do + cabalReconfigure readProc progs crdl projdir distdir = do withDirectory_ (cradleRootDir crdl) $ do cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack let progOpts = - [ "--with-ghc=" ++ T.ghcProgram opts ] + [ "--with-ghc=" ++ T.ghcProgram progs ] -- Only pass ghc-pkg if it was actually set otherwise we -- might break cabal's guessing logic - ++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions - then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ] + ++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (programs defaultOptions) + then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ] else [] ++ map pkgDbArg cusPkgStack - liftIO $ void $ readProc (T.cabalProgram opts) ("configure":progOpts) "" + liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) "" gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files" liftIO $ writeAutogenFiles readProc projdir distdir + stackReconfigure crdl progs = do + withDirectory_ (cradleRootDir crdl) $ do + supported <- haveStackSupport + if supported + then do + spawn [T.stackProgram progs, "build", "--only-dependencies"] + spawn [T.stackProgram progs, "build", "--only-configure"] + else + gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build' as your stack version is too old (need at least 1.4.0.0)" + + spawn [] = return () + spawn (exe:args) = do + readProc <- gmReadProcess + liftIO $ void $ readProc exe args "" + + haveStackSupport = do + (rv, _, _) <- + liftIO $ readProcessWithExitCode "stack" ["--numeric-version"] "" + case rv of + ExitSuccess -> return True + ExitFailure _ -> return False + + pkgDbArg :: GhcPkgDb -> String pkgDbArg GlobalDb = "--package-db=global" @@ -233,12 +270,12 @@ isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do worldCabalConfig < worldCabalFile -helperProgs :: Options -> Programs -helperProgs opts = Programs { - cabalProgram = T.cabalProgram opts, - ghcProgram = T.ghcProgram opts, - ghcPkgProgram = T.ghcPkgProgram opts - } +helperProgs :: Programs -> CH.Programs +helperProgs progs = CH.Programs { + cabalProgram = T.cabalProgram progs, + ghcProgram = T.ghcProgram progs, + ghcPkgProgram = T.ghcPkgProgram progs + } chCached :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m, Serialize a) => (FilePath -> Cached m GhcModState ChCacheData a) -> m a @@ -252,7 +289,9 @@ chCached c = do -- changes the cache files will be gone anyways ;) cacheInputData root = do opt <- options - return $ ( helperProgs opt + crdl <- cradle + progs <- patchStackPrograms crdl (programs opt) + return $ ( helperProgs progs , root , (gmVer, chVer) ) diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 2441ec9..a1acd85 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -53,6 +53,7 @@ cabalDebug = do return $ [ "Cabal file: " ++ show cradleCabalFile + , "Cabal Project Type: " ++ show cradleProjectType , "Cabal entrypoints:\n" ++ render (nest 4 $ mapDoc gmComponentNameDoc smpDoc entrypoints) , "Cabal components:\n" ++ render (nest 4 $ diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index 965aa7e..3a3c786 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -140,6 +140,9 @@ gmeDoc e = case e of ++ intercalate "\", \"" cfs ++"\"." GMECabalStateFile csfe -> gmCsfeDoc csfe + GMEStackBootrap rv stderr -> + (text $ "Boostrapping stack project failed (exited with "++show rv++")") + <+>: text stderr ghcExceptionDoc :: GhcException -> Doc ghcExceptionDoc e@(CmdLineError _) = diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 0639e24..1b75940 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -31,6 +31,8 @@ import Distribution.Helper (buildPlatform) import System.Directory import System.FilePath import System.Process +import System.Info.Extra +import System.Exit import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Error @@ -76,9 +78,38 @@ findStackConfigFile :: FilePath -> IO (Maybe FilePath) findStackConfigFile dir = mightExist (dir "stack.yaml") getStackDistDir :: FilePath -> IO (Maybe FilePath) -getStackDistDir dir = U.withDirectory_ dir $ runMaybeT $ do - stack <- MaybeT $ findExecutable "stack" - liftIO $ takeWhile (/='\n') <$> readProcess stack ["path", "--dist-dir"] "" +getStackDistDir projdir = U.withDirectory_ projdir $ runMaybeT $ do + takeWhile (/='\n') <$> readStack ["path", "--dist-dir"] + +getStackGhcPath :: FilePath -> IO (Maybe FilePath) +getStackGhcPath = findExecutablesInStackBinPath "ghc" + +getStackGhcPkgPath :: FilePath -> IO (Maybe FilePath) +getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg" + +findExecutablesInStackBinPath :: String -> FilePath -> IO (Maybe FilePath) +findExecutablesInStackBinPath exe projdir = + U.withDirectory_ projdir $ runMaybeT $ do + path <- splitSearchPath . takeWhile (/='\n') + <$> readStack ["path", "--bin-path"] + MaybeT $ listToMaybe <$> findExecutablesInDirectories' path 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 :: [String] -> MaybeT IO String +readStack args = do + stack <- MaybeT $ findExecutable "stack" + (e, out, err) <- liftIO $ readProcessWithExitCode stack args "" + case e of + ExitSuccess -> return out + (ExitFailure rv) -> throw $ GMEStackBootrap rv err -- | Get path to sandbox config file getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 8525503..ff893fb 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes, StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} module Language.Haskell.GhcMod.Types ( @@ -27,7 +27,8 @@ import Data.Maybe import Data.Typeable (Typeable) import Data.IORef import Data.Label.Derive -import Distribution.Helper +import Distribution.Helper hiding (Programs(..)) +import qualified Distribution.Helper as CabalHelper import Exception (ExceptionMonad) #if __GLASGOW_HASKELL__ < 708 import qualified MonadUtils as GHC (MonadIO(..)) @@ -74,6 +75,19 @@ data FileMapping = FileMapping {fmPath :: FilePath, fmTemp :: Bool} type FileMappingMap = Map FilePath FileMapping +data ProgramSource = ProgramSourceUser | ProgramSourceStack + +data Programs = Programs { + -- | @ghc@ program name. + ghcProgram :: FilePath + -- | @ghc-pkg@ program name. + , ghcPkgProgram :: FilePath + -- | @cabal@ program name. + , cabalProgram :: FilePath + -- | @stack@ program name. + , stackProgram :: FilePath + } deriving (Show) + data Options = Options { outputStyle :: OutputStyle -- | Line separator string. @@ -83,12 +97,7 @@ data Options = Options { , linePrefix :: Maybe (String, String) -- | Verbosity , logLevel :: GmLogLevel - -- | @ghc@ program name. - , ghcProgram :: FilePath - -- | @ghc-pkg@ program name. - , ghcPkgProgram :: FilePath - -- | @cabal@ program name. - , cabalProgram :: FilePath + , programs :: Programs -- | GHC command line options set on the @ghc-mod@ command line , ghcUserOptions:: [GHCOption] -- | If 'True', 'browse' also returns operators. @@ -108,9 +117,12 @@ defaultOptions = Options { , lineSeparator = LineSeparator "\0" , linePrefix = Nothing , logLevel = GmWarning - , ghcProgram = "ghc" - , ghcPkgProgram = "ghc-pkg" - , cabalProgram = "cabal" + , programs = Programs { + ghcProgram = "ghc" + , ghcPkgProgram = "ghc-pkg" + , cabalProgram = "cabal" + , stackProgram = "stack" + } , ghcUserOptions = [] , operators = False , detailed = False @@ -366,6 +378,9 @@ data GhcModError | GMECabalStateFile GMConfigStateFileError -- ^ Reading Cabal's state configuration file falied somehow. + + | GMEStackBootrap Int String + -- ^ Bootstrapping @stack@ environment failed (process exited with failure) deriving (Eq,Show,Typeable) instance Error GhcModError where @@ -386,10 +401,12 @@ data GMConfigStateFileError deriving instance Generic Version instance Serialize Version -instance Serialize Programs +instance Serialize CabalHelper.Programs instance Serialize ChModuleName instance Serialize ChComponentName instance Serialize ChEntrypoint mkLabel ''GhcModCaches mkLabel ''GhcModState +mkLabel ''Options +mkLabel ''Programs diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 2ee4e4d..d4f8043 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -197,3 +197,14 @@ mkRevRedirMapFunc = do where mf :: FilePath -> FileMapping -> (FilePath, FilePath) mf from to = (fmPath to, from) + +findFilesWith' :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath] +findFilesWith' _ [] _ = return [] +findFilesWith' f (d:ds) fileName = do + let file = d fileName + exist <- doesFileExist file + b <- if exist then f file else return False + if b then do + files <- findFilesWith' f ds fileName + return $ file : files + else findFilesWith' f ds fileName diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 500a235..d24f528 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -98,11 +98,9 @@ Library GHC-Options: -Wall -fno-warn-deprecations Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, ConstraintKinds, FlexibleContexts, - DataKinds, KindSignatures, TypeOperators + DataKinds, KindSignatures, TypeOperators, ViewPatterns Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Internal - Other-Modules: Paths_ghc_mod - Utils Language.Haskell.GhcMod.Boot Language.Haskell.GhcMod.Browse Language.Haskell.GhcMod.CabalHelper @@ -142,6 +140,8 @@ Library Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.World + Other-Modules: Paths_ghc_mod + Utils Build-Depends: base >= 4.0 && < 5 , bytestring , cereal >= 0.4 @@ -169,7 +169,8 @@ Library , haskell-src-exts , text , djinn-ghc >= 0.0.2.2 - , fclabels + , fclabels == 2.0.* + , extra == 1.4.* if impl(ghc < 7.8) Build-Depends: convertible if impl(ghc < 7.5) @@ -181,7 +182,7 @@ Executable ghc-mod Default-Language: Haskell2010 Main-Is: GHCMod.hs Other-Modules: Paths_ghc_mod - GHC-Options: -Wall -fno-warn-deprecations + GHC-Options: -Wall -fno-warn-deprecations -threaded Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5 @@ -194,6 +195,7 @@ Executable ghc-mod , mtl >= 2.0 , ghc , ghc-mod + , fclabels == 2.0.* Executable ghc-modi Default-Language: Haskell2010 @@ -229,7 +231,7 @@ Test-Suite spec Default-Language: Haskell2010 Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, ConstraintKinds, FlexibleContexts, - DataKinds, KindSignatures, TypeOperators + DataKinds, KindSignatures, TypeOperators, ViewPatterns Main-Is: Main.hs Hs-Source-Dirs: test, . Ghc-Options: -Wall -fno-warn-deprecations diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 149d8c0..f27fc03 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -3,12 +3,13 @@ module Main where import Config (cProjectVersion) -import MonadUtils (liftIO) +import Control.Category import Control.Applicative import Control.Arrow import Control.Monad import Data.Typeable (Typeable) import Data.Version (showVersion) +import Data.Label import Data.List import Data.List.Split import Data.Char (isSpace) @@ -16,6 +17,7 @@ import Data.Maybe import Exception import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) +import Language.Haskell.GhcMod.Types import Paths_ghc_mod import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) import qualified System.Console.GetOpt as O @@ -26,7 +28,7 @@ import System.Environment (getArgs) import System.IO (stdout, hSetEncoding, utf8, hFlush) import System.Exit import Text.PrettyPrint -import Prelude +import Prelude hiding ((.)) import Misc @@ -313,13 +315,16 @@ Exposed functions: Right $ o { fileMappings = m : fileMappings o } , option "" ["with-ghc"] "GHC executable to use" $ - reqArg "PROG" $ \p o -> Right $ o { ghcProgram = p } + reqArg "PATH" $ \p o -> Right $ set (lGhcProgram . lPrograms) p o , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $ - reqArg "PROG" $ \p o -> Right $ o { ghcPkgProgram = p } + reqArg "PATH" $ \p o -> Right $ set (lGhcPkgProgram . lPrograms) p o , option "" ["with-cabal"] "cabal-install executable to use" $ - reqArg "PROG" $ \p o -> Right $ o { cabalProgram = p } + reqArg "PATH" $ \p o -> Right $ set (lCabalProgram . lPrograms) p o + + , option "" ["with-stack"] "stack executable to use" $ + reqArg "PATH" $ \p o -> Right $ set (lStackProgram . lPrograms) p o , option "" ["version"] "print version information" $ NoArg $ \_ -> Left ["version"]