Merge pull request #3498 from commercialhaskell/3397-ghc-solver

3397 ghc solver

Author: snoyberg

src/Stack/BuildPlan.hs

@@ -396,11 +396,12 @@ checkSnapBuildPlan
     -> [GenericPackageDescription]
     -> Maybe (Map PackageName (Map FlagName Bool))
     -> SnapshotDef
+    -> Maybe (CompilerVersion 'CVActual)
     -> RIO env BuildPlanCheck
-checkSnapBuildPlan root gpds flags snapshotDef = do
+checkSnapBuildPlan root gpds flags snapshotDef mactualCompiler = do
     platform <- view platformL
     menv <- getMinimalEnvOverride
-    rs <- loadSnapshot menv Nothing root snapshotDef
+    rs <- loadSnapshot menv mactualCompiler root snapshotDef
 
     let
         compiler = lsCompilerVersion rs
@@ -447,6 +448,12 @@ selectBestSnapshot root gpds snaps = do
 
         getResult snap = do
             result <- checkSnapBuildPlan root gpds Nothing snap
+              -- We know that we're only dealing with ResolverSnapshot
+              -- here, where we can rely on the global package hints.
+              -- Therefore, we don't use an actual compiler. For more
+              -- info, see comments on
+              -- Stack.Solver.checkSnapBuildPlanActual.
+              Nothing
             reportResult result snap
             return (snap, result)
 

src/Stack/Init.hs

@@ -430,7 +430,7 @@ checkBundleResolver
          (Either [PackageName] ( Map PackageName (Map FlagName Bool)
                                , Map PackageName Version))
 checkBundleResolver whichCmd stackYaml initOpts bundle sd = do
-    result <- checkSnapBuildPlan (parent stackYaml) gpds Nothing sd
+    result <- checkSnapBuildPlanActual (parent stackYaml) gpds Nothing sd
     case result of
         BuildPlanCheckOk f -> return $ Right (f, Map.empty)
         BuildPlanCheckPartial f e -> do

src/Stack/Solver.hs

@@ -14,6 +14,7 @@ module Stack.Solver
     , mergeConstraints
     , solveExtraDeps
     , solveResolverSpec
+    , checkSnapBuildPlanActual
     -- * Internal - for tests
     , parseCabalOutputLine
     ) where
@@ -647,7 +648,7 @@ solveExtraDeps modStackYaml = do
         srcConstraints    = mergeConstraints oldSrcs oldSrcFlags
         extraConstraints  = mergeConstraints oldExtraVersions oldExtraFlags
 
-    resolverResult <- checkSnapBuildPlan (parent stackYaml) gpds (Just oldSrcFlags) sd
+    resolverResult <- checkSnapBuildPlanActual (parent stackYaml) gpds (Just oldSrcFlags) sd
     resultSpecs <- case resolverResult of
         BuildPlanCheckOk flags ->
             return $ Just (mergeConstraints oldSrcs flags, Map.empty)
@@ -753,6 +754,31 @@ solveExtraDeps modStackYaml = do
             , "        - Adjust resolver.\n"
             ]
 
+-- | Same as 'checkSnapBuildPLan', but set up a real GHC if needed.
+--
+-- If we're using a Stackage snapshot, we can use the snapshot hints
+-- to determine global library information. This will not be available
+-- for custom and GHC resolvers, however. Therefore, we insist that it
+-- be installed first. Fortunately, the standard `stack solver`
+-- behavior only chooses Stackage snapshots, so the common case will
+-- not force the installation of a bunch of GHC versions.
+checkSnapBuildPlanActual
+    :: (HasConfig env, HasGHCVariant env)
+    => Path Abs Dir -- ^ project root, used for checking out necessary files
+    -> [C.GenericPackageDescription]
+    -> Maybe (Map PackageName (Map FlagName Bool))
+    -> SnapshotDef
+    -> RIO env BuildPlanCheck
+checkSnapBuildPlanActual root gpds flags sd = do
+    let forNonSnapshot = (Just . snd) <$> setupCabalEnv (sdWantedCompilerVersion sd)
+    mactualCompiler <-
+      case sdResolver sd of
+        ResolverSnapshot _ -> return Nothing
+        ResolverCompiler _ -> forNonSnapshot
+        ResolverCustom _ _ -> forNonSnapshot
+
+    checkSnapBuildPlan root gpds flags sd mactualCompiler
+
 prettyPath
     :: forall r t m. (MonadIO m, RelPath (Path r t) ~ Path Rel t, AnyPath (Path r t))
     => Path r t -> m String

test/integration/tests/3397-ghc-solver/Main.hs

@@ -0,0 +1,6 @@
+import StackTest
+
+main :: IO ()
+main = do
+  stack ["init", "--solver", "--resolver", "ghc-8.2.1"]
+  stack ["solver", "--update-config"]

test/integration/tests/3397-ghc-solver/files/package.yaml

@@ -0,0 +1,9 @@
+name: issue3397
+
+library:
+  dependencies:
+  - base
+  - stm
+  exposed-modules:
+  - Lib
+

test/integration/tests/3397-ghc-solver/files/src/Lib.hs

@@ -0,0 +1,6 @@
+module Lib
+    ( someFunc
+    ) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"