Add supports for warnings while parsing

Author: sol

src/Data/Aeson/Config/FromValue.hs

@@ -12,6 +12,8 @@ module Data.Aeson.Config.FromValue (
   FromValue(..)
 , Parser
 , Result
+, Warning(..)
+, WarningReason(..)
 , decodeValue
 
 , Generic
@@ -28,6 +30,8 @@ module Data.Aeson.Config.FromValue (
 , withNumber
 , withBool
 
+, warn
+
 , parseArray
 , traverseObject
 
@@ -56,7 +60,7 @@ import           Data.Aeson.Types (FromJSON(..))
 import           Data.Aeson.Config.Util
 import           Data.Aeson.Config.Parser
 
-type Result a = Either String (a, [String])
+type Result a = Either String (a, [Warning])
 
 decodeValue :: FromValue a => Value -> Result a
 decodeValue = runParser fromValue

src/Data/Aeson/Config/Parser.hs

@@ -4,6 +4,8 @@
 {-# LANGUAGE CPP #-}
 module Data.Aeson.Config.Parser (
   Parser
+, Warning(..)
+, WarningReason(..)
 , runParser
 
 , typeMismatch
@@ -14,6 +16,8 @@ module Data.Aeson.Config.Parser (
 , withNumber
 , withBool
 
+, warn
+
 , explicitParseField
 , explicitParseFieldMaybe
 
@@ -67,6 +71,7 @@ fromAesonPathElement e = case e of
 
 data ParserState = ParserState {
   parserStateConsumedFields :: !(Set JSONPath)
+, parserStateWarnings :: ![(JSONPath, String)]
 }
 
 newtype Parser a = Parser {unParser :: StateT ParserState Aeson.Parser a}
@@ -75,10 +80,22 @@ newtype Parser a = Parser {unParser :: StateT ParserState Aeson.Parser a}
 liftParser :: Aeson.Parser a -> Parser a
 liftParser = Parser . lift
 
-runParser :: (Value -> Parser a) -> Value -> Either String (a, [String])
-runParser p v = case iparse (flip runStateT (ParserState mempty) . unParser <$> p) v of
+data Warning = Warning String WarningReason
+  deriving (Eq, Show)
+
+data WarningReason = WarningReason String | UnknownField
+  deriving (Eq, Show)
+
+runParser :: (Value -> Parser a) -> Value -> Either String (a, [Warning])
+runParser p v = case iparse (flip runStateT (ParserState mempty mempty) . unParser <$> p) v of
   IError path err -> Left ("Error while parsing " ++ formatPath (fromAesonPath path) ++ " - " ++ err)
-  ISuccess (a, ParserState consumed) -> Right (a, map formatPath (determineUnconsumed consumed v))
+  ISuccess (a, ParserState consumed warnings) -> Right (a, map warning warnings ++ map unknownField (determineUnconsumed consumed v))
+  where
+    warning :: (JSONPath, String) -> Warning
+    warning (path, reason) = Warning (formatPath path) (WarningReason reason)
+
+    unknownField :: JSONPath -> Warning
+    unknownField path = Warning (formatPath path) UnknownField
 
 formatPath :: JSONPath -> String
 formatPath = go "$" . reverse
@@ -160,3 +177,8 @@ withNumber _ v = typeMismatch "Number" v
 withBool :: (Bool -> Parser a) -> Value -> Parser a
 withBool p (Bool b) = p b
 withBool _ v = typeMismatch "Boolean" v
+
+warn :: String -> Parser ()
+warn s = do
+  path <- getPath
+  Parser . modify $ \ st -> st {parserStateWarnings = (path, s) : parserStateWarnings st}

src/Hpack/Config.hs

@@ -849,16 +849,18 @@ sectionAll f sect = f sect <> foldMap (foldMap $ sectionAll f) (sectionCondition
 
 decodeValue :: FromValue a => ProgramName -> FilePath -> Value -> Warnings (Errors IO) a
 decodeValue (ProgramName programName) file value = do
-  (r, unknown) <- lift . ExceptT . return $ first (prefix ++) (Config.decodeValue value)
+  (r, warnings) <- lift . ExceptT . return $ first (prefix ++) (Config.decodeValue value)
   case r of
     UnsupportedSpecVersion v -> do
       lift $ throwE ("The file " ++ file ++ " requires version " ++ showVersion v ++ " of the Hpack package specification, however this version of " ++ programName ++ " only supports versions up to " ++ showVersion Hpack.version ++ ". Upgrading to the latest version of " ++ programName ++ " may resolve this issue.")
     SupportedSpecVersion a -> do
-      tell (map formatUnknownField unknown)
+      tell (map formatWarning warnings)
       return a
   where
     prefix = file ++ ": "
-    formatUnknownField name = prefix ++ "Ignoring unrecognized field " ++ name
+    formatWarning warning = prefix ++ case warning of
+      Warning path (WarningReason reason) -> reason <> " in " <> path
+      Warning path UnknownField -> "Ignoring unrecognized field " <> path
 
 data CheckSpecVersion a = SupportedSpecVersion a | UnsupportedSpecVersion Version
 

src/Hpack/Yaml.hs

@@ -20,13 +20,13 @@ module Hpack.Yaml (
 import           Data.Bifunctor
 import           Data.Yaml hiding (decodeFile, decodeFileWithWarnings)
 import           Data.Yaml.Include
-import           Data.Yaml.Internal (Warning(..))
+import qualified Data.Yaml.Internal as Yaml
 import           Data.Aeson.Config.FromValue
 import           Data.Aeson.Config.Parser (fromAesonPath, formatPath)
 
-formatWarning :: FilePath -> Warning -> String
+formatWarning :: FilePath -> Yaml.Warning -> String
 formatWarning file = \ case
-  DuplicateKey path -> file ++ ": Duplicate field " ++ formatPath (fromAesonPath path)
+  Yaml.DuplicateKey path -> file ++ ": Duplicate field " ++ formatPath (fromAesonPath path)
 
 decodeYaml :: FilePath -> IO (Either String ([String], Value))
 decodeYaml file = do

test/Data/Aeson/Config/FromValueSpec.hs

@@ -52,7 +52,7 @@ spec = do
         name: "Joe"
         age: 23
         foo: bar
-        |] `shouldDecodeTo` Right (Person "Joe" 23 Nothing, ["$.foo"])
+        |] `shouldDecodeTo` Right (Person "Joe" 23 Nothing, [unknownField "$.foo"])
 
       it "captures nested unrecognized fields" $ do
         [yaml|
@@ -63,7 +63,7 @@ spec = do
           zip: "123456"
           foo:
             bar: 23
-        |] `shouldDecodeTo` Right (Person "Joe" 23 (Just (Address "somewhere" "123456")), ["$.address.foo"])
+        |] `shouldDecodeTo` Right (Person "Joe" 23 (Just (Address "somewhere" "123456")), [unknownField "$.address.foo"])
 
       it "ignores fields that start with an underscore" $ do
         [yaml|
@@ -95,7 +95,7 @@ spec = do
         role: engineer
         salary: 100000
         foo: bar
-        |] `shouldDecodeTo` Right ((Person "Joe" 23 Nothing, Job "engineer" 100000), ["$.foo"])
+        |] `shouldDecodeTo` Right ((Person "Joe" 23 Nothing, Job "engineer" 100000), [unknownField "$.foo"])
 
     context "with []" $ do
       it "captures unrecognized fields" $ do
@@ -111,7 +111,7 @@ spec = do
         - name: "Marry"
           age: 25
           bar: 42
-        |] `shouldDecodeTo` Right (expected, ["$[1].bar", "$[0].address.foo"])
+        |] `shouldDecodeTo` Right (expected, [unknownField "$[1].bar", unknownField "$[0].address.foo"])
 
     context "with Map" $ do
       it "captures unrecognized fields" $ do
@@ -120,4 +120,4 @@ spec = do
           region: somewhere
           zip: '123456'
           foo: bar
-        |] `shouldDecodeTo` Right (Map.fromList [("Joe", Address "somewhere" "123456")], ["$.Joe.foo"])
+        |] `shouldDecodeTo` Right (Map.fromList [("Joe", Address "somewhere" "123456")], [unknownField "$.Joe.foo"])

test/Helper.hs

@@ -10,6 +10,7 @@ module Helper (
 , module System.FilePath
 , withCurrentDirectory
 , yaml
+, unknownField
 ) where
 
 import           Test.Hspec
@@ -26,6 +27,7 @@ import           Data.Yaml.TH (yamlQQ)
 import           Language.Haskell.TH.Quote (QuasiQuoter)
 
 import           Hpack.Config
+import           Data.Aeson.Config.FromValue
 
 instance IsString Cond where
   fromString = CondExpression
@@ -42,3 +44,6 @@ withTempDirectory action = Temp.withSystemTempDirectory "hspec" $ \dir -> do
 
 yaml :: Language.Haskell.TH.Quote.QuasiQuoter
 yaml = yamlQQ
+
+unknownField :: String -> Warning
+unknownField path = Warning path UnknownField

test/Hpack/Syntax/DependenciesSpec.hs

@@ -212,7 +212,7 @@ spec = do
               outer-name:
                 name: inner-name
                 path: somewhere
-            |] `shouldDecodeTo` Right (Dependencies [("outer-name", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })], ["$.outer-name.name"])
+            |] `shouldDecodeTo` Right (Dependencies [("outer-name", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })], [unknownField "$.outer-name.name"])
 
           it "defaults to any version" $ do
             [yaml|