From 807354f7dc6644fec15dfa1e534c69c14d219628 Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Sun, 14 Oct 2018 03:33:38 +0200 Subject: Start refactoring to support cabal v2-build --- cabal-helper.cabal | 6 +- lib/Distribution/Helper.hs | 874 +++++++++++++++++++------------ src/CabalHelper/Compiletime/Compile.hs | 70 +-- src/CabalHelper/Compiletime/Types.hs | 29 +- src/CabalHelper/Runtime/Compat.hs | 4 +- src/CabalHelper/Runtime/Main.hs | 252 +++++---- src/CabalHelper/Shared/InterfaceTypes.hs | 54 +- tests/CompileTest.hs | 1 + tests/GhcSession.hs | 24 +- 9 files changed, 782 insertions(+), 532 deletions(-) diff --git a/cabal-helper.cabal b/cabal-helper.cabal index fa071f0..3115522 100644 --- a/cabal-helper.cabal +++ b/cabal-helper.cabal @@ -112,7 +112,7 @@ library , directory < 1.4 && >= 1.2.1.0 , filepath < 1.5 && >= 1.3.0.0 , mtl < 2.3 && >= 2.0 - , process < 1.7 && >= 1.1.0.1 + , process < 1.7 && >= 1.2.3.0 , pretty-show < 1.9 && >= 1.8.1 , semigroupoids < 5.3 && >= 5.2 , SHA < 1.7 && >= 1.6.4.4 @@ -163,7 +163,7 @@ test-suite compile-test , directory < 1.4 && >= 1.2.1.0 , filepath < 1.5 && >= 1.3.0.0 , mtl < 2.3 && >= 2.0 - , process < 1.7 && >= 1.1.0.1 + , process < 1.7 && >= 1.2.3.0 , pretty-show < 1.9 && >= 1.8.1 , SHA < 1.7 && >= 1.6.4.4 , text < 1.3 && >= 1.0.0.0 @@ -214,7 +214,7 @@ test-suite ghc-session , directory < 1.4 && >= 1.2.1.0 , filepath < 1.5 && >= 1.3.0.0 , mtl < 2.3 && >= 2.0 - , process < 1.7 && >= 1.1.0.1 + , process < 1.7 && >= 1.2.3.0 , pretty-show < 1.9 && >= 1.8.1 , SHA < 1.7 && >= 1.6.4.4 , text < 1.3 && >= 1.0.0.0 diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs index 622972a..edf71f7 100644 --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -16,7 +16,11 @@ {-# LANGUAGE RecordWildCards, FlexibleContexts, ConstraintKinds, GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric, DeriveFunctor, - NamedFieldPuns, OverloadedStrings, ViewPatterns #-} + StandaloneDeriving, NamedFieldPuns, OverloadedStrings, ViewPatterns, + TupleSections, TypeFamilies, DataKinds, GADTs, ScopedTypeVariables, + ImplicitParams, RankNTypes #-} + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-| Module : Distribution.Helper @@ -32,48 +36,37 @@ module Distribution.Helper ( -- * Queries against Cabal\'s on disk state - -- ** Package queries - , packageId - , packageDbStack - , packageFlags + -- ** Project queries , compilerVersion + , projectUnits - , ghcMergedPkgOptions - - -- ** cabal-install queries - , configFlags - , nonDefaultConfigFlags - - - -- ** Component queries - , ComponentQuery - , components - - , ghcSrcOptions - , ghcPkgOptions - , ghcLangOptions - , ghcOptions - , sourceDirs - , entrypoints - , needsBuildOutput + -- ** Unit queries + , Unit -- abstract + , UnitId -- abstract + , UnitInfo(..) + , unitQuery -- * Query environment - , QueryEnv + , QueryEnv -- abstract , mkQueryEnv , qeReadProcess , qePrograms , qeProjectDir , qeDistDir - , qeCabalPkgDb - , qeCabalVer + + -- * GADTs + , DistDir(..) + , ProjType(..) + , ProjDir(..) , Programs(..) , defaultPrograms -- * Result types - , ChModuleName(..) + , ChComponentInfo(..) , ChComponentName(..) + , ChModuleName(..) , ChPkgDb(..) , ChEntrypoint(..) , NeedsBuildOutput(..) @@ -93,39 +86,52 @@ module Distribution.Helper ( , module Data.Functor.Apply ) where -import Cabal.Plan +import Cabal.Plan hiding (Unit, UnitId, uDistDir) +import qualified Cabal.Plan as CP import Control.Applicative import Control.Monad +import Control.Monad.Trans.Maybe import Control.Monad.IO.Class -import Control.Monad.State.Strict -import Control.Monad.Reader import Control.Exception as E -import Data.List +import Data.Char +import Data.Coerce +import Data.IORef +import Data.List hiding (filter) +import Data.String +import qualified Data.Text as Text import Data.Maybe +import Data.Either +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set import Data.Version -import qualified Data.Text as Text import Data.Function import Data.Functor.Apply import System.Environment import System.FilePath hiding ((<.>)) import System.Directory import System.Process +import System.Posix.Types +import System.PosixCompat.Files import Text.Printf import Text.Show.Pretty import Prelude - import CabalHelper.Compiletime.Compile import CabalHelper.Compiletime.Types import CabalHelper.Shared.InterfaceTypes import CabalHelper.Shared.Sandbox +import CabalHelper.Shared.Common +import CabalHelper.Compiletime.Compat.Version +import qualified CabalHelper.Compiletime.Compat.ProgramDb as ProgDb + ( defaultProgramDb, programPath, lookupProgram, ghcProgram, ghcPkgProgram) import Distribution.System (buildPlatform) import Distribution.Text (display) import Distribution.Verbosity (silent, deafening) -import Distribution.Package (packageName, packageVersion) +--import Distribution.Package (packageName, packageVersion) import Distribution.Simple.GHC as GHC (configure) import qualified CabalHelper.Compiletime.Compat.ProgramDb as ProgDb @@ -134,193 +140,275 @@ import CabalHelper.Compiletime.Compat.Version import CabalHelper.Shared.Common +-- | The kind of project being managed by a 'QueryEnv' (pun intended). +data ProjType + = V1 -- ^ @cabal v1-build@ project, see 'DistDirV1' + | V2 -- ^ @cabal v2-build@ project, see 'DistDirV2' + +-- | A project directory. The project type of a given directory can be +-- determined by trying to access a set of marker files. See below. +data ProjDir (pt :: ProjType) where + -- | A @cabal v1-build@ project directory can be identified by one file + -- ending in @.cabal@ existing in the directory. More than one such files + -- existing is a user error. Note: For this project type the concepts of + -- project and package coincide. + ProjDirV1 :: FilePath -> ProjDir 'V1 + + -- | A @cabal v2-build@ project\'s marker file is called + -- @cabal.project@. This configuration file points to the packages that make + -- up this project. + ProjDirV2 :: FilePath -> ProjDir 'V2 + +data DistDir (pt :: ProjType) where + -- | Build directory for cabal /old-build/ aka. /v1-build/ aka. just + -- /build/. Planned to be superceeded by /v2-build/, see 'DistDirV2' for + -- that. + -- + -- You can tell a builddir is a /v1/ builddir by looking for a file + -- called @setup-config@ directly underneath it. + DistDirV1 :: FilePath -> DistDir 'V1 + + -- | Build directory for cabal /new-build/ aka. /v2-build/, as of the time + -- of this writing it is usually called @dist-newstyle/@ but this will + -- presumably change once it becomes the default /build/ command. + -- + -- You can tell a builddir is a /v2/ builddir by trying to access the path + -- @cache/plan.json@ directly underneath it. + DistDirV2 :: FilePath -> DistDir 'V2 + +-- | Environment for running a 'Query' value. The real constructor is +-- not exposed, use the 'mkQueryEnv' smart constructor instead. The field +-- accessors are exported and may be used to override the defaults, see below. +type QueryEnv (proj_type :: ProjType) + = QueryEnvI (QueryCache proj_type) proj_type + +data QueryEnvI cache (proj_type :: ProjType) = QueryEnv + { qeReadProcess + :: Maybe FilePath -> FilePath -> [String] -> String -> IO String + -- ^ Field accessor for 'QueryEnv'. Function used to to start + -- processes. Useful if you need to, for example, redirect standard error + -- output away from the user\'s terminal. + + , qePrograms :: Programs + -- ^ Field accessor for 'QueryEnv'. + + , qeProjectDir :: ProjDir proj_type + -- ^ Field accessor for 'QueryEnv'. Defines path to the project directory, + -- i.e. a directory containing a @cabal.project@ file + + , qeDistDir :: DistDir proj_type + -- ^ Field accessor for 'QueryEnv'. Defines path to the @dist/@ or + -- @dist-newstyle/@ directory, aka. /builddir/ in Cabal terminology. + + , qeCacheRef :: IORef cache + -- ^ Cache for query results, only accessible when type parameter @cache@ is + -- instantiated and not forall quantified. + } --- | 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, +data QueryCache pt = QueryCache + { qcProjInfo :: !(Maybe (ProjInfo pt)) + , qcUnitInfos :: !(Map DistDirLib UnitInfo) + } - -- | Field accessor for 'QueryEnv'. - qePrograms :: Programs, +newtype DistDirLib = DistDirLib FilePath + deriving (Eq, Ord, Read, Show) - -- | Field accessor for 'QueryEnv'. Defines path to the project directory, - -- i.e. a directory containing a @project.cabal@ file - qeProjectDir :: FilePath, +-- | Abstractly speaking a Unit consists of a set of components (exes, libs, +-- tests etc.) which are managed by an instance of the Cabal build system. The +-- distinction between a Unit and a set of components is somewhat hard to +-- explain if you're not already familliar with the concept from +-- cabal-install. Luckily for most purposes the details may be ignored. +-- +-- We merely use the concept of a Unit for caching purposes. It is necessary to +-- extract the information on all components in a Unit at the same time as we +-- must load all of it into memory before extracting any of it. +-- +-- As opposed to components, different 'Unit's can be queried independently +-- since their on-disk information is stored separately. +data Unit = Unit + { uUnitId :: !UnitId + , uPackageDir :: !FilePath + , uDistDir :: !DistDirLib + } +newtype UnitId = UnitId String + deriving (Eq, Ord, Read, Show) - -- | Field accessor for 'QueryEnv'. Defines path to the @dist/@ directory, - -- /builddir/ in Cabal terminology. - qeDistDir :: FilePath, +-- | The information extracted from a 'Unit's on-disk configuration. +data UnitInfo = UnitInfo + { uiUnitId :: !UnitId + -- ^ A unique identifier of this init within the project. - -- | Field accessor for 'QueryEnv'. Defines where to look for the Cabal - -- library when linking the helper. - qeCabalPkgDb :: Maybe FilePath, + , uiComponents :: !(Map ChComponentName ChComponentInfo) + -- ^ The components of the unit: libraries, executables, test-suites, + -- benchmarks and so on. - -- | 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 - } + , uiCompilerVersion :: !(String, Version) + -- ^ The version of GHC the unit is configured to use --- | @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)], - 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)], - slbiNeedsBuildOutput :: [(ChComponentName, NeedsBuildOutput)] + , uiPackageDbStack :: !([ChPkgDb]) + -- ^ List of package databases to use. + + , uiPackageFlags :: !([(String, Bool)]) + -- ^ Flag definitions from cabal file + + , uiConfigFlags :: ![(String, Bool)] + -- ^ Flag assignments from active configuration + + , uiNonDefaultConfigFlags :: ![(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. + + , uiModTimes :: !UnitModTimes + } deriving (Eq, Ord, Read, Show) + +data ProjInfo pt where + ProjInfoV1 :: + { piV1ProjConfModTimes :: !(ProjConfModTimes 'V1) + } -> ProjInfo 'V1 + + ProjInfoV2 :: + { piV2ProjConfModTimes :: !(ProjConfModTimes 'V2) + , piV2Plan :: !PlanJson + , piV2PlanModTime :: !EpochTime + } -> ProjInfo 'V2 + +data ProjConfModTimes pt where + ProjConfModTimesV1 + :: !(FilePath, EpochTime) -> ProjConfModTimes 'V1 + ProjConfModTimesV2 + :: !([(FilePath, EpochTime)]) -> ProjConfModTimes 'V2 + +deriving instance Eq (ProjConfModTimes pt) + +piProjConfModTimes :: ProjInfo pt -> ProjConfModTimes pt +piProjConfModTimes ProjInfoV1 {piV1ProjConfModTimes} = + piV1ProjConfModTimes +piProjConfModTimes ProjInfoV2 {piV2ProjConfModTimes} = + piV2ProjConfModTimes + +data UnitModTimes = UnitModTimes + { umtCabalFile :: !(FilePath, EpochTime) + , umtSetupConfig :: !(FilePath, EpochTime) } 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 (Functor m, 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] - --- | 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)] +newtype Query pt a = Query + { runQuery :: QueryEnv pt -> IO a + -- ^ @runQuery env query@. Run a 'Query' under a given 'QueryEnv. + } --- | The version of GHC the project is configured to use -compilerVersion :: MonadIO m => Query m (String, Version) +instance Functor (Query pt) where + fmap = liftM --- | Package identifier, i.e. package name and version -packageId :: MonadIO m => Query m (String, Version) +instance Applicative (Query pt) where + (<*>) = ap + pure = return --- | 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) `liftM` sc +instance Monad (Query pt) where + (Query ma) >>= amb = Query $ \qe -> ma qe >>= \a -> runQuery (amb a) qe + return a = Query $ const $ return a --- | 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 +-- | @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 + :: ProjDir pt + -- ^ Path to the project directory + -> DistDir pt + -- ^ Path to the @dist/@ or @dist-newstyle/@ directory, called + -- /builddir/ in Cabal terminology. + -> IO (QueryEnv pt) +mkQueryEnv projdir distdir = do + cr <- newIORef $ QueryCache Nothing Map.empty + return $ QueryEnv + { qeReadProcess = \mcwd exe args stdin -> + readCreateProcess (proc exe args){ cwd = mcwd } stdin + , qePrograms = defaultPrograms + , qeProjectDir = projdir + , qeDistDir = distdir + , qeCacheRef = cr + } --- | The component has a non-default module renaming, so needs build output (). -needsBuildOutput :: MonadIO m => ComponentQuery m NeedsBuildOutput +piUnits :: DistDir pt -> ProjInfo pt -> [Unit] +piUnits (DistDirV1 distdir) (ProjInfoV1 (ProjConfModTimesV1 (cabal_file, _))) = + (:[]) $ Unit + { uUnitId = UnitId "" + , uPackageDir = takeDirectory cabal_file + , uDistDir = DistDirLib distdir + } +piUnits _ ProjInfoV2{..} = + case lefts units of + [] -> rights units + us@(_:_) -> panic $ + msg ++ (concat $ map (unlines . map (" "++) . lines . ppShow) us) + where + msg = "\ +\plan.json doesn't contain 'dist-dir' key for the following local units:\n" + units = catMaybes $ map takeunit $ Map.elems $ pjUnits piV2Plan + takeunit u@CP.Unit + { uType=UnitTypeLocal + , uDistDir=Just distdirv1 + , uPkgSrc=Just (LocalUnpackedPackage pkgdir) + } = Just $ Right $ Unit + { uUnitId = UnitId $ Text.unpack (coerce (uId u)) + , uPackageDir = pkgdir + , uDistDir = DistDirLib distdirv1 + } + takeunit u@CP.Unit {uType=UnitTypeLocal} = + Just $ Left u + takeunit _ = + Nothing --- | 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] +-- | Find files relevant to the project-scope configuration. Depending on the +-- 'ProjType' this could be (for example) just a cabal file, one of the +-- @caba.project*@ files or @stack.yaml@. +-- +-- The returned paths include the project-dir path. +projConfModTimes :: ProjDir pt -> IO (ProjConfModTimes pt) +projConfModTimes pd@(ProjDirV1 _) = + ProjConfModTimesV1 <$> (getFileModTime =<< findCabalFile pd) +projConfModTimes (ProjDirV2 projdir) = do + ex_files <- filterM doesFileExist (map (projdir ) additional_files) + let files = [ projdir "cabal.project" ] ++ ex_files + ProjConfModTimesV2 <$> mapM getFileModTime files + where + additional_files = + [ "cabal.project.local" + , "cabal.project.freeze" + ] + +getUnitModTimes :: Unit -> IO UnitModTimes +getUnitModTimes Unit { uDistDir=DistDirLib distdirv1, uPackageDir=pkgdir } = do + cabal_file <- findCabalFile (ProjDirV1 pkgdir) + cabal_file_mtime <- getFileModTime cabal_file + + let setup_config = distdirv1 "setup-config" + setup_config_mtime <- getFileModTime setup_config + + return UnitModTimes + { umtCabalFile = cabal_file_mtime + , umtSetupConfig = setup_config_mtime + } --- | 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] +-- | The version of GHC the project is configured to use +compilerVersion :: Query pt (String, Version) +compilerVersion = undefined + +-- | List of units in a project +projectUnits :: Query pt [Unit] +projectUnits = Query $ \qe@QueryEnv{qeDistDir} -> + piUnits qeDistDir <$> getProjInfo qe --- | Only language related options, i.e. @-XSomeExtension@ -ghcLangOptions :: MonadIO m => ComponentQuery m [String] +-- | Run a 'UnitQuery' on a given unit. To get a a unit see 'projectUnits'. +unitQuery :: Unit -> Query pt UnitInfo +unitQuery u = Query $ \qe -> getUnitInfo qe u -packageId = Query $ getPackageId -packageDbStack = Query $ slbiPackageDbStack `liftM` getSlbi -packageFlags = Query $ slbiPackageFlags `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 -needsBuildOutput = ComponentQuery $ Query $ slbiNeedsBuildOutput `liftM` getSlbi -- | Run @cabal configure@ reconfigure :: MonadIO m @@ -340,98 +428,205 @@ reconfigure readProc progs cabalOpts = do _ <- liftIO $ readProc (cabalProgram progs) ("configure":progOpts) "" return () -readHelper :: (MonadIO m, MonadQuery m) => [String] -> m [Maybe ChResponse] -readHelper args = ask >>= \qe -> liftIO $ do - out <- 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 ++ "'" - panicIO $ msg ++ case md of - Nothing -> ", for more information set the environment variable CABAL_HELPER_DEBUG" - Just _ -> ", output: '"++ out ++"'" - -invokeHelper :: QueryEnv -> [String] -> IO String -invokeHelper QueryEnv {..} args0 = do - let opts = defaultCompileOptions - { oPrograms = qePrograms - , oCabalPkgDb = PackageDbDir <$> qeCabalPkgDb } - opts' <- overrideVerbosityEnvVar =<< guessProgramPaths opts - - exe <- wrapperV1 opts' qeProjectDir qeDistDir +getProjInfo :: QueryEnv pt -> IO (ProjInfo pt) +getProjInfo qe@QueryEnv{..} = do + cache@QueryCache{qcProjInfo, qcUnitInfos} <- readIORef qeCacheRef + proj_info <- checkUpdateProj qe qcProjInfo + let active_units = piUnits qeDistDir proj_info + writeIORef qeCacheRef $ cache + { qcProjInfo = Just proj_info + , qcUnitInfos = discardInactiveUnitInfos active_units qcUnitInfos + } + return proj_info + +checkUpdateProj + :: QueryEnvI c pt + -> Maybe (ProjInfo pt) + -> IO (ProjInfo pt) +checkUpdateProj qe mproj_info = do + mtime <- projConfModTimes (qeProjectDir qe) + + case mproj_info of + Nothing -> reconf mtime + Just proj_info + | piProjConfModTimes proj_info /= mtime + -> reconf mtime + | otherwise + -> return proj_info + where + reconf mtime = do + shallowReconfigureProject qe + readProjInfo qe mtime + + + +getUnitInfo :: QueryEnv pt -> Unit -> IO UnitInfo +getUnitInfo qe@QueryEnv{..} unit@Unit{uDistDir} = do + proj_info <- getProjInfo qe + + cache@QueryCache{qcUnitInfos} <- readIORef qeCacheRef + let munit_info = Map.lookup uDistDir qcUnitInfos + unit_info <- checkUpdateUnitInfo qe proj_info unit munit_info + writeIORef qeCacheRef $ cache + { qcUnitInfos = Map.insert uDistDir unit_info qcUnitInfos } + return unit_info + +checkUpdateUnitInfo + :: QueryEnvI c pt + -> ProjInfo pt + -> Unit + -> Maybe UnitInfo + -> IO UnitInfo +checkUpdateUnitInfo qe proj_info unit munit_info = do + unit_mtimes <- getUnitModTimes unit + case munit_info of + Nothing -> reconf + Just unit_info + | uiModTimes unit_info /= unit_mtimes + -> reconf + | otherwise + -> return unit_info + where + reconf = do + reconfigureUnit qe unit + helper <- wrapper proj_info qe + readUnitInfo qe helper unit + +-- | Restrict 'UnitInfo' cache to units that are still active +discardInactiveUnitInfos + :: [Unit] + -> Map DistDirLib UnitInfo + -> Map DistDirLib UnitInfo +discardInactiveUnitInfos active_units uis0 = + restrictKeysMap uis0 $ Set.fromList $ map uDistDir active_units + where + restrictKeysMap :: Ord k => Map k a -> Set k -> Map k a + restrictKeysMap m s = Map.filterWithKey (\k _ -> Set.member k s) m + + +-- | Regenerate project level information by calling the appropriate build +-- system (@cabal@ or @stack@). +shallowReconfigureProject :: QueryEnvI c pt -> IO () +shallowReconfigureProject QueryEnv + { qeProjectDir = ProjDirV1 _projdir + , qeDistDir = DistDirV1 _distdirv1 } = + return () +shallowReconfigureProject QueryEnv + { qeProjectDir = ProjDirV2 projdir + , qeDistDir = DistDirV2 _distdirv2, .. } = do + _ <- liftIO $ qeReadProcess (Just projdir) (cabalProgram qePrograms) + ["v2-build", "--dry-run", "all"] "" + return () - let args1 = qeProjectDir : qeDistDir : args0 +reconfigureUnit :: QueryEnvI c pt -> Unit -> IO () +reconfigureUnit QueryEnv{qeDistDir=DistDirV1{}, ..} Unit{uPackageDir=_} = do + return () +reconfigureUnit QueryEnv{qeDistDir=DistDirV2{}, ..} Unit{uPackageDir=_} = do + return () + +findCabalFile :: ProjDir 'V1 -> IO FilePath +findCabalFile (ProjDirV1 pkgdir) = do + [cfile] <- filter isCabalFile <$> getDirectoryContents pkgdir + return cfile + +getFileModTime :: FilePath -> IO (FilePath, EpochTime) +getFileModTime f = do + t <- modificationTime <$> getFileStatus f + return (f, t) + +readProjInfo :: QueryEnvI c pt -> ProjConfModTimes pt -> IO (ProjInfo pt) +readProjInfo qe conf_files = do + case (qeProjectDir qe, qeDistDir qe) of + (ProjDirV1 _projdir, DistDirV1 _) -> + return $ ProjInfoV1 { piV1ProjConfModTimes = conf_files } + (ProjDirV2 _projdir, DistDirV2 distdirv2) -> do + let plan_path = distdirv2 "cache" "plan.json" + plan_mtime <- modificationTime <$> getFileStatus plan_path + plan <- decodePlanJson plan_path + return $ ProjInfoV2 + { piV2ProjConfModTimes = conf_files + , piV2Plan = plan + , piV2PlanModTime = plan_mtime + } + +readUnitInfo :: QueryEnvI c pt -> FilePath -> Unit -> IO UnitInfo +readUnitInfo + qe exe unit@Unit {uUnitId=uiUnitId, uPackageDir=pkgdir, uDistDir=distdir} = do + res <- readHelper qe exe pkgdir distdir + [ "package-db-stack" + , "flags" + , "compiler-version" + , "config-flags" + , "non-default-config-flags" + , "component-info" + ] + let [ Just (ChResponsePkgDbs uiPackageDbStack), + Just (ChResponseFlags uiPackageFlags), + Just (ChResponseVersion comp compVer), + Just (ChResponseFlags uiConfigFlags), + Just (ChResponseFlags uiNonDefaultConfigFlags), + Just (ChResponseComponentsInfo uiComponents) + ] = res + uiCompilerVersion = (comp, compVer) + uiModTimes <- getUnitModTimes unit + return $ UnitInfo {..} + +readHelper + :: QueryEnvI c pt + -> FilePath + -> FilePath + -> DistDirLib + -> [String] + -> IO [Maybe ChResponse] +readHelper qe exe cabal_file distdir args = do + out <- invokeHelper qe exe cabal_file distdir args + let res :: [Maybe ChResponse] + res = read out + liftIO $ evaluate res `E.catch` \ex@ErrorCall{} -> do + md <- lookupEnv' "CABAL_HELPER_DEBUG" + let msg = "readHelper: exception: '" ++ show ex ++ "'" + panicIO $ msg ++ case md of + Nothing -> "\n for more information set the environment variable CABAL_HELPER_DEBUG and try again" + Just _ -> "\n output:\n'"++ out ++"'" - out <- qeReadProcess exe args1 "" - evaluate out `E.catch` \(SomeException _) -> +invokeHelper + :: QueryEnvI c pt + -> FilePath + -> FilePath + -> DistDirLib + -> [String] + -> IO String +invokeHelper QueryEnv {..} exe cabal_file (DistDirLib distdir) args0 = do + let args1 = cabal_file : distdir : args0 + evaluate =<< qeReadProcess Nothing exe args1 "" `E.catch` + \(_ :: E.IOException) -> panicIO $ concat ["invokeHelper", ": ", exe, " " , intercalate " " (map show args1) , " failed!" ] -getPackageId :: (MonadQuery m, MonadIO m) => m (String, Version) -getPackageId = ask >>= \QueryEnv {..} -> liftIO $ do - let v = silent - [cfile] <- filter isCabalFile <$> getDirectoryContents qeProjectDir - gpd <- readPackageDescription v (qeProjectDir cfile) - return $ (display (packageName gpd), toDataVersion (packageVersion gpd)) - -getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo -getSomeConfigState = ask >>= \QueryEnv {..} -> do - res <- readHelper - [ "package-db-stack" - , "flags" - , "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" - , "needs-build-output" - ] - let [ Just (ChResponsePkgDbs slbiPackageDbStack), - Just (ChResponseFlags slbiPackageFlags), - 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), - Just (ChResponseNeedsBuild slbiNeedsBuildOutput) - ] = res - slbiCompilerVersion = (comp, compVer) - return $ SomeLocalBuildInfo {..} - +-- getPackageId :: QueryEnv pt -> IO (String, Version) +-- getPackageId QueryEnv{..} = do +-- [cfile] <- filter isCabalFile <$> getDirectoryContents qeProjectDir +-- gpd <- readPackageDescription silent (qeProjectDir cfile) +-- return $ (display (packageName gpd), toDataVersion (packageVersion gpd)) -- | 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 [] +prepare :: QueryEnv pt -> IO () +prepare qe = do + proj_info <- getProjInfo qe + void $ wrapper proj_info qe -- | Create @cabal_macros.h@ and @Paths_\@ possibly other generated files -- in the usual place. -writeAutogenFiles :: MonadIO m => QueryEnv -> m () -writeAutogenFiles qe = - liftIO $ void $ invokeHelper qe ["write-autogen-files"] +writeAutogenFiles :: QueryEnv pt -> IO () +writeAutogenFiles qe = do + proj_info <- getProjInfo qe + _exe <- wrapper proj_info qe + undefined -- void $ invokeHelper qe exe ["write-autogen-files"] -- | Get the path to the sandbox package-db in a project getSandboxPkgDb @@ -452,16 +647,15 @@ buildPlatform = display Distribution.System.buildPlatform lookupEnv' :: String -> IO (Maybe String) lookupEnv' k = lookup k <$> getEnvironment +guessProgramPaths :: (Verbose, Progs) => (Progs => IO a) -> IO a +guessProgramPaths act = do + let v | ?verbose = deafening + | otherwise = silent -guessProgramPaths :: CompileOptions -> IO CompileOptions -guessProgramPaths opts = do - let v | oVerbose opts = deafening - | otherwise = silent - - mGhcPath0 | same ghcProgram progs dprogs = Nothing - | otherwise = Just $ ghcProgram progs - mGhcPkgPath0 | same ghcPkgProgram progs dprogs = Nothing - | otherwise = Just $ ghcPkgProgram progs + mGhcPath0 | same ghcProgram ?progs dprogs = Nothing + | otherwise = Just $ ghcProgram ?progs + mGhcPkgPath0 | same ghcPkgProgram ?progs dprogs = Nothing + | otherwise = Just $ ghcPkgProgram ?progs (_compiler, _mplatform, progdb) <- GHC.configure @@ -473,90 +667,72 @@ guessProgramPaths opts = do mghcPath1 = getProg ProgDb.ghcProgram mghcPkgPath1 = getProg ProgDb.ghcPkgProgram - progs' = progs - { ghcProgram = fromMaybe (ghcProgram progs) mghcPath1 - , ghcPkgProgram = fromMaybe (ghcProgram progs) mghcPkgPath1 + let ?progs = ?progs + { ghcProgram = fromMaybe (ghcProgram ?progs) mghcPath1 + , ghcPkgProgram = fromMaybe (ghcProgram ?progs) mghcPkgPath1 } - return opts { oPrograms = progs' } + act where same f o o' = f o == f o' - progs = oPrograms opts dprogs = defaultPrograms -overrideVerbosityEnvVar :: CompileOptions -> IO CompileOptions -overrideVerbosityEnvVar opts = do +withVerbosity :: (Verbose => a) -> IO a +withVerbosity a = do x <- lookup "CABAL_HELPER_DEBUG" <$> getEnvironment - return $ case x of - Just _ -> opts { oVerbose = True } - Nothing -> opts - -wrapperV1 - :: CompileOptions - -> FilePath - -> FilePath + let ?verbose = + case x of + Just xs | not (null xs) -> True + _ -> False + return a + +wrapper + :: ProjInfo pt -> QueryEnvI c pt -> IO FilePath +wrapper proj_info QueryEnv{..} = do + join $ withVerbosity $ do + let ?progs = qePrograms + guessProgramPaths $ wrapper' qeProjectDir qeDistDir proj_info + +wrapper' + :: Env + => ProjDir pt + -> DistDir pt + -> ProjInfo pt -> IO FilePath -wrapperV1 opts projdir distdir = do +wrapper' (ProjDirV1 projdir) (DistDirV1 distdir) _ = do cfgf <- canonicalizePath (distdir "setup-config") mhdr <- getCabalConfigHeader cfgf - case (mhdr, oCabalVersion opts) of - (Nothing, _) -> panicIO $ printf "\ + case mhdr of + Nothing -> panicIO $ printf "\ \Could not read Cabal's persistent setup configuration header\n\ \- Check first line of: %s\n\ \- Maybe try: $ cabal configure" cfgf - (Just (hdrCabalVersion, _), Just ver) - | hdrCabalVersion /= ver -> panicIO $ printf "\ -\Cabal version %s was requested but setup configuration was\n\ -\written by version %s" (showVersion ver) (showVersion hdrCabalVersion) - (Just (hdrCabalVersion, _), _) -> do - compileHelper' opts hdrCabalVersion projdir Nothing distdir - -wrapperV2 - :: CompileOptions - -> FilePath - -> FilePath - -> UnitId - -> IO (FilePath, FilePath) -wrapperV2 opts projdir distdir unitid@(UnitId (Text.unpack -> unitid')) = do - let plan_path = distdir "cache" "plan.json" - plan@PlanJson {pjCabalLibVersion=Ver (makeDataVersion -> pjCabalLibVersion) } - <- decodePlanJson plan_path - case oCabalVersion opts of - Just ver | pjCabalLibVersion /= ver -> let - sver = showVersion ver - spjVer = showVersion pjCabalLibVersion - in panicIO $ printf "\ -\Cabal version %s was requested but plan.json was written by version %s" sver spjVer - _ -> case Map.lookup unitid $ pjUnits plan of - Just u@Unit {uType} | uType /= UnitTypeLocal -> do - panicIO $ "\ -\UnitId '"++ unitid' ++"' points to non-local unit: " ++ ppShow u - Just Unit {uDistDir=Nothing} -> panicIO $ printf "\ -\plan.json doesn't contain 'dist-dir' for UnitId '"++ unitid' ++"'" - Just Unit {uType=UnitTypeLocal, uDistDir=Just distdirv1} -> do - exe <- compileHelper' opts pjCabalLibVersion projdir (Just (plan, distdir)) distdirv1 - return (exe, distdirv1) - _ -> let - units = map (\(UnitId u) -> Text.unpack u) - $ Map.keys - $ Map.filter ((==UnitTypeLocal) . uType) - $ pjUnits plan - units_list = unlines $ map (" "++) units - in - panicIO $ "\ -\UnitId '"++ unitid' ++"' not found in plan.json, available local units:\n" ++ units_list - + Just (hdrCabalVersion, _) -> do + compileHelper' hdrCabalVersion Nothing projdir Nothing distdir +wrapper' + (ProjDirV2 projdir) + (DistDirV2 distdir) + ProjInfoV2{piV2Plan=plan} + = do + let PlanJson {pjCabalLibVersion=Ver (makeDataVersion -> pjCabalLibVersion) } + = plan + compileHelper' pjCabalLibVersion + Nothing + projdir + (Just (plan, distdir)) + (distdir "cache") compileHelper' - :: CompileOptions - -> Version + :: Env + => Version + -> Maybe PackageDbDir -> FilePath -> Maybe (PlanJson, FilePath) -> FilePath -> IO FilePath -compileHelper' opts pjCabalLibVersion projdir mnewstyle distdirv1 = do - eexe <- compileHelper opts pjCabalLibVersion projdir mnewstyle distdirv1 +compileHelper' pjCabalLibVersion cabalPkgDb projdir mnewstyle distdirv1 = do + eexe <- compileHelper pjCabalLibVersion cabalPkgDb projdir mnewstyle distdirv1 case eexe of Left rv -> - panicIO $ "compileHelper': compiling helper failed! (exit code "++ show rv + panicIO $ "compileHelper': compiling helper failed! (exit code "++ show rv Right exe -> - return exe + return exe diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs index 305c11c..3126128 100644 --- a/src/CabalHelper/Compiletime/Compile.hs +++ b/src/CabalHelper/Compiletime/Compile.hs @@ -13,8 +13,8 @@ -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE RecordWildCards, FlexibleContexts, NamedFieldPuns, DeriveFunctor, - GADTs, ImplicitParams, ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts, DeriveFunctor, GADTs, ConstraintKinds, + ImplicitParams, NamedFieldPuns, RecordWildCards #-} {-| Module : CabalHelper.Compiletime.Compile @@ -24,7 +24,9 @@ License : GPL-3 module CabalHelper.Compiletime.Compile where +import qualified Cabal.Plan as CP import Cabal.Plan + ( PlanJson(..), PkgId(..), PkgName(..), Ver(..), uPId) import Control.Applicative import Control.Arrow import Control.Exception as E @@ -49,16 +51,24 @@ import System.IO.Error import System.IO.Temp import Prelude - import qualified Data.Text as Text import qualified Data.Map.Strict as Map -import Distribution.System (buildPlatform) -import Distribution.Text (display) +import Distribution.System + ( buildPlatform ) +import Distribution.Text + ( display ) + +import Paths_cabal_helper + ( version ) -import Paths_cabal_helper (version) +--import CabalHelper.Compiletime.Cabal import CabalHelper.Compiletime.Data +--import CabalHelper.Compiletime.Log +--import CabalHelper.Compiletime.Program.GHC +--import CabalHelper.Compiletime.Program.CabalInstall import CabalHelper.Compiletime.Types + import CabalHelper.Shared.Common import CabalHelper.Shared.Sandbox (getSandboxPkgDb) @@ -87,18 +97,17 @@ data CompPaths = CompPaths data CompilationProductScope = CPSGlobal | CPSProject compileHelper - :: CompileOptions - -> Version + :: Env + => Version + -> Maybe PackageDbDir -> FilePath -> Maybe (PlanJson, FilePath) -> FilePath -> IO (Either ExitCode FilePath) -compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do - let ?opts = opts - +compileHelper hdrCabalVersion cabalPkgDb projdir mnewstyle cachedir = do ghcVer <- ghcVersion Just (prepare, comp) <- runMaybeT $ msum $ - case oCabalPkgDb opts of + case cabalPkgDb of Nothing -> [ compileCabalSource , compileNewBuild ghcVer @@ -107,7 +116,7 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do , MaybeT $ Just <$> compileWithCabalInPrivatePkgDb ] Just db -> - [ return $ (return (), compileWithPkg (Just db) hdrCabalVersion CPSProject) + [ pure $ (pure (), compileWithPkg (Just db) hdrCabalVersion CPSProject) ] appdir <- appCacheDir @@ -122,7 +131,7 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do vLog $ "helper exe does not exist, compiling "++compExePath prepare >> compile comp cp - where + where logMsg = "using helper compiled with Cabal from " -- for relaxed deps: find (sameMajorVersionAs hdrCabalVersion) . reverse . sort @@ -130,7 +139,7 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do -- | Check if this version is globally available compileGlobal :: Env => MaybeT IO (IO (), Compile) compileGlobal = do - cabal_versions <- listCabalVersions + cabal_versions <- listCabalVersions' Nothing ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions vLog $ logMsg ++ "user/global package-db" return $ (return (), compileWithPkg Nothing ver CPSGlobal) @@ -150,10 +159,10 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do (PlanJson {pjUnits}, distdir_newstyle) <- maybe mzero pure mnewstyle let cabal_pkgid = PkgId (PkgName (Text.pack "Cabal")) - (Ver $ versionBranch hdrCabalVersion) + (Ver $ versionBranch hdrCabalVersion) mcabal_unit = listToMaybe $ - Map.elems $ Map.filter (\Unit {..} -> uPId == cabal_pkgid) pjUnits - Unit {} <- maybe mzero pure mcabal_unit + Map.elems $ Map.filter (\CP.Unit{..} -> uPId == cabal_pkgid) pjUnits + CP.Unit {} <- maybe mzero pure mcabal_unit let inplace_db_path = distdir_newstyle "packagedb" ("ghc-" ++ showVersion ghcVer) inplace_db = PackageDbDir inplace_db_path @@ -175,7 +184,7 @@ compileHelper opts hdrCabalVersion projdir mnewstyle cachedir = do db_exists <- liftIO $ cabalVersionExistsInPkgDb hdrCabalVersion db when (not db_exists) $ void $ installCabal (Right hdrCabalVersion) `E.catch` - \(SomeException _) -> errorInstallCabal hdrCabalVersion cachedir + \(SomeException _) -> errorInstallCabal hdrCabalVersion -- | See if we're in a cabal source tree compileCabalSource :: Env => MaybeT IO (IO (), Compile) @@ -318,7 +327,7 @@ cabalMinVersionMacro _ = invokeGhc :: Env => GhcInvocation -> IO (Either ExitCode FilePath) invokeGhc GhcInvocation {..} = do - rv <- callProcessStderr' Nothing oGhcProgram $ concat + rv <- callProcessStderr' Nothing (ghcProgram ?progs) $ concat [ [ "-outputdir", giOutDir , "-o", giOutput ] @@ -335,8 +344,6 @@ invokeGhc GhcInvocation {..} = do case rv of ExitSuccess -> Right giOutput e@(ExitFailure _) -> Left e - where - CompileOptions {..} = ?opts -- | Cabal library version we're compiling the helper exe against. @@ -460,7 +467,7 @@ runCabalInstall (PackageDbDir db) (CabalSourceDir srcdir) ever = do then ["--no-require-sandbox"] else [] , [ "install", srcdir ] - , if oVerbose ?opts + , if ?verbose then ["-v"] else [] , [ "--only-dependencies" ] @@ -635,8 +642,8 @@ unpackCabalHEAD tmpdir = do (liftIO . setCurrentDirectory) (\_ -> liftIO (setCurrentDirectory dir) >> action) -errorInstallCabal :: Version -> FilePath -> IO a -errorInstallCabal cabalVer _distdir = panicIO $ printf "\ +errorInstallCabal :: Version -> IO a +errorInstallCabal cabalVer = panicIO $ printf "\ \Installing Cabal version %s failed.\n\ \\n\ \You have the following choices to fix this:\n\ @@ -670,9 +677,6 @@ errorInstallCabal cabalVer _distdir = panicIO $ printf "\ where sver = showVersion cabalVer -listCabalVersions :: Env => MaybeT IO [Version] -listCabalVersions = listCabalVersions' Nothing - listCabalVersions' :: Env => Maybe PackageDbDir -> MaybeT IO [Version] listCabalVersions' mdb = do case mdb of @@ -746,12 +750,12 @@ cabalFileTopField field cabalFile = value ls = map (map toLower) $ lines cabalFile extract = dropWhile (/=':') >>> drop 1 >>> dropWhile isSpace >>> takeWhile (not . isSpace) -vLog :: (Env, MonadIO m) => String -> m () -vLog msg | CompileOptions { oVerbose = True } <- ?opts = - liftIO $ hPutStrLn stderr msg -vLog _ = return () +vLog :: (MonadIO m, Verbose) => String -> m () +vLog msg + | ?verbose = liftIO $ hPutStrLn stderr msg + | otherwise = return () -logIOError :: Env => String -> IO (Maybe a) -> IO (Maybe a) +logIOError :: Verbose => String -> IO (Maybe a) -> IO (Maybe a) logIOError label a = do a `catchIOError` \ex -> do vLog $ label ++ ": " ++ show ex diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs index 10fe916..843a886 100644 --- a/src/CabalHelper/Compiletime/Types.hs +++ b/src/CabalHelper/Compiletime/Types.hs @@ -15,7 +15,8 @@ -- along with this program. If not, see . {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DefaultSignatures, - KindSignatures, ImplicitParams, ConstraintKinds #-} + StandaloneDeriving, GADTs, DataKinds, KindSignatures, ImplicitParams, + ConstraintKinds, RankNTypes #-} {-| Module : CabalHelper.Compiletime.Types @@ -25,13 +26,25 @@ License : GPL-3 module CabalHelper.Compiletime.Types where +import Cabal.Plan + ( PlanJson ) +import Data.IORef import Data.Version import Data.Typeable +import Data.Map.Strict (Map) import GHC.Generics +import System.Posix.Types +import CabalHelper.Shared.InterfaceTypes -type Env = (?opts :: CompileOptions) +type Verbose = (?verbose :: Bool) +type Progs = (?progs :: Programs) +-- TODO: rname to `CompEnv` or something +type Env = + ( ?verbose :: Bool + , ?progs :: Programs + ) --- | Paths or names of various programs we need. +-- | Configurable paths to various programs we use. data Programs = Programs { -- | The path to the @cabal@ program. cabalProgram :: FilePath, @@ -44,8 +57,8 @@ data Programs = Programs { 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@. +-- | By default all programs use their unqualified names, i.e. they will be +-- searched for on @PATH@. defaultPrograms :: Programs defaultPrograms = Programs "cabal" "ghc" "ghc-pkg" @@ -57,13 +70,13 @@ data CompileOptions = CompileOptions } oCabalProgram :: Env => FilePath -oCabalProgram = cabalProgram $ oPrograms ?opts +oCabalProgram = cabalProgram ?progs oGhcProgram :: Env => FilePath -oGhcProgram = ghcProgram $ oPrograms ?opts +oGhcProgram = ghcProgram ?progs oGhcPkgProgram :: Env => FilePath -oGhcPkgProgram = ghcPkgProgram $ oPrograms ?opts +oGhcPkgProgram = ghcPkgProgram ?progs defaultCompileOptions :: CompileOptions defaultCompileOptions = diff --git a/src/CabalHelper/Runtime/Compat.hs b/src/CabalHelper/Runtime/Compat.hs index cafbfc3..8c32adf 100644 --- a/src/CabalHelper/Runtime/Compat.hs +++ b/src/CabalHelper/Runtime/Compat.hs @@ -151,9 +151,9 @@ type UnitId = InstalledPackageId componentNameToCh :: ComponentName -> ChComponentName -componentNameToCh CLibName = ChLibName +componentNameToCh CLibName = ChLibName ChMainLibName #if CH_MIN_VERSION_Cabal(2,0,0) -componentNameToCh (CSubLibName n) = ChSubLibName (unUnqualComponentName' n) +componentNameToCh (CSubLibName n) = ChLibName $ ChSubLibName (unUnqualComponentName' n) componentNameToCh (CFLibName n) = ChFLibName (unUnqualComponentName' n) #endif componentNameToCh (CExeName n) = ChExeName (unUnqualComponentName' n) diff --git a/src/CabalHelper/Runtime/Main.hs b/src/CabalHelper/Runtime/Main.hs index ecdbc2a..3a363a3 100644 --- a/src/CabalHelper/Runtime/Main.hs +++ b/src/CabalHelper/Runtime/Main.hs @@ -14,7 +14,11 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . -{-# LANGUAGE CPP, BangPatterns, RecordWildCards, RankNTypes, ViewPatterns #-} +{-# LANGUAGE CPP, BangPatterns, RecordWildCards, RankNTypes, ViewPatterns, + TupleSections #-} + +{- # OPTIONS_GHC -Wno-missing-signatures #-} +{- # OPTIONS_GHC -fno-warn-incomplete-patterns #-} #ifdef MIN_VERSION_Cabal #undef CH_MIN_VERSION_Cabal @@ -34,7 +38,7 @@ import Distribution.PackageDescription ( PackageDescription , GenericPackageDescription(..) , Flag(..) - , FlagName(..) + , FlagName , FlagAssignment , Executable(..) , Library(..) @@ -65,7 +69,7 @@ import Distribution.Simple.LocalBuildInfo , ComponentLocalBuildInfo(..) , componentBuildInfo , externalPackageDeps - , withComponentsLBI + , withAllComponentsInBuildOrder , withLibLBI , withExeLBI ) @@ -141,7 +145,13 @@ import Distribution.Types.ForeignLib ( ForeignLib(..) ) import Distribution.Types.UnqualComponentName - ( unUnqualComponentName + ( UnqualComponentName + , unUnqualComponentName + ) +#else +-- <1.25 +import Distribution.PackageDescription + ( FlagName(FlagName) ) #endif @@ -198,12 +208,12 @@ import Distribution.Types.GenericPackageDescription ) #endif -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>), ZipList(..)) import Control.Arrow (first, second, (&&&)) import Control.Monad import Control.Exception (catch, PatternMatchFail(..)) import Data.List -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map import Data.Maybe import Data.Monoid import Data.IORef @@ -227,42 +237,26 @@ usage = do hPutStr stderr $ "Usage: " ++ prog ++ " " ++ usageMsg where usageMsg = "" - ++"PROJ_DIR DIST_DIR [--with-* ...] (\n" - ++" version\n" - ++" | print-lbi [--human]\n" - ++" | package-id\n" + ++"PROJ_DIR DIST_DIR [--with-* ...]\n" + ++" ( version\n" ++" | flags\n" ++" | config-flags\n" ++" | non-default-config-flags\n" ++" | write-autogen-files\n" ++" | compiler-version\n" - ++" | 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" - ++" | package-db-stack\n" - ++" | entrypoints\n" - ++" | needs-build-output\n" - ++" | source-dirs\n" + ++" | component-info\n" + ++" | print-lbi [--human]\n" ++" ) ...\n" commands :: [String] -commands = [ "print-lbi" - , "package-id" - , "flags" +commands = [ "flags" , "config-flags" , "non-default-config-flags" , "write-autogen-files" , "compiler-version" - , "ghc-options" - , "ghc-src-options" - , "ghc-pkg-options" - , "ghc-lang-options" , "package-db-stack" - , "entrypoints" - , "needs-build-output" - , "source-dirs" + , "component-info" + , "print-lbi" ] main :: IO () @@ -352,12 +346,41 @@ main = do let CompilerId comp ver = compilerId $ compiler lbi return $ Just $ ChResponseVersion (show comp) (toDataVersion ver) - "ghc-options":flags -> do - res <- componentOptions lvd True flags id - return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) + "package-db-stack":[] -> do + let + pkgDb GlobalPackageDB = ChPkgGlobal + pkgDb UserPackageDB = ChPkgUser + pkgDb (SpecificPackageDB s) = ChPkgSpecific s + + -- TODO: Setup.hs has access to the sandbox as well: ghc-mod#478 + return $ Just $ ChResponsePkgDbs $ map pkgDb $ withPackageDB lbi + + "component-info":flags -> do + res <- componentsInfo flags lvd lbi v distdir + return $ Just $ ChResponseComponentsInfo res + + "print-lbi":flags -> + case flags of + ["--human"] -> print lbi >> return Nothing + [] -> return $ Just $ ChResponseLbi $ show lbi - "ghc-src-options":flags -> do - res <- componentOptions lvd False flags $ \opts -> mempty { + cmd:_ | not (cmd `elem` commands) -> + errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure + _ -> + errMsg "Invalid usage!" >> usage >> exitFailure + + +componentsInfo + :: [String] + -> (LocalBuildInfo, Verbosity, FilePath) + -> LocalBuildInfo + -> Verbosity + -> FilePath + -> IO (Map.Map ChComponentName ChComponentInfo) +componentsInfo flags lvd lbi v distdir = do + ciGhcOptions <- componentOptions lvd True flags id + + ciGhcSrcOptions <- componentOptions lvd False flags $ \opts -> mempty { -- Not really needed but "unexpected package db stack: []" ghcOptPackageDBs = [GlobalPackageDB, UserPackageDB], @@ -368,90 +391,61 @@ main = do ghcOptSourcePathClear = ghcOptSourcePathClear opts, ghcOptSourcePath = ghcOptSourcePath opts } - return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) - "ghc-pkg-options":flags -> do - res <- componentOptions lvd True flags $ \opts -> mempty { + ciGhcPkgOptions <- componentOptions lvd True flags $ \opts -> mempty { ghcOptPackageDBs = ghcOptPackageDBs opts, ghcOptPackages = ghcOptPackages opts, ghcOptHideAllPackages = ghcOptHideAllPackages opts } - return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) - - "ghc-merged-pkg-options":flags -> do - res <- mconcat . map snd <$> (componentOptions' lvd True flags (\_ _ o -> return o) $ \opts -> mempty { - ghcOptPackageDBs = [], - ghcOptHideAllPackages = NoFlag, - ghcOptPackages = ghcOptPackages opts - }) - - let res' = nubPackageFlags $ res { ghcOptPackageDBs = withPackageDB lbi - , ghcOptHideAllPackages = Flag True - } - - Just . ChResponseList <$> renderGhcOptions' lbi v res' - "ghc-lang-options":flags -> do - res <- componentOptions lvd False flags $ \opts -> mempty { + ciGhcLangOptions <- componentOptions lvd False flags $ \opts -> mempty { ghcOptPackageDBs = [GlobalPackageDB, UserPackageDB], ghcOptLanguage = ghcOptLanguage opts, ghcOptExtensions = ghcOptExtensions opts, ghcOptExtensionMap = ghcOptExtensionMap opts } - return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) - "package-db-stack":[] -> do - let - pkgDb GlobalPackageDB = ChPkgGlobal - pkgDb UserPackageDB = ChPkgUser - pkgDb (SpecificPackageDB s) = ChPkgSpecific s + ciSourceDirs <- componentsMap lbi v distdir $ \_ _ bi -> return $ hsSourceDirs bi - -- TODO: Setup.hs has access to the sandbox as well: ghc-mod#478 - return $ Just $ ChResponsePkgDbs $ map pkgDb $ withPackageDB lbi - - "entrypoints":[] -> do #if CH_MIN_VERSION_Cabal(2,0,0) includeDirMap <- recursiveDepInfo lbi v distdir - eps <- componentsMap lbi v distdir $ \c clbi _bi -> do + ciEntrypoints <- componentsMap lbi v distdir $ \c clbi _bi -> do case needsBuildOutput includeDirMap (componentUnitId clbi) of ProduceBuildOutput -> return $ componentEntrypoints c NoBuildOutput -> return seps where (_,_,seps) = recursiveIncludeDirs includeDirMap (componentUnitId clbi) #else - eps <- componentsMap lbi v distdir $ \c _clbi _bi -> + ciEntrypoints <- componentsMap lbi v distdir $ \c _clbi _bi -> return $ componentEntrypoints c #endif - -- MUST append Setup component at the end otherwise CabalHelper gets - -- confused - let eps' = eps ++ [(ChSetupHsName, ChSetupEntrypoint)] - return $ Just $ ChResponseEntrypoints eps' - "needs-build-output":[] -> do #if CH_MIN_VERSION_Cabal(2,0,0) - includeDirMap <- recursiveDepInfo lbi v distdir - nbs <- componentsMap lbi v distdir $ \c clbi _bi -> + ciNeedsBuildOutput <- componentsMap lbi v distdir $ \_c clbi _bi -> return $ needsBuildOutput includeDirMap (componentUnitId clbi) #else - nbs <- componentsMap lbi v distdir $ \c _clbi _bi -> + ciNeedsBuildOutput <- componentsMap lbi v distdir $ \_c _clbi _bi -> return $ NoBuildOutput #endif - return $ Just $ ChResponseNeedsBuild nbs - "source-dirs":[] -> do - res <- componentsMap lbi v distdir $$ \_ _ bi -> return $ hsSourceDirs bi - return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) + let comp_name = map fst ciGhcOptions + uiComponents = Map.fromList + $ map (ciComponentName &&& id) + $ getZipList + $ ChComponentInfo + <$> ZipList comp_name + <*> ZipList (map snd ciGhcOptions) + <*> ZipList (map snd ciGhcSrcOptions) + <*> ZipList (map snd ciGhcPkgOptions) + <*> ZipList (map snd ciGhcLangOptions) + <*> ZipList (map snd ciSourceDirs) + <*> ZipList (map snd ciEntrypoints) + <*> ZipList (map snd ciNeedsBuildOutput) - "print-lbi":flags -> - case flags of - ["--human"] -> print lbi >> return Nothing - [] -> return $ Just $ ChResponseLbi $ show lbi + return uiComponents - cmd:_ | not (cmd `elem` commands) -> - errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure - _ -> - errMsg "Invalid usage!" >> usage >> exitFailure +flagName' :: Distribution.PackageDescription.Flag -> String flagName' = unFlagName . flagName -- getLibrary :: PackageDescription -> Library @@ -460,6 +454,10 @@ flagName' = unFlagName . flagName -- withLib pd (writeIORef lr) -- readIORef lr +getLibraryClbi + :: PackageDescription + -> LocalBuildInfo + -> Maybe (Library, ComponentLocalBuildInfo) getLibraryClbi pd lbi = unsafePerformIO $ do lr <- newIORef Nothing @@ -469,15 +467,6 @@ getLibraryClbi pd lbi = unsafePerformIO $ do readIORef lr -getExeClbi pd lbi = unsafePerformIO $ do - lr <- newIORef Nothing - - withExeLBI pd lbi $ \ exe clbi -> - writeIORef lr $ Just (exe,clbi) - - readIORef lr - - componentsMap :: LocalBuildInfo -> Verbosity -> FilePath @@ -493,20 +482,23 @@ componentsMap lbi _v _distdir f = do -- withComponentsLBI is deprecated but also exists in very old versions -- it's equivalent to withAllComponentsInBuildOrder in newer versions - withComponentsLBI pd lbi $ \c clbi -> do + withAllComponentsInBuildOrder pd lbi $ \c clbi -> do let bi = componentBuildInfo c - name = componentNameFromComponent c + name = componentNameToCh $ componentNameFromComponent c l' <- readIORef lr r <- f c clbi bi -#if CH_MIN_VERSION_Cabal(2,0,0) - writeIORef lr $ (componentNameToCh name, r):l' -#else - writeIORef lr $ (componentNameToCh name, r):l' -#endif + writeIORef lr $ (name, r) : l' reverse <$> readIORef lr +componentOptions' + :: (LocalBuildInfo, Verbosity, FilePath) + -> Bool + -> [String] + -> (LocalBuildInfo -> Verbosity -> GhcOptions -> IO a) + -> (GhcOptions -> GhcOptions) + -> IO [(ChComponentName, a)] componentOptions' (lbi, v, distdir) inplaceFlag flags rf f = do let pd = localPkgDescr lbi #if CH_MIN_VERSION_Cabal(2,0,0) @@ -529,12 +521,18 @@ componentOptions' (lbi, v, distdir) inplaceFlag flags rf f = do in rf lbi v $ nubPackageFlags $ opts' `mappend` adopts +componentOptions :: (LocalBuildInfo, Verbosity, FilePath) + -> Bool + -> [String] + -> (GhcOptions -> GhcOptions) + -> IO [(ChComponentName, [String])] componentOptions (lbi, v, distdir) inplaceFlag flags f = componentOptions' (lbi, v, distdir) inplaceFlag flags renderGhcOptions' f gmModuleName :: C.ModuleName -> ChModuleName gmModuleName = ChModuleName . intercalate "." . components + #if CH_MIN_VERSION_Cabal(2,0,0) removeInplaceDeps :: Verbosity -> LocalBuildInfo @@ -571,7 +569,7 @@ removeInplaceDeps _v lbi pd clbi includeDirs = let , ghcOptPackages = ghcOptPackages opts <> toNubListR extraDeps } libopts = - case (getLibraryClbi pd lbi,getExeClbi pd lbi) of + case (getLibraryClbi pd lbi, getExeClbi pd lbi) of (Just (lib, libclbi),_) | hasIdeps -> let libbi = libBuildInfo lib @@ -594,7 +592,21 @@ removeInplaceDeps _v lbi pd clbi includeDirs = let NoBuildOutput -> libopts ProduceBuildOutput -> mempty { ghcOptPackageDBs = [SpecificPackageDB packageDbDir] } in (clbi', libopts') + +getExeClbi + :: PackageDescription + -> LocalBuildInfo + -> Maybe (Executable, ComponentLocalBuildInfo) +getExeClbi pd lbi = unsafePerformIO $ do + lr <- newIORef Nothing + + withExeLBI pd lbi $ \ exe clbi -> + writeIORef lr $ Just (exe,clbi) + + readIORef lr + #else + removeInplaceDeps :: Verbosity -> LocalBuildInfo -> PackageDescription @@ -616,10 +628,16 @@ removeInplaceDeps _v lbi pd clbi = let _ -> mempty clbi' = clbi { componentPackageDeps = deps } in (clbi', libopts) + #endif #if CH_MIN_VERSION_Cabal(2,0,0) +recursiveDepInfo + :: LocalBuildInfo + -> Verbosity + -> FilePath + -> IO (Map.Map UnitId SubDeps) recursiveDepInfo lbi v distdir = do includeDirs <- componentsMap lbi v distdir $ \c clbi bi -> do return (componentUnitId clbi @@ -656,7 +674,7 @@ needsBuildOutput includeDirs unit = go [unit] go [] = NoBuildOutput go (u:us) = case Map.lookup u includeDirs of Nothing -> go us - Just (SubDeps us' sfp sci sep) -> + Just (SubDeps us' _sfp sci _sep) -> if any (isIndef . fst) sci then ProduceBuildOutput else go (us++us') @@ -666,31 +684,32 @@ needsBuildOutput includeDirs unit = go [unit] -- current accumulated value, and the second one is the current sub-dependency -- being considered. So the bias should be to preserve the type of entrypoint -- from the first parameter. +combineEp :: Maybe ChEntrypoint -> ChEntrypoint -> ChEntrypoint combineEp Nothing e = e combineEp (Just ChSetupEntrypoint) e = e combineEp (Just (ChLibEntrypoint es1 os1 ss1)) (ChLibEntrypoint es2 os2 ss2) = (ChLibEntrypoint (nub $ es2++es1) (nub $ os2++os1) (nub $ ss2++ss1)) -combineEp _ e@(ChExeEntrypoint mi os2) = error $ "combineEP: cannot have a sub exe:" ++ show e +combineEp _ e@(ChExeEntrypoint _mi _os2) = error $ "combineEP: cannot have a sub exe:" ++ show e combineEp (Just (ChExeEntrypoint mi os1)) (ChLibEntrypoint es2 os2 ss2) = (ChExeEntrypoint mi (nub $ os1++es2++os2++ss2)) -- no, you unconditionally always wrap the result in Just, so instead of `f x = Just y; f x = Just z` do `f x = y; f x = z` and use f as `Just . f` - - -instantiatedGhcPackage :: (ModuleName,OpenModule) -> [(OpenUnitId, ModuleRenaming)] -instantiatedGhcPackage (_,OpenModule oui@(DefiniteUnitId _) _) = [(oui,DefaultRenaming)] -instantiatedGhcPackage (_, _) = [] #endif + +initialBuildStepsForAllComponents + :: FilePath + -> PackageDescription + -> LocalBuildInfo + -> Verbosity + -> IO () initialBuildStepsForAllComponents distdir pd lbi v = initialBuildSteps distdir pd lbi v - - - #if !CH_MIN_VERSION_Cabal(1,25,0) -- CPP < 1.25 +unFlagName :: FlagName -> String unFlagName (FlagName n) = n -- mkFlagName n = FlagName n #endif @@ -742,14 +761,14 @@ componentEntrypoints (CBench Benchmark {}) #if CH_MIN_VERSION_Cabal(2,0,0) isInplaceCompInc :: ComponentLocalBuildInfo -> (OpenUnitId, ModuleRenaming) -> Bool isInplaceCompInc clbi (DefiniteUnitId uid, _mr) = unDefUnitId uid `elem` componentInternalDeps clbi -isInplaceCompInc clbi (IndefFullUnitId uid _, _mmr) = False +isInplaceCompInc _clbi (IndefFullUnitId _uid _, _mmr) = False #endif #if CH_MIN_VERSION_Cabal(2,0,0) -isInplaceDep :: LocalBuildInfo -> ComponentLocalBuildInfo -> (UnitId, MungedPackageId) -> Bool -isInplaceDep lbi clbi (uid, _mpid) = uid `elem` componentInternalDeps clbi +-- isInplaceDep :: LocalBuildInfo -> ComponentLocalBuildInfo -> (UnitId, MungedPackageId) -> Bool +-- isInplaceDep lbi clbi (uid, _mpid) = uid `elem` componentInternalDeps clbi #else -isInplaceDep :: LocalBuildInfo -> (InstalledPackageId, PackageId) -> Bool +isInplaceDep :: LocalBuildInfo -> (UnitId, PackageId) -> Bool # if CH_MIN_VERSION_Cabal(1,23,0) -- CPP >= 1.23 isInplaceDep lbi (ipid, _pid) = localUnitId lbi == ipid @@ -759,6 +778,7 @@ isInplaceDep _lbi (ipid, pid) = inplacePackageId pid == ipid # endif #endif +nubPackageFlags :: GhcOptions -> GhcOptions #if CH_MIN_VERSION_Cabal(1,22,0) -- CPP >= 1.22 -- >= 1.22 uses NubListR diff --git a/src/CabalHelper/Shared/InterfaceTypes.hs b/src/CabalHelper/Shared/InterfaceTypes.hs index a108c72..0539b96 100644 --- a/src/CabalHelper/Shared/InterfaceTypes.hs +++ b/src/CabalHelper/Shared/InterfaceTypes.hs @@ -34,31 +34,63 @@ module CabalHelper.Shared.InterfaceTypes where import GHC.Generics import Data.Version +import Data.Map.Strict (Map) data ChResponse - = ChResponseCompList [(ChComponentName, [String])] - | ChResponseEntrypoints [(ChComponentName, ChEntrypoint)] - | ChResponseNeedsBuild [(ChComponentName, NeedsBuildOutput)] - | ChResponseList [String] - | ChResponsePkgDbs [ChPkgDb] - | ChResponseLbi String - | ChResponseVersion String Version - | ChResponseLicenses [(String, [(String, Version)])] - | ChResponseFlags [(String, Bool)] + = ChResponseComponentsInfo (Map ChComponentName ChComponentInfo) + | ChResponseList [String] + | ChResponsePkgDbs [ChPkgDb] + | ChResponseLbi String + | ChResponseVersion String Version + | ChResponseLicenses [(String, [(String, Version)])] + | ChResponseFlags [(String, Bool)] deriving (Eq, Ord, Read, Show, Generic) data ChComponentName = ChSetupHsName - | ChLibName - | ChSubLibName String + | ChLibName ChLibraryName | ChFLibName String | ChExeName String | ChTestName String | ChBenchName String deriving (Eq, Ord, Read, Show, Generic) +data ChLibraryName = ChMainLibName + | ChSubLibName String + deriving (Eq, Ord, Read, Show, Generic) + newtype ChModuleName = ChModuleName String deriving (Eq, Ord, Read, Show, Generic) +data ChComponentInfo = ChComponentInfo + { ciComponentName :: ChComponentName + -- ^ The component\'s type and name + + , ciGhcOptions :: [String] + -- ^ Full set of GHC options, ready for loading this component into GHCi. + + , ciGhcSrcOptions :: [String] + -- ^ Only search path related GHC options. + + , ciGhcPkgOptions :: [String] + -- ^ Only package related GHC options, sufficient for things don't need to + -- access any home modules. + + , ciGhcLangOptions :: [String] + -- ^ Only Haskell language extension related options, i.e. @-XSomeExtension@ + + , ciSourceDirs :: [String] + -- ^ A component's @source-dirs@ field, beware since if this is empty + -- implicit behaviour in GHC kicks in which you might have to emulate. + + , ciEntrypoints :: ChEntrypoint + -- ^ Modules or files Cabal would have the compiler build directly. Can be + -- used to compute the home module closure for a component. + + , ciNeedsBuildOutput :: NeedsBuildOutput + -- ^ If a component has a non-default module renaming (backpack) it cannot + -- be built in memory and instead needs proper build output. + } deriving (Eq, Ord, Read, Show) + data ChEntrypoint = ChSetupEntrypoint -- ^ Almost like 'ChExeEntrypoint' but -- @main-is@ could either be @"Setup.hs"@ -- or @"Setup.lhs"@. Since we don't know diff --git a/tests/CompileTest.hs b/tests/CompileTest.hs index 02f4c3b..5e03d8c 100644 --- a/tests/CompileTest.hs +++ b/tests/CompileTest.hs @@ -46,6 +46,7 @@ main :: IO () main = do let ?progs = defaultPrograms let ?opts = defaultCompileOptions { oVerbose = True } + let ?verbose = True args <- getArgs case args of diff --git a/tests/GhcSession.hs b/tests/GhcSession.hs index 6e71075..63085db 100644 --- a/tests/GhcSession.hs +++ b/tests/GhcSession.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections, ScopedTypeVariables #-} +{-# LANGUAGE TupleSections, ScopedTypeVariables, RecordWildCards #-} module Main where import GHC @@ -10,6 +10,7 @@ import Control.Monad import Control.Monad.IO.Class import Data.List import Data.Version +import qualified Data.Map as Map import System.Environment (getArgs) import System.Exit import System.FilePath (()) @@ -91,23 +92,26 @@ run x xs = do ExitSuccess <- rawSystem x xs return () +allComponents :: Query pt [ChComponentInfo] +allComponents = + concat . map (Map.elems . uiComponents) <$> (mapM unitQuery =<< projectUnits) + test :: FilePath -> IO [Bool] test dir = do - let qe = mkQueryEnv dir (dir "dist") - cs <- runQuery qe $ components $ (,,,) <$> entrypoints <.> ghcOptions <.> needsBuildOutput - forM cs $ \(ep, opts, nb, cn) -> do - - putStrLn $ "\n" ++ show cn ++ ":::: " ++ show nb + qe <- mkQueryEnv (ProjDirV1 dir) (DistDirV1 $ dir "dist") + cs <- runQuery allComponents qe + forM cs $ \ChComponentInfo{..} -> do + putStrLn $ "\n" ++ show ciComponentName ++ ":::: " ++ show ciNeedsBuildOutput - when (nb == ProduceBuildOutput) $ do + when (ciNeedsBuildOutput == ProduceBuildOutput) $ do run "cabal" [ "build" ] - let opts' = "-Werror" : opts + let opts' = "-Werror" : ciGhcOptions let sopts = intercalate " " $ map formatArg $ "\nghc" : opts' - putStrLn $ "\n" ++ show cn ++ ": " ++ sopts + putStrLn $ "\n" ++ show ciComponentName ++ ": " ++ sopts hFlush stdout - compileModule nb ep opts' + compileModule ciNeedsBuildOutput ciEntrypoints opts' where formatArg x | "-" `isPrefixOf` x = "\n "++x -- cgit v1.2.3