Make snapshot: a synonym for resolver

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,6 +22,7 @@ module Data.Aeson.Extended (
   , tellJSONField
   , unWarningParser
   , (..:)
+  , (...:)
   , (..:?)
   , (..!=)
   ) where
@@ -67,6 +68,18 @@ wp ..!= d =
          do a <- fmap snd p
             fmap (, a) (fmap fst p .!= d)
 
+-- | Synonym version of @..:@.
+(...:) :: FromJSON a => Object -> [Text] -> WarningParser a
+_ ...: [] = fail "failed to find an empty key"
+o ...: ss@(key:_) = do
+    when (presentCount /= 1) $ fail $
+      "failed to parse field " ++
+      "'" ++ show key ++ "': " ++
+      "keys " ++ show ss ++ " not present"
+    asum $ map (o..:) ss
+    where isPresent s = HashMap.member s o
+          presentCount = length . filter isPresent $ 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})