Merge pull request #4790 from commercialhaskell/4789-improved-from-js…

…on-instances

Fix some misplaced parse warnings #4789

subs/pantry/src/Pantry/Types.hs

@@ -506,15 +506,6 @@ instance Display Repo where
     (if T.null subdir
       then mempty
       else " in subdirectory " <> display subdir)
-instance FromJSON Repo where
-    parseJSON =
-        withObject "Repo" $ \o -> do
-            repoSubdir <- o .: "subdir"
-            repoCommit <- o .: "commit"
-            (repoType, repoUrl) <-
-                (o .: "git" >>= \url -> pure (RepoGit, url)) <|>
-                (o .: "hg" >>= \url -> pure (RepoHg, url))
-            pure Repo {..}
 
 
 -- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains
@@ -1411,16 +1402,15 @@ instance Display PackageMetadata where
     , "cabal file == " <> display (pmCabal pm)
     ]
 
-instance FromJSON PackageMetadata where
-    parseJSON =
-        withObject "PackageMetadata" $ \o -> do
-            pmCabal :: BlobKey  <- o .: "cabal-file"
-            pantryTree :: BlobKey <- o .: "pantry-tree"
-            CabalString pkgName  <- o .: "name"
-            CabalString pkgVersion <- o .: "version"
-            let pmTreeKey = TreeKey pantryTree
-                pmIdent = PackageIdentifier {..}
-            pure PackageMetadata {..}
+parsePackageMetadata :: Object -> WarningParser PackageMetadata
+parsePackageMetadata o = do
+  pmCabal :: BlobKey <- o ..: "cabal-file"
+  pantryTree :: BlobKey <- o ..: "pantry-tree"
+  CabalString pkgName <- o ..: "name"
+  CabalString pkgVersion <- o ..: "version"
+  let pmTreeKey = TreeKey pantryTree
+      pmIdent = PackageIdentifier {..}
+  pure PackageMetadata {..}
 
 
 -- | Conver package metadata to its "raw" equivalent.
@@ -1540,35 +1530,38 @@ instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where
                   <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v)
         where
           repoObject :: Value -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
-          repoObject value = do
-            pm <- parseJSON value
-            repo <- parseJSON value
-            pure $ noJSONWarnings $ pure $ PLIRepo repo pm
-
-          archiveObject value = do
-            pm <- parseJSON value
-            withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" (\o -> do
+          repoObject = withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do
+            pm <- parsePackageMetadata o
+            repoSubdir <- o ..:? "subdir" ..!= ""
+            repoCommit <- o ..: "commit"
+            (repoType, repoUrl) <-
+                (o ..: "git" >>= \url -> pure (RepoGit, url)) <|>
+                (o ..: "hg" >>= \url -> pure (RepoHg, url))
+            pure $ pure $ PLIRepo Repo {..} pm
+
+          archiveObject =
+            withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do
+              pm <- parsePackageMetadata o
               Unresolved mkArchiveLocation <- parseArchiveLocationObject o
               archiveHash <- o ..: "sha256"
               archiveSize <- o ..: "size"
               archiveSubdir <- o ..:? "subdir" ..!= ""
               pure $ Unresolved $ \mdir -> do
                 archiveLocation <- mkArchiveLocation mdir
                 pure $ PLIArchive Archive {..} pm
-              ) value
 
-          hackageObject value =
-             withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" (\o -> do
+          hackageObject =
+             withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do
                       treeKey <- o ..: "pantry-tree"
                       htxt <- o ..: "hackage"
                       case parseHackageText htxt of
                         Left e -> fail $ show e
                         Right (pkgIdentifier, blobKey) ->
-                          pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey)) value
+                          pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey)
 
-          github value = do
-            pm <- parseJSON value
+          github value =
             withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do
+              pm <- parsePackageMetadata o
               GitHubRepo ghRepo <- o ..: "github"
               commit <- o ..: "commit"
               let archiveLocation = ALUrl $ T.concat
@@ -1580,7 +1573,7 @@ instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where
                     ]
               archiveHash <- o ..: "sha256"
               archiveSize <- o ..: "size"
-              archiveSubdir <- o ..: "subdir"
+              archiveSubdir <- o ..:? "subdir" ..!= ""
               pure $ pure $ PLIArchive Archive {..} pm) value
 
 instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where
@@ -1594,7 +1587,7 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmu
     <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v)
     where
       http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable)))
-      http = withText "UnresolvedPackageLocationImmutable.UPLIArchive (Text)" $ \t ->
+      http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t ->
         case parseArchiveLocationText t of
           Nothing -> fail $ "Invalid archive location: " ++ T.unpack t
           Just (Unresolved mkArchiveLocation) ->
@@ -1640,7 +1633,7 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmu
         os <- optionalSubdirs o
         pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os)
 
-      archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIArchive" $ \o -> do
+      archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do
         Unresolved mkArchiveLocation <- parseArchiveLocationObject o
         raHash <- o ..:? "sha256"
         raSize <- o ..:? "size"

subs/pantry/test/Pantry/TypesSpec.hs

@@ -60,6 +60,21 @@ pantry-tree:
 commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0
 |]
 
+samplePLIRepo2 :: ByteString
+samplePLIRepo2 =
+    [r|
+cabal-file:
+  size: 1863
+  sha256: 5ebffc39e75ea1016adcc8426dc31d2040d2cc8a5f4bbce228592ef35e233da2
+name: merkle-log
+version: 0.1.0.0
+git: https://github.com/kadena-io/merkle-log.git
+pantry-tree:
+  size: 615
+  sha256: 5a99e5e41ccd675a7721a733714ba2096f4204d9010f867c5fb7095b78e2959d
+commit: a7ae61d7082afe3aa1a0fd0546fc1351a2f7c376
+|]
+
 spec :: Spec
 spec = do
   describe "WantedCompiler" $ do
@@ -140,11 +155,10 @@ spec = do
       liftIO $
         Yaml.toJSON (nightlySnapshotLocation day) `shouldBe`
         Yaml.String (T.pack $ "nightly-" ++ show day)
-    it "FromJSON instance for Repo" $ do
-      repValue <-
-        case Yaml.decodeThrow samplePLIRepo of
-          Just x -> pure x
-          Nothing -> fail "Can't parse Repo"
+    it "FromJSON instance for PLIRepo" $ do
+      WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo
+      warnings `shouldBe` []
+      pli <- resolvePaths Nothing unresolvedPli
       let repoValue =
               Repo
                   { repoSubdir = "wai"
@@ -153,13 +167,7 @@ spec = do
                         "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0"
                   , repoUrl = "https://github.com/yesodweb/wai.git"
                   }
-      repValue `shouldBe` repoValue
-    it "FromJSON instance for PackageMetadata" $ do
-      pkgMeta <-
-        case Yaml.decodeThrow samplePLIRepo of
-          Just x -> pure x
-          Nothing -> fail "Can't parse Repo"
-      let cabalSha =
+          cabalSha =
               SHA256.fromHexBytes
                   "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410"
           pantrySha =
@@ -177,7 +185,12 @@ spec = do
                   , pmTreeKey = TreeKey (BlobKey psha (FileSize 714))
                   , pmCabal = BlobKey csha (FileSize 1765)
                   }
-      pkgMeta `shouldBe` pkgValue
+      pli `shouldBe` PLIRepo repoValue pkgValue
+
+      WithJSONWarnings reparsed warnings2 <- Yaml.decodeThrow $ Yaml.encode pli
+      warnings2 `shouldBe` []
+      reparsed' <- resolvePaths Nothing reparsed
+      reparsed' `shouldBe` pli
     it "parseHackageText parses" $ do
       let txt =
               "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058"
@@ -193,3 +206,11 @@ spec = do
           PackageIdentifier
               (mkPackageName "persistent")
               (mkVersion [2, 8, 2])
+    it "roundtripping a PLIRepo" $ do
+      WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo2
+      warnings `shouldBe` []
+      pli <- resolvePaths Nothing unresolvedPli
+      WithJSONWarnings unresolvedPli2 warnings2 <- Yaml.decodeThrow $ Yaml.encode pli
+      warnings2 `shouldBe` []
+      pli2 <- resolvePaths Nothing unresolvedPli2
+      pli2 `shouldBe` (pli :: PackageLocationImmutable)