diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 6cfbf819b25..9617acd74c1 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -89,6 +89,7 @@ library Distribution.Simple.Bench Distribution.Simple.Build Distribution.Simple.Build.Macros + Distribution.Simple.Build.Monad Distribution.Simple.Build.PackageInfoModule Distribution.Simple.Build.PathsModule Distribution.Simple.BuildPaths diff --git a/Cabal/src/Distribution/Simple/Build/Monad.hs b/Cabal/src/Distribution/Simple/Build/Monad.hs new file mode 100644 index 00000000000..b3d68f66276 --- /dev/null +++ b/Cabal/src/Distribution/Simple/Build/Monad.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Distribution.Simple.Build.Monad + ( BuildM (..) + , runBuildM + , PreBuildComponentInputs (..) + + -- * Re-exports + , BuildingWhat (..) + , LocalBuildInfo (..) + , TargetInfo (..) + , buildingWhatVerbosity + , buildingWhatDistPref + ) +where + +import Control.Monad.Reader + +import Distribution.Simple.Setup (BuildingWhat (..), buildingWhatDistPref, buildingWhatVerbosity) +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo + +-- | The information required for a build computation (@'BuildM'@) +-- which is available right before building each component, i.e. the pre-build +-- component inputs. +data PreBuildComponentInputs = PreBuildComponentInputs + { buildingWhat :: BuildingWhat + -- ^ What kind of build are we doing? + , localBuildInfo :: LocalBuildInfo + -- ^ Information about the package + , targetInfo :: TargetInfo + -- ^ Information about an individual component + } + +-- | Computations carried out in the context of building a component (e.g. @'buildAllExtraSources'@) +newtype BuildM a = BuildM (PreBuildComponentInputs -> IO a) + deriving (Functor, Applicative, Monad) via ReaderT PreBuildComponentInputs IO + +-- | Run a 'BuildM' action, i.e. a computation in the context of building a component. +runBuildM :: BuildingWhat -> LocalBuildInfo -> TargetInfo -> BuildM a -> IO a +runBuildM buildingWhat localBuildInfo targetInfo (BuildM f) = + f PreBuildComponentInputs{buildingWhat, localBuildInfo, targetInfo} diff --git a/Cabal/src/Distribution/Simple/Setup.hs b/Cabal/src/Distribution/Simple/Setup.hs index b4d55d604ba..fe05e882089 100644 --- a/Cabal/src/Distribution/Simple/Setup.hs +++ b/Cabal/src/Distribution/Simple/Setup.hs @@ -131,9 +131,13 @@ module Distribution.Simple.Setup , trueArg , falseArg , optionVerbosity + , BuildingWhat (..) + , buildingWhatVerbosity + , buildingWhatDistPref ) where -import Prelude () +import GHC.Generics (Generic) +import Prelude (FilePath, Show, ($)) import Distribution.Simple.Flag import Distribution.Simple.InstallDirs @@ -154,6 +158,37 @@ import Distribution.Simple.Setup.Repl import Distribution.Simple.Setup.SDist import Distribution.Simple.Setup.Test +import Distribution.Verbosity (Verbosity) + +-- | What kind of build are we doing? +-- +-- Is this a normal build, or is it perhaps for running an interactive +-- session or Haddock? +data BuildingWhat + = -- | A normal build. + BuildNormal BuildFlags + | -- | Build steps for an interactive session. + BuildRepl ReplFlags + | -- | Build steps for generating documentation. + BuildHaddock HaddockFlags + | -- | Build steps for Hscolour. + BuildHscolour HscolourFlags + deriving (Generic, Show) + +buildingWhatVerbosity :: BuildingWhat -> Verbosity +buildingWhatVerbosity = \case + BuildNormal flags -> fromFlag $ buildVerbosity flags + BuildRepl flags -> fromFlag $ replVerbosity flags + BuildHaddock flags -> fromFlag $ haddockVerbosity flags + BuildHscolour flags -> fromFlag $ hscolourVerbosity flags + +buildingWhatDistPref :: BuildingWhat -> FilePath +buildingWhatDistPref = \case + BuildNormal flags -> fromFlag $ buildDistPref flags + BuildRepl flags -> fromFlag $ replDistPref flags + BuildHaddock flags -> fromFlag $ haddockDistPref flags + BuildHscolour flags -> fromFlag $ hscolourDistPref flags + -- The test cases kinda have to be rewritten from the ground up... :/ -- hunitTests :: [Test] -- hunitTests =