Better handling of unrecognized fields

hpack.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 673b49264a8acc7c22607806c4d188ae1979a8dd940edacfae4895002f4bc64a
+-- hash: 1597d0d933485404bf8046e9586ac2203f8b08fd83d3d61e0e1cc39f6890024b
 
 name:           hpack
 version:        0.23.0
@@ -48,6 +48,7 @@ library
     , text
     , transformers
     , unordered-containers
+    , vector
     , yaml
   exposed-modules:
       Hpack
@@ -55,6 +56,10 @@ library
       Hpack.Run
       Hpack.Yaml
   other-modules:
+      Data.Aeson.Config.FromValue
+      Data.Aeson.Config.Parser
+      Data.Aeson.Config.Types
+      Data.Aeson.Config.Util
       Hpack.CabalFile
       Hpack.Defaults
       Hpack.Dependency
@@ -62,11 +67,8 @@ library
       Hpack.Haskell
       Hpack.Options
       Hpack.Render
-      Hpack.Syntax
-      Hpack.Syntax.GenericsUtil
+      Hpack.Syntax.Defaults
       Hpack.Syntax.Git
-      Hpack.Syntax.UnknownFields
-      Hpack.Syntax.Util
       Hpack.Utf8
       Hpack.Util
       Paths_hpack
@@ -98,6 +100,7 @@ executable hpack
     , text
     , transformers
     , unordered-containers
+    , vector
     , yaml
   other-modules:
       Paths_hpack
@@ -114,6 +117,7 @@ test-suite spec
   build-depends:
       Cabal
     , Glob
+    , HUnit
     , QuickCheck
     , aeson >=1.0.0
     , base >=4.8 && <5
@@ -132,12 +136,17 @@ test-suite spec
     , mockery >=0.3
     , pretty
     , scientific
+    , template-haskell
     , temporary
     , text
     , transformers
     , unordered-containers
-    , yaml
+    , vector
+    , yaml >=0.8.28
   other-modules:
+      Data.Aeson.Config.FromValueSpec
+      Data.Aeson.Config.TypesSpec
+      Data.Aeson.Config.UtilSpec
       EndToEndSpec
       Helper
       Hpack.CabalFileSpec
@@ -149,13 +158,15 @@ test-suite spec
       Hpack.OptionsSpec
       Hpack.RenderSpec
       Hpack.RunSpec
-      Hpack.Syntax.GenericsUtilSpec
+      Hpack.Syntax.DefaultsSpec
       Hpack.Syntax.GitSpec
-      Hpack.Syntax.UtilSpec
-      Hpack.SyntaxSpec
       Hpack.Utf8Spec
       Hpack.UtilSpec
       HpackSpec
+      Data.Aeson.Config.FromValue
+      Data.Aeson.Config.Parser
+      Data.Aeson.Config.Types
+      Data.Aeson.Config.Util
       Hpack
       Hpack.CabalFile
       Hpack.Config
@@ -166,11 +177,8 @@ test-suite spec
       Hpack.Options
       Hpack.Render
       Hpack.Run
-      Hpack.Syntax
-      Hpack.Syntax.GenericsUtil
+      Hpack.Syntax.Defaults
       Hpack.Syntax.Git
-      Hpack.Syntax.UnknownFields
-      Hpack.Syntax.Util
       Hpack.Utf8
       Hpack.Util
       Hpack.Yaml

package.yaml

@@ -32,6 +32,7 @@ dependencies:
   - http-types
   - http-client
   - http-client-tls
+  - vector
 
 library:
   source-dirs: src
@@ -60,3 +61,6 @@ tests:
       - temporary
       - mockery >= 0.3
       - interpolate
+      - template-haskell
+      - HUnit
+      - yaml >= 0.8.28

src/Data/Aeson/Config/FromValue.hs

@@ -0,0 +1,138 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
+
+{-# LANGUAGE ConstraintKinds #-}
+module Data.Aeson.Config.FromValue (
+  FromValue(..)
+, Parser
+, DecodeResult
+, decodeValue
+
+, Generic
+, GenericDecode
+, genericFromValue
+, Options(..)
+, genericFromValueWith
+
+, typeMismatch
+, withObject
+, withText
+, withString
+, withArray
+, withNumber
+, withBool
+
+, (.:)
+, (.:?)
+
+, Value(..)
+, Object
+, Array
+) where
+
+import           GHC.Generics
+
+import           Control.Monad
+import           Control.Applicative
+
+import           Data.Map.Lazy (Map)
+import qualified Data.Map.Lazy as Map
+import           Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import qualified Data.HashMap.Strict as HashMap
+import           Data.Aeson.Types (FromJSON(..))
+
+import           Data.Aeson.Config.Util
+import           Data.Aeson.Config.Parser
+
+type DecodeResult a = Either String (a, [String])
+
+decodeValue :: FromValue a => Value -> DecodeResult a
+decodeValue = runParser fromValue
+
+(.:) :: FromValue a => Object -> Text -> Parser a
+(.:) = explicitParseField fromValue
+
+(.:?) :: FromValue a => Object -> Text -> Parser (Maybe a)
+(.:?) = explicitParseFieldMaybe fromValue
+
+class FromValue a where
+  fromValue :: Value -> Parser a
+  default fromValue :: forall d m. (Generic a, Rep a ~ D1 d m, Datatype d, GenericDecode (Rep a)) => Value -> Parser a
+  fromValue = genericFromValue
+
+genericFromValue :: forall a d m. (Generic a, Rep a ~ D1 d m, Datatype d, GenericDecode (Rep a)) => Value -> Parser a
+genericFromValue = genericFromValueWith (Options $ hyphenize name)
+  where
+    name :: String
+    name = datatypeName (undefined :: D1 d m p)
+
+instance FromValue Bool where
+  fromValue = liftParser . parseJSON
+
+instance FromValue Int where
+  fromValue = liftParser . parseJSON
+
+instance FromValue Text where
+  fromValue = liftParser . parseJSON
+
+instance {-# OVERLAPPING #-} FromValue String where
+  fromValue = liftParser . parseJSON
+
+instance FromValue a => FromValue (Maybe a) where
+  fromValue value = liftParser (parseJSON value) >>= traverse fromValue
+
+instance FromValue a => FromValue [a] where
+  fromValue = withArray $ zipWithM (parseIndexed fromValue) [0..] . V.toList
+    where
+      parseIndexed :: (Value -> Parser a) -> Int -> Value -> Parser a
+      parseIndexed p n value = p value <?> Index n
+
+instance FromValue a => FromValue (Map String a) where
+  fromValue = withObject $ \ o -> do
+    xs <- forM (HashMap.toList o) $ \ (name, value) ->
+      (,) (T.unpack name) <$> fromValue value <?> Key name
+    return $ Map.fromList xs
+
+instance (FromValue a, FromValue b) => FromValue (a, b) where
+  fromValue v = (,) <$> fromValue v <*> fromValue v
+
+instance (FromValue a, FromValue b) => FromValue (Either a b) where
+  fromValue v = Left <$> fromValue v <|> Right <$> fromValue v
+
+data Options = Options {
+  optionsRecordSelectorModifier :: String -> String
+}
+
+genericFromValueWith :: (Generic a, GenericDecode (Rep a)) => Options -> Value -> Parser a
+genericFromValueWith opts = fmap to . genericDecode  opts
+
+class GenericDecode f where
+  genericDecode :: Options -> Value -> Parser (f p)
+
+instance (GenericDecode a) => GenericDecode (D1 d a) where
+  genericDecode opts = fmap M1 . genericDecode opts
+
+instance (GenericDecode a) => GenericDecode (C1 c a) where
+  genericDecode opts = fmap M1 . genericDecode opts
+
+instance (GenericDecode a, GenericDecode b) => GenericDecode (a :*: b) where
+  genericDecode opts o = (:*:) <$> genericDecode opts o <*> genericDecode opts o
+
+instance (Selector sel, FromValue a) => GenericDecode (S1 sel (Rec0 a)) where
+  genericDecode = accessFieldWith (.:)
+
+instance {-# OVERLAPPING #-} (Selector sel, FromValue a) => GenericDecode (S1 sel (Rec0 (Maybe a))) where
+  genericDecode = accessFieldWith (.:?)
+
+accessFieldWith :: forall sel a p. Selector sel => (Object -> Text -> Parser a) -> Options -> Value -> Parser (S1 sel (Rec0 a) p)
+accessFieldWith op Options{..} v = M1 . K1 <$> withObject (`op` T.pack label) v
+  where
+    label = optionsRecordSelectorModifier $ selName (undefined :: S1 sel (Rec0 a) p)

src/Data/Aeson/Config/Parser.hs

@@ -0,0 +1,143 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ViewPatterns #-}
+module Data.Aeson.Config.Parser (
+  Parser
+, runParser
+
+, typeMismatch
+, withObject
+, withText
+, withString
+, withArray
+, withNumber
+, withBool
+
+, explicitParseField
+, explicitParseFieldMaybe
+
+, Aeson.JSONPathElement(..)
+, (<?>)
+
+, Value(..)
+, Object
+, Array
+
+, liftParser
+) where
+
+import           Control.Monad
+import           Control.Applicative
+import           Control.Monad.Trans.Class
+import           Control.Monad.Trans.Writer
+import           Data.Monoid ((<>))
+import           Data.Scientific
+import           Data.Set (Set, notMember)
+import qualified Data.Set as Set
+import           Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import qualified Data.HashMap.Strict as HashMap
+import           Data.Aeson.Types (Value(..), Object, Array)
+import qualified Data.Aeson.Types as Aeson
+import           Data.Aeson.Internal (IResult(..), iparse)
+import qualified Data.Aeson.Internal as Aeson
+
+-- This is needed so that we have an Ord instance for aeson < 1.2.4.
+data JSONPathElement = Key Text | Index Int
+  deriving (Eq, Show, Ord)
+
+type JSONPath = [JSONPathElement]
+
+fromAesonPath :: Aeson.JSONPath -> JSONPath
+fromAesonPath = reverse . map fromAesonPathElement
+
+fromAesonPathElement :: Aeson.JSONPathElement -> JSONPathElement
+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}
+  deriving (Functor, Applicative, Alternative, Monad)
+
+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
+  IError path err -> Left ("Error while parsing " ++ formatPath (fromAesonPath path) ++ " - " ++ err)
+  ISuccess (a, consumed) -> Right (a, map formatPath (determineUnconsumed consumed v))
+
+formatPath :: JSONPath -> String
+formatPath = go "$" . reverse
+  where
+    go :: String -> JSONPath -> String
+    go acc path = case path of
+      [] -> acc
+      Index n : xs -> go (acc ++ "[" ++ show n ++ "]") xs
+      Key key : xs -> go (acc ++ "." ++ T.unpack key) xs
+
+determineUnconsumed :: Set JSONPath -> Value -> [JSONPath]
+determineUnconsumed ((<> Set.singleton []) -> consumed) = Set.toList . execWriter . go []
+  where
+    go :: JSONPath -> Value -> Writer (Set JSONPath) ()
+    go path value
+      | path `notMember` consumed = tell (Set.singleton path)
+      | otherwise = case value of
+          Number _ -> return ()
+          String _ -> return ()
+          Bool _ -> return ()
+          Null -> return ()
+          Object o -> do
+            forM_ (HashMap.toList o) $ \ (k, v) -> do
+              go (Key k : path) v
+          Array xs -> do
+            forM_ (zip [0..] $ V.toList xs) $ \ (n, v) -> do
+              go (Index n : path) v
+
+(<?>) :: Parser a -> Aeson.JSONPathElement -> Parser a
+(<?>) (Parser (WriterT p)) e = do
+  Parser (WriterT (p Aeson.<?> e)) <* markConsumed (fromAesonPathElement e)
+
+markConsumed :: JSONPathElement -> Parser ()
+markConsumed e = do
+  path <- getPath
+  Parser $ tell (Set.singleton $ e : path)
+
+getPath :: Parser JSONPath
+getPath = liftParser $ Aeson.parserCatchError empty $ \ path _ -> return (fromAesonPath path)
+
+explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a
+explicitParseField p o key = case HashMap.lookup key o of
+  Nothing -> fail $ "key " ++ show key ++ " not present"
+  Just v  -> p v <?> Aeson.Key key
+
+explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a)
+explicitParseFieldMaybe p o key = case HashMap.lookup key o of
+  Nothing -> pure Nothing
+  Just v  -> Just <$> p v <?> Aeson.Key key
+
+typeMismatch :: String -> Value -> Parser a
+typeMismatch expected = liftParser . Aeson.typeMismatch expected
+
+withObject :: (Object -> Parser a) -> Value -> Parser a
+withObject p (Object o) = p o
+withObject _ v = typeMismatch "Object" v
+
+withText :: (Text -> Parser a) -> Value -> Parser a
+withText p (String s) = p s
+withText _ v = typeMismatch "String" v
+
+withString :: (String -> Parser a) -> Value -> Parser a
+withString p = withText (p . T.unpack)
+
+withArray :: (Array -> Parser a) -> Value -> Parser a
+withArray p (Array xs) = p xs
+withArray _ v = typeMismatch "Array" v
+
+withNumber :: (Scientific -> Parser a) -> Value -> Parser a
+withNumber p (Number n) = p n
+withNumber _ v = typeMismatch "Number" v
+
+withBool :: (Bool -> Parser a) -> Value -> Parser a
+withBool p (Bool b) = p b
+withBool _ v = typeMismatch "Boolean" v

src/Data/Aeson/Config/Types.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Data.Aeson.Config.Types where
+
+import           Data.Monoid hiding (Product)
+import           Data.Bitraversable
+import           Data.Bifoldable
+import           Data.Bifunctor
+
+import           Data.Aeson.Config.FromValue
+
+newtype List a = List {fromList :: [a]}
+  deriving (Eq, Show, Functor, Foldable, Traversable, Monoid)
+
+instance FromValue a => FromValue (List a) where
+  fromValue v = List <$> case v of
+    Array _ -> fromValue v
+    _ -> return <$> fromValue v
+
+fromMaybeList :: Maybe (List a) -> [a]
+fromMaybeList = maybe [] fromList
+
+data Product a b = Product a b
+  deriving (Eq, Show, Functor, Foldable, Traversable)
+
+instance (Monoid a, Monoid b) => Monoid (Product a b) where
+  mempty = Product mempty mempty
+  Product a1 b1 `mappend` Product a2 b2 = Product (a1 <> a2) (b1 <> b2)
+
+instance Bifunctor Product where
+  bimap fa fb (Product a b) = Product (fa a) (fb b)
+
+instance Bifoldable Product where
+  bifoldMap = bifoldMapDefault
+
+instance Bitraversable Product where
+  bitraverse fa fb (Product a b) = Product <$> fa a <*> fb b
+
+instance (FromValue a, FromValue b) => FromValue (Product a b) where
+  fromValue v = Product <$> fromValue v <*> fromValue v

src/Data/Aeson/Config/Util.hs

@@ -0,0 +1,8 @@
+module Data.Aeson.Config.Util where
+
+import           Data.Aeson.Types (camelTo2)
+
+hyphenize :: String -> String -> String
+hyphenize name = camelTo2 '-' . dropPrefix . dropWhile (== '_')
+  where
+    dropPrefix = drop (length (dropWhile (== '_') $ reverse name))

src/Hpack/Config.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveFoldable #-}
 {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -43,15 +44,14 @@ module Hpack.Config (
 
 , LibrarySection(..)
 , fromLibrarySectionInConditional
+, formatOrList
 #endif
 ) where
 
 import           Control.Applicative
 import           Control.Arrow ((>>>))
 import           Control.Monad
-import           Data.Data
 import           Data.Bifunctor
-import           Data.Bifoldable
 import           Data.Bitraversable
 import           Data.Map.Lazy (Map)
 import qualified Data.Map.Lazy as Map
@@ -60,21 +60,20 @@ import           Data.List (nub, (\\), sortBy, intercalate)
 import           Data.Maybe
 import           Data.Monoid hiding (Product)
 import           Data.Ord
-import           Data.String
 import           Data.Text (Text)
 import qualified Data.Text as T
 import           System.Directory
 import           System.FilePath
-import           Data.Functor.Identity
 import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Writer
 import           Control.Monad.Trans.Except
 import           Control.Monad.IO.Class
-import           Data.Aeson.Internal
 
-import           Hpack.Syntax.Util
-import           Hpack.Syntax.UnknownFields
-import           Hpack.Syntax
+import           Data.Aeson.Config.Types
+import           Data.Aeson.Config.FromValue hiding (decodeValue)
+import qualified Data.Aeson.Config.FromValue as Config
+
+import           Hpack.Syntax.Defaults
 import           Hpack.Util hiding (expandGlobs)
 import qualified Hpack.Util as Util
 import           Hpack.Defaults
@@ -146,12 +145,7 @@ packageConfig = "package.yaml"
 
 data CustomSetupSection = CustomSetupSection {
   customSetupSectionDependencies :: Maybe Dependencies
-} deriving (Eq, Show, Generic)
-
-instance HasFieldNames CustomSetupSection
-
-instance FromJSON CustomSetupSection where
-  parseJSON = genericParseJSON
+} deriving (Eq, Show, Generic, FromValue)
 
 data LibrarySection = LibrarySection {
   librarySectionExposed :: Maybe Bool
@@ -161,7 +155,7 @@ data LibrarySection = LibrarySection {
 , librarySectionGeneratedOtherModules :: Maybe (List String)
 , librarySectionReexportedModules :: Maybe (List String)
 , librarySectionSignatures :: Maybe (List String)
-} deriving (Eq, Show, Generic)
+} deriving (Eq, Show, Generic, FromValue)
 
 instance Monoid LibrarySection where
   mempty = LibrarySection Nothing Nothing Nothing Nothing Nothing Nothing Nothing
@@ -175,16 +169,11 @@ instance Monoid LibrarySection where
     , librarySectionSignatures = librarySectionSignatures a <> librarySectionSignatures b
     }
 
-instance HasFieldNames LibrarySection
-
-instance FromJSON LibrarySection where
-  parseJSON = genericParseJSON
-
 data ExecutableSection = ExecutableSection {
   executableSectionMain :: Maybe FilePath
 , executableSectionOtherModules :: Maybe (List String)
 , executableSectionGeneratedOtherModules :: Maybe (List String)
-} deriving (Eq, Show, Generic)
+} deriving (Eq, Show, Generic, FromValue)
 
 instance Monoid ExecutableSection where
   mempty = ExecutableSection Nothing Nothing Nothing
@@ -194,12 +183,7 @@ instance Monoid ExecutableSection where
     , executableSectionGeneratedOtherModules = executableSectionGeneratedOtherModules a <> executableSectionGeneratedOtherModules b
     }
 
-instance HasFieldNames ExecutableSection
-
-instance FromJSON ExecutableSection where
-  parseJSON = genericParseJSON
-
-data CommonOptions capture cSources jsSources a = CommonOptions {
+data CommonOptions cSources jsSources a = CommonOptions {
   commonOptionsSourceDirs :: Maybe (List FilePath)
 , commonOptionsDependencies :: Maybe Dependencies
 , commonOptionsPkgConfigDependencies :: Maybe (List String)
@@ -220,11 +204,14 @@ data CommonOptions capture cSources jsSources a = CommonOptions {
 , commonOptionsInstallIncludes :: Maybe (List FilePath)
 , commonOptionsLdOptions :: Maybe (List LdOption)
 , commonOptionsBuildable :: Maybe Bool
-, commonOptionsWhen :: Maybe (List (ConditionalSection capture cSources jsSources a))
+, commonOptionsWhen :: Maybe (List (ConditionalSection cSources jsSources a))
 , commonOptionsBuildTools :: Maybe Dependencies
 } deriving (Functor, Generic)
 
-instance (Monoid cSources, Monoid jsSources) => Monoid (CommonOptions capture cSources jsSources a) where
+type ParseCommonOptions = CommonOptions ParseCSources ParseJsSources
+instance FromValue a => FromValue (ParseCommonOptions a)
+
+instance (Monoid cSources, Monoid jsSources) => Monoid (CommonOptions cSources jsSources a) where
   mempty = CommonOptions {
     commonOptionsSourceDirs = Nothing
   , commonOptionsDependencies = Nothing
@@ -274,43 +261,28 @@ instance (Monoid cSources, Monoid jsSources) => Monoid (CommonOptions capture cS
   , commonOptionsBuildTools = commonOptionsBuildTools b <> commonOptionsBuildTools a
   }
 
-type ParseCommonOptions = CommonOptions CaptureUnknownFields ParseCSources ParseJsSources
-
-instance HasFieldNames (ParseCommonOptions a)
-
-instance (FromJSON a, HasFieldNames a) => FromJSON (ParseCommonOptions a) where
-  parseJSON = genericParseJSON
-
 type ParseCSources = Maybe (List FilePath)
 type ParseJsSources = Maybe (List FilePath)
 
 type CSources = [FilePath]
 type JsSources = [FilePath]
 
-type WithCommonOptions capture cSources jsSources a = Product (CommonOptions capture cSources jsSources a) a
+type WithCommonOptions cSources jsSources a = Product (CommonOptions cSources jsSources a) a
 
-data Traverse m capture capture_ cSources cSources_ jsSources jsSources_ = Traverse {
-  traverseCapture :: forall a. capture a -> m (capture_ a)
-, traverseCSources :: cSources -> m cSources_
+data Traverse m cSources cSources_ jsSources jsSources_ = Traverse {
+  traverseCSources :: cSources -> m cSources_
 , traverseJsSources :: jsSources -> m jsSources_
 }
 
-defaultTraverse :: Applicative m => Traverse m capture capture cSources cSources jsSources jsSources
-defaultTraverse = Traverse {
-  traverseCapture = pure
-, traverseCSources = pure
-, traverseJsSources = pure
-}
+type Traversal t = forall m cSources cSources_ jsSources jsSources_. Monad m
+  => Traverse m cSources cSources_ jsSources jsSources_
+  -> t cSources jsSources
+  -> m (t cSources_ jsSources_)
 
-type Traversal t = forall m capture capture_ cSources cSources_ jsSources jsSources_. (Monad m, Traversable capture_)
-  => Traverse m capture capture_ cSources cSources_ jsSources jsSources_
-  -> t capture cSources jsSources
-  -> m (t capture_ cSources_ jsSources_)
-
-type Traversal_ t = forall m capture capture_ cSources cSources_ jsSources jsSources_ a. (Monad m, Traversable capture_)
-  => Traverse m capture capture_ cSources cSources_ jsSources jsSources_
-  -> t capture cSources jsSources a
-  -> m (t capture_ cSources_ jsSources_ a)
+type Traversal_ t = forall m cSources cSources_ jsSources jsSources_ a. Monad m
+  => Traverse m cSources cSources_ jsSources jsSources_
+  -> t cSources jsSources a
+  -> m (t cSources_ jsSources_ a)
 
 traverseCommonOptions :: Traversal_ CommonOptions
 traverseCommonOptions t@Traverse{..} c@CommonOptions{..} = do
@@ -325,60 +297,33 @@ traverseCommonOptions t@Traverse{..} c@CommonOptions{..} = do
 
 traverseConditionalSection :: Traversal_ ConditionalSection
 traverseConditionalSection t@Traverse{..} = \ case
-  ThenElseConditional c -> ThenElseConditional <$> (traverseCapture c >>= traverse (bitraverse (traverseThenElse t) return))
-  FlatConditional c -> FlatConditional <$> (traverseCapture c >>= traverse (bitraverse (traverseWithCommonOptions t) return))
+  ThenElseConditional c -> ThenElseConditional <$> bitraverse (traverseThenElse t) return c
+  FlatConditional c -> FlatConditional <$> bitraverse (traverseWithCommonOptions t) return c
 
 traverseThenElse :: Traversal_ ThenElse
 traverseThenElse t@Traverse{..} c@ThenElse{..} = do
-  then_ <- traverseCapture thenElseThen >>= traverse (traverseWithCommonOptions t)
-  else_ <- traverseCapture thenElseElse >>= traverse (traverseWithCommonOptions t)
+  then_ <- traverseWithCommonOptions t thenElseThen
+  else_ <- traverseWithCommonOptions t thenElseElse
   return c{thenElseThen = then_, thenElseElse = else_}
 
 traverseWithCommonOptions :: Traversal_ WithCommonOptions
 traverseWithCommonOptions t = bitraverse (traverseCommonOptions t) return
 
-data Product a b = Product a b
-  deriving (Eq, Show, Functor, Foldable, Traversable)
+data ConditionalSection cSources jsSources a =
+    ThenElseConditional (Product (ThenElse cSources jsSources a) Condition)
+  | FlatConditional (Product (WithCommonOptions cSources jsSources a) Condition)
 
-instance (Monoid a, Monoid b) => Monoid (Product a b) where
-  mempty = Product mempty mempty
-  Product a1 b1 `mappend` Product a2 b2 = Product (a1 <> a2) (b1 <> b2)
-
-instance Bifunctor Product where
-  bimap fa fb (Product a b) = Product (fa a) (fb b)
-
-instance Bifoldable Product where
-  bifoldMap = bifoldMapDefault
-
-instance Bitraversable Product where
-  bitraverse fa fb (Product a b) = Product <$> fa a <*> fb b
-
-instance (FromJSON a, FromJSON b) => FromJSON (Product a b) where
-  parseJSON value = Product <$> parseJSON value <*> parseJSON value
-
-instance (HasFieldNames a, HasFieldNames b) => HasFieldNames (Product a b) where
-  fieldNames Proxy =
-       fieldNames (Proxy :: Proxy a)
-    ++ fieldNames (Proxy :: Proxy b)
-  ignoreUnderscoredUnknownFields Proxy =
-       ignoreUnderscoredUnknownFields (Proxy :: Proxy a)
-    || ignoreUnderscoredUnknownFields (Proxy :: Proxy b)
-
-data ConditionalSection capture cSources jsSources a =
-    ThenElseConditional (capture (Product (ThenElse capture cSources jsSources a) Condition))
-  | FlatConditional (capture (Product (WithCommonOptions capture cSources jsSources a) Condition))
-
-instance Functor capture => Functor (ConditionalSection capture cSources jsSources) where
+instance Functor (ConditionalSection cSources jsSources) where
   fmap f = \ case
-    ThenElseConditional c -> ThenElseConditional (first (fmap f) <$> c)
-    FlatConditional c -> FlatConditional (first (bimap (fmap f) f) <$> c)
+    ThenElseConditional c -> ThenElseConditional (first (fmap f) c)
+    FlatConditional c -> FlatConditional (first (bimap (fmap f) f) c)
 
-type ParseConditionalSection = ConditionalSection CaptureUnknownFields ParseCSources ParseJsSources
+type ParseConditionalSection = ConditionalSection ParseCSources ParseJsSources
 
-instance (FromJSON a, HasFieldNames a) => FromJSON (ParseConditionalSection a) where
-  parseJSON v
-    | hasKey "then" v || hasKey "else" v = ThenElseConditional <$> parseJSON v
-    | otherwise = FlatConditional <$> parseJSON v
+instance FromValue a => FromValue (ParseConditionalSection a) where
+  fromValue v
+    | hasKey "then" v || hasKey "else" v = ThenElseConditional <$> fromValue v
+    | otherwise = FlatConditional <$> fromValue v
 
 hasKey :: Text -> Value -> Bool
 hasKey key (Object o) = HashMap.member key o
@@ -386,39 +331,31 @@ hasKey _ _ = False
 
 newtype Condition = Condition {
   _conditionCondition :: Cond
-} deriving (Eq, Show, Generic)
-
-instance FromJSON Condition where
-  parseJSON = genericParseJSON
-
-instance HasFieldNames Condition
+} deriving (Eq, Show, Generic, FromValue)
 
 newtype Cond = Cond String
   deriving (Eq, Show)
 
-instance FromJSON Cond where
-  parseJSON v = case v of
-    String _ -> Cond <$> parseJSON v
+instance FromValue Cond where
+  fromValue v = case v of
+    String s -> return (Cond $ T.unpack s)
     Bool True -> return (Cond "true")
     Bool False -> return (Cond "false")
     _ -> typeMismatch "Boolean or String" v
 
-data ThenElse capture cSources jsSources a = ThenElse {
-  thenElseThen :: capture (WithCommonOptions capture cSources jsSources a)
-, thenElseElse :: capture (WithCommonOptions capture cSources jsSources a)
+data ThenElse cSources jsSources a = ThenElse {
+  thenElseThen :: WithCommonOptions cSources jsSources a
+, thenElseElse :: WithCommonOptions cSources jsSources a
 } deriving Generic
 
-instance Functor capture => Functor (ThenElse capture cSources jsSources) where
+instance Functor (ThenElse cSources jsSources) where
   fmap f c@ThenElse{..} = c{thenElseThen = map_ thenElseThen, thenElseElse = map_ thenElseElse}
     where
-      map_ = fmap (bimap (fmap f) f)
+      map_ = bimap (fmap f) f
 
-type ParseThenElse = ThenElse CaptureUnknownFields ParseCSources ParseJsSources
+type ParseThenElse = ThenElse ParseCSources ParseJsSources
 
-instance HasFieldNames (ParseThenElse a)
-
-instance (FromJSON a, HasFieldNames a) => FromJSON (ParseThenElse a) where
-  parseJSON = genericParseJSON
+instance FromValue a => FromValue (ParseThenElse a)
 
 data Empty = Empty
   deriving (Eq, Show)
@@ -427,51 +364,53 @@ instance Monoid Empty where
   mempty = Empty
   mappend Empty Empty = Empty
 
-instance FromJSON Empty where
-  parseJSON _ = return Empty
+instance FromValue Empty where
+  fromValue _ = return Empty
 
-instance HasFieldNames Empty where
-  fieldNames _ = []
-
--- From Cabal the library, copied here to avoid a dependency on Cabal.
-data BuildType
-  = Simple
+data BuildType =
+    Simple
   | Configure
   | Make
   | Custom
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show, Generic, Enum, Bounded)
 
-instance FromJSON BuildType where
-  parseJSON = withText "String" $ \case
-    "Simple"    -> return Simple
-    "Configure" -> return Configure
-    "Make"      -> return Make
-    "Custom"    -> return Custom
-    _           -> fail "build-type must be one of: Simple, Configure, Make, Custom"
+instance FromValue BuildType where
+  fromValue = withText $ \ (T.unpack -> t) -> do
+    maybe err return (lookup t options)
+    where
+      err = fail ("expected one of " ++ formatOrList buildTypesAsString)
+      buildTypes = [minBound .. maxBound]
+      buildTypesAsString = map show buildTypes
+      options = zip buildTypesAsString buildTypes
 
-type SectionConfigWithDefaluts capture cSources jsSources a = capture (Product (DefaultsConfig capture) (WithCommonOptions capture cSources jsSources a))
+formatOrList :: [String] -> String
+formatOrList xs = case reverse xs of
+  [] -> ""
+  x : [] -> x
+  y : x : [] -> x ++ " or " ++ y
+  x : ys@(_:_:_) -> intercalate ", " . reverse $ ("or " ++ x) : ys
 
-type PackageConfigWithDefaults capture cSources jsSources = PackageConfig_
-  (SectionConfigWithDefaluts capture cSources jsSources LibrarySection)
-  (SectionConfigWithDefaluts capture cSources jsSources ExecutableSection)
-  capture cSources jsSources
+type SectionConfigWithDefaluts cSources jsSources a = Product DefaultsConfig (WithCommonOptions cSources jsSources a)
 
-type SectionConfig capture cSources jsSources a = capture (WithCommonOptions capture cSources jsSources a)
+type PackageConfigWithDefaults cSources jsSources = PackageConfig_
+  (SectionConfigWithDefaluts cSources jsSources LibrarySection)
+  (SectionConfigWithDefaluts cSources jsSources ExecutableSection)
+  cSources jsSources
 
-type PackageConfig capture cSources jsSources = PackageConfig_
-  (SectionConfig capture cSources jsSources LibrarySection)
-  (SectionConfig capture cSources jsSources ExecutableSection)
-  capture cSources jsSources
+type PackageConfig cSources jsSources = PackageConfig_
+  (WithCommonOptions cSources jsSources LibrarySection)
+  (WithCommonOptions cSources jsSources ExecutableSection)
+  cSources jsSources
 
 data PackageVersion = PackageVersion {unPackageVersion :: String}
 
-instance FromJSON PackageVersion where
-  parseJSON v = case v of
-    Number n -> return (PackageVersion $ scientificToVersion n)
-    String _ -> PackageVersion <$> parseJSON v
+instance FromValue PackageVersion where
+  fromValue v = PackageVersion <$> case v of
+    Number n -> return (scientificToVersion n)
+    String s -> return (T.unpack s)
     _ -> typeMismatch "Number or String" v
 
-data PackageConfig_ library executable capture cSources jsSources = PackageConfig {
+data PackageConfig_ library executable cSources jsSources = PackageConfig {
   packageConfigName :: Maybe String
 , packageConfigVersion :: Maybe PackageVersion
 , packageConfigSynopsis :: Maybe String
@@ -487,13 +426,13 @@ data PackageConfig_ library executable capture cSources jsSources = PackageConfi
 , packageConfigLicense :: Maybe String
 , packageConfigLicenseFile :: Maybe (List String)
 , packageConfigTestedWith :: Maybe String
-, packageConfigFlags :: Maybe (Map String (capture FlagSection))
+, packageConfigFlags :: Maybe (Map String FlagSection)
 , packageConfigExtraSourceFiles :: Maybe (List FilePath)
 , packageConfigExtraDocFiles :: Maybe (List FilePath)
 , packageConfigDataFiles :: Maybe (List FilePath)
 , packageConfigGithub :: Maybe Text
 , packageConfigGit :: Maybe String
-, packageConfigCustomSetup :: Maybe (capture CustomSetupSection)
+, packageConfigCustomSetup :: Maybe CustomSetupSection
 , packageConfigLibrary :: Maybe library
 , packageConfigInternalLibraries :: Maybe (Map String library)
 , packageConfigExecutable :: Maybe executable
@@ -502,29 +441,20 @@ data PackageConfig_ library executable capture cSources jsSources = PackageConfi
 , packageConfigBenchmarks :: Maybe (Map String executable)
 } deriving Generic
 
-data DefaultsConfig capture = DefaultsConfig {
-  defaultsConfigDefaults :: Maybe (List (capture Defaults))
-} deriving Generic
-
-instance HasFieldNames (DefaultsConfig a)
-
-instance FromJSON (DefaultsConfig CaptureUnknownFields) where
-  parseJSON = genericParseJSON
+data DefaultsConfig = DefaultsConfig {
+  defaultsConfigDefaults :: Maybe (List Defaults)
+} deriving (Generic, FromValue)
 
 traversePackageConfig :: Traversal PackageConfig
 traversePackageConfig t@Traverse{..} p@PackageConfig{..} = do
-  flags <- traverse (traverse traverseCapture) packageConfigFlags
-  customSetup <- traverse traverseCapture packageConfigCustomSetup
-  library <- traverse (traverseSectionConfig t) packageConfigLibrary
+  library <- traverse (traverseWithCommonOptions t) packageConfigLibrary
   internalLibraries <- traverseNamedConfigs t packageConfigInternalLibraries
-  executable <- traverse (traverseSectionConfig t) packageConfigExecutable
+  executable <- traverse (traverseWithCommonOptions t) packageConfigExecutable
   executables <- traverseNamedConfigs t packageConfigExecutables
   tests <- traverseNamedConfigs t packageConfigTests
   benchmarks <- traverseNamedConfigs t packageConfigBenchmarks
   return p {
-      packageConfigFlags = flags
-    , packageConfigCustomSetup = customSetup
-    , packageConfigLibrary = library
+      packageConfigLibrary = library
     , packageConfigInternalLibraries = internalLibraries
     , packageConfigExecutable = executable
     , packageConfigExecutables = executables
@@ -532,45 +462,17 @@ traversePackageConfig t@Traverse{..} p@PackageConfig{..} = do
     , packageConfigBenchmarks = benchmarks
     }
   where
-    traverseNamedConfigs = traverse . traverse . traverseSectionConfig
+    traverseNamedConfigs = traverse . traverse . traverseWithCommonOptions
 
-traverseSectionConfig :: Traversal_ SectionConfig
-traverseSectionConfig t = traverseCapture t >=> traverse (traverseWithCommonOptions t)
+type ParsePackageConfig = PackageConfigWithDefaults ParseCSources ParseJsSources
 
-traverseSectionConfigWithDefaluts :: Traversal_ SectionConfigWithDefaluts
-traverseSectionConfigWithDefaluts t =
-  traverseCapture t >=> traverse (bitraverse (traverseDefaultsConfig t) (traverseWithCommonOptions t))
-
-type ParsePackageConfig = PackageConfigWithDefaults CaptureUnknownFields ParseCSources ParseJsSources
-
-instance HasFieldNames ParsePackageConfig where
-  ignoreUnderscoredUnknownFields _ = True
-
-instance FromJSON ParsePackageConfig where
-  parseJSON value = handleNullValues <$> genericParseJSON value
-    where
-      handleNullValues :: ParsePackageConfig -> ParsePackageConfig
-      handleNullValues =
-          ifNull "homepage" (\p -> p {packageConfigHomepage = Just Nothing})
-        . ifNull "bug-reports" (\p -> p {packageConfigBugReports = Just Nothing})
-
-      ifNull :: String -> (a -> a) -> a -> a
-      ifNull name f
-        | isNull name value = f
-        | otherwise = id
-
-isNull :: String -> Value -> Bool
-isNull name value = case parseMaybe p value of
-  Just Null -> True
-  _ -> False
-  where
-    p = parseJSON >=> (.: fromString name)
+instance FromValue ParsePackageConfig
 
 type Warnings m = WriterT [String] m
 type Errors = ExceptT String
 
-decodeYaml :: FromJSON a => FilePath -> Warnings (Errors IO) a
-decodeYaml file = lift . ExceptT $ (>>= parseValue file) <$> Yaml.decodeYaml file
+decodeYaml :: FromValue a => FilePath -> Warnings (Errors IO) a
+decodeYaml file = lift (ExceptT $ Yaml.decodeYaml file) >>= decodeValue file
 
 readPackageConfig :: FilePath -> FilePath -> IO (Either String (Package, [String]))
 readPackageConfig = readPackageConfigWith Yaml.decodeYaml
@@ -578,23 +480,18 @@ readPackageConfig = readPackageConfigWith Yaml.decodeYaml
 readPackageConfigWith :: (FilePath -> IO (Either String Value)) -> FilePath -> FilePath -> IO (Either String (Package, [String]))
 readPackageConfigWith readValue userDataDir file = runExceptT $ runWriterT $ do
   value <- lift . ExceptT $ readValue file
-  config <- lift . ExceptT . return $ parseValue file value
+  config <- decodeValue file value
   dir <- liftIO $ takeDirectory <$> canonicalizePath file
   toPackage userDataDir dir config
 
-parseValue :: FromJSON a => FilePath -> Value -> Either String a
-parseValue file value = case ifromJSON value of
-  IError path err -> Left (file ++ ": Error while parsing " ++ formatPath "$" path ++ " - " ++ sanitizeError err)
-  ISuccess a -> Right a
+decodeValue :: FromValue a => FilePath -> Value -> Warnings (Errors IO) a
+decodeValue file value = do
+  (a, unknown) <- lift . ExceptT . return $ first (prefix ++) (Config.decodeValue value)
+  tell (map formatUnknownField unknown)
+  return a
   where
-    formatPath acc [] = acc
-    formatPath acc (Index n : xs) = formatPath (acc ++ "[" ++ show n ++ "]") xs
-    formatPath acc (Key key : xs) = formatPath (acc ++ "." ++ T.unpack key) xs
-
-    sanitizeError = replace "record (:*:)" "Object"
-
-replace :: String -> String -> String -> String
-replace old new = T.unpack . T.replace (T.pack old) (T.pack new) . T.pack
+    prefix = file ++ ": "
+    formatUnknownField name = prefix ++ "Ignoring unrecognized field " ++ name
 
 data Package = Package {
   packageName :: String
@@ -680,12 +577,7 @@ data FlagSection = FlagSection {
   _flagSectionDescription :: Maybe String
 , _flagSectionManual :: Bool
 , _flagSectionDefault :: Bool
-} deriving (Eq, Show, Generic)
-
-instance HasFieldNames FlagSection
-
-instance FromJSON FlagSection where
-  parseJSON = genericParseJSON
+} deriving (Eq, Show, Generic, FromValue)
 
 data Flag = Flag {
   flagName :: String
@@ -702,57 +594,49 @@ data SourceRepository = SourceRepository {
 , sourceRepositorySubdir :: Maybe String
 } deriving (Eq, Show)
 
-type Config capture cSources jsSources =
-  Product (CommonOptions capture cSources jsSources Empty) (PackageConfig capture cSources jsSources)
+type Config cSources jsSources =
+  Product (CommonOptions cSources jsSources Empty) (PackageConfig cSources jsSources)
 
 traverseConfig :: Traversal Config
 traverseConfig t = bitraverse (traverseCommonOptions t) (traversePackageConfig t)
 
-type ConfigWithDefaults capture = Product
-  (CommonOptionsWithDefaults capture Empty)
-  (PackageConfigWithDefaults capture ParseCSources ParseJsSources)
+type ConfigWithDefaults = Product
+  (CommonOptionsWithDefaults Empty)
+  (PackageConfigWithDefaults ParseCSources ParseJsSources)
 
-type CommonOptionsWithDefaults capture a = Product
-  (DefaultsConfig capture)
-  (CommonOptions capture ParseCSources ParseJsSources a)
+type CommonOptionsWithDefaults a = Product DefaultsConfig (CommonOptions ParseCSources ParseJsSources a)
+type WithCommonOptionsWithDefaults a = Product DefaultsConfig (WithCommonOptions ParseCSources ParseJsSources a)
 
-type WithCommonOptionsWithDefaults capture a = Product
-  (DefaultsConfig capture)
-  (WithCommonOptions capture ParseCSources ParseJsSources a)
-
-type ParseConfig = CaptureUnknownFields (ConfigWithDefaults CaptureUnknownFields)
-
-toPackage :: FilePath -> FilePath -> ParseConfig -> Warnings (Errors IO) Package
+toPackage :: FilePath -> FilePath -> ConfigWithDefaults -> Warnings (Errors IO) Package
 toPackage userDataDir dir =
-      warnUnknownFieldsInConfig
-  >=> expandDefaultsInConfig userDataDir
+      expandDefaultsInConfig userDataDir
   >=> traverseConfig (expandForeignSources dir)
   >=> toPackage_ dir
 
 expandDefaultsInConfig
   :: FilePath
-  -> ConfigWithDefaults Identity
-  -> Warnings (Errors IO) (Config Identity ParseCSources ParseJsSources)
+  -> ConfigWithDefaults
+  -> Warnings (Errors IO) (Config ParseCSources ParseJsSources)
 expandDefaultsInConfig userDataDir = bitraverse (expandGlobalDefaults userDataDir) (expandSectionDefaults userDataDir)
 
 expandGlobalDefaults
   :: FilePath
-  -> CommonOptionsWithDefaults Identity Empty
-  -> Warnings (Errors IO) (CommonOptions Identity ParseCSources ParseJsSources Empty)
+  -> CommonOptionsWithDefaults Empty
+  -> Warnings (Errors IO) (CommonOptions ParseCSources ParseJsSources Empty)
 expandGlobalDefaults userDataDir = do
   fmap (`Product` Empty) >>> expandDefaults userDataDir >=> \ (Product c Empty) -> return c
 
 expandSectionDefaults
   :: FilePath
-  -> PackageConfigWithDefaults Identity ParseCSources ParseJsSources
-  -> Warnings (Errors IO) (PackageConfig Identity ParseCSources ParseJsSources)
+  -> PackageConfigWithDefaults ParseCSources ParseJsSources
+  -> Warnings (Errors IO) (PackageConfig ParseCSources ParseJsSources)
 expandSectionDefaults userDataDir p@PackageConfig{..} = do
-  library <- traverse (traverse (expandDefaults userDataDir)) packageConfigLibrary
-  internalLibraries <- traverse (traverse (traverse (expandDefaults userDataDir))) packageConfigInternalLibraries
-  executable <- traverse (traverse (expandDefaults userDataDir)) packageConfigExecutable
-  executables <- traverse (traverse (traverse (expandDefaults userDataDir))) packageConfigExecutables
-  tests <- traverse (traverse (traverse (expandDefaults userDataDir))) packageConfigTests
-  benchmarks <- traverse (traverse (traverse (expandDefaults userDataDir))) packageConfigBenchmarks
+  library <- traverse (expandDefaults userDataDir) packageConfigLibrary
+  internalLibraries <- traverse (traverse (expandDefaults userDataDir)) packageConfigInternalLibraries
+  executable <- traverse (expandDefaults userDataDir) packageConfigExecutable
+  executables <- traverse (traverse (expandDefaults userDataDir)) packageConfigExecutables
+  tests <- traverse (traverse (expandDefaults userDataDir)) packageConfigTests
+  benchmarks <- traverse (traverse (expandDefaults userDataDir)) packageConfigBenchmarks
   return p{
       packageConfigLibrary = library
     , packageConfigInternalLibraries = internalLibraries
@@ -763,28 +647,28 @@ expandSectionDefaults userDataDir p@PackageConfig{..} = do
     }
 
 expandDefaults
-  :: (HasFieldNames a, FromJSON a, Monoid a)
+  :: (FromValue a, Monoid a)
   => FilePath
-  -> WithCommonOptionsWithDefaults Identity a
-  -> Warnings (Errors IO) (WithCommonOptions Identity ParseCSources ParseJsSources a)
+  -> WithCommonOptionsWithDefaults a
+  -> Warnings (Errors IO) (WithCommonOptions ParseCSources ParseJsSources a)
 expandDefaults userDataDir = expand []
   where
-    expand :: (HasFieldNames a, FromJSON a, Monoid a) =>
+    expand :: (FromValue a, Monoid a) =>
          [FilePath]
-      -> WithCommonOptionsWithDefaults Identity a
-      -> Warnings (Errors IO) (WithCommonOptions Identity ParseCSources ParseJsSources a)
+      -> WithCommonOptionsWithDefaults a
+      -> Warnings (Errors IO) (WithCommonOptions ParseCSources ParseJsSources a)
     expand seen (Product DefaultsConfig{..} c) = do
-      d <- mconcat <$> mapM (get seen . runIdentity) (fromMaybeList defaultsConfigDefaults)
+      d <- mconcat <$> mapM (get seen) (fromMaybeList defaultsConfigDefaults)
       return (d <> c)
 
-    get :: (HasFieldNames a, FromJSON a, Monoid a) =>
+    get :: forall a. (FromValue a, Monoid a) =>
          [FilePath]
       -> Defaults
-      -> Warnings (Errors IO) (WithCommonOptions Identity ParseCSources ParseJsSources a)
+      -> Warnings (Errors IO) (WithCommonOptions ParseCSources ParseJsSources a)
     get seen defaults = do
       file <- lift $ ExceptT (ensure userDataDir defaults)
       seen_ <- lift (checkCycle seen file)
-      decodeYaml file >>= warnUnknownFieldsInDefaults file >>= expand seen_
+      decodeYaml file >>= expand seen_
 
     checkCycle :: [FilePath] -> FilePath -> Errors IO [FilePath]
     checkCycle seen file = do
@@ -803,9 +687,9 @@ toExecutableMap name executables mExecutable = do
       return $ Just (Map.fromList [(name, executable)])
     Nothing -> return executables
 
-type GlobalOptions = CommonOptions Identity CSources JsSources Empty
+type GlobalOptions = CommonOptions CSources JsSources Empty
 
-toPackage_ :: MonadIO m => FilePath -> Product GlobalOptions (PackageConfig Identity CSources JsSources) -> Warnings m Package
+toPackage_ :: MonadIO m => FilePath -> Product GlobalOptions (PackageConfig CSources JsSources) -> Warnings m Package
 toPackage_ dir (Product globalOptions PackageConfig{..}) = do
   mLibrary <- liftIO $ traverse (toLibrary dir packageName_ globalOptions) packageConfigLibrary
 
@@ -880,9 +764,9 @@ toPackage_ dir (Product globalOptions PackageConfig{..}) = do
       Just n -> ([], n)
 
     mCustomSetup :: Maybe CustomSetup
-    mCustomSetup = toCustomSetup . runIdentity <$> packageConfigCustomSetup
+    mCustomSetup = toCustomSetup <$> packageConfigCustomSetup
 
-    flags = map (toFlag . fmap runIdentity) $ toList packageConfigFlags
+    flags = map toFlag $ toList packageConfigFlags
 
     toList :: Maybe (Map String a) -> [(String, a)]
     toList = Map.toList . fromMaybe mempty
@@ -917,80 +801,11 @@ toPackage_ dir (Product globalOptions PackageConfig{..}) = do
       where
         fromGithub = (++ "/issues") . sourceRepositoryUrl <$> github
 
-sequenceUnknownFields :: Applicative capture => Traverse capture capture Identity cSources cSources jsSources jsSources
-sequenceUnknownFields = defaultTraverse{traverseCapture = fmap Identity}
-
-warnUnknownFieldsInDefaults
-  :: Monad m
-  => String
-  -> CaptureUnknownFields (WithCommonOptionsWithDefaults CaptureUnknownFields a)
-  -> Warnings m (WithCommonOptionsWithDefaults Identity a)
-warnUnknownFieldsInDefaults name =
-  (warnUnknownFields In name . (>>= bitraverse sequenceDefaults (traverseWithCommonOptions sequenceUnknownFields)))
-
-traverseDefaultsConfig
-  :: Applicative m
-  => Traverse m capture capture_ cSources cSources_ jsSources jsSources_
-  -> DefaultsConfig capture -> m (DefaultsConfig capture_)
-traverseDefaultsConfig Traverse{..} (DefaultsConfig defaults) = do
-  DefaultsConfig <$> traverse (traverse $ traverseCapture) defaults
-
-sequenceDefaults :: Applicative capture => DefaultsConfig capture -> capture (DefaultsConfig Identity)
-sequenceDefaults = traverseDefaultsConfig sequenceUnknownFields
-
-warnUnknownFieldsInConfig :: forall m. Monad m => ParseConfig -> Warnings m (ConfigWithDefaults Identity)
-warnUnknownFieldsInConfig =
-      warnGlobal
-  >=> bitraverse (bitraverse warnDefaults return) return
-  >=> traverse warnSections
-  where
-    t = sequenceUnknownFields
-
-    warnGlobal c = warnUnknownFields In "package description" (c >>= bitraverse (traverse (traverseCommonOptions t)) return)
-
-    warnDefaults :: DefaultsConfig CaptureUnknownFields -> Warnings m (DefaultsConfig Identity)
-    warnDefaults = warnUnknownFields In "defaults section" . sequenceDefaults
-
-    warnSections :: ParsePackageConfig -> Warnings m (PackageConfigWithDefaults Identity ParseCSources ParseJsSources)
-    warnSections p@PackageConfig{..} = do
-      flags <- traverse (warnNamed For "flag" . fmap (traverseCapture t)) packageConfigFlags
-      customSetup <- warnUnknownFields In "custom-setup section" (traverse (traverseCapture t) packageConfigCustomSetup)
-      library <- warnUnknownFields In "library section" (traverse (traverseSectionConfigWithDefaluts t) packageConfigLibrary)
-      internalLibraries <- warnNamedSection "internal-libraries" packageConfigInternalLibraries
-      executable <- warnUnknownFields In "executable section" (traverse (traverseSectionConfigWithDefaluts t) packageConfigExecutable)
-      executables <- warnNamedSection "executable" packageConfigExecutables
-      tests <- warnNamedSection "test" packageConfigTests
-      benchmarks <- warnNamedSection "benchmark" packageConfigBenchmarks
-      return p {
-          packageConfigFlags = flags
-        , packageConfigCustomSetup = customSetup
-        , packageConfigLibrary = library
-        , packageConfigInternalLibraries = internalLibraries
-        , packageConfigExecutable = executable
-        , packageConfigExecutables = executables
-        , packageConfigTests = tests
-        , packageConfigBenchmarks = benchmarks
-        }
-
-    warnNamedSection
-      :: String
-      -> Maybe (Map String (SectionConfigWithDefaluts CaptureUnknownFields cSources jsSources a))
-      -> Warnings m (Maybe (Map String (SectionConfigWithDefaluts Identity cSources jsSources a)))
-    warnNamedSection sectionType = traverse (warnNamed In (sectionType ++ " section") . fmap (traverseSectionConfigWithDefaluts t))
-
-    warnNamed :: Preposition -> String -> Map String (CaptureUnknownFields a) -> Warnings m (Map String a)
-    warnNamed preposition sect = fmap Map.fromList . mapM f . Map.toList
-      where
-        f (name, fields) = (,) name <$> (warnUnknownFields preposition (sect ++ " " ++ show name) fields)
-
-warnUnknownFields :: forall m a. Monad m => Preposition -> String -> CaptureUnknownFields a -> Warnings m a
-warnUnknownFields preposition name = fmap snd . bitraverse tell return . formatUnknownFields preposition name
-
 expandForeignSources
   :: MonadIO m
   => FilePath
-  -> Traverse (Warnings m) capture capture ParseCSources CSources ParseJsSources JsSources
-expandForeignSources dir = defaultTraverse {
+  -> Traverse (Warnings m) ParseCSources CSources ParseJsSources JsSources
+expandForeignSources dir = Traverse {
     traverseCSources = expand "c-sources"
   , traverseJsSources = expand "js-sources"
   }
@@ -1051,10 +866,10 @@ inferModules dir packageName_ getMentionedModules getInferredModules fromData fr
         r = fromConfig pathsModule inferableModules conf
       return (outerModules ++ getInferredModules r, r)
 
-toLibrary :: FilePath -> String -> GlobalOptions -> SectionConfig Identity CSources JsSources LibrarySection -> IO (Section Library)
+toLibrary :: FilePath -> String -> GlobalOptions -> WithCommonOptions CSources JsSources LibrarySection -> IO (Section Library)
 toLibrary dir name globalOptions =
     inferModules dir name getMentionedLibraryModules getLibraryModules fromLibrarySectionTopLevel fromLibrarySectionInConditional
-  . toSectionI (mempty <$ globalOptions)
+  . toSection (mempty <$ globalOptions)
   where
     getLibraryModules :: Library -> [String]
     getLibraryModules Library{..} = libraryExposedModules ++ libraryOtherModules
@@ -1093,21 +908,21 @@ fromLibrarySectionPlain LibrarySection{..} = Library {
   , librarySignatures = fromMaybeList librarySectionSignatures
   }
 
-toInternalLibraries :: FilePath -> String -> GlobalOptions -> Maybe (Map String (SectionConfig Identity CSources JsSources LibrarySection)) -> IO (Map String (Section Library))
+toInternalLibraries :: FilePath -> String -> GlobalOptions -> Maybe (Map String (WithCommonOptions CSources JsSources LibrarySection)) -> IO (Map String (Section Library))
 toInternalLibraries dir packageName_ globalOptions = traverse (toLibrary dir packageName_ globalOptions) . fromMaybe mempty
 
-toExecutables :: FilePath -> String -> GlobalOptions -> Maybe (Map String (SectionConfig Identity CSources JsSources ExecutableSection)) -> IO (Map String (Section Executable))
+toExecutables :: FilePath -> String -> GlobalOptions -> Maybe (Map String (WithCommonOptions CSources JsSources ExecutableSection)) -> IO (Map String (Section Executable))
 toExecutables dir packageName_ globalOptions = traverse (toExecutable dir packageName_ globalOptions) . fromMaybe mempty
 
 getMentionedExecutableModules :: ExecutableSection -> [String]
 getMentionedExecutableModules (ExecutableSection main otherModules generatedModules)=
   maybe id (:) (main >>= toModule . splitDirectories) $ fromMaybeList (otherModules <> generatedModules)
 
-toExecutable :: FilePath -> String -> GlobalOptions -> SectionConfig Identity CSources JsSources ExecutableSection -> IO (Section Executable)
+toExecutable :: FilePath -> String -> GlobalOptions -> WithCommonOptions CSources JsSources ExecutableSection -> IO (Section Executable)
 toExecutable dir packageName_ globalOptions =
     inferModules dir packageName_ getMentionedExecutableModules executableOtherModules fromExecutableSection (fromExecutableSection [])
   . expandMain
-  . toSectionI (mempty <$ globalOptions)
+  . toSection (mempty <$ globalOptions)
   where
     fromExecutableSection :: [String] -> [String] -> ExecutableSection -> Executable
     fromExecutableSection pathsModule inferableModules ExecutableSection{..} =
@@ -1135,13 +950,10 @@ expandMain = flatten . expand
       , sectionConditionals = map (fmap flatten) sectionConditionals
       }
 
-toSectionI :: CommonOptions Identity CSources JsSources a -> Identity (WithCommonOptions Identity CSources JsSources a) -> Section a
-toSectionI globalOptions = toSection globalOptions . runIdentity
-
-toSection :: CommonOptions Identity CSources JsSources a -> WithCommonOptions Identity CSources JsSources a -> Section a
+toSection :: CommonOptions CSources JsSources a -> WithCommonOptions CSources JsSources a -> Section a
 toSection globalOptions (Product options a) = toSection_ (Product (globalOptions <> options) a)
 
-toSection_ :: WithCommonOptions Identity CSources JsSources a -> Section a
+toSection_ :: WithCommonOptions CSources JsSources a -> Section a
 toSection_ (Product CommonOptions{..} a) = Section {
         sectionData = a
       , sectionSourceDirs = fromMaybeList commonOptionsSourceDirs
@@ -1168,15 +980,12 @@ toSection_ (Product CommonOptions{..} a) = Section {
       , sectionBuildTools = fromMaybe mempty commonOptionsBuildTools
       }
   where
-    toSectionI_ :: Identity (WithCommonOptions Identity CSources JsSources a) -> Section a
-    toSectionI_ = toSection_ . runIdentity
-
     conditionals = map toConditional (fromMaybeList commonOptionsWhen)
 
-    toConditional :: ConditionalSection Identity CSources JsSources a -> Conditional (Section a)
+    toConditional :: ConditionalSection CSources JsSources a -> Conditional (Section a)
     toConditional x = case x of
-      FlatConditional (Identity (Product sect c)) -> conditional c (toSection_ sect) Nothing
-      ThenElseConditional (Identity (Product (ThenElse then_ else_) c)) -> conditional c (toSectionI_ then_) (Just $ toSectionI_ else_)
+      ThenElseConditional (Product (ThenElse then_ else_) c) -> conditional c (toSection_ then_) (Just $ toSection_ else_)
+      FlatConditional (Product sect c) -> conditional c (toSection_ sect) Nothing
       where
         conditional (Condition (Cond c)) = Conditional c
 

src/Hpack/Defaults.hs

@@ -21,7 +21,7 @@ import qualified Data.ByteString.Char8 as B
 import           System.FilePath
 import           System.Directory
 
-import           Hpack.Syntax
+import           Hpack.Syntax.Defaults
 
 type URL = String
 

src/Hpack/Dependency.hs

@@ -22,10 +22,11 @@ import qualified Distribution.Version as D
 import           Data.Map.Lazy (Map)
 import qualified Data.Map.Lazy as Map
 import           Data.Scientific
-import           Data.Aeson.Types
 import           Control.Applicative
 import           GHC.Exts
 
+import           Data.Aeson.Config.FromValue
+
 githubBaseUrl :: String
 githubBaseUrl = "https://github.com/"
 
@@ -50,11 +51,11 @@ data SourceDependency = GitRef GitUrl GitRef (Maybe FilePath) | Local FilePath
 type GitUrl = String
 type GitRef = String
 
-instance FromJSON Dependencies where
-  parseJSON v = case v of
-    String _ -> dependenciesFromList . return <$> parseJSON v
-    Array _ -> dependenciesFromList <$> parseJSON v
-    Object _ -> Dependencies <$> parseJSON v
+instance FromValue Dependencies where
+  fromValue v = case v of
+    String _ -> dependenciesFromList . return <$> fromValue v
+    Array _ -> dependenciesFromList <$> fromValue v
+    Object _ -> Dependencies <$> fromValue v
     _ -> typeMismatch "Array, Object, or String" v
     where
       fromDependency :: Dependency -> (String, DependencyVersion)
@@ -63,10 +64,11 @@ instance FromJSON Dependencies where
       dependenciesFromList :: [Dependency] -> Dependencies
       dependenciesFromList = Dependencies . Map.fromList . map fromDependency
 
-instance FromJSON DependencyVersion where
-  parseJSON v = case v of
+
+instance FromValue DependencyVersion where
+  fromValue v = case v of
     Null -> return AnyVersion
-    Object _ -> SourceDependency <$> parseJSON v
+    Object _ -> SourceDependency <$> fromValue v
     Number n -> return (scientificToDependencyVersion n)
     String s -> parseVersionRange ("== " ++ input) <|> parseVersionRange input
       where
@@ -88,8 +90,8 @@ scientificToVersion n = version
       | otherwise = 0
     e = base10Exponent n
 
-instance FromJSON SourceDependency where
-  parseJSON = withObject "SourceDependency" (\o -> let
+instance FromValue SourceDependency where
+  fromValue = withObject (\o -> let
     local :: Parser SourceDependency
     local = Local <$> o .: "path"
 
@@ -115,15 +117,13 @@ data Dependency = Dependency {
 , _dependencyVersion :: DependencyVersion
 } deriving (Eq, Show)
 
-instance FromJSON Dependency where
-  parseJSON v = case v of
-    String _ -> do
-      (name, versionRange) <- parseJSON v >>= parseDependency
-      return (Dependency name versionRange)
+instance FromValue Dependency where
+  fromValue v = case v of
+    String s -> uncurry Dependency <$> parseDependency (T.unpack s)
     Object o -> addSourceDependency o
     _ -> typeMismatch "Object or String" v
     where
-      addSourceDependency o = Dependency <$> name <*> (SourceDependency <$> parseJSON v)
+      addSourceDependency o = Dependency <$> name <*> (SourceDependency <$> fromValue v)
         where
           name :: Parser String
           name = o .: "name"

src/Hpack/Syntax/Defaults.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE RecordWildCards #-}
-module Hpack.Syntax (
+module Hpack.Syntax.Defaults (
   Defaults(..)
 #ifdef TEST
 , isValidUser
@@ -10,31 +11,25 @@ module Hpack.Syntax (
 ) where
 
 import           Data.List
-import           Data.Data
+import qualified Data.Text as T
 import           System.FilePath.Posix (splitDirectories)
 
-import           Hpack.Syntax.Util
-import           Hpack.Syntax.UnknownFields
+import           Data.Aeson.Config.FromValue
 import           Hpack.Syntax.Git
 
 data ParseDefaults = ParseDefaults {
   parseDefaultsGithub :: Github
 , parseDefaultsRef :: Ref
 , parseDefaultsPath :: Maybe Path
-} deriving Generic
-
-instance HasFieldNames ParseDefaults
-
-instance FromJSON ParseDefaults where
-  parseJSON = genericParseJSON
+} deriving (Generic, FromValue)
 
 data Github = Github {
   githubUser :: String
 , githubRepo :: String
 }
 
-instance FromJSON Github where
-  parseJSON v = parseJSON v >>= parseGithub
+instance FromValue Github where
+  fromValue = withString parseGithub
 
 parseGithub :: String -> Parser Github
 parseGithub github
@@ -70,8 +65,8 @@ alphaNum = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']
 
 data Ref = Ref {unRef :: String}
 
-instance FromJSON Ref where
-  parseJSON v = parseJSON v >>= parseRef
+instance FromValue Ref where
+  fromValue = withString parseRef
 
 parseRef :: String -> Parser Ref
 parseRef ref
@@ -80,8 +75,8 @@ parseRef ref
 
 data Path = Path {unPath :: [FilePath]}
 
-instance FromJSON Path where
-  parseJSON v = parseJSON v >>= parsePath
+instance FromValue Path where
+  fromValue = withString parsePath
     where
       parsePath path
         | '\\' `elem` path = fail ("rejecting '\\' in " ++ show path ++ ", please use '/' to separate path components")
@@ -99,10 +94,10 @@ data Defaults = Defaults {
 , defaultsPath :: [FilePath]
 } deriving (Eq, Show)
 
-instance FromJSON Defaults where
-  parseJSON v = toDefaults <$> case v of
-    String _ -> parseJSON v >>= parseDefaultsFromString
-    Object _ -> parseJSON v
+instance FromValue Defaults where
+  fromValue v = toDefaults <$> case v of
+    String s -> parseDefaultsFromString (T.unpack s)
+    Object _ -> fromValue v
     _ -> typeMismatch "Object or String" v
     where
       toDefaults :: ParseDefaults -> Defaults
@@ -117,6 +112,3 @@ parseDefaultsFromString :: String -> Parser ParseDefaults
 parseDefaultsFromString xs = case break (== '@') xs of
   (github, '@' : ref) -> ParseDefaults <$> parseGithub github <*> parseRef ref <*> pure Nothing
   _ -> fail ("missing Git reference for " ++ show xs ++ ", the expected format is user/repo@ref")
-
-instance HasFieldNames Defaults where
-  fieldNames Proxy = fieldNames (Proxy :: Proxy ParseDefaults)

src/Hpack/Syntax/GenericsUtil.hs

@@ -1,45 +0,0 @@
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ConstraintKinds #-}
-module Hpack.Syntax.GenericsUtil (
-  HasTypeName
-, typeName
-, Selectors
-, selectors
-) where
-
-import           Data.Proxy
-import           GHC.Generics
-
-type HasTypeName a d m = (Datatype d, Generic a, Rep a ~ M1 D d m)
-
-typeName :: forall a d m. (Datatype d, Generic a, Rep a ~ M1 D d m) => Proxy a -> String
-typeName _ = datatypeName (undefined :: M1 D d x y)
-
-selectors :: (Selectors (Rep a)) => Proxy a -> [String]
-selectors = f
-  where
-    f :: forall a. (Selectors (Rep a)) => Proxy a -> [String]
-    f _ = selNames (Proxy :: Proxy (Rep a))
-
-class Selectors a where
-  selNames :: Proxy a -> [String]
-
-instance Selectors f => Selectors (M1 D x f) where
-  selNames _ = selNames (Proxy :: Proxy f)
-
-instance Selectors f => Selectors (M1 C x f) where
-  selNames _ = selNames (Proxy :: Proxy f)
-
-instance Selector s => Selectors (M1 S s (K1 R t)) where
-  selNames _ = [selName (undefined :: M1 S s (K1 R t) ())]
-
-instance (Selectors a, Selectors b) => Selectors (a :*: b) where
-  selNames _ = selNames (Proxy :: Proxy a) ++ selNames (Proxy :: Proxy b)
-
-instance Selectors U1 where
-  selNames _ = []

src/Hpack/Syntax/UnknownFields.hs

@@ -1,83 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
-module Hpack.Syntax.UnknownFields (
-  FieldName
-, HasFieldNames(..)
-, hyphenize
-
-, CaptureUnknownFields
-, Preposition(..)
-, formatUnknownFields
-) where
-
-import           Control.Monad
-import           Data.Data
-import qualified Data.HashMap.Lazy as HashMap
-import           Data.List
-import qualified Data.Text as T
-import           GHC.Generics
-
-import           Hpack.Syntax.GenericsUtil
-import           Hpack.Syntax.Util
-
-newtype FieldName = FieldName {unFieldName :: String}
-
-class HasFieldNames a where
-  fieldNames :: Proxy a -> [FieldName]
-
-  default fieldNames :: (HasTypeName a d m, Selectors (Rep a)) => Proxy a -> [FieldName]
-  fieldNames proxy = map (FieldName . hyphenize (typeName proxy)) (selectors proxy)
-
-  ignoreUnderscoredUnknownFields :: Proxy a -> Bool
-  ignoreUnderscoredUnknownFields _ = False
-
-data CaptureUnknownFields a = CaptureUnknownFields [FieldName] a
-  deriving Functor
-
-instance Applicative CaptureUnknownFields where
-  pure = return
-  (<*>) = ap
-
-instance Monad CaptureUnknownFields where
-  return = CaptureUnknownFields mempty
-  (CaptureUnknownFields xs x) >>= f = CaptureUnknownFields (xs `mappend` ys) y
-    where
-      CaptureUnknownFields ys y = f x
-
-captureUnknownFields :: forall a. (HasFieldNames a, FromJSON a) => Value -> Parser (CaptureUnknownFields a)
-captureUnknownFields v = CaptureUnknownFields unknown <$> parseJSON v
-  where
-    unknown = getUnknownFields v (Proxy :: Proxy a)
-
-instance (HasFieldNames a, FromJSON a) => FromJSON (CaptureUnknownFields a) where
-  parseJSON = captureUnknownFields
-
-getUnknownFields :: forall a. HasFieldNames a => Value -> Proxy a -> [FieldName]
-getUnknownFields v _ = case v of
-  Object o -> map FieldName (ignoreUnderscored unknown)
-    where
-      unknown = keys \\ fields
-      keys = map T.unpack (HashMap.keys o)
-      fields = map unFieldName $ fieldNames (Proxy :: Proxy a)
-      ignoreUnderscored
-        | ignoreUnderscoredUnknownFields (Proxy :: Proxy a) = filter (not . isPrefixOf "_")
-        | otherwise = id
-  _ -> []
-
-data Preposition = In | For
-
-formatUnknownFields :: Preposition -> String -> CaptureUnknownFields a -> ([String], a)
-formatUnknownFields p name (CaptureUnknownFields unknownFields a) = (formatUnknownFields_ preposition name unknownFields, a)
-  where
-    preposition = case p of
-      In -> "in"
-      For -> "for"
-
-formatUnknownFields_ :: String -> String -> [FieldName] -> [String]
-formatUnknownFields_ preposition name = map f
-  where
-    f (FieldName field) = "Ignoring unknown field " ++ show field ++ " " ++ preposition ++ " " ++ name

src/Hpack/Syntax/Util.hs

@@ -1,26 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-module Hpack.Syntax.Util (
-  Generic
-, genericParseJSON
-, hyphenize
-, module Data.Aeson.Types
-) where
-
-import qualified Data.Aeson.Types as Aeson
-import           Data.Aeson.Types hiding (genericParseJSON)
-import           Data.Data
-import           GHC.Generics
-
-import           Hpack.Syntax.GenericsUtil
-
-genericParseJSON :: forall a d m. (GFromJSON Zero (Rep a), HasTypeName a d m) => Value -> Parser a
-genericParseJSON = Aeson.genericParseJSON defaultOptions {fieldLabelModifier = hyphenize name}
-  where
-    name :: String
-    name = typeName (Proxy :: Proxy a)
-
-hyphenize :: String -> String -> String
-hyphenize name =
-  camelTo2 '-' . drop (length (dropWhile (== '_') $ reverse name)) . dropWhile (== '_')

src/Hpack/Util.hs

@@ -1,12 +1,6 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Hpack.Util (
-  List(..)
-, fromMaybeList
-, GhcOption
+  GhcOption
 , GhcProfOption
 , GhcjsOption
 , CppOption
@@ -25,7 +19,6 @@ module Hpack.Util (
 
 import           Control.Exception
 import           Control.Monad
-import           Data.Aeson.Types
 import           Data.Char
 import           Data.List hiding (sort)
 import           Data.Ord
@@ -45,17 +38,6 @@ sort = sortBy (comparing lexicographically)
 lexicographically :: String -> (String, String)
 lexicographically x = (map toLower x, x)
 
-newtype List a = List {fromList :: [a]}
-  deriving (Eq, Show, Functor, Foldable, Traversable, Monoid)
-
-instance FromJSON a => FromJSON (List a) where
-  parseJSON v = List <$> case v of
-    Array _ -> parseJSON v
-    _ -> return <$> parseJSON v
-
-fromMaybeList :: Maybe (List a) -> [a]
-fromMaybeList = maybe [] fromList
-
 type GhcOption = String
 type GhcProfOption = String
 type GhcjsOption = String

stack.yaml

@@ -1 +1 @@
-resolver: nightly-2017-09-25
+resolver: nightly-2018-01-29

test/Data/Aeson/Config/FromValueSpec.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstraintKinds #-}
+module Data.Aeson.Config.FromValueSpec where
+
+import           Helper
+
+import           GHC.Generics
+import qualified Data.Map.Lazy as Map
+
+import           Data.Aeson.Config.FromValue
+
+shouldDecodeTo :: (HasCallStack, Eq a, Show a, FromValue a) => Value -> DecodeResult a -> Expectation
+shouldDecodeTo value expected = decodeValue value `shouldBe` expected
+
+shouldDecodeTo_ :: (HasCallStack, Eq a, Show a, FromValue a) => Value -> a -> Expectation
+shouldDecodeTo_ value expected = decodeValue value `shouldBe` Right (expected, [])
+
+data Person = Person {
+  personName :: String
+, personAge :: Int
+, personAddress :: Maybe Address
+} deriving (Eq, Show, Generic, FromValue)
+
+data Address = Address {
+  addressRegion :: String
+, addressZip :: String
+} deriving (Eq, Show, Generic, FromValue)
+
+data Job = Job {
+  jobRole :: String
+, jobSalary :: Int
+} deriving (Eq, Show, Generic, FromValue)
+
+spec :: Spec
+spec = do
+  describe "fromValue" $ do
+    context "with a record" $ do
+      let
+        left :: String -> DecodeResult Person
+        left = Left
+      it "decodes a record" $ do
+        [yaml|
+        name: "Joe"
+        age: 23
+        |] `shouldDecodeTo_` Person "Joe" 23 Nothing
+
+      it "captures unrecognized fields" $ do
+        [yaml|
+        name: "Joe"
+        age: 23
+        foo: bar
+        |] `shouldDecodeTo` Right (Person "Joe" 23 Nothing, ["$.foo"])
+
+      it "captures nested unrecognized fields" $ do
+        [yaml|
+        name: "Joe"
+        age: 23
+        address:
+          region: somewhere
+          zip: "123456"
+          foo:
+            bar: 23
+        |] `shouldDecodeTo` Right (Person "Joe" 23 (Just (Address "somewhere" "123456")), ["$.address.foo"])
+
+      it "fails on missing field" $ do
+        [yaml|
+        name: "Joe"
+        |] `shouldDecodeTo` left "Error while parsing $ - key \"age\" not present"
+
+      it "fails on invalid field value" $ do
+        [yaml|
+        name: "Joe"
+        age: "23"
+        |] `shouldDecodeTo` left "Error while parsing $.age - expected Int, encountered String"
+
+    context "with (,)" $ do
+      it "captures unrecognized fields" $ do
+        [yaml|
+        name: Joe
+        age: 23
+        role: engineer
+        salary: 100000
+        foo: bar
+        |] `shouldDecodeTo` Right ((Person "Joe" 23 Nothing, Job "engineer" 100000), ["$.foo"])
+
+    context "with []" $ do
+      it "captures unrecognized fields" $ do
+        let
+          expected = [Person "Joe" 23 (Just (Address "somewhere" "123456")), Person "Marry" 25 Nothing]
+        [yaml|
+        - name: "Joe"
+          age: 23
+          address:
+            region: somewhere
+            zip: "123456"
+            foo: 23
+        - name: "Marry"
+          age: 25
+          bar: 42
+        |] `shouldDecodeTo` Right (expected, ["$[1].bar", "$[0].address.foo"])
+
+    context "with Map" $ do
+      it "captures unrecognized fields" $ do
+        [yaml|
+        Joe:
+          region: somewhere
+          zip: '123456'
+          foo: bar
+        |] `shouldDecodeTo` Right (Map.fromList [("Joe", Address "somewhere" "123456")], ["$.Joe.foo"])

test/Data/Aeson/Config/TypesSpec.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Data.Aeson.Config.TypesSpec (spec) where
+
+import           Helper
+import           Data.Aeson.Config.FromValueSpec (shouldDecodeTo, shouldDecodeTo_)
+
+import           Data.Aeson.Config.FromValue
+import           Data.Aeson.Config.Types
+
+spec :: Spec
+spec = do
+  describe "fromValue" $ do
+    context "List" $ do
+      let
+        parseError :: String -> DecodeResult (List Int)
+        parseError prefix = Left (prefix ++ " - expected Int, encountered String")
+
+      context "when parsing single values" $ do
+        it "returns the value in a singleton list" $ do
+          [yaml|23|] `shouldDecodeTo_` (List [23 :: Int])
+
+        it "returns error messages from element parsing" $ do
+          [yaml|foo|] `shouldDecodeTo` parseError "Error while parsing $"
+
+      context "when parsing a list of values" $ do
+        it "returns the list" $ do
+          [yaml|
+          - 23
+          - 42
+          |] `shouldDecodeTo_` List [23, 42 :: Int]
+
+        it "propagates parse error messages of invalid elements" $ do
+          [yaml|
+          - 23
+          - foo
+          |] `shouldDecodeTo` parseError "Error while parsing $[1]"

test/Data/Aeson/Config/UtilSpec.hs

@@ -1,8 +1,8 @@
-module Hpack.Syntax.UtilSpec (spec) where
+module Data.Aeson.Config.UtilSpec (spec) where
 
 import           Test.Hspec
 
-import           Hpack.Syntax.Util
+import           Data.Aeson.Config.Util
 
 spec :: Spec
 spec = do

test/EndToEndSpec.hs

@@ -9,9 +9,9 @@ import           Prelude hiding (writeFile)
 import qualified Prelude
 
 import           Helper
+import           Test.HUnit
 
 import           System.Directory (canonicalizePath)
-import           Control.Exception
 import           Data.Maybe
 import           Data.List
 import           Data.String.Interpolate
@@ -218,16 +218,15 @@ spec = around_ (inTempDirectoryNamed "foo") $ do
         name: foo
         library: {}
         |] `shouldWarn` [
-            "Ignoring unknown field \"bar\" in defaults section"
-          , "Ignoring unknown field \"foo\" in " ++ file
+            "package.yaml: Ignoring unrecognized field $.defaults.bar"
+          , file ++ ": Ignoring unrecognized field $.foo"
           ]
 
     describe "version" $ do
       it "accepts string" $ do
         [i|
         version: 0.1.0
-        |] `shouldRenderTo` (package [i|
-        |]) {packageVersion = "0.1.0"}
+        |] `shouldRenderTo` (package "") {packageVersion = "0.1.0"}
 
       it "accepts number" $ do
         [i|
@@ -240,6 +239,33 @@ spec = around_ (inTempDirectoryNamed "foo") $ do
         version: {}
         |] `shouldFailWith` "package.yaml: Error while parsing $.version - expected Number or String, encountered Object"
 
+    describe "build-type" $ do
+      it "accept Simple" $ do
+        [i|
+        build-type: Simple
+        |] `shouldRenderTo` (package "") {packageBuildType = "Simple"}
+
+      it "accept Configure" $ do
+        [i|
+        build-type: Configure
+        |] `shouldRenderTo` (package "") {packageBuildType = "Configure"}
+
+      it "accept Make" $ do
+        [i|
+        build-type: Make
+        |] `shouldRenderTo` (package "") {packageBuildType = "Make"}
+
+      it "accept Custom" $ do
+        [i|
+        build-type: Custom
+        |] `shouldRenderTo` (package "") {packageBuildType = "Custom"}
+
+      it "rejects invalid values" $ do
+        [i|
+        build-type: foo
+        |] `shouldFailWith` "package.yaml: Error while parsing $.build-type - expected one of Simple, Configure, Make, or Custom"
+
+
     describe "extra-doc-files" $ do
       it "accepts a list of files" $ do
         touch "CHANGES.markdown"
@@ -509,8 +535,8 @@ spec = around_ (inTempDirectoryNamed "foo") $ do
           foo: 1
           bar: 2
         |] `shouldWarn` [
-            "Ignoring unknown field \"bar\" in custom-setup section"
-          , "Ignoring unknown field \"foo\" in custom-setup section"
+            "package.yaml: Ignoring unrecognized field $.custom-setup.bar"
+          , "package.yaml: Ignoring unrecognized field $.custom-setup.foo"
           ]
 
       it "accepts dependencies" $ do
@@ -790,7 +816,7 @@ spec = around_ (inTempDirectoryNamed "foo") $ do
         internal-libraries:
           bar:
             baz: 42
-        |] `shouldWarn` pure "Ignoring unknown field \"baz\" in internal-libraries section \"bar\""
+        |] `shouldWarn` pure "package.yaml: Ignoring unrecognized field $.internal-libraries.bar.baz"
 
       it "warns on missing source-dirs" $ do
         [i|
@@ -972,10 +998,10 @@ spec = around_ (inTempDirectoryNamed "foo") $ do
           - condition: os(windows)
             baz: 23
         |] `shouldWarn` [
-            "Ignoring unknown field \"foo\" in package description"
-          , "Ignoring unknown field \"bar\" in package description"
-          , "Ignoring unknown field \"bar2\" in package description"
-          , "Ignoring unknown field \"baz\" in package description"
+            "package.yaml: Ignoring unrecognized field $.foo"
+          , "package.yaml: Ignoring unrecognized field $.when[0].bar"
+          , "package.yaml: Ignoring unrecognized field $.when[0].when.bar2"
+          , "package.yaml: Ignoring unrecognized field $.when[1].baz"
           ]
 
       context "when parsing conditionals with else-branch" $ do
@@ -1028,13 +1054,13 @@ spec = around_ (inTempDirectoryNamed "foo") $ do
                 else:
                   baz: null
           |] `shouldWarn` [
-              "Ignoring unknown field \"foo\" in package description"
-            , "Ignoring unknown field \"bar\" in package description"
-            , "Ignoring unknown field \"baz\" in package description"
+              "package.yaml: Ignoring unrecognized field $.when.foo"
+            , "package.yaml: Ignoring unrecognized field $.when.then.bar"
+            , "package.yaml: Ignoring unrecognized field $.when.else.when.else.baz"
             ]
 
-run :: FilePath -> String -> IO ([String], String)
-run c old = run_ c old >>= either (throwIO . ErrorCall) return
+run :: HasCallStack => FilePath -> String -> IO ([String], String)
+run c old = run_ c old >>= either assertFailure return
 
 run_ :: FilePath -> String -> IO (Either String ([String], String))
 run_ c old = do

test/Helper.hs

@@ -7,10 +7,8 @@ module Helper (
 , withTempDirectory
 , module System.FilePath
 , withCurrentDirectory
-, shouldParseAs
+, yaml
 ) where
-import           Data.Yaml
-import           Data.ByteString (ByteString)
 
 import           Test.Hspec
 import           Test.Mockery.Directory
@@ -20,6 +18,9 @@ import           Control.Exception
 import qualified System.IO.Temp as Temp
 import           System.FilePath
 
+import           Data.Yaml.TH (yamlQQ)
+import           Language.Haskell.TH.Quote (QuasiQuoter)
+
 withCurrentDirectory :: FilePath -> IO a -> IO a
 withCurrentDirectory dir action = do
   bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do
@@ -30,6 +31,5 @@ withTempDirectory :: (FilePath -> IO a) -> IO a
 withTempDirectory action = Temp.withSystemTempDirectory "hspec" $ \dir -> do
   canonicalizePath dir >>= action
 
-shouldParseAs :: (HasCallStack, Show a, Eq a, FromJSON a) => ByteString -> Either String a -> Expectation
-shouldParseAs input expected = do
-  decodeEither input `shouldBe` expected
+yaml :: Language.Haskell.TH.Quote.QuasiQuoter
+yaml = yamlQQ

test/Hpack/ConfigSpec.hs

@@ -15,7 +15,8 @@ module Hpack.ConfigSpec (
 ) where
 
 import           Helper
-import           Data.Aeson.Types
+import           Data.Aeson.Config.FromValueSpec hiding (spec)
+
 import           Data.String.Interpolate.IsString
 import           Control.Arrow
 import qualified GHC.Exts as Exts
@@ -23,11 +24,14 @@ import           System.Directory (createDirectory)
 import           Data.Either
 import qualified Data.Map.Lazy as Map
 
-import           Hpack.Util
 import           Hpack.Dependency
 import           Hpack.Config hiding (package)
 import qualified Hpack.Config as Config
 
+import           Data.Aeson.Config.Types
+import           Data.Aeson.Config.FromValue
+
+
 instance Exts.IsList (Maybe (List a)) where
   type Item (Maybe (List a)) = a
   fromList = Just . List
@@ -152,78 +156,6 @@ spec = do
         getModules dir  "./." `shouldReturn` ["Foo"]
 
   describe "readPackageConfig" $ do
-    it "warns on unknown fields" $ do
-      withPackageWarnings_ [i|
-        name: foo
-        bar: 23
-        baz: 42
-        _qux: 66
-        |]
-        (`shouldMatchList` [
-          "Ignoring unknown field \"bar\" in package description"
-        , "Ignoring unknown field \"baz\" in package description"
-        ]
-        )
-
-    it "warns on unknown fields in when block, list" $ do
-      withPackageWarnings_ [i|
-        name: foo
-        when:
-          - condition: impl(ghc)
-            bar: 23
-            baz: 42
-            _qux: 66
-        |]
-        (`shouldMatchList` [
-          "Ignoring unknown field \"_qux\" in package description"
-        , "Ignoring unknown field \"bar\" in package description"
-        , "Ignoring unknown field \"baz\" in package description"
-        ]
-        )
-
-    it "warns on unknown fields in when block, single" $ do
-      withPackageWarnings_ [i|
-        name: foo
-        when:
-          condition: impl(ghc)
-          github: foo/bar
-          dependencies: ghc-prim
-          baz: 42
-        |]
-        (`shouldMatchList` [
-          "Ignoring unknown field \"baz\" in package description"
-        , "Ignoring unknown field \"github\" in package description"
-        ]
-        )
-
-    it "warns on unknown fields in when block in library section" $ do
-      withPackageWarnings_ [i|
-        name: foo
-        library:
-          when:
-            condition: impl(ghc)
-            baz: 42
-        |]
-        (`shouldBe` [
-          "Ignoring unknown field \"baz\" in library section"
-        ]
-        )
-
-    it "warns on unknown fields in when block in executable section" $ do
-      withPackageWarnings_ [i|
-        name: foo
-        executables:
-          foo:
-            main: Main.hs
-            when:
-              condition: impl(ghc)
-              baz: 42
-        |]
-        (`shouldBe` [
-          "Ignoring unknown field \"baz\" in executable section \"foo\""
-        ]
-        )
-
     it "warns on missing name" $ do
       withPackageWarnings_ [i|
         {}
@@ -320,33 +252,6 @@ spec = do
         |]
         (packageLicenseFile >>> (`shouldBe` ["FOO", "BAR"]))
 
-    it "accepts build-type: Simple" $ do
-      withPackageConfig_ [i|
-        build-type: Simple
-        |]
-        (`shouldBe` package {packageBuildType = Simple})
-
-    it "accepts build-type: Configure" $ do
-      withPackageConfig_ [i|
-        build-type: Configure
-        |]
-        (`shouldBe` package {packageBuildType = Configure})
-
-    it "accepts build-type: Make" $ do
-      withPackageConfig_ [i|
-        build-type: Make
-        |]
-        (`shouldBe` package {packageBuildType = Make})
-
-    it "accepts build-type: Custom" $ do
-      withPackageConfig_ [i|
-        build-type: Custom
-        |]
-        (`shouldBe` package {packageBuildType = Custom})
-
-    it "rejects unknown build-type" $ do
-      parseEither parseJSON (String "foobar") `shouldBe` (Left "Error in $: build-type must be one of: Simple, Configure, Make, Custom" :: Either String BuildType)
-
     it "accepts flags" $ do
       withPackageConfig_ [i|
         flags:
@@ -357,21 +262,6 @@ spec = do
         |]
         (packageFlags >>> (`shouldBe` [Flag "integration-tests" (Just "Run the integration test suite") True False]))
 
-    it "warns on unknown fields in flag sections" $ do
-      withPackageWarnings_ [i|
-        name: foo
-        flags:
-          integration-tests:
-            description: Run the integration test suite
-            manual: yes
-            default: no
-            foo: 23
-        |]
-        (`shouldBe` [
-          "Ignoring unknown field \"foo\" for flag \"integration-tests\""
-        ]
-        )
-
     it "accepts extra-source-files" $ do
       withPackageConfig [i|
         extra-source-files:
@@ -510,19 +400,6 @@ spec = do
         (packageName >>> (`shouldBe` "n2"))
 
     context "when reading library section" $ do
-      it "warns on unknown fields" $ do
-        withPackageWarnings_ [i|
-          name: foo
-          library:
-            bar: 23
-            baz: 42
-          |]
-          (`shouldMatchList` [
-            "Ignoring unknown field \"bar\" in library section"
-          , "Ignoring unknown field \"baz\" in library section"
-          ]
-          )
-
       it "accepts source-dirs" $ do
         withPackageConfig_ [i|
           library:
@@ -585,21 +462,6 @@ spec = do
           (packageLibrary >>> (`shouldBe` Just (section library{libraryExposed = Just False})))
 
     context "when reading executable section" $ do
-      it "warns on unknown fields" $ do
-        withPackageWarnings_ [i|
-          name: foo
-          executables:
-            foo:
-              main: Main.hs
-              bar: 42
-              baz: 23
-          |]
-          (`shouldMatchList` [
-            "Ignoring unknown field \"bar\" in executable section \"foo\""
-          , "Ignoring unknown field \"baz\" in executable section \"foo\""
-          ]
-          )
-
       it "reads executables section" $ do
         withPackageConfig_ [i|
           executables:
@@ -615,15 +477,6 @@ spec = do
           |]
           (packageExecutables >>> (`shouldBe` Map.fromList [("foo", section $ executable "driver/Main.hs")]))
 
-      it "warns on unknown executable fields" $ do
-        withPackageWarnings_ [i|
-          name: foo
-          executable:
-            main: Main.hs
-            unknown: true
-          |]
-          (`shouldBe` ["Ignoring unknown field \"unknown\" in executable section"])
-
       context "with both executable and executables" $ do
         it "gives executable precedence" $ do
           withPackageConfig_ [i|
@@ -748,38 +601,7 @@ spec = do
           |]
           (`shouldBe` package {packageExecutables = Map.fromList [("foo", (section $ executable "driver/Main.hs") {sectionGhcProfOptions = ["-fprof-auto"]})]})
 
-    context "when reading benchmark section" $ do
-      it "warns on unknown fields" $ do
-        withPackageWarnings_ [i|
-          name: foo
-          benchmarks:
-            foo:
-              main: Main.hs
-              bar: 42
-              baz: 23
-          |]
-          (`shouldMatchList` [
-            "Ignoring unknown field \"bar\" in benchmark section \"foo\""
-          , "Ignoring unknown field \"baz\" in benchmark section \"foo\""
-          ]
-          )
-
     context "when reading test section" $ do
-      it "warns on unknown fields" $ do
-        withPackageWarnings_ [i|
-          name: foo
-          tests:
-            foo:
-              main: Main.hs
-              bar: 42
-              baz: 23
-          |]
-          (`shouldMatchList` [
-            "Ignoring unknown field \"bar\" in test section \"foo\""
-          , "Ignoring unknown field \"baz\" in test section \"foo\""
-          ]
-          )
-
       it "reads test section" $ do
         withPackageConfig_ [i|
           tests:
@@ -841,24 +663,34 @@ spec = do
           let file = dir </> "package.yaml"
           readPackageConfig undefined file `shouldReturn` Left [i|#{file}: Yaml file not found: #{file}|]
 
-  describe "parseJSON" $ do
-    context "when parsing Cond" $ do
+  describe "fromValue" $ do
+    context "with Cond" $ do
       it "accepts Strings" $ do
-        [i|
+        [yaml|
         os(windows)
-        |] `shouldParseAs` Right (Cond "os(windows)")
+        |] `shouldDecodeTo_` Cond "os(windows)"
 
       it "accepts True" $ do
-        [i|
+        [yaml|
         yes
-        |] `shouldParseAs` Right (Cond "true")
+        |] `shouldDecodeTo_` Cond "true"
 
       it "accepts False" $ do
-        [i|
+        [yaml|
         no
-        |] `shouldParseAs` Right (Cond "false")
+        |] `shouldDecodeTo_` Cond "false"
 
       it "rejects other values" $ do
-        [i|
+        [yaml|
         23
-        |] `shouldParseAs` (Left "Error in $: expected Boolean or String, encountered Number" :: Either String Cond)
+        |] `shouldDecodeTo` (Left "Error while parsing $ - expected Boolean or String, encountered Number" :: DecodeResult Cond)
+
+  describe "formatOrList" $ do
+    it "formats a singleton list" $ do
+      formatOrList ["foo"] `shouldBe` "foo"
+
+    it "formats a 2-element list" $ do
+      formatOrList ["foo", "bar"] `shouldBe` "foo or bar"
+
+    it "formats an n-element list" $ do
+      formatOrList ["foo", "bar", "baz"] `shouldBe` "foo, bar, or baz"

test/Hpack/DependencySpec.hs

@@ -6,164 +6,164 @@ module Hpack.DependencySpec (spec) where
 
 import           Helper
 
-import           Data.String.Interpolate.IsString
-import           Data.ByteString (ByteString)
+import           Data.Aeson.Config.FromValueSpec (shouldDecodeTo, shouldDecodeTo_)
 
+import           Data.Aeson.Config.FromValue
 import           Hpack.Dependency
 
-parsesAs :: HasCallStack => ByteString -> Either String Dependencies -> Expectation
-parsesAs = shouldParseAs
+left :: String -> DecodeResult Dependencies
+left = Left
 
 spec :: Spec
 spec = do
-  describe "parseJSON" $ do
+  describe "fromValue" $ do
     context "when parsing Dependencies" $ do
       context "with a scalar" $ do
         it "accepts dependencies without constraints" $ do
-          [i|
+          [yaml|
             hpack
-          |] `parsesAs` Right [("hpack", AnyVersion)]
+          |] `shouldDecodeTo_` Dependencies [("hpack", AnyVersion)]
 
         it "accepts dependencies with constraints" $ do
-          [i|
+          [yaml|
             hpack >= 2 && < 3
-          |] `parsesAs` Right [("hpack", VersionRange ">=2 && <3")]
+          |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange ">=2 && <3")]
 
         context "with invalid constraint" $ do
           it "returns an error message" $ do
-            [i|
+            [yaml|
               hpack ==
-            |] `parsesAs` Left "Error in $: invalid dependency \"hpack ==\""
+            |] `shouldDecodeTo` left "Error while parsing $ - invalid dependency \"hpack ==\""
 
       context "with a list" $ do
         it "accepts dependencies without constraints" $ do
-          [i|
+          [yaml|
             - hpack
-          |] `parsesAs` Right [("hpack", AnyVersion)]
+          |] `shouldDecodeTo_` Dependencies [("hpack", AnyVersion)]
 
         it "accepts dependencies with constraints" $ do
-          [i|
+          [yaml|
             - hpack >= 2 && < 3
-          |] `parsesAs` Right [("hpack", VersionRange ">=2 && <3")]
+          |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange ">=2 && <3")]
 
         it "accepts git dependencies" $ do
           let source = GitRef "https://github.com/sol/hpack" "master" Nothing
-          [i|
+          [yaml|
             - name: hpack
               git: https://github.com/sol/hpack
               ref: master
-          |] `parsesAs` Right [("hpack", SourceDependency source)]
+          |] `shouldDecodeTo_` Dependencies [("hpack", SourceDependency source)]
 
         it "accepts github dependencies" $ do
           let source = GitRef "https://github.com/sol/hpack" "master" Nothing
-          [i|
+          [yaml|
             - name: hpack
               github: sol/hpack
               ref: master
-          |] `parsesAs` Right [("hpack", SourceDependency source)]
+          |] `shouldDecodeTo_` Dependencies [("hpack", SourceDependency source)]
 
         it "accepts an optional subdirectory for git dependencies" $ do
           let source = GitRef "https://github.com/yesodweb/wai" "master" (Just "warp")
-          [i|
+          [yaml|
             - name: warp
               github: yesodweb/wai
               ref: master
               subdir: warp
-          |] `parsesAs` Right [("warp", SourceDependency source)]
+          |] `shouldDecodeTo_` Dependencies [("warp", SourceDependency source)]
 
         it "accepts local dependencies" $ do
           let source = Local "../hpack"
-          [i|
+          [yaml|
             - name: hpack
               path: ../hpack
-          |] `parsesAs` Right [("hpack", SourceDependency source)]
+          |] `shouldDecodeTo_` Dependencies [("hpack", SourceDependency source)]
 
         context "when ref is missing" $ do
           it "produces accurate error messages" $ do
-            [i|
+            [yaml|
               - name: hpack
                 git: sol/hpack
                 ef: master
-            |] `parsesAs` Left "Error in $[0]: key \"ref\" not present"
+            |] `shouldDecodeTo` left "Error while parsing $[0] - key \"ref\" not present"
 
         context "when both git and github are missing" $ do
           it "produces accurate error messages" $ do
-            [i|
+            [yaml|
               - name: hpack
                 gi: sol/hpack
                 ref: master
-            |] `parsesAs` Left "Error in $[0]: neither key \"git\" nor key \"github\" present"
+            |] `shouldDecodeTo` left "Error while parsing $[0] - neither key \"git\" nor key \"github\" present"
 
       context "with a mapping from dependency names to constraints" $ do
         it "accepts dependencies without constraints" $ do
-          [i|
+          [yaml|
             array:
-          |] `parsesAs` Right [("array", AnyVersion)]
+          |] `shouldDecodeTo_` Dependencies [("array", AnyVersion)]
 
         it "rejects invalid values" $ do
-          [i|
+          [yaml|
             hpack: []
-          |] `parsesAs` Left "Error in $.hpack: expected Null, Object, Number, or String, encountered Array"
+          |] `shouldDecodeTo` left "Error while parsing $.hpack - expected Null, Object, Number, or String, encountered Array"
 
         context "when the constraint is a Number" $ do
           it "accepts 1" $ do
-            [i|
+            [yaml|
               hpack: 1
-            |] `parsesAs` Right [("hpack", VersionRange "==1")]
+            |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==1")]
 
           it "accepts 1.0" $ do
-            [i|
+            [yaml|
               hpack: 1.0
-            |] `parsesAs` Right [("hpack", VersionRange "==1.0")]
+            |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==1.0")]
 
           it "accepts 0.11" $ do
-            [i|
+            [yaml|
               hpack: 0.11
-            |] `parsesAs` Right [("hpack", VersionRange "==0.11")]
+            |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==0.11")]
 
           it "accepts 0.110" $ do
-            [i|
+            [yaml|
               hpack: 0.110
-            |] `parsesAs` Right [("hpack", VersionRange "==0.110")]
+            |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==0.110")]
 
           it "accepts 1e2" $ do
-            [i|
+            [yaml|
               hpack: 1e2
-            |] `parsesAs` Right [("hpack", VersionRange "==100")]
+            |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==100")]
 
         context "when the constraint is a String" $ do
           it "accepts version ranges" $ do
-            [i|
+            [yaml|
               hpack: '>=2'
-            |] `parsesAs` Right [("hpack", VersionRange ">=2")]
+            |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange ">=2")]
 
           it "accepts specific versions" $ do
-            [i|
+            [yaml|
               hpack: 0.10.8.2
-            |] `parsesAs` Right [("hpack", VersionRange "==0.10.8.2")]
+            |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==0.10.8.2")]
 
           it "accepts wildcard versions" $ do
-            [i|
+            [yaml|
               hpack: 2.*
-            |] `parsesAs` Right [("hpack", VersionRange "==2.*")]
+            |] `shouldDecodeTo_` Dependencies [("hpack", VersionRange "==2.*")]
 
           it "reports parse errors" $ do
-            [i|
+            [yaml|
               hpack: foo
-            |] `parsesAs` Left "Error in $.hpack: invalid constraint \"foo\""
+            |] `shouldDecodeTo` left "Error while parsing $.hpack - invalid constraint \"foo\""
 
         context "when the constraint is an Object" $ do
           it "accepts github dependencies" $ do
-            [i|
+            [yaml|
               Cabal:
                 github: haskell/cabal
                 ref: d53b6e0d908dfedfdf4337b2935519fb1d689e76
                 subdir: Cabal
-            |] `parsesAs` Right [("Cabal", SourceDependency (GitRef "https://github.com/haskell/cabal" "d53b6e0d908dfedfdf4337b2935519fb1d689e76" (Just "Cabal")))]
+            |] `shouldDecodeTo_` Dependencies [("Cabal", SourceDependency (GitRef "https://github.com/haskell/cabal" "d53b6e0d908dfedfdf4337b2935519fb1d689e76" (Just "Cabal")))]
 
           it "ignores names in nested hashes" $ do
-            [i|
+            [yaml|
               outer-name:
                 name: inner-name
                 path: somewhere
-            |] `parsesAs` Right [("outer-name", SourceDependency (Local "somewhere"))]
+            |] `shouldDecodeTo` Right (Dependencies [("outer-name", SourceDependency (Local "somewhere"))], ["$.outer-name.name"])

test/Hpack/Syntax/DefaultsSpec.hs

@@ -1,10 +1,12 @@
 {-# LANGUAGE QuasiQuotes #-}
-module Hpack.SyntaxSpec (spec) where
+module Hpack.Syntax.DefaultsSpec (spec) where
 
 import           Helper
-import           Data.String.Interpolate.IsString
 
-import           Hpack.Syntax
+import           Data.Aeson.Config.FromValueSpec hiding (spec)
+
+import           Data.Aeson.Config.FromValue
+import           Hpack.Syntax.Defaults
 
 spec :: Spec
 spec = do
@@ -46,15 +48,18 @@ spec = do
     it "accepts hyphens" $ do
       isValidRepo "foo-bar" `shouldBe` True
 
-  describe "parseJSON" $ do
+  describe "fromValue" $ do
     context "when parsing Defaults" $ do
+      let
+        left :: String -> DecodeResult Defaults
+        left = Left
       context "with Object" $ do
         it "accepts Defaults from GitHub" $ do
-          [i|
+          [yaml|
           github: sol/hpack
           ref: 0.1.0
           path: defaults.yaml
-          |] `shouldParseAs` Right Defaults {
+          |] `shouldDecodeTo_` Defaults {
               defaultsGithubUser = "sol"
             , defaultsGithubRepo = "hpack"
             , defaultsRef = "0.1.0"
@@ -62,59 +67,59 @@ spec = do
             }
 
         it "rejects invalid user names" $ do
-          [i|
+          [yaml|
           github: ../hpack
           ref: 0.1.0
           path: defaults.yaml
-          |] `shouldParseAs` (Left "Error in $.github: invalid user name \"..\"" :: Either String Defaults)
+          |] `shouldDecodeTo` left "Error while parsing $.github - invalid user name \"..\""
 
         it "rejects invalid repository names" $ do
-          [i|
+          [yaml|
           github: sol/..
           ref: 0.1.0
           path: defaults.yaml
-          |] `shouldParseAs` (Left "Error in $.github: invalid repository name \"..\"" :: Either String Defaults)
+          |] `shouldDecodeTo` left "Error while parsing $.github - invalid repository name \"..\""
 
         it "rejects invalid Git references" $ do
-          [i|
+          [yaml|
           github: sol/hpack
           ref: ../foo/bar
           path: defaults.yaml
-          |] `shouldParseAs` (Left "Error in $.ref: invalid Git reference \"../foo/bar\"" :: Either String Defaults)
+          |] `shouldDecodeTo` left "Error while parsing $.ref - invalid Git reference \"../foo/bar\""
 
         it "rejects \\ in path" $ do
-          [i|
+          [yaml|
           github: sol/hpack
           ref: 0.1.0
-          path: hpack\\defaults.yaml
-          |] `shouldParseAs` (Left "Error in $.path: rejecting '\\' in \"hpack\\\\defaults.yaml\", please use '/' to separate path components" :: Either String Defaults)
+          path: hpack\defaults.yaml
+          |] `shouldDecodeTo` left "Error while parsing $.path - rejecting '\\' in \"hpack\\\\defaults.yaml\", please use '/' to separate path components"
 
         it "rejects : in path" $ do
-          [i|
+          [yaml|
           github: sol/hpack
           ref: 0.1.0
           path: foo:bar.yaml
-          |] `shouldParseAs` (Left "Error in $.path: rejecting ':' in \"foo:bar.yaml\"" :: Either String Defaults)
+          |] `shouldDecodeTo` left "Error while parsing $.path - rejecting ':' in \"foo:bar.yaml\""
 
         it "rejects absolute paths" $ do
-          [i|
+          [yaml|
           github: sol/hpack
           ref: 0.1.0
           path: /defaults.yaml
-          |] `shouldParseAs` (Left "Error in $.path: rejecting absolute path \"/defaults.yaml\"" :: Either String Defaults)
+          |] `shouldDecodeTo` left "Error while parsing $.path - rejecting absolute path \"/defaults.yaml\""
 
         it "rejects .. in path" $ do
-          [i|
+          [yaml|
           github: sol/hpack
           ref: 0.1.0
           path: ../../defaults.yaml
-          |] `shouldParseAs` (Left "Error in $.path: rejecting \"..\" in \"../../defaults.yaml\"" :: Either String Defaults)
+          |] `shouldDecodeTo` left "Error while parsing $.path - rejecting \"..\" in \"../../defaults.yaml\""
 
       context "with String" $ do
         it "accepts Defaults from GitHub" $ do
-          [i|
+          [yaml|
           sol/hpack@0.1.0
-          |] `shouldParseAs` Right Defaults {
+          |] `shouldDecodeTo_` Defaults {
               defaultsGithubUser = "sol"
             , defaultsGithubRepo = "hpack"
             , defaultsRef = "0.1.0"
@@ -122,27 +127,27 @@ spec = do
             }
 
         it "rejects invalid user names" $ do
-          [i|
+          [yaml|
           ../hpack@0.1.0
-          |] `shouldParseAs` (Left "Error in $: invalid user name \"..\"" :: Either String Defaults)
+          |] `shouldDecodeTo` left "Error while parsing $ - invalid user name \"..\""
 
         it "rejects invalid repository names" $ do
-          [i|
+          [yaml|
           sol/..@0.1.0
-          |] `shouldParseAs` (Left "Error in $: invalid repository name \"..\"" :: Either String Defaults)
+          |] `shouldDecodeTo` left "Error while parsing $ - invalid repository name \"..\""
 
         it "rejects invalid Git references" $ do
-          [i|
+          [yaml|
           sol/pack@../foo/bar
-          |] `shouldParseAs` (Left "Error in $: invalid Git reference \"../foo/bar\"" :: Either String Defaults)
+          |] `shouldDecodeTo` left "Error while parsing $ - invalid Git reference \"../foo/bar\""
 
         it "rejects missing Git reference" $ do
-          [i|
+          [yaml|
           sol/hpack
-          |] `shouldParseAs` (Left "Error in $: missing Git reference for \"sol/hpack\", the expected format is user/repo@ref" :: Either String Defaults)
+          |] `shouldDecodeTo` left "Error while parsing $ - missing Git reference for \"sol/hpack\", the expected format is user/repo@ref"
 
       context "with neither Object nor String" $ do
         it "fails" $ do
-          [i|
+          [yaml|
           10
-          |] `shouldParseAs` (Left "Error in $: expected Object or String, encountered Number" :: Either String Defaults)
+          |] `shouldDecodeTo` left "Error while parsing $ - expected Object or String, encountered Number"

test/Hpack/Syntax/GenericsUtilSpec.hs

@@ -1,24 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-module Hpack.Syntax.GenericsUtilSpec (spec) where
-
-import           Test.Hspec
-
-import           Data.Proxy
-import           GHC.Generics
-
-import           Hpack.Syntax.GenericsUtil
-
-data Person = Person {
-  _personName :: String
-, _personAge :: Int
-} deriving Generic
-
-spec :: Spec
-spec = do
-  describe "selectors" $ do
-    it "returns a list of record selectors" $ do
-      selectors (Proxy :: Proxy Person) `shouldBe` ["_personName", "_personAge"]
-
-  describe "typeName" $ do
-    it "gets datatype name" $ do
-      typeName (Proxy :: Proxy Person) `shouldBe` "Person"

test/Hpack/UtilSpec.hs

@@ -1,9 +1,5 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
 module Hpack.UtilSpec (main, spec) where
 
-import           Data.Aeson
-import           Data.Aeson.Types
 import           Helper
 import           System.Directory
 
@@ -69,25 +65,6 @@ spec = do
           touch "foo/bar/baz"
           getModuleFilesRecursive "foo" `shouldReturn` empty
 
-  describe "List" $ do
-    let
-      parseError :: String -> Either String (List Int)
-      parseError prefix = Left (prefix ++ ": expected Int, encountered String")
-
-    context "when parsing single values" $ do
-      it "returns the value in a singleton list" $ do
-        fromJSON (toJSON $ Number 23) `shouldBe` Success (List [23 :: Int])
-
-      it "returns error messages from element parsing" $ do
-        parseEither parseJSON (String "foo") `shouldBe` parseError "Error in $"
-
-    context "when parsing a list of values" $ do
-      it "returns the list" $ do
-        fromJSON (toJSON [Number 23, Number 42]) `shouldBe` Success (List [23, 42 :: Int])
-
-      it "propagates parse error messages of invalid elements" $ do
-        parseEither parseJSON (toJSON [Number 23, String "foo"]) `shouldBe` parseError "Error in $[1]"
-
   describe "tryReadFile" $ do
     it "reads file" $ do
       inTempDirectory $ do