Warn on spaces in module names

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
 
@@ -35,6 +39,7 @@ import           Control.Applicative
 import qualified Control.Monad.Fail as Fail
 import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Writer
+import           Control.Monad.Trans.State.Strict
 import           Data.Monoid ((<>))
 import           Data.Scientific
 import           Data.Set (Set, notMember)
@@ -64,16 +69,33 @@ fromAesonPathElement e = case e of
   Aeson.Key k -> Key k
   Aeson.Index n -> Index n
 
-newtype Parser a = Parser {unParser :: WriterT (Set JSONPath) Aeson.Parser a}
+data ParserState = ParserState {
+  parserStateConsumedFields :: !(Set JSONPath)
+, parserStateWarnings :: ![(JSONPath, String)]
+}
+
+newtype Parser a = Parser {unParser :: StateT ParserState Aeson.Parser a}
   deriving (Functor, Applicative, Alternative, Monad, Fail.MonadFail)
 
 liftParser :: Aeson.Parser a -> Parser a
 liftParser = Parser . lift
 
-runParser :: (Value -> Parser a) -> Value -> Either String (a, [String])
-runParser p v = case iparse (runWriterT . 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, 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
@@ -104,13 +126,18 @@ determineUnconsumed ((<> Set.singleton []) -> consumed) = Set.toList . execWrite
               go (Index n : path) v
 
 (<?>) :: Parser a -> Aeson.JSONPathElement -> Parser a
-(<?>) (Parser (WriterT p)) e = do
-  Parser (WriterT (p Aeson.<?> e)) <* markConsumed (fromAesonPathElement e)
+(<?>) p e = mapParser (Aeson.<?> e) p <* markConsumed (fromAesonPathElement e)
+
+mapParser :: (Aeson.Parser (a, ParserState) -> Aeson.Parser (b, ParserState)) -> Parser a -> Parser b
+mapParser f = Parser . mapStateT f . unParser
 
 markConsumed :: JSONPathElement -> Parser ()
 markConsumed e = do
   path <- getPath
-  Parser $ tell (Set.singleton $ e : path)
+  tellJSONPath (e : path)
+
+tellJSONPath :: JSONPath -> Parser ()
+tellJSONPath path = Parser . modify $ \ st -> st {parserStateConsumedFields = Set.insert path $ parserStateConsumedFields st}
 
 getPath :: Parser JSONPath
 getPath = liftParser $ Aeson.parserCatchError empty $ \ path _ -> return (fromAesonPath path)
@@ -150,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/Module.hs

@@ -33,7 +33,11 @@ instance IsString Module where
   fromString = Module
 
 instance FromValue Module where
-  fromValue = fmap Module . fromValue
+  fromValue v = do
+    r <- fromValue v
+    case words r of
+      [name] -> return (Module name)
+      _ -> warn ("invalid module name " ++ show r) >> return (Module r)
 
 toModule :: Path -> Module
 toModule path = case reverse $ Path.components path of

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/EndToEndSpec.hs

@@ -70,6 +70,17 @@ spec = around_ (inTempDirectoryNamed "foo") $ do
           "package.yaml: Duplicate field $.name"
         ]
 
+    context "when a module name contains spaces" $ do
+      it "warns" $ do
+        [i|
+        name: foo
+        library:
+          other-modules:
+            Foo
+            Bar
+            Baz
+        |] `shouldWarn` ["package.yaml: invalid module name \"Foo Bar Baz\" in $.library.other-modules"]
+
     describe "handling of Paths_ module" $ do
       it "adds Paths_ to other-modules" $ do
         [i|

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|