diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Distribution/Helper.hs | 527 |
1 files changed, 527 insertions, 0 deletions
diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs new file mode 100644 index 0000000..73ad668 --- /dev/null +++ b/lib/Distribution/Helper.hs @@ -0,0 +1,527 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015,2017 Daniel Gröber <dxld ÄT darkboxed DOT org> +-- +-- 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 <http://www.gnu.org/licenses/>. + +{-# LANGUAGE CPP, RecordWildCards, FlexibleContexts, ConstraintKinds, + GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric, DeriveFunctor + #-} + +{-| +Module : Distribution.Helper +License : AGPL-3 +Maintainer : dxld@darkboxed.org +Portability : POSIX +-} + +module Distribution.Helper ( + -- * Running Queries + Query + , runQuery + + -- * Queries against Cabal\'s on disk state + + -- ** Package queries + , packageId + , packageDbStack + , packageFlags + , packageLicenses + , compilerVersion + + , ghcMergedPkgOptions + + -- ** cabal-install queries + , configFlags + , nonDefaultConfigFlags + + + -- ** Component queries + , ComponentQuery + , components + + , ghcSrcOptions + , ghcPkgOptions + , ghcLangOptions + , ghcOptions + , sourceDirs + , entrypoints + + -- * Query environment + , QueryEnv + , mkQueryEnv + , qeReadProcess + , qePrograms + , qeProjectDir + , qeDistDir + , qeCabalPkgDb + , qeCabalVer + + , Programs(..) + , defaultPrograms + + + -- * Result types + , ChModuleName(..) + , ChComponentName(..) + , ChPkgDb(..) + , ChEntrypoint(..) + + -- * General information + , buildPlatform + + -- * Stuff that cabal-install really should export + , Distribution.Helper.getSandboxPkgDb + + -- * Managing @dist/@ + , prepare + , reconfigure + , writeAutogenFiles + + -- * $libexec related error handling + , LibexecNotFoundError(..) + , libexecNotFoundError + + -- * Reexports + , module Data.Functor.Apply + ) where + +import Control.Applicative +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.List +import Data.Maybe +import Data.Version +import Data.Typeable +import Data.Functor.Apply +import Distribution.Simple.BuildPaths (exeExtension) +import System.Environment +import System.FilePath hiding ((<.>)) +import qualified System.FilePath as FP +import System.Directory +import System.Process +import System.IO.Unsafe +import Text.Printf +import GHC.Generics +import Prelude + +import Paths_cabal_helper (getLibexecDir) +import CabalHelper.Shared.InterfaceTypes +import CabalHelper.Shared.Sandbox + +-- | Paths or names of various programs we need. +data Programs = Programs { + -- | The path to the @cabal@ program. + cabalProgram :: FilePath, + + -- | The path to the @ghc@ program. + ghcProgram :: FilePath, + + -- | The path to the @ghc-pkg@ program. If + -- not changed it will be derived from the path to 'ghcProgram'. + ghcPkgProgram :: FilePath + } deriving (Eq, Ord, Show, Read, Generic, Typeable) + +-- | Default all programs to their unqualified names, i.e. they will be searched +-- for on @PATH@. +defaultPrograms :: Programs +defaultPrograms = Programs "cabal" "ghc" "ghc-pkg" + +-- | Environment for running a 'Query'. The real constructor is not exposed, +-- the field accessors are however. See below. Use the 'mkQueryEnv' smart +-- constructor to construct one. +data QueryEnv = QueryEnv { + -- | Field accessor for 'QueryEnv'. Defines how to start the cabal-helper + -- process. Useful if you need to capture stderr output from the helper. + qeReadProcess :: FilePath -> [String] -> String -> IO String, + + -- | Field accessor for 'QueryEnv'. + qePrograms :: Programs, + + -- | Field accessor for 'QueryEnv'. Defines path to the project directory, + -- i.e. a directory containing a @project.cabal@ file + qeProjectDir :: FilePath, + + + -- | Field accessor for 'QueryEnv'. Defines path to the @dist/@ directory, + -- /builddir/ in Cabal terminology. + qeDistDir :: FilePath, + + -- | Field accessor for 'QueryEnv'. Defines where to look for the Cabal + -- library when linking the helper. + qeCabalPkgDb :: Maybe FilePath, + + -- | Field accessor for 'QueryEnv'. If @dist/setup-config@ wasn\'t written + -- by this version of Cabal an error is thrown when running the query. + qeCabalVer :: Maybe Version + } + +-- | @mkQueryEnv projdir distdir@. Smart constructor for 'QueryEnv'. +-- Sets fields 'qeProjectDir' and 'qeDistDir' to @projdir@ and @distdir@ +-- respectively and provides sensible defaults for the other fields. +mkQueryEnv :: FilePath + -- ^ Path to the project directory, i.e. the directory containing a + -- @project.cabal@ file + -> FilePath + -- ^ Path to the @dist/@ directory, called /builddir/ in Cabal + -- terminology. + -> QueryEnv +mkQueryEnv projdir distdir = QueryEnv { + qeReadProcess = readProcess + , qePrograms = defaultPrograms + , qeProjectDir = projdir + , qeDistDir = distdir + , qeCabalPkgDb = Nothing + , qeCabalVer = Nothing + } + +data SomeLocalBuildInfo = SomeLocalBuildInfo { + slbiPackageDbStack :: [ChPkgDb], + slbiPackageFlags :: [(String, Bool)], + slbiPkgLicenses :: [(String, [(String, Version)])], + slbiCompilerVersion :: (String, Version), + + slbiGhcMergedPkgOptions :: [String], + + slbiConfigFlags :: [(String, Bool)], + slbiNonDefaultConfigFlags :: [(String, Bool)], + + slbiGhcSrcOptions :: [(ChComponentName, [String])], + slbiGhcPkgOptions :: [(ChComponentName, [String])], + slbiGhcLangOptions :: [(ChComponentName, [String])], + slbiGhcOptions :: [(ChComponentName, [String])], + + slbiSourceDirs :: [(ChComponentName, [String])], + slbiEntrypoints :: [(ChComponentName, ChEntrypoint)] + } deriving (Eq, Ord, Read, Show) + +-- | A lazy, cached, query against a package's Cabal configuration. Use +-- 'runQuery' to execute it. +newtype Query m a = Query { unQuery :: StateT (Maybe SomeLocalBuildInfo) + (ReaderT QueryEnv m) a } + deriving (Functor, Applicative, Monad, MonadIO) + +instance MonadTrans Query where + lift = Query . lift . lift + +type MonadQuery m = ( MonadIO m + , MonadState (Maybe SomeLocalBuildInfo) m + , MonadReader QueryEnv m) + +-- | A 'Query' to run on all components of a package. Use 'components' to get a +-- regular 'Query'. +newtype ComponentQuery m a = ComponentQuery (Query m [(ChComponentName, a)]) + deriving (Functor) + +instance Monad m => Apply (ComponentQuery m) where + ComponentQuery flab <.> ComponentQuery fla = + ComponentQuery $ liftM2 go flab fla + where + go :: [(ChComponentName, a -> b)] + -> [(ChComponentName, a)] + -> [(ChComponentName, b)] + go lab la = + [ (cn, ab a) + | (cn, ab) <- lab + , (cn', a) <- la + , cn == cn' + ] + +run :: Monad m => QueryEnv -> Maybe SomeLocalBuildInfo -> Query m a -> m a +run e s action = flip runReaderT e (flip evalStateT s (unQuery action)) + +-- | @runQuery env query@. Run a 'Query' under a given 'QueryEnv'. +runQuery :: Monad m + => QueryEnv + -> Query m a + -> m a +runQuery qe action = run qe Nothing action + +getSlbi :: MonadQuery m => m SomeLocalBuildInfo +getSlbi = do + s <- get + case s of + Nothing -> do + slbi <- getSomeConfigState + put (Just slbi) + return slbi + Just slbi -> return slbi + +-- | List of package databases to use. +packageDbStack :: MonadIO m => Query m [ChPkgDb] + +-- | Like @ghcPkgOptions@ but for the whole package not just one component +ghcMergedPkgOptions :: MonadIO m => Query m [String] + +-- | Get the licenses of the packages the current project is linking against. +packageLicenses :: MonadIO m => Query m [(String, [(String, Version)])] + +-- | Flag definitions from cabal file +packageFlags :: MonadIO m => Query m [(String, Bool)] + +-- | Flag assignments from setup-config +configFlags :: MonadIO m => Query m [(String, Bool)] + +-- | Flag assignments from setup-config which differ from the default +-- setting. This can also include flags which cabal decided to modify, +-- i.e. don't rely on these being the flags set by the user directly. +nonDefaultConfigFlags :: MonadIO m => Query m [(String, Bool)] + +-- | The version of GHC the project is configured to use +compilerVersion :: MonadIO m => Query m (String, Version) + +-- | Package identifier, i.e. package name and version +packageId :: MonadIO m => Query m (String, Version) + +-- | Run a ComponentQuery on all components of the package. +components :: Monad m => ComponentQuery m (ChComponentName -> b) -> Query m [b] +components (ComponentQuery sc) = map (\(cn, f) -> f cn) <$> sc + +-- | Modules or files Cabal would have the compiler build directly. Can be used +-- to compute the home module closure for a component. +entrypoints :: MonadIO m => ComponentQuery m ChEntrypoint + +-- | A component's @source-dirs@ field, beware since if this is empty implicit +-- behaviour in GHC kicks in. +sourceDirs :: MonadIO m => ComponentQuery m [FilePath] + +-- | All options Cabal would pass to GHC. +ghcOptions :: MonadIO m => ComponentQuery m [String] + +-- | Only search path related GHC options. +ghcSrcOptions :: MonadIO m => ComponentQuery m [String] + +-- | Only package related GHC options, sufficient for things don't need to +-- access any home modules. +ghcPkgOptions :: MonadIO m => ComponentQuery m [String] + +-- | Only language related options, i.e. @-XSomeExtension@ +ghcLangOptions :: MonadIO m => ComponentQuery m [String] + +packageId = Query $ getPackageId +packageDbStack = Query $ slbiPackageDbStack `liftM` getSlbi +packageFlags = Query $ slbiPackageFlags `liftM` getSlbi +packageLicenses = Query $ slbiPkgLicenses `liftM` getSlbi +compilerVersion = Query $ slbiCompilerVersion `liftM` getSlbi +ghcMergedPkgOptions = Query $ slbiGhcMergedPkgOptions `liftM` getSlbi +configFlags = Query $ slbiConfigFlags `liftM` getSlbi +nonDefaultConfigFlags = Query $ slbiNonDefaultConfigFlags `liftM` getSlbi + +ghcSrcOptions = ComponentQuery $ Query $ slbiGhcSrcOptions `liftM` getSlbi +ghcPkgOptions = ComponentQuery $ Query $ slbiGhcPkgOptions `liftM` getSlbi +ghcOptions = ComponentQuery $ Query $ slbiGhcOptions `liftM` getSlbi +ghcLangOptions = ComponentQuery $ Query $ slbiGhcLangOptions `liftM` getSlbi +sourceDirs = ComponentQuery $ Query $ slbiSourceDirs `liftM` getSlbi +entrypoints = ComponentQuery $ Query $ slbiEntrypoints `liftM` getSlbi + +-- | Run @cabal configure@ +reconfigure :: MonadIO m + => (FilePath -> [String] -> String -> IO String) + -> Programs -- ^ Program paths + -> [String] -- ^ Command line arguments to be passed to @cabal@ + -> m () +reconfigure readProc progs cabalOpts = do + let progOpts = + [ "--with-ghc=" ++ ghcProgram progs ] + -- Only pass ghc-pkg if it was actually set otherwise we + -- might break cabal's guessing logic + ++ if ghcPkgProgram progs /= "ghc-pkg" + then [ "--with-ghc-pkg=" ++ ghcPkgProgram progs ] + else [] + ++ cabalOpts + _ <- liftIO $ readProc (cabalProgram progs) ("configure":progOpts) "" + return () + +readHelper :: (MonadIO m, MonadQuery m) => [String] -> m [Maybe ChResponse] +readHelper args = ask >>= \qe -> liftIO $ do + out <- either error id <$> invokeHelper qe args + let res = read out + liftIO $ evaluate res `E.catch` \se@(SomeException _) -> do + md <- lookupEnv' "CABAL_HELPER_DEBUG" + let msg = "readHelper: exception: '" ++ show se ++ "'" + error $ msg ++ case md of + Nothing -> ", for more information set the environment variable CABAL_HELPER_DEBUG" + Just _ -> ", output: '"++ out ++"'" + +invokeHelper :: QueryEnv -> [String] -> IO (Either String String) +invokeHelper QueryEnv {..} args = do + let progArgs = [ "--with-ghc=" ++ ghcProgram qePrograms + , "--with-ghc-pkg=" ++ ghcPkgProgram qePrograms + , "--with-cabal=" ++ cabalProgram qePrograms + ] + exe <- findLibexecExe + let args' = progArgs ++ qeProjectDir:qeDistDir:args + out <- qeReadProcess exe args' "" + (Right <$> evaluate out) `E.catch` \(SomeException _) -> + return $ Left $ concat + ["invokeHelper", ": ", exe, " " + , intercalate " " (map show args') + , " failed" + ] + +getPackageId :: MonadQuery m => m (String, Version) +getPackageId = ask >>= \QueryEnv {..} -> do + [ Just (ChResponseVersion pkgName pkgVer) ] <- readHelper [ "package-id" ] + return (pkgName, pkgVer) + +getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo +getSomeConfigState = ask >>= \QueryEnv {..} -> do + res <- readHelper + [ "package-db-stack" + , "flags" + , "licenses" + , "compiler-version" + + , "ghc-merged-pkg-options" + + , "config-flags" + , "non-default-config-flags" + + , "ghc-src-options" + , "ghc-pkg-options" + , "ghc-lang-options" + , "ghc-options" + + , "source-dirs" + , "entrypoints" + ] + let [ Just (ChResponsePkgDbs slbiPackageDbStack), + Just (ChResponseFlags slbiPackageFlags), + Just (ChResponseLicenses slbiPkgLicenses), + Just (ChResponseVersion comp compVer), + + Just (ChResponseList slbiGhcMergedPkgOptions), + + Just (ChResponseFlags slbiConfigFlags), + Just (ChResponseFlags slbiNonDefaultConfigFlags), + + Just (ChResponseCompList slbiGhcSrcOptions), + Just (ChResponseCompList slbiGhcPkgOptions), + Just (ChResponseCompList slbiGhcLangOptions), + Just (ChResponseCompList slbiGhcOptions), + + Just (ChResponseCompList slbiSourceDirs), + Just (ChResponseEntrypoints slbiEntrypoints) + ] = res + slbiCompilerVersion = (comp, compVer) + return $ SomeLocalBuildInfo {..} + + +-- | Make sure the appropriate helper executable for the given project is +-- installed and ready to run queries. +prepare :: MonadIO m => QueryEnv -> m () +prepare qe = + liftIO $ void $ invokeHelper qe [] + +-- | Create @cabal_macros.h@ and @Paths_\<pkg\>@ possibly other generated files +-- in the usual place. +writeAutogenFiles :: MonadIO m => QueryEnv -> m () +writeAutogenFiles qe = + liftIO $ void $ invokeHelper qe ["write-autogen-files"] + +-- | Get the path to the sandbox package-db in a project +getSandboxPkgDb :: (FilePath -> [String] -> String -> IO String) + -> FilePath + -- ^ Cabal build platform, i.e. @buildPlatform@ + -> Version + -- ^ GHC version (@cProjectVersion@ is your friend) + -> IO (Maybe FilePath) +getSandboxPkgDb readProc = + CabalHelper.Shared.Sandbox.getSandboxPkgDb $ unsafePerformIO $ buildPlatform readProc + +buildPlatform :: (FilePath -> [String] -> String -> IO String) -> IO String +buildPlatform readProc = do + exe <- findLibexecExe + CabalHelper.Shared.Sandbox.dropWhileEnd isSpace <$> readProc 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 +-- an appropriate error message however the default is to print +-- 'libexecNotFoundError'. +data LibexecNotFoundError = LibexecNotFoundError String FilePath + deriving (Typeable) +instance Exception LibexecNotFoundError +instance Show LibexecNotFoundError where + show (LibexecNotFoundError exe dir) = + libexecNotFoundError exe dir "https://github.com/DanielG/cabal-helper/issues" + +findLibexecExe :: IO FilePath +findLibexecExe = do + libexecdir <- getLibexecDir + let exeName = "cabal-helper-wrapper" + exe = libexecdir </> exeName FP.<.> exeExtension' + + exists <- doesFileExist exe + + if exists + then return exe + else do + mdir <- tryFindCabalHelperTreeLibexecDir + case mdir of + Nothing -> + error $ throw $ LibexecNotFoundError exeName libexecdir + Just dir -> + return $ dir </> "dist" </> "build" </> exeName </> exeName + +tryFindCabalHelperTreeLibexecDir :: IO (Maybe FilePath) +tryFindCabalHelperTreeLibexecDir = do + exe <- getExecutablePath' + dir <- case takeFileName exe of + "ghc" -> do -- we're probably in ghci; try CWD + getCurrentDirectory + _ -> + return $ (!!4) $ iterate takeDirectory exe + exists <- doesFileExist $ dir </> "cabal-helper.cabal" + return $ if exists + then Just dir + else Nothing + +libexecNotFoundError :: String -- ^ Name of the executable we were trying to + -- find + -> FilePath -- ^ Path to @$libexecdir@ + -> String -- ^ URL the user will be directed towards to + -- report a bug. + -> String +libexecNotFoundError exe dir reportBug = printf + ( "Could not find $libexecdir/%s\n" + ++"\n" + ++"If you are a cabal-helper developer you can set the environment variable\n" + ++"`cabal_helper_libexecdir' to override $libexecdir[1]. The following will\n" + ++"work in the cabal-helper source tree:\n" + ++"\n" + ++" $ export cabal_helper_libexecdir=$PWD/dist/build/%s\n" + ++"\n" + ++"[1]: %s\n" + ++"\n" + ++"If you don't know what I'm talking about something went wrong with your\n" + ++"installation. Please report this problem here:\n" + ++"\n" + ++" %s") exe exe dir reportBug + +getExecutablePath' :: IO FilePath +getExecutablePath' = +#if MIN_VERSION_base(4,6,0) + getExecutablePath +#else + getProgName +#endif + +lookupEnv' :: String -> IO (Maybe String) +lookupEnv' k = lookup k <$> getEnvironment + +exeExtension' :: FilePath +exeExtension' = Distribution.Simple.BuildPaths.exeExtension |