aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--cabal-helper.cabal6
-rw-r--r--lib/Distribution/Helper.hs874
-rw-r--r--src/CabalHelper/Compiletime/Compile.hs70
-rw-r--r--src/CabalHelper/Compiletime/Types.hs29
-rw-r--r--src/CabalHelper/Runtime/Compat.hs4
-rw-r--r--src/CabalHelper/Runtime/Main.hs252
-rw-r--r--src/CabalHelper/Shared/InterfaceTypes.hs54
-rw-r--r--tests/CompileTest.hs1
-rw-r--r--tests/GhcSession.hs24
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_\<pkg\>@ 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 <http://www.gnu.org/licenses/>.
-{-# 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 <http://www.gnu.org/licenses/>.
{-# 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 <http://www.gnu.org/licenses/>.
-{-# 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-07 22:01:10 +0000