Force resolver, prefer snapshots, fallback resolver #253

src/Stack/BuildPlan.hs

@@ -26,7 +26,6 @@ module Stack.BuildPlan
 
 import           Control.Applicative
 import           Control.Exception (assert)
-import           Control.Exception.Enclosed (handleIO)
 import           Control.Monad (liftM, forM)
 import           Control.Monad.Catch
 import           Control.Monad.IO.Class
@@ -44,7 +43,7 @@ import qualified Data.Foldable as F
 import qualified Data.HashMap.Strict as HM
 import           Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
-import           Data.List (intercalate, sort)
+import           Data.List (intercalate)
 import           Data.Map (Map)
 import qualified Data.Map as Map
 import           Data.Maybe (mapMaybe)
@@ -73,7 +72,7 @@ import           Stack.Package
 import           Stack.PackageIndex
 import           Stack.Types
 import           Stack.Types.StackT
-import           System.Directory (createDirectoryIfMissing, getDirectoryContents)
+import           System.Directory (createDirectoryIfMissing)
 import           System.FilePath (takeDirectory)
 
 data BuildPlanException
@@ -450,12 +449,10 @@ loadBuildPlan name = do
 -- only modify non-manual flags, and will prefer default values for flags.
 -- Returns @Nothing@ if no combination exists.
 checkBuildPlan :: (MonadLogger m, MonadThrow m, MonadIO m, MonadReader env m, HasConfig env, MonadCatch m)
-               => SnapName -- ^ used only for debugging purposes
-               -> MiniBuildPlan
+               => MiniBuildPlan
                -> GenericPackageDescription
                -> m (Maybe (Map FlagName Bool))
-checkBuildPlan name mbp gpd = do
-    $logInfo $ "Checking against build plan " <> renderSnapName name
+checkBuildPlan mbp gpd = do
     platform <- asks (configPlatform . getConfig)
     loop platform flagOptions
   where
@@ -526,56 +523,28 @@ checkDeps flags deps packages = do
 -- 'GenericPackageDescription'. Returns 'Nothing' if no such snapshot is found.
 findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)
               => [GenericPackageDescription]
-              -> Snapshots
+              -> [SnapName]
               -> m (Maybe (SnapName, Map PackageName (Map FlagName Bool)))
-findBuildPlan gpds0 snapshots = do
-    -- Get the most recent LTS and Nightly in the snapshots directory and
-    -- prefer them over anything else, since odds are high that something
-    -- already exists for them.
-    existing <-
-        liftM (reverse . sort . mapMaybe (parseSnapName . T.pack)) $
-        snapshotsDir >>=
-        liftIO . handleIO (const $ return [])
-               . getDirectoryContents . toFilePath
-    let isLTS LTS{} = True
-        isLTS Nightly{} = False
-        isNightly Nightly{} = True
-        isNightly LTS{} = False
-
-    let names = nubOrd $ concat
-            [ take 2 $ filter isLTS existing
-            , take 2 $ filter isNightly existing
-            , map (uncurry LTS)
-                (take 2 $ reverse $ IntMap.toList $ snapshotsLts snapshots)
-            , [Nightly $ snapshotsNightly snapshots]
-            ]
-        loop [] = return Nothing
-        loop (name:names') = do
-            mbp <- loadMiniBuildPlan name
-            let checkGPDs flags [] = return $ Just (name, flags)
-                checkGPDs flags (gpd:gpds) = do
-                    let C.PackageIdentifier pname' _ = C.package $ C.packageDescription gpd
-                        pname = fromCabalPackageName pname'
-                    mflags <- checkBuildPlan name mbp gpd
-                    case mflags of
-                        Nothing -> loop names'
-                        Just flags' -> checkGPDs
-                            (if Map.null flags'
-                                then flags
-                                else Map.insert pname flags' flags)
-                            gpds
-            checkGPDs Map.empty gpds0
-    loop names
-
--- | Same semantics as @nub@, but more efficient by using the @Ord@ constraint.
-nubOrd :: Ord a => [a] -> [a]
-nubOrd =
-    go Set.empty
+findBuildPlan gpds0 =
+    loop
   where
-    go _ [] = []
-    go s (x:xs)
-        | x `Set.member` s = go s xs
-        | otherwise = x : go (Set.insert x s) xs
+    loop [] = return Nothing
+    loop (name:names') = do
+        mbp <- loadMiniBuildPlan name
+        $logInfo $ "Checking against build plan " <> renderSnapName name
+        let checkGPDs flags [] = return $ Just (name, flags)
+            checkGPDs flags (gpd:gpds) = do
+                let C.PackageIdentifier pname' _ = C.package $ C.packageDescription gpd
+                    pname = fromCabalPackageName pname'
+                mflags <- checkBuildPlan mbp gpd
+                case mflags of
+                    Nothing -> loop names'
+                    Just flags' -> checkGPDs
+                        (if Map.null flags'
+                            then flags
+                            else Map.insert pname flags' flags)
+                        gpds
+        checkGPDs Map.empty gpds0
 
 shadowMiniBuildPlan :: MiniBuildPlan
                     -> Set PackageName

src/Stack/Config.hs

@@ -74,17 +74,14 @@ getLatestResolver
     => m Resolver
 getLatestResolver = do
     snapshots <- getSnapshots
-    let lts = do
+    let mlts = do
             (x,y) <- listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots)))
             return (LTS x y)
-        nightly =
-            Just (Nightly (snapshotsNightly snapshots))
-    case lts <|> nightly of
-        Nothing -> do
-            $logDebug "Downloaded snapshots, but they were empty."
-            throwM NoResolverFound
-        Just snap ->
-            return (ResolverSnapshot snap)
+        snap =
+            case mlts of
+                Nothing -> Nightly (snapshotsNightly snapshots)
+                Just lts -> lts
+    return (ResolverSnapshot snap)
 
 data ProjectAndConfigMonoid
   = ProjectAndConfigMonoid !Project !ConfigMonoid

src/Stack/Init.hs

@@ -5,34 +5,43 @@
 module Stack.Init
     ( findCabalFiles
     , initProject
+    , InitOpts (..)
+    , initOptsParser
+    , readResolver
     ) where
 
 import           Control.Exception               (assert)
-import           Control.Monad                   (when)
+import           Control.Exception.Enclosed      (handleIO)
+import           Control.Monad                   (liftM, when)
 import           Control.Monad.Catch             (MonadCatch, SomeException,
                                                   catch, throwM)
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
 import           Control.Monad.Reader            (MonadReader)
 import           Control.Monad.Trans.Control     (MonadBaseControl)
 import qualified Data.IntMap                     as IntMap
+import           Data.List                       (sort)
 import           Data.List                       (isSuffixOf)
 import           Data.Map                        (Map)
 import qualified Data.Map                        as Map
+import           Data.Maybe                      (mapMaybe)
 import           Data.Monoid
 import           Data.Set                        (Set)
 import qualified Data.Set                        as Set
 import qualified Data.Text                       as T
 import qualified Data.Yaml                       as Yaml
 import qualified Distribution.PackageDescription as C
 import           Network.HTTP.Client.Conduit     (HasHttpManager)
+import           Options.Applicative
+import           Options.Applicative.Types       (readerAsk)
 import           Path
 import           Path.Find
 import           Path.IO
 import           Stack.BuildPlan
 import           Stack.Constants
 import           Stack.Package
 import           Stack.Types
+import           System.Directory                (getDirectoryContents)
 
 findCabalFiles :: MonadIO m => Path Abs Dir -> m [Path Abs File]
 findCabalFiles dir =
@@ -50,21 +59,28 @@ ignoredDirs = Set.fromList
     , ".stack-work"
     ]
 
+-- | Generate stack.yaml
 initProject :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
-            => m ()
-initProject = do
+            => Maybe Resolver -- ^ force this resolver to be used
+            -> InitOpts
+            -> m ()
+initProject mresolver initOpts = do
     currDir <- getWorkingDir
     let dest = currDir </> stackDotYaml
         dest' = toFilePath dest
     exists <- fileExists dest
     when exists $ error "Invariant violated: in toBuildConfig's Nothing branch, and the stack.yaml file exists"
-    $logInfo $ "Writing default config file to: " <> T.pack dest'
 
     cabalfps <- findCabalFiles currDir
+    $logInfo $ "Writing default config file to: " <> T.pack dest'
+    $logInfo $ "Basing on cabal files:"
+    mapM_ (\path -> $logInfo $ "- " <> T.pack (toFilePath path)) cabalfps
+    $logInfo ""
+
     when (null cabalfps) $ error "In order to init, you should have an existing .cabal file. Please try \"stack new\" instead"
     gpds <- mapM readPackageUnresolved cabalfps
 
-    (r, flags) <- getDefaultResolver gpds
+    (r, flags) <- getDefaultResolver gpds mresolver initOpts
     let p = Project
             { projectPackages = pkgs
             , projectExtraDeps = Map.empty
@@ -80,15 +96,14 @@ initProject = do
                     Just rel -> toFilePath rel
             , peSubdirs = []
             }
+    $logInfo $ "Selected resolver: " <> renderResolver r
     liftIO $ Yaml.encodeFile dest' p
     $logInfo $ "Wrote project config to: " <> T.pack dest'
 
--- | Get the default resolver value
-getDefaultResolver :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
-                   => [C.GenericPackageDescription] -- ^ cabal files
-                   -> m (Resolver, Map PackageName (Map FlagName Bool))
-getDefaultResolver gpds = do
-    snapshots <- getSnapshots `catch` \e -> do
+getSnapshots' :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
+              => m Snapshots
+getSnapshots' =
+    getSnapshots `catch` \e -> do
         $logError $
             "Unable to download snapshot list, and therefore could " <>
             "not generate a stack.yaml file automatically"
@@ -103,18 +118,110 @@ getDefaultResolver gpds = do
         $logError "    https://github.com/commercialhaskell/stack/wiki/stack.yaml"
         $logError ""
         throwM (e :: SomeException)
-    mpair <- findBuildPlan gpds snapshots
+
+-- | Get the default resolver value
+getDefaultResolver :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
+                   => [C.GenericPackageDescription] -- ^ cabal files
+                   -> Maybe Resolver -- ^ resolver override
+                   -> InitOpts
+                   -> m (Resolver, Map PackageName (Map FlagName Bool))
+getDefaultResolver gpds mresolver initOpts = do
+    names <-
+        case mresolver of
+            Nothing -> do
+                snapshots <- getSnapshots'
+                getRecommendedSnapshots snapshots initOpts
+            Just resolver ->
+                return $
+                    case resolver of
+                        ResolverSnapshot name -> [name]
+                        ResolverGhc _ -> []
+    mpair <- findBuildPlan gpds names
     case mpair of
         Just (snap, flags) ->
             return (ResolverSnapshot snap, flags)
-        Nothing -> do
-            let snap = case IntMap.maxViewWithKey (snapshotsLts snapshots) of
-                    Just ((x, y), _) -> LTS x y
-                    Nothing -> Nightly $ snapshotsNightly snapshots
-            $logWarn $ T.concat
-                [ "No matching snapshot was found for your package, "
-                , "falling back to: "
-                , renderSnapName snap
-                ]
-            $logWarn "This behavior will improve in the future, please see: https://github.com/commercialhaskell/stack/issues/253"
-            return (ResolverSnapshot snap, Map.empty)
+        Nothing ->
+            case mresolver of
+                Nothing ->
+                    case ioFallback initOpts of
+                        Nothing -> throwM $ NoMatchingSnapshot names
+                        Just resolver -> return (resolver, Map.empty)
+                Just resolver -> return (resolver, Map.empty)
+
+getRecommendedSnapshots :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
+                        => Snapshots
+                        -> InitOpts
+                        -> m [SnapName]
+getRecommendedSnapshots snapshots initOpts = do
+    -- Get the most recent LTS and Nightly in the snapshots directory and
+    -- prefer them over anything else, since odds are high that something
+    -- already exists for them.
+    existing <-
+        liftM (reverse . sort . mapMaybe (parseSnapName . T.pack)) $
+        snapshotsDir >>=
+        liftIO . handleIO (const $ return [])
+               . getDirectoryContents . toFilePath
+    let isLTS LTS{} = True
+        isLTS Nightly{} = False
+        isNightly Nightly{} = True
+        isNightly LTS{} = False
+
+        names = nubOrd $ concat
+            [ take 2 $ filter isLTS existing
+            , take 2 $ filter isNightly existing
+            , map (uncurry LTS)
+                (take 2 $ reverse $ IntMap.toList $ snapshotsLts snapshots)
+            , [Nightly $ snapshotsNightly snapshots]
+            ]
+
+        namesLTS = filter isLTS names
+        namesNightly = filter isNightly names
+
+    case ioPref initOpts of
+        PrefNone -> return names
+        PrefLTS -> return $ namesLTS ++ namesNightly
+        PrefNightly -> return $ namesNightly ++ namesLTS
+
+data InitOpts = InitOpts
+    { ioPref     :: !SnapPref
+    -- ^ Preferred snapshots
+    , ioFallback :: !(Maybe Resolver)
+    }
+
+data SnapPref = PrefNone | PrefLTS | PrefNightly
+
+initOptsParser :: Parser InitOpts
+initOptsParser = InitOpts
+    <$> pref
+    <*> optional fallback
+  where
+    pref =
+        flag' PrefLTS
+            (long "prefer-lts" <>
+             help "Prefer LTS snapshots over Nightly snapshots") <|>
+        flag' PrefNightly
+            (long "prefer-nightly" <>
+             help "Prefer Nightly snapshots over LTS snapshots") <|>
+        pure PrefNone
+
+    fallback = option readResolver
+        (long "fallback" <>
+         metavar "RESOLVER" <>
+         help "Fallback resolver if none of the tested snapshots work")
+
+readResolver :: ReadM Resolver
+readResolver = do
+    s <- readerAsk
+    case parseResolver $ T.pack s of
+        Left e -> readerError $ show e
+        Right x -> return x
+
+-- | Same semantics as @nub@, but more efficient by using the @Ord@ constraint.
+nubOrd :: Ord a => [a] -> [a]
+nubOrd =
+    go Set.empty
+  where
+    go _ [] = []
+    go s (x:xs)
+        | x `Set.member` s = go s xs
+        | otherwise = x : go (Set.insert x s) xs

src/Stack/Types/Config.hs

@@ -454,7 +454,7 @@ data ConfigException
   | NoProjectConfigFound (Path Abs Dir) (Maybe Text)
   | UnexpectedTarballContents [Path Abs Dir] [Path Abs File]
   | BadStackVersionException VersionRange
-  | NoResolverFound
+  | NoMatchingSnapshot [SnapName]
   deriving Typeable
 instance Show ConfigException where
     show (ParseResolverException t) = concat
@@ -485,7 +485,18 @@ instance Show ConfigException where
         ,"version range ("
         , T.unpack (versionRangeText requiredRange)
         , ") specified in stack.yaml." ]
-    show NoResolverFound = "No resolver was found"
+    show (NoMatchingSnapshot names) = concat
+        [ "There was no snapshot found that matched the package "
+        , "bounds in your .cabal files.\n"
+        , "Please choose one of the following commands to get started.\n\n"
+        , unlines $ map
+            (\name -> "    stack init --resolver " ++ T.unpack (renderSnapName name))
+            names
+        , "\nYou'll then need to add some extra-deps. See:\n\n"
+        , "    https://github.com/commercialhaskell/stack/wiki/stack.yaml#extra-deps"
+        , "\n\nNote that this will be improved in the future, see:\n\n"
+        , "    https://github.com/commercialhaskell/stack/issues/116"
+        ]
 instance Exception ConfigException
 
 -- | Helper function to ask the environment and apply getConfig