diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs --- a/CabalHelper/Main.hs +++ b/CabalHelper/Main.hs @@ -94,6 +94,7 @@ ++" | ghc-options [--with-inplace]\n" ++" | ghc-src-options [--with-inplace]\n" ++" | ghc-pkg-options [--with-inplace]\n" + ++" | ghc-merged-pkg-options [--with-inplace]\n" ++" | ghc-lang-options [--with-inplace]\n" ++" | entrypoints\n" ++" | source-dirs\n" @@ -126,6 +127,7 @@ v <- maybe silent (const deafening) . lookup "GHC_MOD_DEBUG" <$> getEnvironment lbi <- unsafeInterleaveIO $ getPersistBuildConfig distdir let pd = localPkgDescr lbi + let lvd = (lbi, v, distdir) let -- a =<< b $$ c == (a =<< b) $$ c @@ -173,18 +175,10 @@ opts = componentGhcOptions normal lbi bi clbi' outdir in renderGhcOptions' lbi v (opts `mappend` adopts) - return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])]) + return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) "ghc-src-options":flags -> do - res <- componentsMap lbi v distdir $ \c clbi bi -> let - outdir = componentOutDir lbi c - (clbi', adopts) = case flags of - ["--with-inplace"] -> (clbi, mempty) - [] -> removeInplaceDeps v lbi pd clbi - opts = componentGhcOptions normal lbi bi clbi' outdir - comp = compiler lbi - - opts' = mempty { + res <- componentOptions lvd flags $ \opts -> mempty { -- Not really needed but "unexpected package db stack: []" ghcOptPackageDBs = [GlobalPackageDB, UserPackageDB], @@ -195,44 +189,43 @@ ghcOptSourcePathClear = ghcOptSourcePathClear opts, ghcOptSourcePath = ghcOptSourcePath opts } - in renderGhcOptions' lbi v $ opts `mappend` adopts - return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])]) + return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) "ghc-pkg-options":flags -> do - res <- componentsMap lbi v distdir $ \c clbi bi -> let - comp = compiler lbi - outdir = componentOutDir lbi c - (clbi', adopts) = case flags of - ["--with-inplace"] -> (clbi, mempty) - [] -> removeInplaceDeps v lbi pd clbi - opts = componentGhcOptions normal lbi bi clbi' outdir + res <- componentOptions lvd flags $ \opts -> mempty { + ghcOptPackageDBs = ghcOptPackageDBs opts, + ghcOptPackages = ghcOptPackages opts, + ghcOptHideAllPackages = ghcOptHideAllPackages opts + } + return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) - opts' = mempty { + "ghc-merged-pkg-options":flags -> do + let pd = localPkgDescr lbi + res <- mconcat . map snd <$> (componentsMap lbi v distdir $ \c clbi bi -> let + outdir = componentOutDir lbi c + opts = componentGhcOptions normal lbi bi clbi outdir + comp = compiler lbi + opts' = mempty { ghcOptPackageDBs = ghcOptPackageDBs opts, ghcOptPackages = ghcOptPackages opts, ghcOptHideAllPackages = ghcOptHideAllPackages opts } - in renderGhcOptions' lbi v $ opts' `mappend` adopts - return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])]) - "ghc-lang-options":flags -> do - res <- componentsMap lbi v distdir $ \c clbi bi -> let - comp = compiler lbi - outdir = componentOutDir lbi c - (clbi', adopts) = case flags of - ["--with-inplace"] -> (clbi, mempty) - [] -> removeInplaceDeps v lbi pd clbi - opts = componentGhcOptions normal lbi bi clbi' outdir + in return opts') - opts' = mempty { + let res' = res { ghcOptPackageDBs = nub $ ghcOptPackageDBs res } + + Just . ChResponseList <$> renderGhcOptions' lbi v res' + + "ghc-lang-options":flags -> do + res <- componentOptions lvd flags $ \opts -> mempty { ghcOptPackageDBs = [GlobalPackageDB, UserPackageDB], ghcOptLanguage = ghcOptLanguage opts, ghcOptExtensions = ghcOptExtensions opts, ghcOptExtensionMap = ghcOptExtensionMap opts } - in renderGhcOptions' lbi v $ opts' `mappend` adopts - return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])]) + return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) "entrypoints":[] -> do eps <- componentsMap lbi v distdir $ \c clbi bi -> @@ -244,7 +237,7 @@ "source-dirs":[] -> do res <- componentsMap lbi v distdir $$ \_ _ bi -> return $ hsSourceDirs bi - return $ Just $ ChResponseStrings (res ++ [(ChSetupHsName, [])]) + return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) "print-lbi":[] -> return $ Just $ ChResponseLbi $ show lbi @@ -292,6 +285,20 @@ writeIORef lr $ (componentNameToCh name, r):l' reverse <$> readIORef lr + +componentOptions (lbi, v, distdir) flags f = do + let pd = localPkgDescr lbi + componentsMap lbi v distdir $ \c clbi bi -> let + outdir = componentOutDir lbi c + (clbi', adopts) = case flags of + ["--with-inplace"] -> (clbi, mempty) + [] -> removeInplaceDeps v lbi pd clbi + opts = componentGhcOptions normal lbi bi clbi' outdir + comp = compiler lbi + opts' = f opts + + in renderGhcOptions' lbi v $ opts' `mappend` adopts + componentNameToCh CLibName = ChLibName componentNameToCh (CExeName n) = ChExeName n diff --git a/CabalHelper/Types.hs b/CabalHelper/Types.hs --- a/CabalHelper/Types.hs +++ b/CabalHelper/Types.hs @@ -14,7 +14,7 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE DeriveGeneric, DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DefaultSignatures #-} module CabalHelper.Types where import GHC.Generics @@ -31,8 +31,9 @@ deriving (Eq, Ord, Read, Show, Generic) data ChResponse - = ChResponseStrings [(ChComponentName, [String])] + = ChResponseCompList [(ChComponentName, [String])] | ChResponseEntrypoints [(ChComponentName, ChEntrypoint)] + | ChResponseList [String] | ChResponseLbi String | ChResponseVersion String Version deriving (Eq, Ord, Read, Show, Generic) diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs --- a/CabalHelper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -148,6 +148,8 @@ -- | Check if this version is globally available compileGlobal :: FilePath -> MaybeT IO (Either ExitCode FilePath) compileGlobal chdir = do + -- TODO: add option to let user specify custom package-db, relevant when + -- using a Cabal compiled from git! _ <- MaybeT $ find (== cabalVer) <$> listCabalVersions opts liftIO $ compileWithPkg chdir Nothing @@ -190,7 +192,7 @@ cabalPkgId v = "Cabal-" ++ showVersion v errorInstallCabal :: Version -> FilePath -> a -errorInstallCabal cabalVer distdir = panic $ printf "\ +errorInstallCabal cabalVer _distdir = panic $ printf "\ \Installing Cabal version %s failed.\n\ \\n\ \You have the following choices to fix this:\n\ @@ -295,8 +297,9 @@ appdir <- appDataDir let sver = showVersion ver hPutStr stderr $ printf "\ -\cabal-helper-wrapper: Installing a private copy of Cabal, this might take a\n\ -\while but will only happen once per Cabal version.\n\ +\cabal-helper-wrapper: Installing a private copy of Cabal because we couldn't\n\ +\find the right version in your global/user package-db, this might take a\n\ +\while but will only happen once per Cabal version you're using.\n\ \\n\ \If anything goes horribly wrong just delete this directory and try again:\n\ \ %s\n\ diff --git a/Distribution/Helper.hs b/Distribution/Helper.hs --- a/Distribution/Helper.hs +++ b/Distribution/Helper.hs @@ -32,6 +32,7 @@ , ghcOptions , ghcSrcOptions , ghcPkgOptions + , ghcMergedPkgOptions , ghcLangOptions -- * Result types @@ -85,12 +86,13 @@ def = Programs "cabal" "ghc" "ghc-pkg" data SomeLocalBuildInfo = SomeLocalBuildInfo { - slbiEntrypoints :: [(ChComponentName, ChEntrypoint)], - slbiSourceDirs :: [(ChComponentName, [String])], - slbiGhcOptions :: [(ChComponentName, [String])], - slbiGhcSrcOptions :: [(ChComponentName, [String])], - slbiGhcPkgOptions :: [(ChComponentName, [String])], - slbiGhcLangOptions :: [(ChComponentName, [String])] + slbiEntrypoints :: [(ChComponentName, ChEntrypoint)], + slbiSourceDirs :: [(ChComponentName, [String])], + slbiGhcOptions :: [(ChComponentName, [String])], + slbiGhcSrcOptions :: [(ChComponentName, [String])], + slbiGhcPkgOptions :: [(ChComponentName, [String])], + slbiGhcMergedPkgOptions :: [String], + slbiGhcLangOptions :: [(ChComponentName, [String])] } deriving (Eq, Ord, Read, Show) -- | Caches helper executable result so it doesn't have to be run more than once @@ -149,15 +151,19 @@ -- access any home modules. ghcPkgOptions :: MonadIO m => Query m [(ChComponentName, [String])] +-- | Like @ghcPkgOptions@ but for the whole package not just one component +ghcMergedPkgOptions :: MonadIO m => Query m [String] + -- | Only language related options, i.e. @-XSomeExtension@ ghcLangOptions :: MonadIO m => Query m [(ChComponentName, [String])] -entrypoints = Query $ slbiEntrypoints `liftM` getSlbi -sourceDirs = Query $ slbiSourceDirs `liftM` getSlbi -ghcOptions = Query $ slbiGhcOptions `liftM` getSlbi -ghcSrcOptions = Query $ slbiGhcSrcOptions `liftM` getSlbi -ghcPkgOptions = Query $ slbiGhcPkgOptions `liftM` getSlbi -ghcLangOptions = Query $ slbiGhcLangOptions `liftM` getSlbi +entrypoints = Query $ slbiEntrypoints `liftM` getSlbi +sourceDirs = Query $ slbiSourceDirs `liftM` getSlbi +ghcOptions = Query $ slbiGhcOptions `liftM` getSlbi +ghcSrcOptions = Query $ slbiGhcSrcOptions `liftM` getSlbi +ghcPkgOptions = Query $ slbiGhcPkgOptions `liftM` getSlbi +ghcMergedPkgOptions = Query $ slbiGhcMergedPkgOptions `liftM` getSlbi +ghcLangOptions = Query $ slbiGhcLangOptions `liftM` getSlbi -- | Run @cabal configure@ reconfigure :: MonadIO m @@ -188,6 +194,7 @@ , "ghc-options" , "ghc-src-options" , "ghc-pkg-options" + , "ghc-merged-pkg-options" , "ghc-lang-options" ] ++ progArgs @@ -200,14 +207,15 @@ , " (read failed)"] let [ Just (ChResponseEntrypoints eps), - Just (ChResponseStrings srcDirs), - Just (ChResponseStrings ghcOpts), - Just (ChResponseStrings ghcSrcOpts), - Just (ChResponseStrings ghcPkgOpts), - Just (ChResponseStrings ghcLangOpts) ] = res + Just (ChResponseCompList srcDirs), + Just (ChResponseCompList ghcOpts), + Just (ChResponseCompList ghcSrcOpts), + Just (ChResponseCompList ghcPkgOpts), + Just (ChResponseList ghcMergedPkgOpts), + Just (ChResponseCompList ghcLangOpts) ] = res return $ SomeLocalBuildInfo - eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts ghcLangOpts + eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts ghcMergedPkgOpts ghcLangOpts -- | Create @cabal_macros.h@ and @Paths_\@ possibly other generated files -- in the usual place. diff --git a/cabal-helper.cabal b/cabal-helper.cabal --- a/cabal-helper.cabal +++ b/cabal-helper.cabal @@ -1,5 +1,5 @@ name: cabal-helper -version: 0.3.4.0 +version: 0.3.5.0 synopsis: Simple interface to Cabal's configuration state used by ghc-mod description: @cabal-helper@ provides a library which wraps the internal use of executables @@ -83,3 +83,5 @@ GHC-Options: -Wall Build-Depends: base >= 4.5 && < 5 , cabal-helper + , extra + , unix diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -1,4 +1,10 @@ import Distribution.Helper +import System.Environment.Extra (lookupEnv) +import System.Posix.Env (setEnv) +import Data.Maybe +import Data.Functor +main :: IO () main = do + flip (setEnv "HOME") True =<< fromMaybe "/tmp" <$> lookupEnv "TMPDIR" writeAutogenFiles "./dist"