From 2330822913c37f48c6d189eabf3db433830ffb4b Mon Sep 17 00:00:00 2001
From: Rodrigo Mesquita <rodrigo.m.mesquita@gmail.com>
Date: Tue, 9 Jan 2024 13:35:29 +0000
Subject: [PATCH] Introduce computations in the context of building a component

Introduces 'BuildM', a monad for actions defined in the context of
building a component. Actions in the 'BuildM' monad have access to
'PreBuildComponentInputs', which is the information necessary and
available to a build right before building a component (hence the name).

Introduces as well 'BuildingWhat', a type that distinguishes the kind of
build we are doing (Normal vs Repl vs Haddock vs Hscolour) and the
different flags available for each kind of build.
---
 Cabal/Cabal.cabal                            |  1 +
 Cabal/src/Distribution/Simple/Build/Monad.hs | 43 ++++++++++++++++++++
 Cabal/src/Distribution/Simple/Setup.hs       | 37 ++++++++++++++++-
 3 files changed, 80 insertions(+), 1 deletion(-)
 create mode 100644 Cabal/src/Distribution/Simple/Build/Monad.hs

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 =