Merge pull request #4648 from commercialhaskell/nicer-resolver-names

Nicer resolver names

src/Stack/BuildPlan.hs

@@ -400,15 +400,15 @@ selectBestSnapshot gpds snaps = do
           | otherwise = (s2, r2)
 
         reportResult BuildPlanCheckOk {} snap = do
-            logInfo $ "* Matches " <> RIO.display (sdResolverName snap)
+            logInfo $ "* Matches " <> RIO.display (sdResolver snap)
             logInfo ""
 
         reportResult r@BuildPlanCheckPartial {} snap = do
-            logWarn $ "* Partially matches " <> RIO.display (sdResolverName snap)
+            logWarn $ "* Partially matches " <> RIO.display (sdResolver snap)
             logWarn $ RIO.display $ indent $ T.pack $ show r
 
         reportResult r@BuildPlanCheckFail {} snap = do
-            logWarn $ "* Rejected " <> RIO.display (sdResolverName snap)
+            logWarn $ "* Rejected " <> RIO.display (sdResolver snap)
             logWarn $ RIO.display $ indent $ T.pack $ show r
 
         indent t = T.unlines $ fmap ("    " <>) (T.lines t)

src/Stack/Init.hs

@@ -133,7 +133,7 @@ initProject whichCmd currDir initOpts mresolver = do
         toPkg dir = makeRelDir dir
         indent t = T.unlines $ fmap ("    " <>) (T.lines t)
 
-    logInfo $ "Initialising configuration using resolver: " <> display (sdResolverName sd)
+    logInfo $ "Initialising configuration using resolver: " <> display (sdResolver sd)
     logInfo $ "Total number of user packages considered: "
                <> display (Map.size bundle + length dupPkgs)
 
@@ -381,7 +381,7 @@ getWorkingResolverPlan
        --   , Extra dependencies
        --   , Src packages actually considered)
 getWorkingResolverPlan whichCmd initOpts bundle sd = do
-    logInfo $ "Selected resolver: " <> display (sdResolverName sd)
+    logInfo $ "Selected resolver: " <> display (sdResolver sd)
     go bundle
     where
         go info = do
@@ -445,19 +445,19 @@ checkBundleResolver whichCmd initOpts bundle sd = do
                         warnPartial result
                         logWarn "*** Omitting packages with unsatisfied dependencies"
                         return $ Left $ failedUserPkgs e
-                    else throwM $ ResolverPartial whichCmd (sdResolverName sd) (show result)
+                    else throwM $ ResolverPartial whichCmd (sdResolver sd) (show result)
         BuildPlanCheckFail _ e _
             | omitPackages initOpts -> do
                 logWarn $ "*** Resolver compiler mismatch: "
-                           <> display (sdResolverName sd)
+                           <> display (sdResolver sd)
                 logWarn $ display $ indent $ T.pack $ show result
                 return $ Left $ failedUserPkgs e
-            | otherwise -> throwM $ ResolverMismatch whichCmd (sdResolverName sd) (show result)
+            | otherwise -> throwM $ ResolverMismatch whichCmd (sdResolver sd) (show result)
     where
       resolver = sdResolver sd
       indent t  = T.unlines $ fmap ("    " <>) (T.lines t)
       warnPartial res = do
-          logWarn $ "*** Resolver " <> display (sdResolverName sd)
+          logWarn $ "*** Resolver " <> display (sdResolver sd)
                       <> " will need external packages: "
           logWarn $ display $ indent $ T.pack $ show res
 

src/Stack/Snapshot.hs

@@ -202,7 +202,7 @@ loadSnapshot mcompiler helper =
 
     inner :: SnapshotDef -> RIO env LoadedSnapshot
     inner sd = do
-      logInfo $ "Loading a snapshot from a SnapshotDef: " <> RIO.display (sdResolverName sd)
+      logInfo $ "Loading a snapshot from a SnapshotDef: " <> RIO.display (sdResolver sd)
       case sdSnapshot sd of
         Nothing -> helper (sdWantedCompilerVersion sd)
         Just (snapshot, sd') -> start sd' >>= inner2 snapshot

src/Stack/Solver.hs

@@ -358,7 +358,7 @@ solveResolverSpec
 
 solveResolverSpec cabalDirs
                   (sd, srcConstraints, extraConstraints) = do
-  logInfo $ "Using resolver: " <> RIO.display (sdResolverName sd)
+  logInfo $ "Using resolver: " <> RIO.display (sdResolver sd)
   let wantedCompilerVersion = sdWantedCompilerVersion sd
   setupCabalEnv wantedCompilerVersion $ \compilerVersion -> do
     (compilerVer, snapConstraints) <- getResolverConstraints <$> loadSnapshotCompiler compilerVersion sd
@@ -376,7 +376,7 @@ solveResolverSpec cabalDirs
                      ["--ghcjs" | whichCompiler compilerVer == Ghcjs]
 
     let srcNames = T.intercalate " and " $
-          ["packages from " <> sdResolverName sd
+          ["packages from " <> utf8BuilderToText (RIO.display (sdResolver sd))
               | not (Map.null snapConstraints)] ++
           [T.pack (show (Map.size extraConstraints) <> " external packages")
               | not (Map.null extraConstraints)]
@@ -646,7 +646,7 @@ solveExtraDeps modStackYaml = do
             -- TODO Solver should also use the init code to ignore incompatible
             -- packages
         BuildPlanCheckFail {} ->
-            throwM $ ResolverMismatch IsSolverCmd (sdResolverName sd) (show resolverResult)
+            throwM $ ResolverMismatch IsSolverCmd (sdResolver sd) (show resolverResult)
 
     (srcs, edeps) <- case resultSpecs of
         Nothing -> throwM (SolverGiveUp giveUpMsg)

src/Stack/Types/BuildPlan.hs

@@ -21,7 +21,6 @@ module Stack.Types.BuildPlan
     , ModuleInfo (..)
     , moduleInfoVC
     , sdSnapshots
-    , sdResolverName
     ) where
 
 import qualified Data.Map as Map
@@ -56,9 +55,6 @@ data SnapshotDef = SnapshotDef -- To be removed as part of https://github.com/co
 instance Store SnapshotDef
 instance NFData SnapshotDef
 
-sdResolverName :: SnapshotDef -> Text
-sdResolverName = utf8BuilderToText . display . sdResolver
-
 sdSnapshots :: SnapshotDef -> [RawSnapshotLayer]
 sdSnapshots sd =
   case sdSnapshot sd of

src/Stack/Types/Config.hs

@@ -1029,8 +1029,8 @@ data ConfigException
   | UnableToExtractArchive Text (Path Abs File)
   | BadStackVersionException VersionRange
   | NoMatchingSnapshot WhichSolverCmd (NonEmpty SnapName)
-  | ResolverMismatch WhichSolverCmd !Text String -- Text == resolver name, sdName
-  | ResolverPartial WhichSolverCmd !Text String -- Text == resolver name, sdName
+  | ResolverMismatch WhichSolverCmd !RawSnapshotLocation String
+  | ResolverPartial WhichSolverCmd !RawSnapshotLocation String
   | NoSuchDirectory FilePath
   | ParseGHCVariantException String
   | BadStackRoot (Path Abs Dir)
@@ -1093,15 +1093,15 @@ instance Show ConfigException where
         ]
     show (ResolverMismatch whichCmd resolver errDesc) = concat
         [ "Resolver '"
-        , T.unpack resolver
+        , T.unpack $ utf8BuilderToText $ display resolver
         , "' does not have a matching compiler to build some or all of your "
         , "package(s).\n"
         , errDesc
         , showOptions whichCmd Don'tSuggestSolver
         ]
     show (ResolverPartial whichCmd resolver errDesc) = concat
         [ "Resolver '"
-        , T.unpack resolver
+        , T.unpack $ utf8BuilderToText $ display resolver
         , "' does not have all the packages to match your requirements.\n"
         , unlines $ fmap ("    " <>) (lines errDesc)
         , showOptions whichCmd

subs/pantry/src/Pantry/Types.hs

@@ -113,7 +113,7 @@ import qualified RIO.ByteString as B
 import qualified RIO.ByteString.Lazy as BL
 import RIO.Char (isSpace)
 import RIO.List (intersperse)
-import RIO.Time (toGregorian, Day)
+import RIO.Time (toGregorian, Day, fromGregorianValid)
 import qualified RIO.Map as Map
 import qualified RIO.HashMap as HM
 import qualified Data.Map.Strict as Map (mapKeysMonotonic)
@@ -1698,7 +1698,9 @@ instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where
 
 instance Display SnapshotLocation where
   display (SLCompiler compiler) = display compiler
-  display (SLUrl url blob) = display url <> " (" <> display blob <> ")"
+  display (SLUrl url blob) =
+    fromMaybe (display url) (specialRawSnapshotLocation url) <>
+    " (" <> display blob <> ")"
   display (SLFilePath resolved) = display (resolvedRelative resolved)
 
 -- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'.
@@ -1809,12 +1811,46 @@ instance NFData RawSnapshotLocation
 
 instance Display RawSnapshotLocation where
   display (RSLCompiler compiler) = display compiler
-  display (RSLUrl url Nothing) = display url
-  display (RSLUrl url (Just blob)) = display url <> " (" <> display blob <> ")"
+  display (RSLUrl url Nothing) = fromMaybe (display url) $ specialRawSnapshotLocation url
+  display (RSLUrl url (Just blob)) =
+    fromMaybe (display url) (specialRawSnapshotLocation url) <>
+    " (" <> display blob <> ")"
   display (RSLFilePath resolved) = display (resolvedRelative resolved)
 
+-- | For nicer display purposes: present a 'RawSnapshotLocation' as a
+-- short form like lts-13.13 if possible.
+specialRawSnapshotLocation :: Text -> Maybe Utf8Builder
+specialRawSnapshotLocation url = do
+  t1 <- T.stripPrefix "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/" url
+  parseLTS t1 <|> parseNightly t1
+  where
+    popInt :: Text -> Maybe (Int, Text)
+    popInt t0 =
+      -- Would be nice if this function did overflow checking for us
+      case decimal t0 of
+        Left _ -> Nothing
+        Right (x, rest) -> (, rest) <$> do
+          if (x :: Integer) > fromIntegral (maxBound :: Int)
+            then Nothing
+            else Just (fromIntegral x)
+
+    parseLTS t1 = do
+      t2 <- T.stripPrefix "lts/" t1
+      (major, t3) <- popInt t2
+      (minor, ".yaml") <- T.stripPrefix "/" t3 >>= popInt
+      Just $ "lts-" <> display major <> "." <> display minor
+    parseNightly t1 = do
+      t2 <- T.stripPrefix "nightly/" t1
+      (year, t3) <- popInt t2
+      (month, t4) <- T.stripPrefix "/" t3 >>= popInt
+      (day, ".yaml") <- T.stripPrefix "/" t4 >>= popInt
+      date <- fromGregorianValid (fromIntegral year) month day
+      Just $ "nightly-" <> displayShow date
+
 instance ToJSON RawSnapshotLocation where
   toJSON (RSLCompiler compiler) = object ["compiler" .= compiler]
+  toJSON (RSLUrl url Nothing)
+    | Just x <- specialRawSnapshotLocation url = String $ utf8BuilderToText x
   toJSON (RSLUrl url mblob) = object
     $ "url" .= url
     : maybe [] blobKeyPairs mblob

subs/pantry/test/Pantry/TypesSpec.hs

@@ -17,6 +17,7 @@ import qualified RIO.Text as T
 import qualified Data.Yaml as Yaml
 import Data.Aeson.Extended (WithJSONWarnings (..))
 import qualified Data.ByteString.Char8 as S8
+import RIO.Time (Day (..))
 
 hh :: HasCallStack => String -> Property -> Spec
 hh name p = it name $ do
@@ -94,3 +95,18 @@ spec = do
         "name: 'test'\n" ++
         "compiler: ghc-8.0.1\n"
       rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [8, 0, 1]))
+
+    hh "rendering an LTS gives a nice name" $ property $ do
+      (major, minor) <- forAll $ (,)
+        <$> Gen.integral (Range.linear 1 10000)
+        <*> Gen.integral (Range.linear 1 10000)
+      liftIO $
+        Yaml.toJSON (ltsSnapshotLocation major minor) `shouldBe`
+        Yaml.String (T.pack $ concat ["lts-", show major, ".", show minor])
+
+    hh "rendering a nightly gives a nice name" $ property $ do
+      days <- forAll $ Gen.integral $ Range.linear 1 10000000
+      let day = ModifiedJulianDay days
+      liftIO $
+        Yaml.toJSON (nightlySnapshotLocation day) `shouldBe`
+        Yaml.String (T.pack $ "nightly-" ++ show day)

test/integration/tests/nice-resolver-names/Main.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedStrings #-}
+import StackTest
+import Control.Exception (throwIO)
+import Data.Maybe (mapMaybe)
+import Data.Foldable (for_)
+import Data.List (stripPrefix)
+
+main :: IO ()
+main = do
+  for_ ["lts-11.22", "nightly-2018-01-01"] $ \snapshot -> do
+    stack ["init", "--force", "--resolver", snapshot]
+    str <- readFile "stack.yaml"
+    case mapMaybe (stripPrefix "resolver: ") $ lines str of
+      [x] ->
+        if filter (/= '\r') x == snapshot
+          then pure ()
+          else error $ "Mismatch: " ++ show (snapshot, x)
+      _ -> error $ "Wrong number of resolvers: " ++ show str

test/integration/tests/nice-resolver-names/files/.gitignore

@@ -0,0 +1,2 @@
+stack.yaml
+unimportant.cabal

test/integration/tests/nice-resolver-names/files/package.yaml

@@ -0,0 +1,3 @@
+name: unimportant
+version: 0
+library: {}