Merge pull request #4341 from aleksejkozin/master

Make snapshot: a synonym for resolver

ChangeLog.md

@@ -44,6 +44,7 @@ Major changes:
       match `foo.txt`, but not `foo.2.txt`.
 
 Behavior changes:
+* `stack.yaml` now supports `snapshot`: a synonym for `resolver`. See [#4256](https://github.com/commercialhaskell/stack/issues/4256)
 
 Other enhancements:
 

doc/yaml_configuration.md

@@ -49,6 +49,8 @@ resolver.
 
 ### resolver
 
+> Note: Starting with **Stack 2.0**, `snapshot` is accepted as a synonym for `resolver`. Only one of these fields is permitted, not both.
+
 Specifies which snapshot is to be used for this project. A snapshot
 defines a GHC version, a number of packages available for
 installation, and various settings like build flags. It is called a

src/Stack/Types/Config.hs

@@ -169,7 +169,7 @@ import           Crypto.Hash (hashWith, SHA1(..))
 import           Stack.Prelude
 import           Data.Aeson.Extended
                  (ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON, withText, object,
-                  (.=), (..:), (..:?), (..!=), Value(Bool),
+                  (.=), (..:), (...:), (..:?), (..!=), Value(Bool),
                   withObjectWarnings, WarningParser, Object, jsonSubWarnings,
                   jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings,
                   FromJSONKeyFunction (FromJSONKeyTextParser))
@@ -1458,7 +1458,7 @@ parseProjectAndConfigMonoid rootDir =
         let flags = unCabalStringMap <$> unCabalStringMap
                     (flags' :: Map (CabalString PackageName) (Map (CabalString FlagName) Bool))
 
-        resolver <- jsonSubWarnings (o ..: "resolver")
+        resolver <- jsonSubWarnings $ o ...: ["snapshot", "resolver"]
         mcompiler <- o ..:? "compiler"
         msg <- o ..:? "user-message"
         config <- parseConfigMonoidObject rootDir o

src/test/Stack/ConfigSpec.hs

@@ -56,6 +56,22 @@ hpackConfig =
   "with-hpack: /usr/local/bin/hpack\n" ++
   "packages: ['.']\n"
 
+resolverConfig :: String
+resolverConfig =
+  "resolver: lts-2.10\n" ++
+  "packages: ['.']\n"
+
+snapshotConfig :: String
+snapshotConfig =
+  "snapshot: lts-2.10\n" ++
+  "packages: ['.']\n"
+
+resolverSnapshotConfig :: String
+resolverSnapshotConfig =
+  "resolver: lts-2.10\n" ++
+  "snapshot: lts-2.10\n" ++
+  "packages: ['.']\n"
+
 stackDotYaml :: Path Rel File
 stackDotYaml = either impureThrow id (parseRelFile "stack.yaml")
 
@@ -82,6 +98,38 @@ spec = beforeAll setup $ do
         let resetVar = setEnv name originalValue
         bracket_ setVar resetVar action
 
+  describe "parseProjectAndConfigMonoid" $ do
+    let loadProject' fp inner =
+          withRunner logLevel True False ColorAuto mempty Nothing False $
+          \runner ->
+            runRIO runner $ do
+              iopc <- loadConfigYaml (
+                parseProjectAndConfigMonoid (parent fp)
+                ) fp
+              ProjectAndConfigMonoid project _ <- liftIO iopc
+              liftIO $ inner project
+
+        toAbsPath path = do
+          parentDir <- getCurrentDirectory >>= parseAbsDir
+          return (parentDir </> path)
+
+        loadProject config inner = do
+          yamlAbs <- toAbsPath stackDotYaml
+          writeFile (toFilePath yamlAbs) config
+          loadProject' yamlAbs inner
+
+    it "parses snapshot using 'resolver'" $ inTempDir $ do
+      loadProject resolverConfig $ \Project{..} ->
+        projectResolver `shouldBe` ltsSnapshotLocation 2 10
+
+    it "parses snapshot using 'snapshot'" $ inTempDir $ do
+      loadProject snapshotConfig $ \Project{..} ->
+        projectResolver `shouldBe` ltsSnapshotLocation 2 10
+
+    it "throws if both 'resolver' and 'snapshot' are present" $ inTempDir $ do
+      loadProject resolverSnapshotConfig (const (return ()))
+        `shouldThrow` anyException
+
   describe "loadConfig" $ do
     let loadConfig' inner =
           withRunner logLevel True False ColorAuto mempty Nothing False $ \runner ->

subs/pantry/src/Data/Aeson/Extended.hs

@@ -22,7 +22,9 @@ module Data.Aeson.Extended (
   , tellJSONField
   , unWarningParser
   , (..:)
+  , (...:)
   , (..:?)
+  , (...:?)
   , (..!=)
   ) where
 
@@ -67,6 +69,38 @@ wp ..!= d =
          do a <- fmap snd p
             fmap (, a) (fmap fst p .!= d)
 
+presentCount :: Object -> [Text] -> Int
+presentCount o ss = length . filter (\x -> HashMap.member x o) $ ss
+
+-- | Synonym version of @..:@.
+(...:) :: FromJSON a => Object -> [Text] -> WarningParser a
+_ ...: [] = fail "failed to find an empty key"
+o ...: ss@(key:_) = apply
+    where pc = presentCount o ss
+          apply | pc == 0   = fail $
+                                "failed to parse field " ++
+                                show key ++ ": " ++
+                                "keys " ++ show ss ++ " not present"
+                | pc >  1   = fail $
+                                "failed to parse field " ++
+                                show key ++ ": " ++
+                                "two or more synonym keys " ++
+                                show ss ++ " present"
+                | otherwise = asum $ map (o..:) ss
+
+-- | Synonym version of @..:?@.
+(...:?) :: FromJSON a => Object -> [Text] -> WarningParser (Maybe a)
+_ ...:? [] = fail "failed to find an empty key"
+o ...:? ss@(key:_) = apply
+    where pc = presentCount o ss
+          apply | pc == 0   = return Nothing
+                | pc >  1   = fail $
+                                "failed to parse field " ++
+                                show key ++ ": " ++
+                                "two or more synonym keys " ++
+                                show ss ++ " present"
+                | otherwise = asum $ map (o..:) ss
+
 -- | Tell warning parser about an expected field, so it doesn't warn about it.
 tellJSONField :: Text -> WarningParser ()
 tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key})

subs/pantry/src/Pantry/Types.hs

@@ -1688,7 +1688,7 @@ instance ToJSON SnapshotLayer where
 instance FromJSON (WithJSONWarnings (Unresolved SnapshotLayer)) where
   parseJSON = withObjectWarnings "Snapshot" $ \o -> do
     mcompiler <- o ..:? "compiler"
-    mresolver <- jsonSubWarningsT $ o ..:? "resolver"
+    mresolver <- jsonSubWarningsT $ o ...:? ["snapshot", "resolver"]
     unresolvedSnapshotParent <-
       case (mcompiler, mresolver) of
         (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler"

subs/pantry/test/Pantry/TypesSpec.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Pantry.TypesSpec (spec) where
 
 import Test.Hspec
@@ -12,6 +14,9 @@ import Pantry.Internal (parseTree, renderTree, Tree (..), TreeEntry (..), mkSafe
 import RIO
 import Distribution.Types.Version (mkVersion)
 import qualified RIO.Text as T
+import qualified Data.Yaml as Yaml
+import Data.Aeson.Extended (WithJSONWarnings (..), Value)
+import qualified Data.ByteString.Char8 as S8
 
 hh :: HasCallStack => String -> Property -> Spec
 hh name p = it name $ do
@@ -37,6 +42,7 @@ spec = do
       case parseWantedCompiler text of
         Left e -> throwIO e
         Right actual -> liftIO $ actual `shouldBe` wc
+
   describe "Tree" $ do
     hh "parse/render works" $ property $ do
       tree <- forAll $
@@ -53,3 +59,38 @@ spec = do
          in TreeMap <$> Gen.map (Range.linear 1 20) ((,) <$> sfp <*> entry)
       let bs = renderTree tree
       liftIO $ parseTree bs `shouldBe` Just tree
+
+  describe "SnapshotLayer" $ do
+    let parseSl :: String -> IO SnapshotLayer
+        parseSl str = case Yaml.decodeThrow . S8.pack $ str of
+          (Just (WithJSONWarnings x _)) -> resolvePaths Nothing x
+          Nothing -> fail "Can't parse SnapshotLayer"
+
+    it "parses snapshot using 'resolver'" $ do
+      SnapshotLayer{..} <- parseSl $
+        "name: 'test'\n" ++
+        "resolver: lts-2.10\n"
+      slParent `shouldBe` ltsSnapshotLocation 2 10
+
+    it "parses snapshot using 'snapshot'" $ do
+      SnapshotLayer{..} <- parseSl $
+        "name: 'test'\n" ++
+        "snapshot: lts-2.10\n"
+      slParent `shouldBe` ltsSnapshotLocation 2 10
+
+    it "throws if both 'resolver' and 'snapshot' are present" $ do
+      let go = parseSl $
+                "name: 'test'\n" ++
+                "resolver: lts-2.10\n" ++
+                "snapshot: lts-2.10\n"
+      go `shouldThrow` anyException
+
+    it "throws if both 'snapshot' and 'compiler' are not present" $ do
+      let go = parseSl "name: 'test'\n"
+      go `shouldThrow` anyException
+
+    it "works if no 'snapshot' specified" $ do
+      SnapshotLayer{..} <- parseSl $
+        "name: 'test'\n" ++
+        "compiler: ghc-8.0.1\n"
+      slParent `shouldBe` SLCompiler (WCGhc (mkVersion [8, 0, 1]))