diff --git a/CabalHelper/Data.hs b/CabalHelper/Data.hs --- a/CabalHelper/Data.hs +++ b/CabalHelper/Data.hs @@ -40,5 +40,6 @@ sourceFiles = [ ("Main.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Main.hs"))) , ("Common.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Common.hs"))) + , ("Sandbox.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Sandbox.hs"))) , ("Types.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Types.hs"))) ] diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs --- a/CabalHelper/Main.hs +++ b/CabalHelper/Main.hs @@ -79,6 +79,7 @@ import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO) import Text.Printf +import CabalHelper.Sandbox import CabalHelper.Common import CabalHelper.Types @@ -88,7 +89,7 @@ where usageMsg = "" ++"DIST_DIR ( version\n" - ++" | print-lbi\n" + ++" | print-lbi [--human]\n" ++" | write-autogen-files\n" ++" | compiler-version\n" ++" | ghc-options [--with-inplace]\n" @@ -244,8 +245,10 @@ res <- componentsMap lbi v distdir $$ \_ _ bi -> return $ hsSourceDirs bi return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) - "print-lbi":[] -> - return $ Just $ ChResponseLbi $ show lbi + "print-lbi":flags -> + case flags of + ["--human"] -> print lbi >> return Nothing + [] -> return $ Just $ ChResponseLbi $ show lbi cmd:_ | not (cmd `elem` commands) -> errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure @@ -348,16 +351,11 @@ = ChLibEntrypoint [] [] exeOutDir :: LocalBuildInfo -> String -> FilePath -exeOutDir lbi exeName = +exeOutDir lbi exeName' = ----- Copied from Distribution/Simple/GHC.hs:buildOrReplExe - -- exeNameReal, the name that GHC really uses (with .exe on Windows) - let exeNameReal = exeName <.> - (if takeExtension exeName /= ('.':exeExtension) - then exeExtension - else "") - - targetDir = (buildDir lbi) exeName - in targetDir + let targetDir = (buildDir lbi) exeName' + exeDir = targetDir (exeName' ++ "-tmp") + in exeDir removeInplaceDeps :: Verbosity diff --git a/CabalHelper/Sandbox.hs b/CabalHelper/Sandbox.hs new file mode 100644 --- /dev/null +++ b/CabalHelper/Sandbox.hs @@ -0,0 +1,56 @@ +module CabalHelper.Sandbox where + + +import Control.Applicative +import Data.Char +import Data.Maybe +import Data.List +import Data.Version +import System.FilePath +import System.Directory + +import qualified Data.Traversable as T + +-- | Get the path to the sandbox package-db in a project +getSandboxPkgDb :: FilePath + -- ^ Path to the cabal package root directory (containing the + -- @cabal.sandbox.config@ file) + -> String + -- ^ Cabal build platform, i.e. @buildPlatform@ + -> Version + -- ^ GHC version (@cProjectVersion@ is your friend) + -> IO (Maybe FilePath) +getSandboxPkgDb d platform ghcVer = do + mConf <- T.traverse readFile =<< mightExist (d "cabal.sandbox.config") + return $ fixPkgDbVer <$> (extractSandboxDbDir =<< mConf) + + where + fixPkgDbVer dir = + case takeFileName dir == ghcSandboxPkgDbDir platform ghcVer of + True -> dir + False -> takeDirectory dir ghcSandboxPkgDbDir platform ghcVer + +ghcSandboxPkgDbDir :: String -> Version -> String +ghcSandboxPkgDbDir platform ghcVer = + platform ++ "-ghc-" ++ showVersion ghcVer ++ "-packages.conf.d" + +-- | Extract the sandbox package db directory from the cabal.sandbox.config +-- file. Exception is thrown if the sandbox config file is broken. +extractSandboxDbDir :: String -> Maybe FilePath +extractSandboxDbDir conf = extractValue <$> parse conf + where + key = "package-db:" + keyLen = length key + + parse = listToMaybe . filter (key `isPrefixOf`) . lines + extractValue = CabalHelper.Sandbox.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen + + +mightExist :: FilePath -> IO (Maybe FilePath) +mightExist f = do + exists <- doesFileExist f + return $ if exists then (Just f) else (Nothing) + +-- dropWhileEnd is not provided prior to base 4.5.0.0. +dropWhileEnd :: (a -> Bool) -> [a] -> [a] +dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs --- a/CabalHelper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -373,6 +373,7 @@ \Building Cabal %s ...\n" appdir sver sver sver db <- createPkgDb opts ver + cabalInstallVer <- cabalInstallVersion opts cabal_opts <- return $ concat [ [ "--package-db=clear" @@ -381,6 +382,9 @@ , "--prefix=" ++ db "prefix" , "--with-ghc=" ++ ghcProgram opts ] + , if cabalInstallVer >= Version [1,20,0,0] [] + then ["--no-require-sandbox"] + else [] , if ghcPkgProgram opts /= ghcPkgProgram defaultOptions then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ] else [] @@ -401,6 +405,10 @@ ghcPkgVersion :: Options -> IO Version ghcPkgVersion Options {..} = do parseVer . trim . dropWhile (not . isDigit) <$> readProcess ghcPkgProgram ["--version"] "" + +cabalInstallVersion :: Options -> IO Version +cabalInstallVersion Options {..} = do + parseVer . trim <$> readProcess cabalProgram ["--numeric-version"] "" trim :: String -> String trim = dropWhileEnd isSpace diff --git a/Distribution/Helper.hs b/Distribution/Helper.hs --- a/Distribution/Helper.hs +++ b/Distribution/Helper.hs @@ -45,6 +45,9 @@ -- * General information , buildPlatform + -- * Stuff that cabal-install really should export + , Distribution.Helper.getSandboxPkgDb + -- * Managing @dist/@ , reconfigure , writeAutogenFiles @@ -55,27 +58,28 @@ ) where import Control.Applicative -import Control.Arrow import Control.Monad import Control.Monad.IO.Class import Control.Monad.State.Strict import Control.Monad.Reader import Control.Exception as E import Data.Char -import Data.Monoid import Data.List import Data.Default +import Data.Version import Data.Typeable import Distribution.Simple.BuildPaths (exeExtension) import System.Environment import System.FilePath import System.Directory import System.Process +import System.IO.Unsafe import Text.Printf import GHC.Generics import Paths_cabal_helper (getLibexecDir) import CabalHelper.Types +import CabalHelper.Sandbox -- | Paths or names of various programs we need. data Programs = Programs { @@ -109,6 +113,8 @@ , MonadState (Maybe SomeLocalBuildInfo) m , MonadReader (Programs, FilePath) m) +run :: Monad m + => (Programs, FilePath) -> Maybe SomeLocalBuildInfo -> Query m a -> m a run r s action = flip runReaderT r (flip evalStateT s (unQuery action)) -- | @runQuery query distdir@. Run a 'Query'. @distdir@ is where Cabal's @@ -235,14 +241,19 @@ exe <- findLibexecExe "cabal-helper-wrapper" void $ readProcess exe [distdir, "write-autogen-files"] "" +-- | Get the path to the sandbox package-db in a project +getSandboxPkgDb :: FilePath + -- ^ Cabal build platform, i.e. @buildPlatform@ + -> Version + -- ^ GHC version (@cProjectVersion@ is your friend) + -> IO (Maybe FilePath) +getSandboxPkgDb = + CabalHelper.Sandbox.getSandboxPkgDb $ unsafePerformIO buildPlatform + buildPlatform :: IO String buildPlatform = do exe <- findLibexecExe "cabal-helper-wrapper" - dropWhileEnd isSpace <$> readProcess exe ["print-build-platform"] "" - where - -- dropWhileEnd is not provided prior to base 4.5.0.0. - dropWhileEnd :: (a -> Bool) -> [a] -> [a] - dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] + CabalHelper.Sandbox.dropWhileEnd isSpace <$> readProcess exe ["print-build-platform"] "" -- | This exception is thrown by all 'runQuery' functions if the internal -- wrapper executable cannot be found. You may catch this and present the user 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.8.0 +version: 0.3.9.0 synopsis: Simple interface to some of Cabal's configuration state used by ghc-mod description: @cabal-helper@ provides a library which wraps the internal use of executables @@ -42,7 +42,9 @@ exposed-modules: Distribution.Helper Other-Modules: Paths_cabal_helper , CabalHelper.Types + , CabalHelper.Sandbox default-language: Haskell2010 + GHC-Options: -Wall Build-Depends: base >= 4.5 && < 5 , Cabal >= 1.14 && < 1.23 , data-default