Pass stack ghc paths down to cabal-helper
This commit is contained in:
parent
85722ab6f2
commit
2a0414f368
@ -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)
|
||||
)
|
||||
|
@ -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 $
|
||||
|
@ -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 _) =
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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"]
|
||||
|
Loading…
Reference in New Issue
Block a user