Able to load up SnapshotDef and begin LoadedSnapshot

snoyberg · snoyberg · commit c213a52813bf · 2017-06-28T09:36:25.000+03:00
diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs
diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
@@ -188,12 +188,13 @@ makeConcreteResolver
     :: (StackMiniM env m, HasConfig env)
     => AbstractResolver
     -> m Resolver
-makeConcreteResolver (ARResolver r) = return r
+makeConcreteResolver (ARResolver r) = do
+  mapM (parseCustomLocation (error "FIXME makeConcreteResolver")) r
 makeConcreteResolver ar = do
     snapshots <- getSnapshots
     r <-
         case ar of
-            ARResolver r -> assert False $ return r
+            ARResolver r -> assert False $ makeConcreteResolver $ ARResolver r
             ARGlobal -> do
                 config <- view configL
                 implicitGlobalDir <- getImplicitGlobalProjectDir config
@@ -590,19 +591,16 @@ loadBuildConfig mproject config mresolver mcompiler = do
             , projectCompiler = mcompiler <|> projectCompiler project'
             }
 
-    {- FIXME
-    (rs0, loadedResolver) <- flip runReaderT miniConfig $
-        loadResolver (Just stackYamlFP) (projectResolver project)
-    let rs = case projectCompiler project of
-            Just compiler -> rs0 { rsCompilerVersion = compiler }
-            Nothing -> rs0
-    -}
+    sd0 <- flip runReaderT miniConfig $ loadResolver resolver
+    let sd = case projectCompiler project of
+            Just compiler -> sd0 { sdCompilerVersion = compiler }
+            Nothing -> sd0
 
     extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project)
 
     return BuildConfig
         { bcConfig = config
-        , bcSnapshotDef = error "bcSnapshotDef"
+        , bcSnapshotDef = sd
         , bcGHCVariant = view ghcVariantL miniConfig
         , bcPackageEntries = projectPackages project
         , bcExtraDeps = projectExtraDeps project
diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs
@@ -38,7 +38,7 @@ dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do
                                 (ResolverNotSupportedException $
                                  show aresolver)
                         Nothing ->
-                            fmap projectResolver mproject
+                            fmap ((fmap.fmap) snd projectResolver) mproject
                 defaultTag =
                     case mresolver of
                         Nothing -> ""
diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs
@@ -93,10 +93,10 @@ cfgCmdSetValue (ConfigCmdSetResolver newResolver) = do
     concreteResolver <- makeConcreteResolver newResolver
     case concreteResolver of
         -- Check that the snapshot actually exists
-        ResolverSnapshot snapName -> void $ loadSnapshotDef snapName
+        ResolverSnapshot snapName -> void $ loadResolver $ ResolverSnapshot snapName
         ResolverCompiler _ -> return ()
         -- TODO: custom snapshot support?  Would need a way to specify on CLI
-        ResolverCustom _ _ () -> errorString "'stack config set resolver' does not support custom resolvers"
+        ResolverCustom _ _ -> errorString "'stack config set resolver' does not support custom resolvers"
     return (Yaml.String (resolverName concreteResolver))
 cfgCmdSetValue (ConfigCmdSetSystemGhc _ bool) =
     return (Yaml.Bool bool)
diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs
@@ -25,7 +25,7 @@ import qualified Data.Text                  as T
 import           Path
 import           Path.IO
 import qualified Stack.Build
-import           Stack.BuildPlan            (loadResolver)
+import           Stack.BuildPlan            (loadResolver, loadSnapshot)
 import           Stack.Exec
 import           Stack.GhcPkg               (ghcPkgExeName)
 import           Stack.Options.ScriptParser
@@ -268,7 +268,7 @@ loadModuleInfo :: SnapName -> StackT EnvConfig IO ModuleInfo
 loadModuleInfo name = do
     path <- moduleInfoCache name
     $(versionedDecodeOrLoad moduleInfoVC) path $
-      fmap toModuleInfo $ loadResolver Nothing $ ResolverSnapshot name
+      fmap toModuleInfo $ loadResolver (ResolverSnapshot name) >>= loadSnapshot
 
 parseImports :: ByteString -> (Set PackageName, Set ModuleName)
 parseImports =
diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs
@@ -88,6 +88,7 @@ import qualified    Paths_stack as Meta
 import              Prelude hiding (concat, elem, any) -- Fix AMP warning
 import              Safe (headMay, readMay)
 import              Stack.Build (build)
+import              Stack.BuildPlan (loadSnapshot)
 import              Stack.Config (loadConfig)
 import              Stack.Constants (distRelativeDir, stackProgName)
 import              Stack.Exec (defaultEnvSettings)
@@ -260,13 +261,21 @@ setupEnv mResolveMissingGHC = do
     $logDebug "Resolving package entries"
     packagesRef <- liftIO $ newIORef Nothing
     bc <- view buildConfigL
+
+    -- Set up a modified environment which includes the modified PATH
+    -- that GHC can be found on. This is needed for looking up global
+    -- package information in loadSnapshot.
+    let bcPath :: BuildConfig
+        bcPath = set envOverrideL (const (return menv)) bc
+
+    ls <- runInnerStackT bcPath $ loadSnapshot $ bcSnapshotDef bc
     let envConfig0 = EnvConfig
             { envConfigBuildConfig = bc
             , envConfigCabalVersion = cabalVer
             , envConfigCompilerVersion = compilerVer
             , envConfigCompilerBuild = compilerBuild
             , envConfigPackagesRef = packagesRef
-            , envConfigLoadedSnapshot = error "envLoadedSnapshot2"
+            , envConfigLoadedSnapshot = ls
             }
 
     -- extra installation bin directories
diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs
@@ -485,8 +485,8 @@ getResolverConstraints
     -> m (CompilerVersion,
           Map PackageName (Version, Map FlagName Bool))
 getResolverConstraints stackYaml resolver = do
-    rs <- loadResolver (Just stackYaml) resolver
-    return (lsCompilerVersion rs, lsConstraints rs)
+    ls <- loadResolver resolver >>= loadSnapshot
+    return (lsCompilerVersion ls, lsConstraints ls)
   where
     lpiConstraints lpi = (lpiVersion lpi, maybe Map.empty pdFlags $ lpiDef lpi)
     lsConstraints = fmap lpiConstraints . lsPackages
@@ -657,15 +657,15 @@ solveExtraDeps modStackYaml = do
     let gpds              = Map.elems $ fmap snd bundle
         oldFlags          = unPackageFlags (bcFlags bconfig)
         oldExtraVersions  = bcExtraDeps bconfig
-        resolver          = error "bcResolver" -- FIXME bcResolver bconfig
+        resolver          = sdResolver $ bcSnapshotDef bconfig
         oldSrcs           = gpdPackages gpds
         oldSrcFlags       = Map.intersection oldFlags oldSrcs
         oldExtraFlags     = Map.intersection oldFlags oldExtraVersions
 
         srcConstraints    = mergeConstraints oldSrcs oldSrcFlags
         extraConstraints  = mergeConstraints oldExtraVersions oldExtraFlags
 
-    let resolver' = toResolverNotLoaded resolver
+    let resolver' = fmap (const (error "Solver FIXME")) resolver
     resolverResult <- checkResolverSpec gpds (Just oldSrcFlags) resolver'
     resultSpecs <- case resolverResult of
         BuildPlanCheckOk flags ->
@@ -701,14 +701,14 @@ solveExtraDeps modStackYaml = do
 
         changed =    any (not . Map.null) [newVersions, goneVersions]
                   || any (not . Map.null) [newFlags, goneFlags]
-                  || any (/= resolver') mOldResolver
+                  || any (/= (fmap snd resolver')) (fmap (fmap snd) mOldResolver)
 
     if changed then do
         $logInfo ""
         $logInfo $ "The following changes will be made to "
                    <> T.pack relStackYaml <> ":"
 
-        printResolver mOldResolver resolver'
+        printResolver (fmap (fmap snd) mOldResolver) (fmap snd resolver')
 
         printFlags newFlags  "* Flags to be added"
         printDeps  newVersions   "* Dependencies to be added"
diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs
@@ -167,7 +167,7 @@ newtype StackageSnapshotDef = StackageSnapshotDef (SnapName -> SnapshotDef)
 
 -- | Newtype wrapper to help parse a 'PackageDef' from the Stackage
 -- YAML files.
-newtype StackagePackageDef = StackagePackageDef { unStackagePackageDef :: PackageDef }
+newtype StackagePackageDef = StackagePackageDef { unStackagePackageDef :: PackageName -> PackageDef }
 
 instance FromJSON StackageSnapshotDef where
     parseJSON = withObject "StackageSnapshotDef" $ \o -> do
@@ -181,7 +181,7 @@ instance FromJSON StackageSnapshotDef where
                 (_, Just compiler) -> return compiler
                 _ -> fail "expected field \"ghc-version\" or \"compiler-version\" not present"
 
-        sdPackages <- Map.map unStackagePackageDef <$> o .: "packages"
+        sdPackages <- Map.mapWithKey (\k v -> unStackagePackageDef v k) <$> o .: "packages"
 
         return $ StackageSnapshotDef $ \snapName ->
           let sdResolver = ResolverSnapshot snapName
@@ -200,14 +200,15 @@ instance FromJSON StackagePackageDef where
                             return
                         $ HashMap.lookup ("GitSHA1" :: Text) cfiHashes
             return CabalFileInfo {..}
-        let pdLocation = PLIndex version mcabalFileInfo'
 
         Object constraints <- o .: "constraints"
         pdFlags <- constraints .: "flags"
         pdHide <- constraints .:? "hide" .!= False
         let pdGhcOptions = [] -- Stackage snapshots do not allow setting GHC options
 
-        return $ StackagePackageDef PackageDef {..}
+        return $ StackagePackageDef $ \name ->
+          let pdLocation = PLIndex (PackageIdentifier name version) mcabalFileInfo'
+           in PackageDef {..}
 
 -- | Information on the contents of a cabal file
 data CabalFileInfo = CabalFileInfo
@@ -236,7 +237,7 @@ instance Store LoadedSnapshot
 instance NFData LoadedSnapshot
 
 loadedSnapshotVC :: VersionConfig LoadedSnapshot
-loadedSnapshotVC = storeVersionConfig "ls-v1" "008JT34ImjzaL-brqnMwfPDWrBI="
+loadedSnapshotVC = storeVersionConfig "ls-v1" "-jKxkhdmu5EYSA5qaxw-r9ZzX7k="
 
 -- | Information on a single package for the 'LoadedSnapshot' which
 -- can be installed.
diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs
@@ -171,6 +171,7 @@ module Stack.Types.Config
   ,configUrlsL
   ,cabalVersionL
   ,whichCompilerL
+  ,envOverrideL
   -- * Lens reexport
   ,view
   ,to
@@ -1296,15 +1297,15 @@ flagCacheLocal = do
     root <- installationRootLocal
     return $ root </> $(mkRelDir "flag-cache")
 
--- | Where to store mini build plan caches
+-- | Where to store 'LoadedSnapshot' caches
 configLoadedSnapshotCache
   :: (MonadThrow m, MonadReader env m, HasConfig env, HasGHCVariant env)
-  => SnapName -- FIXME generalize?
+  => LoadedResolver
   -> m (Path Abs File)
-configLoadedSnapshotCache name = do
+configLoadedSnapshotCache resolver = do
     root <- view stackRootL
     platform <- platformGhcVerOnlyRelDir
-    file <- parseRelFile $ T.unpack (renderSnapName name) ++ ".cache"
+    file <- parseRelFile $ T.unpack (resolverName resolver) ++ ".cache"
     -- Yes, cached plans differ based on platform
     return (root </> $(mkRelDir "build-plan-cache") </> platform </> file)
 
@@ -1379,6 +1380,8 @@ parseProjectAndConfigMonoid rootDir =
 
         flags <- o ..:? "flags" ..!= mempty
         resolver <- jsonSubWarnings (o ..: "resolver")
+                >>= either (fail . show) return
+                  . mapM (parseCustomLocation (Just (toFilePath rootDir)))
         compiler <- o ..:? "compiler"
         msg <- o ..:? "user-message"
         config <- parseConfigMonoidObject rootDir o
@@ -1676,7 +1679,7 @@ data CustomSnapshot = CustomSnapshot
     , csGhcOptions :: !GhcOptions
     }
 
-instance FromJSON (WithJSONWarnings (CustomSnapshot, Maybe Resolver)) where
+instance (a ~ Maybe (ResolverWith Text)) => FromJSON (WithJSONWarnings (CustomSnapshot, a)) where
     parseJSON = withObjectWarnings "CustomSnapshot" $ \o -> (,)
         <$> (CustomSnapshot
             <$> o ..:? "compiler"
@@ -1906,3 +1909,8 @@ loadedSnapshotL = envConfigL.lens
 
 whichCompilerL :: Getting r CompilerVersion WhichCompiler
 whichCompilerL = to whichCompiler
+
+envOverrideL :: HasConfig env => Lens' env (EnvSettings -> IO EnvOverride)
+envOverrideL = configL.lens
+    configEnvOverride
+    (\x y -> x { configEnvOverride = y })
diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs
diff --git a/src/main/Main.hs b/src/main/Main.hs
