Skip to content

Commit

Permalink
Introduce computations in the context of building a component
Browse files Browse the repository at this point in the history
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.
  • Loading branch information
alt-romes committed Jan 10, 2024
1 parent 77a6782 commit 2330822
Show file tree
Hide file tree
Showing 3 changed files with 80 additions and 1 deletion.
1 change: 1 addition & 0 deletions Cabal/Cabal.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
43 changes: 43 additions & 0 deletions Cabal/src/Distribution/Simple/Build/Monad.hs
Original file line number Diff line number Diff line change
@@ -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}
37 changes: 36 additions & 1 deletion Cabal/src/Distribution/Simple/Setup.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 =
Expand Down

0 comments on commit 2330822

Please sign in to comment.