Skip to content

Commit a11ae47

Browse files
mgsloanmgsloan
committed
Add a StackM constraint syn to reduce boilerplate
1 parent 23b2835 commit a11ae47

20 files changed

Lines changed: 224 additions & 345 deletions

‎src/Stack/Build.hs‎

Lines changed: 11 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -22,7 +22,6 @@ module Stack.Build
2222

2323
import Control.Exception (Exception)
2424
import Control.Monad
25-
import Control.Monad.Catch (MonadMask, MonadMask)
2625
import Control.Monad.IO.Class
2726
import Control.Monad.Logger
2827
import Control.Monad.Reader (MonadReader, asks)
@@ -48,7 +47,6 @@ import Data.Text.Read (decimal)
4847
import Data.Typeable (Typeable)
4948
import qualified Data.Vector as V
5049
import qualified Data.Yaml as Yaml
51-
import Network.HTTP.Client.Conduit (HasHttpManager)
5250
import Path
5351
import Prelude hiding (FilePath, writeFile)
5452
import Stack.Build.ConstructPlan
@@ -60,14 +58,15 @@ import Stack.Build.Target
6058
import Stack.Fetch as Fetch
6159
import Stack.GhcPkg
6260
import Stack.Package
61+
import Stack.Types.Build
62+
import Stack.Types.Config
6363
import Stack.Types.FlagName
64+
import Stack.Types.Package
6465
import Stack.Types.PackageIdentifier
6566
import Stack.Types.PackageName
67+
import Stack.Types.StackT
6668
import Stack.Types.Version
67-
import Stack.Types.Config
68-
import Stack.Types.Build
69-
import Stack.Types.Package
70-
import Stack.Types.Internal
69+
7170
#ifdef WINDOWS
7271
import Stack.Types.Compiler
7372
#endif
@@ -78,14 +77,12 @@ import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getCons
7877
import qualified Control.Monad.Catch as Catch
7978
#endif
8079

81-
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLoggerIO m,MonadBaseUnlift IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
82-
8380
-- | Build.
8481
--
8582
-- If a buildLock is passed there is an important contract here. That lock must
8683
-- protect the snapshot, and it must be safe to unlock it if there are no further
8784
-- modifications to the snapshot to be performed by this build.
88-
build :: M env m
85+
build :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)
8986
=> (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files
9087
-> Maybe FileLock
9188
-> BuildOptsCLI
@@ -150,7 +147,7 @@ allLocal =
150147
Map.elems .
151148
planTasks
152149

153-
checkCabalVersion :: M env m => m ()
150+
checkCabalVersion :: (StackM env m, HasEnvConfig env) => m ()
154151
checkCabalVersion = do
155152
allowNewer <- asks (configAllowNewer . getConfig)
156153
cabalVer <- asks (envConfigCabalVersion . getEnvConfig)
@@ -275,13 +272,7 @@ mkBaseConfigOpts boptsCli = do
275272
}
276273

277274
-- | Provide a function for loading package information from the package index
278-
withLoadPackage :: ( MonadIO m
279-
, HasHttpManager env
280-
, MonadReader env m
281-
, MonadBaseUnlift IO m
282-
, MonadMask m
283-
, MonadLogger m
284-
, HasEnvConfig env)
275+
withLoadPackage :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m)
285276
=> EnvOverride
286277
-> ((PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -> m a)
287278
-> m a
@@ -311,7 +302,7 @@ withLoadPackage menv inner = do
311302
-- | Set the code page for this process as necessary. Only applies to Windows.
312303
-- See: https://github.com/commercialhaskell/stack/issues/738
313304
#ifdef WINDOWS
314-
fixCodePage :: M env m => m a -> m a
305+
fixCodePage :: (StackM env m, HasBuildConfig env) => m a -> m a
315306
fixCodePage inner = do
316307
mcp <- asks $ configModifyCodePage . getConfig
317308
ec <- asks getEnvConfig
@@ -358,7 +349,7 @@ fixCodePage = id
358349
#endif
359350

360351
-- | Query information about the build and print the result to stdout in YAML format.
361-
queryBuildInfo :: M env m
352+
queryBuildInfo :: (StackM env m, HasEnvConfig env)
362353
=> [Text] -- ^ selectors
363354
-> m ()
364355
queryBuildInfo selectors0 =
@@ -385,7 +376,7 @@ queryBuildInfo selectors0 =
385376
err msg = error $ msg ++ ": " ++ show (front [sel])
386377

387378
-- | Get the raw build information object
388-
rawBuildInfo :: M env m => m Value
379+
rawBuildInfo :: (StackM env m, HasEnvConfig env) => m Value
389380
rawBuildInfo = do
390381
(_, _mbp, locals, _extraToBuild, _sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI
391382
return $ object

‎src/Stack/Build/ConstructPlan.hs‎

Lines changed: 2 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,6 @@ module Stack.Build.ConstructPlan
1717
import Control.Arrow ((&&&))
1818
import Control.Exception.Lifted
1919
import Control.Monad
20-
import Control.Monad.Catch (MonadCatch)
2120
import Control.Monad.IO.Class
2221
import Control.Monad.Logger
2322
import Control.Monad.RWS.Strict
@@ -42,7 +41,6 @@ import qualified Distribution.Text as Cabal
4241
import qualified Distribution.Version as Cabal
4342
import GHC.Generics (Generic)
4443
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
45-
import Network.HTTP.Client.Conduit (HasHttpManager)
4644
import Path
4745
import Prelude hiding (pi, writeFile)
4846
import Stack.Build.Cache
@@ -60,10 +58,10 @@ import Stack.Types.Compiler
6058
import Stack.Types.Config
6159
import Stack.Types.FlagName
6260
import Stack.Types.GhcPkgId
63-
import Stack.Types.Internal (HasTerminal)
6461
import Stack.Types.Package
6562
import Stack.Types.PackageIdentifier
6663
import Stack.Types.PackageName
64+
import Stack.Types.StackT (StackM)
6765
import Stack.Types.Version
6866

6967
data PackageInfo
@@ -145,8 +143,7 @@ instance HasBuildConfig Ctx where
145143
instance HasEnvConfig Ctx where
146144
getEnvConfig = ctxEnvConfig
147145

148-
constructPlan :: forall env m.
149-
(MonadCatch m, MonadReader env m, HasEnvConfig env, MonadLoggerIO m, MonadBaseControl IO m, HasHttpManager env, HasTerminal env)
146+
constructPlan :: forall env m. (StackM env m, HasEnvConfig env)
150147
=> MiniBuildPlan
151148
-> BaseConfigOpts
152149
-> [LocalPackage]

‎src/Stack/Build/Execute.hs‎

Lines changed: 18 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@
66
{-# LANGUAGE RecordWildCards #-}
77
{-# LANGUAGE TemplateHaskell #-}
88
{-# LANGUAGE LambdaCase #-}
9+
{-# LANGUAGE TypeFamilies #-}
910
-- | Perform a build
1011
module Stack.Build.Execute
1112
( printPlan
@@ -25,11 +26,11 @@ import Control.Concurrent.STM
2526
import Control.Exception.Enclosed (catchIO)
2627
import Control.Exception.Lifted
2728
import Control.Monad (liftM, when, unless, void)
28-
import Control.Monad.Catch (MonadCatch, MonadMask)
29+
import Control.Monad.Catch (MonadCatch)
2930
import Control.Monad.Extra (anyM, (&&^))
3031
import Control.Monad.IO.Class
3132
import Control.Monad.Logger
32-
import Control.Monad.Reader (MonadReader, asks)
33+
import Control.Monad.Reader (asks)
3334
import Control.Monad.Trans.Control (liftBaseWith)
3435
import Control.Monad.Trans.Resource
3536
import qualified Crypto.Hash.SHA256 as SHA256
@@ -68,7 +69,6 @@ import Distribution.System (OS (Windows),
6869
Platform (Platform))
6970
import qualified Distribution.Text as C
7071
import Language.Haskell.TH as TH (location)
71-
import Network.HTTP.Client.Conduit (HasHttpManager)
7272
import Path
7373
import Path.Extra (toFilePathNoTrailingSep, rejectMissingFile)
7474
import Path.IO hiding (findExecutable, makeAbsolute)
@@ -110,10 +110,8 @@ import System.Process.Run
110110
import System.Process.Internals (createProcess_)
111111
#endif
112112

113-
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env, HasConfig env)
114-
115113
-- | Fetch the packages necessary for a build, for example in combination with a dry run.
116-
preFetch :: M env m => Plan -> m ()
114+
preFetch :: (StackM env m, HasEnvConfig env) => Plan -> m ()
117115
preFetch plan
118116
| Set.null idents = $logDebug "Nothing to fetch"
119117
| otherwise = do
@@ -133,7 +131,7 @@ preFetch plan
133131
(packageVersion package)
134132

135133
-- | Print a description of build plan for human consumption.
136-
printPlan :: M env m
134+
printPlan :: (StackM env m, HasEnvConfig env)
137135
=> Plan
138136
-> m ()
139137
printPlan plan = do
@@ -261,7 +259,7 @@ simpleSetupHash =
261259
encodeUtf8 (T.pack (unwords buildSetupArgs)) <> setupGhciShimCode <> simpleSetupCode
262260

263261
-- | Get a compiled Setup exe
264-
getSetupExe :: M env m
262+
getSetupExe :: (StackM env m, HasEnvConfig env)
265263
=> Path Abs File -- ^ Setup.hs input file
266264
-> Path Abs File -- ^ SetupShim.hs input file
267265
-> Path Abs Dir -- ^ temporary directory
@@ -322,7 +320,7 @@ getSetupExe setupHs setupShimHs tmpdir = do
322320
return $ Just exePath
323321

324322
-- | Execute a callback that takes an 'ExecuteEnv'.
325-
withExecuteEnv :: M env m
323+
withExecuteEnv :: (StackM env m, HasEnvConfig env)
326324
=> EnvOverride
327325
-> BuildOpts
328326
-> BuildOptsCLI
@@ -440,7 +438,7 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot
440438
$logInfo $ T.pack $ "\n-- End of log file: " ++ toFilePath filepath ++ "\n"
441439

442440
-- | Perform the actual plan
443-
executePlan :: M env m
441+
executePlan :: (StackM env m, HasEnvConfig env)
444442
=> EnvOverride
445443
-> BuildOptsCLI
446444
-> BaseConfigOpts
@@ -575,7 +573,7 @@ windowsRenameCopy src dest = do
575573
old = dest ++ ".old"
576574

577575
-- | Perform the actual plan (internal)
578-
executePlan' :: M env m
576+
executePlan' :: (StackM env m, HasEnvConfig env)
579577
=> InstalledMap
580578
-> Map PackageName SimpleTarget
581579
-> Plan
@@ -671,7 +669,7 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
671669
$ Map.elems
672670
$ planUnregisterLocal plan
673671

674-
toActions :: M env m
672+
toActions :: (StackM env m, HasEnvConfig env)
675673
=> InstalledMap
676674
-> (m () -> IO ())
677675
-> ExecuteEnv
@@ -725,7 +723,7 @@ toActions installedMap runInBase ee (mbuild, mfinal) =
725723
beopts = boptsBenchmarkOpts bopts
726724

727725
-- | Generate the ConfigCache
728-
getConfigCache :: M env m
726+
getConfigCache :: (StackM env m, HasEnvConfig env)
729727
=> ExecuteEnv -> Task -> InstalledMap -> Bool -> Bool
730728
-> m (Map PackageIdentifier GhcPkgId, ConfigCache)
731729
getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = do
@@ -770,7 +768,7 @@ getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = d
770768
return (allDepsMap, cache)
771769

772770
-- | Ensure that the configuration for the package matches what is given
773-
ensureConfig :: M env m
771+
ensureConfig :: (StackM env m, HasEnvConfig env)
774772
=> ConfigCache -- ^ newConfigCache
775773
-> Path Abs Dir -- ^ package directory
776774
-> ExecuteEnv
@@ -831,7 +829,7 @@ announceTask task x = $logInfo $ T.concat
831829
, x
832830
]
833831

834-
withSingleContext :: M env m
832+
withSingleContext :: (StackM env m, HasEnvConfig env)
835833
=> (m () -> IO ())
836834
-> ActionContext
837835
-> ExecuteEnv
@@ -1047,7 +1045,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
10471045
return (outputFile, setupArgs)
10481046
runExe exeName $ (if boptsCabalVerbose eeBuildOpts then ("--verbose":) else id) fullArgs
10491047

1050-
singleBuild :: M env m
1048+
singleBuild :: (StackM env m, HasEnvConfig env)
10511049
=> (m () -> IO ())
10521050
-> ActionContext
10531051
-> ExecuteEnv
@@ -1315,7 +1313,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
13151313
_ -> error "singleBuild: invariant violated: multiple results when describing installed package"
13161314

13171315
-- | Check if any unlisted files have been found, and add them to the build cache.
1318-
checkForUnlistedFiles :: M env m => TaskType -> ModTime -> Path Abs Dir -> m [PackageWarning]
1316+
checkForUnlistedFiles :: (StackM env m, HasEnvConfig env) => TaskType -> ModTime -> Path Abs Dir -> m [PackageWarning]
13191317
checkForUnlistedFiles (TTLocal lp) preBuildTime pkgDir = do
13201318
(addBuildCache,warnings) <-
13211319
addUnlistedToBuildCache
@@ -1338,7 +1336,7 @@ depsPresent installedMap deps = all
13381336
Nothing -> False)
13391337
(Map.toList deps)
13401338

1341-
singleTest :: M env m
1339+
singleTest :: (StackM env m, HasEnvConfig env)
13421340
=> (m () -> IO ())
13431341
-> TestOpts
13441342
-> [Text]
@@ -1481,7 +1479,7 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do
14811479
(fmap fst mlogFile)
14821480
bs
14831481

1484-
singleBench :: M env m
1482+
singleBench :: (StackM env m, HasEnvConfig env)
14851483
=> (m () -> IO ())
14861484
-> BenchmarkOpts
14871485
-> [Text]
@@ -1573,7 +1571,7 @@ getSetupHs dir = do
15731571
-- Do not pass `-hpcdir` as GHC option if the coverage is not enabled.
15741572
-- This helps running stack-compiled programs with dynamic interpreters like `hint`.
15751573
-- Cfr: https://github.com/commercialhaskell/stack/issues/997
1576-
extraBuildOptions :: M env m => WhichCompiler -> BuildOpts -> m [String]
1574+
extraBuildOptions :: (StackM env m, HasEnvConfig env) => WhichCompiler -> BuildOpts -> m [String]
15771575
extraBuildOptions wc bopts = do
15781576
let ddumpOpts = " -ddump-hi -ddump-to-file"
15791577
optsFlag = compilerOptionsCabalFlag wc

‎src/Stack/Build/Haddock.hs‎

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,6 @@ import Control.Monad
2121
import Control.Monad.Catch (MonadCatch)
2222
import Control.Monad.IO.Class
2323
import Control.Monad.Logger
24-
import Control.Monad.Reader (MonadReader)
2524
import Control.Monad.Trans.Resource
2625
import qualified Data.Foldable as F
2726
import Data.Function
@@ -48,17 +47,17 @@ import Stack.Types.Build
4847
import Stack.Types.Compiler
4948
import Stack.Types.Config
5049
import Stack.Types.GhcPkgId
51-
import Stack.Types.Internal (HasTerminal)
5250
import Stack.Types.Package
5351
import Stack.Types.PackageIdentifier
5452
import Stack.Types.PackageName
53+
import Stack.Types.StackT (StackM)
5554
import qualified System.FilePath as FP
5655
import System.IO.Error (isDoesNotExistError)
5756
import System.Process.Read
5857
import Web.Browser (openBrowser)
5958

6059
openHaddocksInBrowser
61-
:: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasTerminal env)
60+
:: StackM env m
6261
=> BaseConfigOpts
6362
-> Map PackageName (PackageIdentifier, InstallLocation)
6463
-- ^ Available packages and their locations for the current project

‎src/Stack/Build/Installed.hs‎

Lines changed: 5 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -11,14 +11,11 @@ module Stack.Build.Installed
1111
, getInstalled
1212
) where
1313

14-
import Control.Arrow
1514
import Control.Applicative
15+
import Control.Arrow
1616
import Control.Monad
17-
import Control.Monad.Catch (MonadMask)
18-
import Control.Monad.IO.Class
1917
import Control.Monad.Logger
20-
import Control.Monad.Reader (MonadReader, asks)
21-
import Control.Monad.Trans.Resource
18+
import Control.Monad.Reader (asks)
2219
import Data.Conduit
2320
import qualified Data.Conduit.List as CL
2421
import qualified Data.Foldable as F
@@ -32,7 +29,6 @@ import Data.Maybe
3229
import Data.Maybe.Extra (mapMaybeM)
3330
import Data.Monoid
3431
import qualified Data.Text as T
35-
import Network.HTTP.Client.Conduit (HasHttpManager)
3632
import Path
3733
import Prelude hiding (FilePath, writeFile)
3834
import Stack.Build.Cache
@@ -43,15 +39,13 @@ import Stack.Types.Build
4339
import Stack.Types.Compiler
4440
import Stack.Types.Config
4541
import Stack.Types.GhcPkgId
46-
import Stack.Types.Internal
4742
import Stack.Types.Package
4843
import Stack.Types.PackageDump
4944
import Stack.Types.PackageIdentifier
5045
import Stack.Types.PackageName
46+
import Stack.Types.StackT
5147
import Stack.Types.Version
5248

53-
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasEnvConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env)
54-
5549
-- | Options for 'getInstalled'.
5650
data GetInstalledOpts = GetInstalledOpts
5751
{ getInstalledProfiling :: !Bool
@@ -61,7 +55,7 @@ data GetInstalledOpts = GetInstalledOpts
6155
}
6256

6357
-- | Returns the new InstalledMap and all of the locally registered packages.
64-
getInstalled :: (M env m, PackageInstallInfo pii)
58+
getInstalled :: (StackM env m, HasEnvConfig env, PackageInstallInfo pii)
6559
=> EnvOverride
6660
-> GetInstalledOpts
6761
-> Map PackageName pii -- ^ does not contain any installed information
@@ -131,7 +125,7 @@ getInstalled menv opts sourceMap = do
131125
-- The goal is to ascertain that the dependencies for a package are present,
132126
-- that it has profiling if necessary, and that it matches the version and
133127
-- location needed by the SourceMap
134-
loadDatabase :: (M env m, PackageInstallInfo pii)
128+
loadDatabase :: (StackM env m, HasEnvConfig env, PackageInstallInfo pii)
135129
=> EnvOverride
136130
-> GetInstalledOpts
137131
-> Maybe InstalledCache -- ^ if Just, profiling or haddock is required

0 commit comments

Comments
 (0)