Remove the StackM type synonym (fixes #1297)

commercialhaskell · Jul 19, 2017 · 62b75d2 · 62b75d2
1 parent f2f0b34
commit 62b75d2
Show file tree

Hide file tree

Showing 33 changed files with 429 additions and 455 deletions.
diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs
@@ -68,11 +68,11 @@ import           System.Win32.Console (setConsoleCP, setConsoleOutputCP, getCons
 --   If a buildLock is passed there is an important contract here.  That lock must
 --   protect the snapshot, and it must be safe to unlock it if there are no further
 --   modifications to the snapshot to be performed by this build.
-build :: (StackM env m, HasEnvConfig env)
+build :: HasEnvConfig env
       => (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files
       -> Maybe FileLock
       -> BuildOptsCLI
-      -> m ()
+      -> StackT env IO ()
 build setLocalFiles mbuildLk boptsCli = fixCodePage $ do
     bopts <- view buildOptsL
     let profiling = boptsLibProfile bopts || boptsExeProfile bopts
@@ -147,7 +147,7 @@ justLocals =
     Map.elems .
     planTasks
 
-checkCabalVersion :: (StackM env m, HasEnvConfig env) => m ()
+checkCabalVersion :: HasEnvConfig env => StackT env IO ()
 checkCabalVersion = do
     allowNewer <- view $ configL.to configAllowNewer
     cabalVer <- view cabalVersionL
@@ -272,9 +272,9 @@ mkBaseConfigOpts boptsCli = do
         }
 
 -- | Provide a function for loading package information from the package index
-withLoadPackage :: (StackM env m, HasEnvConfig env)
-                => ((PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) -> m a)
-                -> m a
+withLoadPackage :: HasEnvConfig env
+                => ((PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) -> StackT env IO a)
+                -> StackT env IO a
 withLoadPackage inner = do
     econfig <- view envConfigL
     menv <- getMinimalEnvOverride
@@ -300,8 +300,8 @@ withLoadPackage inner = do
 
 -- | Set the code page for this process as necessary. Only applies to Windows.
 -- See: https://github.com/commercialhaskell/stack/issues/738
+fixCodePage :: HasEnvConfig env => StackT env IO a -> StackT env IO a
 #ifdef WINDOWS
-fixCodePage :: (StackM env m, HasBuildConfig env, HasEnvConfig env) => m a -> m a
 fixCodePage inner = do
     mcp <- view $ configL.to configModifyCodePage
     ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion
@@ -343,14 +343,13 @@ fixCodePage inner = do
         , " codepage to UTF-8 (65001) to ensure correct output from GHC"
         ]
 #else
-fixCodePage :: a -> a
 fixCodePage = id
 #endif
 
 -- | Query information about the build and print the result to stdout in YAML format.
-queryBuildInfo :: (StackM env m, HasEnvConfig env)
+queryBuildInfo :: HasEnvConfig env
                => [Text] -- ^ selectors
-               -> m ()
+               -> StackT env IO ()
 queryBuildInfo selectors0 =
         rawBuildInfo
     >>= select id selectors0
@@ -375,7 +374,7 @@ queryBuildInfo selectors0 =
         err msg = throwString $ msg ++ ": " ++ show (front [sel])
 
 -- | Get the raw build information object
-rawBuildInfo :: (StackM env m, HasEnvConfig env) => m Value
+rawBuildInfo :: HasEnvConfig env => StackT env IO Value
 rawBuildInfo = do
     (locals, _sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI
     return $ object

diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs
@@ -19,7 +19,6 @@ module Stack.Build.ConstructPlan
     ) where
 
 import           Stack.Prelude
-import           Control.Monad.Logger (runLoggingT)
 import           Control.Monad.RWS.Strict
 import           Control.Monad.State.Strict (execState)
 import qualified Data.HashSet as HashSet
@@ -56,6 +55,7 @@ import           Stack.Types.GhcPkgId
 import           Stack.Types.Package
 import           Stack.Types.PackageIdentifier
 import           Stack.Types.PackageName
+import           Stack.Types.Runner
 import           Stack.Types.Version
 import           System.IO (putStrLn)
 import           System.Process.Read (findExecutable)
@@ -118,7 +118,7 @@ instance Monoid W where
     mempty = memptydefault
     mappend = mappenddefault
 
-type M = RWST
+type M = RWST -- TODO replace with more efficient WS stack on top of StackT
     Ctx
     W
     (Map PackageName (Either ConstructPlanException AddDepRes))
@@ -136,11 +136,14 @@ data Ctx = Ctx
     , getVersions    :: !(PackageName -> IO (Set Version))
     , wanted         :: !(Set PackageName)
     , localNames     :: !(Set PackageName)
-    , logFunc        :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
     }
 
 instance HasPlatform Ctx
 instance HasGHCVariant Ctx
+instance HasLogFunc Ctx where
+    logFuncL = configL.logFuncL
+instance HasRunner Ctx where
+    runnerL = configL.runnerL
 instance HasConfig Ctx
 instance HasBuildConfig Ctx
 instance HasEnvConfig Ctx where
@@ -162,7 +165,7 @@ instance HasEnvConfig Ctx where
 --
 -- 3) It will only rebuild a local package if its files are dirty or
 -- some of its dependencies have changed.
-constructPlan :: forall env m. (StackM env m, HasEnvConfig env)
+constructPlan :: forall env. HasEnvConfig env
               => LoadedSnapshot
               -> BaseConfigOpts
               -> [LocalPackage]
@@ -172,7 +175,7 @@ constructPlan :: forall env m. (StackM env m, HasEnvConfig env)
               -> SourceMap
               -> InstalledMap
               -> Bool
-              -> m Plan
+              -> StackT env IO Plan
 constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap initialBuildSteps = do
     $logDebug "Constructing the build plan"
     u <- askUnliftIO
@@ -182,10 +185,9 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage
     let inner = do
             mapM_ onWanted $ filter lpWanted locals
             mapM_ (addDep False) $ Set.toList extraToBuild0
-    lf <- askLoggerIO
     lp <- getLocalPackages
     ((), m, W efinals installExes dirtyReason deps warnings parents) <-
-        liftIO $ runRWST inner (ctx econfig (unliftIO u . getPackageVersions) lf lp) M.empty
+        liftIO $ runRWST inner (ctx econfig (unliftIO u . getPackageVersions) lp) M.empty
     mapM_ $logWarn (warnings [])
     let toEither (_, Left e)  = Left e
         toEither (k, Right v) = Right (k, v)
@@ -217,7 +219,7 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage
             $prettyError $ pprintExceptions errs stackYaml parents (wantedLocalPackages locals)
             throwM $ ConstructPlanFailed "Plan construction failed."
   where
-    ctx econfig getVersions0 lf lp = Ctx
+    ctx econfig getVersions0 lp = Ctx
         { ls = ls0
         , baseConfigOpts = baseConfigOpts0
         , loadPackage = loadPackage0
@@ -231,7 +233,6 @@ constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage
         , getVersions = getVersions0
         , wanted = wantedLocalPackages locals <> extraToBuild0
         , localNames = Set.fromList $ map (packageName . lpPackage) locals
-        , logFunc = lf
         }
 
     toolMap = getToolMap ls0
@@ -666,7 +667,7 @@ checkDirtiness :: PackageSource
                -> M Bool
 checkDirtiness ps installed package present wanted = do
     ctx <- ask
-    moldOpts <- liftIO $ flip runLoggingT (logFunc ctx) $ flip runReaderT ctx $ tryGetFlagCache installed
+    moldOpts <- runStackT ctx $ tryGetFlagCache installed
     let configOpts = configureOpts
             (view envConfigL ctx)
             (baseConfigOpts ctx)