Stack init and solver overhaul

src/Stack/Config.hs

@@ -28,17 +28,20 @@ module Stack.Config
   ,resolvePackageEntry
   ,getImplicitGlobalProjectDir
   ,getIsGMP4
+  ,getSnapshots
+  ,makeConcreteResolver
   ) where
 
 import qualified Codec.Archive.Tar as Tar
 import qualified Codec.Compression.GZip as GZip
 import           Control.Applicative
 import           Control.Arrow ((***))
+import           Control.Exception (assert)
 import           Control.Monad
 import           Control.Monad.Catch (MonadThrow, MonadCatch, catchAll, throwM)
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger hiding (Loc)
-import           Control.Monad.Reader (MonadReader, ask, runReaderT)
+import           Control.Monad.Reader (MonadReader, ask, asks, runReaderT)
 import           Control.Monad.Trans.Control (MonadBaseControl)
 import qualified Crypto.Hash.SHA256 as SHA256
 import           Data.Aeson.Extended
@@ -58,7 +61,7 @@ import qualified Distribution.Text
 import           Distribution.Version (simplifyVersionRange)
 import           GHC.Conc (getNumProcessors)
 import           Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrl)
-import           Network.HTTP.Download (download)
+import           Network.HTTP.Download (download, downloadJSON)
 import           Options.Applicative (Parser, strOption, long, help)
 import           Path
 import           Path.Extra (toFilePathNoTrailingSep)
@@ -70,7 +73,6 @@ import           Stack.Config.Docker
 import           Stack.Config.Nix
 import           Stack.Constants
 import qualified Stack.Image as Image
-import           Stack.Init
 import           Stack.PackageIndex
 import           Stack.Types
 import           Stack.Types.Internal
@@ -79,6 +81,87 @@ import           System.Environment
 import           System.IO
 import           System.Process.Read
 
+-- | If deprecated path exists, use it and print a warning.
+-- Otherwise, return the new path.
+tryDeprecatedPath
+    :: (MonadIO m, MonadLogger m)
+    => Maybe T.Text -- ^ Description of file for warning (if Nothing, no deprecation warning is displayed)
+    -> (Path Abs a -> m Bool) -- ^ Test for existence
+    -> Path Abs a -- ^ New path
+    -> Path Abs a -- ^ Deprecated path
+    -> m (Path Abs a, Bool) -- ^ (Path to use, whether it already exists)
+tryDeprecatedPath mWarningDesc exists new old = do
+    newExists <- exists new
+    if newExists
+        then return (new, True)
+        else do
+            oldExists <- exists old
+            if oldExists
+                then do
+                    case mWarningDesc of
+                        Nothing -> return ()
+                        Just desc ->
+                            $logWarn $ T.concat
+                                [ "Warning: Location of ", desc, " at '"
+                                , T.pack (toFilePath old)
+                                , "' is deprecated; rename it to '"
+                                , T.pack (toFilePath new)
+                                , "' instead" ]
+                    return (old, True)
+                else return (new, False)
+
+-- | Get the location of the implicit global project directory.
+-- If the directory already exists at the deprecated location, its location is returned.
+-- Otherwise, the new location is returned.
+getImplicitGlobalProjectDir
+    :: (MonadIO m, MonadLogger m)
+    => Config -> m (Path Abs Dir)
+getImplicitGlobalProjectDir config =
+    --TEST no warning printed
+    liftM fst $ tryDeprecatedPath
+        Nothing
+        dirExists
+        (implicitGlobalProjectDir stackRoot)
+        (implicitGlobalProjectDirDeprecated stackRoot)
+  where
+    stackRoot = configStackRoot config
+
+-- | Download the 'Snapshots' value from stackage.org.
+getSnapshots :: (MonadThrow m, MonadIO m, MonadReader env m, HasHttpManager env, HasStackRoot env, HasConfig env)
+             => m Snapshots
+getSnapshots = askLatestSnapshotUrl >>= parseUrl . T.unpack >>= downloadJSON
+
+-- | Turn an 'AbstractResolver' into a 'Resolver'.
+makeConcreteResolver :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadLogger m)
+                     => AbstractResolver
+                     -> m Resolver
+makeConcreteResolver (ARResolver r) = return r
+makeConcreteResolver ar = do
+    snapshots <- getSnapshots
+    r <-
+        case ar of
+            ARResolver r -> assert False $ return r
+            ARGlobal -> do
+                config <- asks getConfig
+                implicitGlobalDir <- getImplicitGlobalProjectDir config
+                let fp = implicitGlobalDir </> stackDotYaml
+                (ProjectAndConfigMonoid project _, _warnings) <-
+                    liftIO (Yaml.decodeFileEither $ toFilePath fp)
+                    >>= either throwM return
+                return $ projectResolver project
+            ARLatestNightly -> return $ ResolverSnapshot $ Nightly $ snapshotsNightly snapshots
+            ARLatestLTSMajor x ->
+                case IntMap.lookup x $ snapshotsLts snapshots of
+                    Nothing -> error $ "No LTS release found with major version " ++ show x
+                    Just y -> return $ ResolverSnapshot $ LTS x y
+            ARLatestLTS
+                | IntMap.null $ snapshotsLts snapshots -> error "No LTS releases found"
+                | otherwise ->
+                    let (x, y) = IntMap.findMax $ snapshotsLts snapshots
+                     in return $ ResolverSnapshot $ LTS x y
+    $logInfo $ "Selected resolver: " <> resolverName r
+    return r
+
 -- | Get the latest snapshot resolver available.
 getLatestResolver
     :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m)

src/Stack/ConfigCmd.hs

@@ -21,7 +21,7 @@ import qualified Data.Yaml as Yaml
 import           Network.HTTP.Client.Conduit (HasHttpManager)
 import           Path
 import           Stack.BuildPlan
-import           Stack.Init
+import           Stack.Config (makeConcreteResolver)
 import           Stack.Types
 
 data ConfigCmdSet = ConfigCmdSetResolver AbstractResolver