diff --git a/Data/Aeson.hs b/Data/Aeson.hs
--- a/Data/Aeson.hs
+++ b/Data/Aeson.hs
@@ -111,6 +111,7 @@
     , withNumber
     , withScientific
     , withBool
+    , withEmbeddedJSON
     -- * Constructors and accessors
     , Series
     , pairs
@@ -381,7 +382,7 @@
 -- The 'Object' type contains JSON objects:
 --
 -- > λ> decode "{\"name\":\"Dave\",\"age\":2}" :: Maybe Object
--- > Just (fromList) [("name",String "Dave"),("age",Number 2)]
+-- > Just (fromList [("name",String "Dave"),("age",Number 2)])
 --
 -- You can extract values from it with a parser using 'parse',
 -- 'parseEither' or, in this example, 'parseMaybe':
diff --git a/Data/Aeson/Compat.hs b/Data/Aeson/Compat.hs
new file mode 100644
--- /dev/null
+++ b/Data/Aeson/Compat.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE CPP #-}
+
+module Data.Aeson.Compat
+  (
+    fromStrict
+  ) where
+
+import qualified Data.ByteString      as S
+import qualified Data.ByteString.Lazy as L
+
+fromStrict :: S.ByteString -> L.ByteString
+#if MIN_VERSION_bytestring(0, 9, 2)
+fromStrict = L.fromChunks . (:[])
+#else
+fromStrict = L.fromStrict
+#endif
diff --git a/Data/Aeson/TH.hs b/Data/Aeson/TH.hs
--- a/Data/Aeson/TH.hs
+++ b/Data/Aeson/TH.hs
@@ -85,7 +85,6 @@
 @
 
 -}
-
 module Data.Aeson.TH
     (
       -- * Encoding configuration
@@ -123,14 +122,14 @@
 import Control.Applicative ((<|>))
 import Data.Aeson (Object, (.=), (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
 import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
-import Data.Aeson.Types.Internal ((<?>), Pair, JSONPathElement(Key))
+import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
 import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)
 import Control.Monad (liftM2, unless, when)
 import Data.Foldable (foldr')
 #if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)
 import Data.List (nub)
 #endif
-import Data.List (foldl', genericLength , intercalate , intersperse, partition, union)
+import Data.List (foldl', genericLength, intercalate, partition, union)
 import Data.List.NonEmpty ((<|), NonEmpty((:|)))
 import Data.Map (Map)
 import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
@@ -154,11 +153,13 @@
 import qualified Data.HashMap.Strict as H (lookup, toList)
 import qualified Data.List.NonEmpty as NE (length, reverse)
 import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
+import qualified Data.Semigroup as Semigroup (Option(..))
 import qualified Data.Set as Set (empty, insert, member)
 import qualified Data.Text as T (Text, pack, unpack)
-import qualified Data.Vector as V (unsafeIndex, null, length, create, fromList)
+import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)
 import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)
 
+{-# ANN module "Hlint: ignore Reduce duplication" #-}
 
 --------------------------------------------------------------------------------
 -- Convenience
@@ -253,8 +254,8 @@
                    -> Name
                    -- ^ Name of the type for which to generate an instance.
                    -> Q [Dec]
-deriveToJSONCommon = deriveJSONClass [ (ToJSON,     \jc _ -> consToValue    jc)
-                                     , (ToEncoding, \jc _ -> consToEncoding jc)
+deriveToJSONCommon = deriveJSONClass [ (ToJSON,     \jc _ -> consToValue Value jc)
+                                     , (ToEncoding, \jc _ -> consToValue Encoding jc)
                                      ]
 
 -- | Generates a lambda expression which encodes the given data type or
@@ -284,7 +285,7 @@
                -> Options -- ^ Encoding options.
                -> Name -- ^ Name of the encoded type.
                -> Q Exp
-mkToJSONCommon = mkFunCommon (\jc _ -> consToValue jc)
+mkToJSONCommon = mkFunCommon (\jc _ -> consToValue Value jc)
 
 -- | Generates a lambda expression which encodes the given data type or
 -- data family instance constructor as a JSON string.
@@ -313,12 +314,14 @@
                    -> Options -- ^ Encoding options.
                    -> Name -- ^ Name of the encoded type.
                    -> Q Exp
-mkToEncodingCommon = mkFunCommon (\jc _ -> consToEncoding jc)
+mkToEncodingCommon = mkFunCommon (\jc _ -> consToValue Encoding jc)
 
 -- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates
--- code to generate a 'Value' of a number of constructors. All constructors
--- must be from the same type.
-consToValue :: JSONClass
+-- code to generate a 'Value' or 'Encoding' of a number of constructors. All
+-- constructors must be from the same type.
+consToValue :: ToJSONFun
+            -- ^ The method ('toJSON' or 'toEncoding') being derived.
+            -> JSONClass
             -- ^ The ToJSON variant being derived.
             -> Options
             -- ^ Encoding options.
@@ -328,10 +331,10 @@
             -- ^ Constructors for which to generate JSON generating code.
             -> Q Exp
 
-consToValue _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "
+consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "
                              ++ "Not a single constructor given!"
 
-consToValue jc opts vars cons = do
+consToValue target jc opts vars cons = do
     value <- newName "value"
     tjs   <- newNameList "_tj"  $ arityInt jc
     tjls  <- newNameList "_tjl" $ arityInt jc
@@ -345,66 +348,26 @@
     matches tvMap = case cons of
       -- A single constructor is directly encoded. The constructor itself may be
       -- forgotten.
-      [con] | not (tagSingleConstructors opts) -> [argsToValue jc tvMap opts False con]
+      [con] | not (tagSingleConstructors opts) -> [argsToValue target jc tvMap opts False con]
       _ | allNullaryToStringTag opts && all isNullary cons ->
-              [ match (conP conName []) (normalB $ conStr opts conName) []
+              [ match (conP conName []) (normalB $ conStr target opts conName) []
               | con <- cons
               , let conName = constructorName con
               ]
-        | otherwise -> [argsToValue jc tvMap opts True con | con <- cons]
+        | otherwise -> [argsToValue target jc tvMap opts True con | con <- cons]
 
-conStr :: Options -> Name -> Q Exp
-conStr opts = appE [|String|] . conTxt opts
+-- | Name of the constructor as a quoted 'Value' or 'Encoding'.
+conStr :: ToJSONFun -> Options -> Name -> Q Exp
+conStr Value opts = appE [|String|] . conTxt opts
+conStr Encoding opts = appE [|E.text|] . conTxt opts
 
+-- | Name of the constructor as a quoted 'Text'.
 conTxt :: Options -> Name -> Q Exp
-conTxt opts = appE [|T.pack|] . conStringE opts
-
-conStringE :: Options -> Name -> Q Exp
-conStringE opts = stringE . constructorTagModifier opts . nameBase
-
--- | Helper function used by both 'deriveToJSON' and 'mkToEncoding'. Generates
--- code to write out a value for a number of constructors. All constructors
--- must be from the same type.
-consToEncoding :: JSONClass
-               -- ^ The ToJSON variant being derived.
-               -> Options
-               -- ^ Encoding options.
-               -> [Type]
-               -- ^ The types from the data type/data family instance declaration
-               -> [ConstructorInfo]
-               -- ^ Constructors for which to generate JSON generating code.
-               -> Q Exp
-
-consToEncoding _ _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "
-                          ++ "Not a single constructor given!"
-
-consToEncoding jc opts vars cons = do
-    value <- newName "value"
-    tes   <- newNameList "_te"  $ arityInt jc
-    tels  <- newNameList "_tel" $ arityInt jc
-    let zippedTEs      = zip tes tels
-        interleavedTEs = interleave tes tels
-        lastTyVars     = map varTToName $ drop (length vars - arityInt jc) vars
-        tvMap          = M.fromList $ zip lastTyVars zippedTEs
-    lamE (map varP $ interleavedTEs ++ [value]) $
-        caseE (varE value) (matches tvMap)
-  where
-    matches tvMap = case cons of
-      -- A single constructor is directly encoded. The constructor itself may be
-      -- forgotten.
-      [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tvMap opts False con]
-      -- Encode just the name of the constructor of a sum type iff all the
-      -- constructors are nullary.
-      _ | allNullaryToStringTag opts && all isNullary cons ->
-              [ match (conP conName [])
-                (normalB $ encStr opts conName) []
-              | con <- cons
-              , let conName = constructorName con
-              ]
-        | otherwise -> [argsToEncoding jc tvMap opts True con | con <- cons]
+conTxt opts = appE [|T.pack|] . stringE . conString opts
 
-encStr :: Options -> Name -> Q Exp
-encStr opts = appE [|E.text|] . conTxt opts
+-- | Name of the constructor.
+conString :: Options -> Name -> String
+conString opts = constructorTagModifier opts . nameBase
 
 -- | If constructor is nullary.
 isNullary :: ConstructorInfo -> Bool
@@ -412,127 +375,133 @@
                           , constructorFields  = tys } = null tys
 isNullary _ = False
 
-sumToValue :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
-sumToValue opts multiCons nullary conName exp
+-- | Wrap fields of a non-record constructor. See 'sumToValue'.
+opaqueSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
+opaqueSumToValue target opts multiCons nullary conName value =
+  sumToValue target opts multiCons nullary conName
+    value
+    pairs
+  where
+    pairs contentsFieldName = listE [toPair target contentsFieldName value]
+
+-- | Wrap fields of a record constructor. See 'sumToValue'.
+recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
+recordSumToValue target opts multiCons nullary conName pairs =
+  sumToValue target opts multiCons nullary conName
+    (objectExp target pairs)
+    (const pairs)
+
+-- | Wrap fields of a constructor.
+sumToValue
+  :: ToJSONFun
+  -- ^ The method being derived.
+  -> Options
+  -- ^ Deriving options.
+  -> Bool
+  -- ^ Does this type have multiple constructors.
+  -> Bool
+  -- ^ Is this constructor nullary.
+  -> Name
+  -- ^ Constructor name.
+  -> ExpQ
+  -- ^ Fields of the constructor as a 'Value' or 'Encoding'.
+  -> (String -> ExpQ)
+  -- ^ Representation of an 'Object' fragment used for the 'TaggedObject'
+  -- variant; of type @[(Text,Value)]@ or @[Encoding]@, depending on the method
+  -- being derived.
+  --
+  -- - For non-records, produces a pair @"contentsFieldName":value@,
+  --   given a @contentsFieldName@ as an argument. See 'opaqueSumToValue'.
+  -- - For records, produces the list of pairs corresponding to fields of the
+  --   encoded value (ignores the argument). See 'recordSumToValue'.
+  -> ExpQ
+sumToValue target opts multiCons nullary conName value pairs
     | multiCons =
         case sumEncoding opts of
           TwoElemArray ->
-              [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp])
+            array target [conStr target opts conName, value]
           TaggedObject{tagFieldName, contentsFieldName} ->
-              let tag      = infixApp [|T.pack tagFieldName|]      [|(.=)|] (conStr opts conName)
-                  contents = infixApp [|T.pack contentsFieldName|] [|(.=)|] exp
-              in
-                  [|A.object|] `appE` listE (if nullary then [tag] else [tag, contents])
+            -- TODO: Maybe throw an error in case
+            -- tagFieldName overwrites a field in pairs.
+            let tag = toPair target tagFieldName (conStr target opts conName)
+                content = pairs contentsFieldName
+            in objectExp target $
+              if nullary then listE [tag] else infixApp tag [|(:)|] content
           ObjectWithSingleField ->
-              [|A.object|] `appE` listE
-                [ infixApp (conTxt opts conName) [|(.=)|] exp
-                ]
-          UntaggedValue | nullary -> conStr opts conName
-          UntaggedValue -> exp
-    | otherwise = exp
+            object target [(conString opts conName, value)]
+          UntaggedValue | nullary -> conStr target opts conName
+          UntaggedValue -> value
+    | otherwise = value
 
 -- | Generates code to generate the JSON encoding of a single constructor.
-argsToValue :: JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match
+argsToValue :: ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match
 
 -- Polyadic constructors with special case for unary constructors.
-argsToValue jc tvMap opts multiCons
+argsToValue target jc tvMap opts multiCons
   ConstructorInfo { constructorName    = conName
                   , constructorVariant = NormalConstructor
                   , constructorFields  = argTys } = do
     argTys' <- mapM resolveTypeSynonyms argTys
     let len = length argTys'
     args <- newNameList "arg" len
-    js <- case [ dispatchToJSON jc conName tvMap argTy
-                   `appE` varE arg
-               | (arg, argTy) <- zip args argTys'
-               ] of
-            -- Single argument is directly converted.
-            [e] -> return e
-            -- Multiple arguments are converted to a JSON array.
-            es  -> do
-              mv <- newName "mv"
-              let newMV = bindS (varP mv)
-                                ([|VM.unsafeNew|] `appE`
-                                  litE (integerL $ fromIntegral len))
-                  stmts = [ noBindS $
-                              [|VM.unsafeWrite|] `appE`
-                                varE mv `appE`
-                                  litE (integerL ix) `appE`
-                                    e
-                          | (ix, e) <- zip [(0::Integer)..] es
-                          ]
-                  ret = noBindS $ [|return|] `appE` varE mv
-              return $ [|Array|] `appE`
-                         (varE 'V.create `appE`
-                           doE (newMV:stmts++[ret]))
+    let js = case [ dispatchToJSON target jc conName tvMap argTy
+                      `appE` varE arg
+                  | (arg, argTy) <- zip args argTys'
+                  ] of
+               -- Single argument is directly converted.
+               [e] -> e
+               -- Zero and multiple arguments are converted to a JSON array.
+               es -> array target es
+
     match (conP conName $ map varP args)
-          (normalB $ sumToValue opts multiCons (null argTys') conName js)
+          (normalB $ opaqueSumToValue target opts multiCons (null argTys') conName js)
           []
 
 -- Records.
-argsToValue jc tvMap opts multiCons
+argsToValue target jc tvMap opts multiCons
   info@ConstructorInfo { constructorName    = conName
                        , constructorVariant = RecordConstructor fields
                        , constructorFields  = argTys } =
     case (unwrapUnaryRecords opts, not multiCons, argTys) of
-      (True,True,[_]) -> argsToValue jc tvMap opts multiCons
+      (True,True,[_]) -> argsToValue target jc tvMap opts multiCons
                                      (info{constructorVariant = NormalConstructor})
       _ -> do
         argTys' <- mapM resolveTypeSynonyms argTys
         args <- newNameList "arg" $ length argTys'
-        let exp = [|A.object|] `appE` pairs
-
-            pairs | omitNothingFields opts = infixApp maybeFields
+        let pairs | omitNothingFields opts = infixApp maybeFields
                                                       [|(++)|]
                                                       restFields
-                  | otherwise = listE $ map toPair argCons
+                  | otherwise = listE $ map pureToPair argCons
 
-            argCons = zip3 args argTys' fields
+            argCons = zip3 (map varE args) argTys' fields
 
             maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
 
-            restFields = listE $ map toPair rest
-
-            (maybes, rest) = partition isMaybe argCons
+            restFields = listE $ map pureToPair rest
 
-            maybeToPair (arg, argTy, field) =
-                infixApp ([|keyValuePairWith|]
-                            `appE` dispatchToJSON jc conName tvMap argTy
-                            `appE` toFieldName field)
-                         [|(<$>)|]
-                         (varE arg)
+            (maybes0, rest0) = partition isMaybe argCons
+            (options, rest) = partition isOption rest0
+            maybes = maybes0 ++ map optionToMaybe options
 
-            toPair (arg, argTy, field) =
-                [|keyValuePairWith|]
-                  `appE` dispatchToJSON jc conName tvMap argTy
-                  `appE` toFieldName field
-                  `appE` varE arg
+            maybeToPair = toPairLifted True
+            pureToPair = toPairLifted False
 
-            toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field
+            toPairLifted lifted (arg, argTy, field) =
+              let toValue = dispatchToJSON target jc conName tvMap argTy
+                  fieldName = fieldLabel opts field
+                  e arg' = toPair target fieldName (toValue `appE` arg')
+              in if lifted
+                then do
+                  x <- newName "x"
+                  infixApp (lam1E (varP x) (e (varE x))) [|(<$>)|] arg
+                else e arg
 
         match (conP conName $ map varP args)
-              ( normalB
-              $ if multiCons
-                then case sumEncoding opts of
-                       TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
-                       TaggedObject{tagFieldName} ->
-                           [|A.object|] `appE`
-                             -- TODO: Maybe throw an error in case
-                             -- tagFieldName overwrites a field in pairs.
-                             infixApp (infixApp [|T.pack tagFieldName|]
-                                                [|(.=)|]
-                                                (conStr opts conName))
-                                      [|(:)|]
-                                      pairs
-                       ObjectWithSingleField ->
-                           [|A.object|] `appE` listE
-                             [ infixApp (conTxt opts conName) [|(.=)|] exp ]
-                       UntaggedValue -> exp
-                else exp
-              ) []
+              (normalB $ recordSumToValue target opts multiCons (null argTys) conName pairs)
+              []
 
 -- Infix constructors.
-argsToValue jc tvMap opts multiCons
+argsToValue target jc tvMap opts multiCons
   ConstructorInfo { constructorName    = conName
                   , constructorVariant = InfixConstructor
                   , constructorFields  = argTys } = do
@@ -541,11 +510,12 @@
     ar <- newName "argR"
     match (infixP (varP al) conName (varP ar))
           ( normalB
-          $ sumToValue opts multiCons False conName
-          $ [|toJSON|] `appE` listE [ dispatchToJSON jc conName tvMap aTy
-                                        `appE` varE a
-                                    | (a, aTy) <- [(al,alTy), (ar,arTy)]
-                                    ]
+          $ opaqueSumToValue target opts multiCons False conName
+          $ array target
+              [ dispatchToJSON target jc conName tvMap aTy
+                  `appE` varE a
+              | (a, aTy) <- [(al,alTy), (ar,arTy)]
+              ]
           )
           []
 
@@ -553,6 +523,13 @@
 isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe
 isMaybe _                       = False
 
+isOption :: (a, Type, b) -> Bool
+isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option
+isOption _                       = False
+
+optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c)
+optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)
+
 (<^>) :: ExpQ -> ExpQ -> ExpQ
 (<^>) a b = infixApp a [|(E.><)|] b
 infixr 6 <^>
@@ -565,139 +542,85 @@
 (<%>) a b = a <^> [|E.comma|] <^> b
 infixr 4 <%>
 
-array :: ExpQ -> ExpQ
-array exp = [|E.wrapArray|] `appE` exp
-
-object :: ExpQ -> ExpQ
-object exp = [|E.wrapObject|] `appE` exp
-
-sumToEncoding :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
-sumToEncoding opts multiCons nullary conName exp
-    | multiCons =
-        let fexp = exp in
-        case sumEncoding opts of
-          TwoElemArray ->
-            array (encStr opts conName <%> fexp)
-          TaggedObject{tagFieldName, contentsFieldName} ->
-            let tag      = [|E.text (T.pack tagFieldName)|]      <:> encStr opts conName
-                contents = [|E.text (T.pack contentsFieldName)|] <:> fexp
-            in
-              object $
-                if nullary then tag else tag <%> contents
-          ObjectWithSingleField ->
-            object (encStr opts conName <:> fexp)
-          UntaggedValue | nullary -> encStr opts conName
-          UntaggedValue -> exp
-    | otherwise = exp
-
--- | Generates code to generate the JSON encoding of a single constructor.
-argsToEncoding :: JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match
-
--- Polyadic constructors with special case for unary constructors.
-argsToEncoding jc tvMap opts multiCons
-  ConstructorInfo { constructorName    = conName
-                  , constructorVariant = NormalConstructor
-                  , constructorFields  = argTys } = do
-    argTys' <- mapM resolveTypeSynonyms argTys
-    args <- newNameList "arg" $ length argTys'
-    js <- case zip args argTys' of
-            -- Nullary constructors are converted to an empty array.
-            [] -> return [| E.emptyArray_ |]
-
-            -- Single argument is directly converted.
-            [(e,eTy)] -> return (dispatchToEncoding jc conName tvMap eTy
-                                   `appE` varE e)
-            -- Multiple arguments are converted to a JSON array.
-            es  ->
-              return (array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap xTy
-                                              `appE` varE x
-                                          | (x,xTy) <- es
-                                          ]))
-    match (conP conName $ map varP args)
-          (normalB $ sumToEncoding opts multiCons (null argTys') conName js)
-          []
-
--- Records.
-argsToEncoding jc tvMap opts multiCons
-  info@ConstructorInfo { constructorName    = conName
-                       , constructorVariant = RecordConstructor fields
-                       , constructorFields  = argTys } =
-    case (unwrapUnaryRecords opts, not multiCons, argTys) of
-      (True,True,[_]) -> argsToEncoding jc tvMap opts multiCons
-                                        (info{constructorVariant = NormalConstructor})
-      _ -> do
-        argTys' <- mapM resolveTypeSynonyms argTys
-        args <- newNameList "arg" $ length argTys'
-        let exp = object objBody
-
-            objBody = [|E.econcat|] `appE`
-                      ([|intersperse E.comma|] `appE` pairs)
-            pairs | omitNothingFields opts = infixApp maybeFields
-                                                      [|(++)|]
-                                                      restFields
-                  | otherwise = listE (map toPair argCons)
-
-            argCons = zip3 args argTys' fields
-
-            maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
+-- | Wrap a list of quoted 'Value's in a quoted 'Array' (of type 'Value').
+array :: ToJSONFun -> [ExpQ] -> ExpQ
+array Encoding [] = [|E.emptyArray_|]
+array Value [] = [|Array V.empty|]
+array Encoding es = [|E.wrapArray|] `appE` foldr1 (<%>) es
+array Value es = do
+  mv <- newName "mv"
+  let newMV = bindS (varP mv)
+                    ([|VM.unsafeNew|] `appE`
+                      litE (integerL $ fromIntegral (length es)))
+      stmts = [ noBindS $
+                  [|VM.unsafeWrite|] `appE`
+                    varE mv `appE`
+                      litE (integerL ix) `appE`
+                        e
+              | (ix, e) <- zip [(0::Integer)..] es
+              ]
+      ret = noBindS $ [|return|] `appE` varE mv
+  [|Array|] `appE`
+             (varE 'V.create `appE`
+               doE (newMV:stmts++[ret]))
 
-            restFields = listE (map toPair rest)
+-- | Wrap an associative list of keys and quoted values in a quoted 'Object'.
+object :: ToJSONFun -> [(String, ExpQ)] -> ExpQ
+object target = wrapObject target . catPairs target . fmap (uncurry (toPair target))
 
-            (maybes, rest) = partition isMaybe argCons
+-- |
+-- - When deriving 'ToJSON', map a list of quoted key-value pairs to an
+--   expression of the list of pairs.
+-- - When deriving 'ToEncoding', map a list of quoted 'Encoding's representing
+--   key-value pairs to a comma-separated 'Encoding' of them.
+--
+-- > catPairs Value [ [|(k0,v0)|], [|(k1,v1)|] ] = [| [(k0,v0), (k1,v1)] |]
+-- > catPairs Encoding [ [|"\"k0\":v0"|], [|"\"k1\":v1"|] ] = [| "\"k0\":v0,\"k1\":v1" |]
+catPairs :: ToJSONFun -> [ExpQ] -> ExpQ
+catPairs Value = listE
+catPairs Encoding = foldr1 (<%>)
 
-            maybeToPair (arg, argTy, field) =
-                infixApp
-                  (infixApp
-                    (infixE
-                      (Just $ toFieldName field <^> [|E.colon|])
-                      [|(E.><)|]
-                      Nothing)
-                    [|(.)|]
-                    (dispatchToEncoding jc conName tvMap argTy))
-                  [|(<$>)|]
-                  (varE arg)
+-- |
+-- - When deriving 'ToJSON', wrap a quoted list of key-value pairs in an 'Object'.
+-- - When deriving 'ToEncoding', wrap a quoted list of encoded key-value pairs
+--   in an encoded 'Object'.
+--
+-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]
+-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "{\"k0\":v0,\"k1\":v1}" |]
+objectExp :: ToJSONFun -> ExpQ -> ExpQ
+objectExp target = wrapObject target . catPairsExp target
 
-            toPair (arg, argTy, field) =
-              toFieldName field
-                <:> dispatchToEncoding jc conName tvMap argTy
-                      `appE` varE arg
+-- | Counterpart of 'catPairsExp' when the list of pairs is already quoted.
+--
+-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| [(k0,v0), (k1,v1)] |]
+-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "\"k0\":v0,\"k1\":v1" |]
+catPairsExp :: ToJSONFun -> ExpQ -> ExpQ
+catPairsExp Value e = e
+catPairsExp Encoding e = [|commaSep|] `appE` e
 
-            toFieldName field = [|E.text|] `appE`
-                                ([|T.pack|] `appE` fieldLabelExp opts field)
+-- | Create (an encoding of) a key-value pair.
+--
+-- > toPair Value "k" [|v|] = [|("k",v)|]  -- The quoted string is actually Text.
+-- > toPair Encoding "k" [|"v"|] = [|"\"k\":v"|]
+toPair :: ToJSONFun -> String -> ExpQ -> ExpQ
+toPair Value k v = infixApp [|T.pack k|] [|(.=)|] v
+toPair Encoding k v = [|E.string k|] <:> v
 
-        match (conP conName $ map varP args)
-              ( normalB
-              $ if multiCons
-                then case sumEncoding opts of
-                       TwoElemArray -> array $
-                         encStr opts conName <%>  exp
-                       TaggedObject{tagFieldName} -> object $
-                         ([|E.text (T.pack tagFieldName)|] <:>
-                          encStr opts conName) <%>
-                         objBody
-                       ObjectWithSingleField -> object $
-                         encStr opts conName <:> exp
-                       UntaggedValue -> exp
-                else exp
-              ) []
+-- | Map an associative list in an 'Object'.
+--
+-- > wrapObject Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]
+-- > wrapObject Encoding [| "\"k0\":v0,\"k1\":v1" |] = [| "{\"k0\":v0,\"k1\":v1}" |]
+wrapObject :: ToJSONFun -> ExpQ -> ExpQ
+wrapObject Value e = [|A.object|] `appE` e
+wrapObject Encoding e = [|E.wrapObject|] `appE` e
 
--- Infix constructors.
-argsToEncoding jc tvMap opts multiCons
-  ConstructorInfo { constructorName    = conName
-                  , constructorVariant = InfixConstructor
-                  , constructorFields  = argTys } = do
-    al <- newName "argL"
-    ar <- newName "argR"
-    [alTy,arTy] <- mapM resolveTypeSynonyms argTys
-    match (infixP (varP al) conName (varP ar))
-          ( normalB
-          $ sumToEncoding opts multiCons False conName
-          $ array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap aTy
-                                    `appE` varE a
-                                | (a,aTy) <- [(al,alTy), (ar,arTy)]
-                                ])
-          )
-          []
+-- | Separate 'Encoding's by commas.
+--
+-- > commaSep ["a","b","c"] = "a,b,c"
+commaSep :: [E.Encoding] -> E.Encoding
+commaSep [] = E.empty
+commaSep [x] = x
+commaSep (x : xs) = x E.>< E.comma E.>< commaSep xs
 
 --------------------------------------------------------------------------------
 -- FromJSON
@@ -824,8 +747,7 @@
                   [ liftM2 (,) (normalG $
                                   infixApp (varE txt)
                                            [|(==)|]
-                                           ([|T.pack|] `appE`
-                                              conStringE opts conName)
+                                           (conTxt opts conName)
                                )
                                ([|pure|] `appE` conE conName)
                   | con <- cons
@@ -917,7 +839,7 @@
       caseE (varE conVal)
         [ match (conP 'String [varP str])
                 (guardedB
-                  [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] ([|T.pack|] `appE` conStringE opts conName)
+                  [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] (conTxt opts conName)
                                )
                                ([|pure|] `appE` conE conName)
                   ]
@@ -1061,7 +983,7 @@
                `appE` litE (stringL $ show tName)
                `appE` litE (stringL $ constructorTagModifier opts $ nameBase conName)
                `appE` varE obj
-               `appE` ( [|T.pack|] `appE` fieldLabelExp opts field
+               `appE` ( [|T.pack|] `appE` stringE (fieldLabel opts field)
                       )
              | (field, argTy) <- zip fields argTys
              ]
@@ -1234,6 +1156,11 @@
 instance INCOHERENT_ LookupField (Maybe a) where
     lookupField pj _ _ = parseOptionalFieldWith pj
 
+instance INCOHERENT_ LookupField (Semigroup.Option a) where
+    lookupField pj tName rec obj key =
+        fmap Semigroup.Option
+             (lookupField (fmap Semigroup.getOption . pj) tName rec obj key)
+
 lookupFieldWith :: (Value -> Parser a) -> String -> String
                 -> Object -> T.Text -> Parser a
 lookupFieldWith pj tName rec obj key =
@@ -1241,9 +1168,6 @@
       Nothing -> unknownFieldFail tName rec (T.unpack key)
       Just v  -> pj v <?> Key key
 
-keyValuePairWith :: (v -> Value) -> T.Text -> v -> Pair
-keyValuePairWith tj name value = (name, tj value)
-
 unknownFieldFail :: String -> String -> String -> Parser fail
 unknownFieldFail tName rec key =
     fail $ printf "When parsing the record %s of type %s the key %s was not present."
@@ -1413,10 +1337,13 @@
                                    (interleave rhsArgs rhsArgs)
             else varE $ jsonFunValOrListName list jf Arity0
 
-dispatchToJSON, dispatchToEncoding, dispatchParseJSON
+dispatchToJSON
+  :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp
+dispatchToJSON target jc n tvMap =
+    dispatchFunByType jc (targetToJSONFun target) n tvMap False
+
+dispatchParseJSON
   :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
-dispatchToJSON     jc n tvMap = dispatchFunByType jc ToJSON     n tvMap False
-dispatchToEncoding jc n tvMap = dispatchFunByType jc ToEncoding n tvMap False
 dispatchParseJSON  jc n tvMap = dispatchFunByType jc ParseJSON  n tvMap False
 
 --------------------------------------------------------------------------------
@@ -1884,11 +1811,11 @@
                 . nameBase
                 . constructorName
 
--- | Creates a string literal expression from a record field label.
-fieldLabelExp :: Options -- ^ Encoding options
-              -> Name
-              -> Q Exp
-fieldLabelExp opts = litE . stringL . fieldLabelModifier opts . nameBase
+-- | Extracts a record field label.
+fieldLabel :: Options -- ^ Encoding options
+           -> Name
+           -> String
+fieldLabel opts = fieldLabelModifier opts . nameBase
 
 -- | The name of the outermost 'Value' constructor.
 valueConName :: Value -> String
@@ -2020,6 +1947,13 @@
 
 -- | A representation of which typeclass method is being spliced in.
 data JSONFun = ToJSON | ToEncoding | ParseJSON
+
+-- | A refinement of JSONFun to [ToJSON, ToEncoding].
+data ToJSONFun = Value | Encoding
+
+targetToJSONFun :: ToJSONFun -> JSONFun
+targetToJSONFun Value = ToJSON
+targetToJSONFun Encoding = ToEncoding
 
 -- | A representation of which typeclass is being derived.
 data JSONClass = JSONClass { direction :: Direction, arity :: Arity }
diff --git a/Data/Aeson/Types.hs b/Data/Aeson/Types.hs
--- a/Data/Aeson/Types.hs
+++ b/Data/Aeson/Types.hs
@@ -84,6 +84,7 @@
     , withNumber
     , withScientific
     , withBool
+    , withEmbeddedJSON
 
     , pairs
     , foldable
diff --git a/Data/Aeson/Types/Class.hs b/Data/Aeson/Types/Class.hs
--- a/Data/Aeson/Types/Class.hs
+++ b/Data/Aeson/Types/Class.hs
@@ -73,6 +73,7 @@
     , withNumber
     , withScientific
     , withBool
+    , withEmbeddedJSON
 
     -- * Functions
     , fromJSON
diff --git a/Data/Aeson/Types/FromJSON.hs b/Data/Aeson/Types/FromJSON.hs
--- a/Data/Aeson/Types/FromJSON.hs
+++ b/Data/Aeson/Types/FromJSON.hs
@@ -55,6 +55,7 @@
     , withNumber
     , withScientific
     , withBool
+    , withEmbeddedJSON
 
     -- * Functions
     , fromJSON
@@ -82,6 +83,7 @@
 import Control.Applicative ((<|>), Const(..))
 import Control.Monad ((<=<), zipWithM)
 import Data.Aeson.Internal.Functions (mapKey)
+import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
 import Data.Aeson.Types.Generic
 import Data.Aeson.Types.Internal
 import Data.Attoparsec.Number (Number(..))
@@ -114,6 +116,7 @@
 import Numeric.Natural (Natural)
 import Text.ParserCombinators.ReadP (readP_to_S)
 import Unsafe.Coerce (unsafeCoerce)
+import qualified Data.Aeson.Compat as Compat
 import qualified Data.Aeson.Parser.Time as Time
 import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
 import qualified Data.DList as DList
@@ -316,7 +319,7 @@
 --
 -- @
 -- instance 'FromJSON' Coord where
---     'parseJSON' = 'withObject' \"Coord\" $ \v -> Coord
+--     'parseJSON' = 'withObject' \"Coord\" $ \\v -> Coord
 --         '<$>' v '.:' \"x\"
 --         '<*>' v '.:' \"y\"
 -- @
@@ -665,6 +668,16 @@
 withBool expected _ v          = typeMismatch expected v
 {-# INLINE withBool #-}
 
+-- | Decode a nested JSON-encoded string.
+withEmbeddedJSON :: (FromJSON a) => String -> (Value -> Parser a) -> Value -> Parser a
+withEmbeddedJSON _ innerParser (String txt) =
+    either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)
+    where
+        eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
+        eitherFormatError = either (Left . uncurry formatError) Right
+withEmbeddedJSON name _ v = typeMismatch name v
+{-# INLINE withEmbeddedJSON #-}
+
 -- | Convert a value from JSON, failing if the types do not match.
 fromJSON :: (FromJSON a) => Value -> Result a
 fromJSON = parse parseJSON
@@ -1034,6 +1047,14 @@
         where
           label = fieldLabelModifier opts $
                     selName (undefined :: t s (K1 i (Maybe a)) p)
+
+-- Parse an Option like a Maybe.
+instance INCOHERENT_ (Selector s, FromJSON a) =>
+  FromRecord arity (S1 s (K1 i (Semigroup.Option a))) where
+    parseRecord opts fargs lab obj = wrap <$> parseRecord opts fargs lab obj
+      where
+        wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
+        wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
 
 --------------------------------------------------------------------------------
 
diff --git a/Data/Aeson/Types/ToJSON.hs b/Data/Aeson/Types/ToJSON.hs
--- a/Data/Aeson/Types/ToJSON.hs
+++ b/Data/Aeson/Types/ToJSON.hs
@@ -1023,6 +1023,19 @@
     recordToPairs opts targs m1 = fieldToPair opts targs m1
     {-# INLINE recordToPairs #-}
 
+instance INCOHERENT_
+    ( Selector s
+    , GToJSON enc arity (K1 i (Maybe a))
+    , GKeyValue enc pairs
+    , Monoid pairs
+    ) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a)))
+  where
+    recordToPairs opts targs = recordToPairs opts targs . unwrap
+      where
+        unwrap :: S1 s (K1 i (Semigroup.Option a)) p -> S1 s (K1 i (Maybe a)) p
+        unwrap (M1 (K1 (Semigroup.Option a))) = M1 (K1 a)
+    {-# INLINE recordToPairs #-}
+
 fieldToPair :: (Selector s
                , GToJSON enc arity a
                , GKeyValue enc pairs)
diff --git a/aeson.cabal b/aeson.cabal
--- a/aeson.cabal
+++ b/aeson.cabal
@@ -1,5 +1,5 @@
 name:            aeson
-version:         1.2.2.0
+version:         1.2.3.0
 license:         BSD3
 license-file:    LICENSE
 category:        Text, Web, JSON
@@ -100,6 +100,7 @@
     Data.Aeson.Encode
 
   other-modules:
+    Data.Aeson.Compat
     Data.Aeson.Encoding.Builder
     Data.Aeson.Internal.Functions
     Data.Aeson.Parser.Unescape
@@ -199,7 +200,7 @@
 
   build-depends:
     HUnit,
-    QuickCheck >= 2.8 && <2.11,
+    QuickCheck >= 2.10.0.1 && < 2.11,
     aeson,
     integer-logarithms >= 1 && <1.1,
     attoparsec,
@@ -226,7 +227,7 @@
     unordered-containers,
     uuid-types,
     vector,
-    quickcheck-instances >=0.3.14
+    quickcheck-instances >= 0.3.16
 
   if flag(bytestring-builder)
     build-depends: bytestring >= 0.9 && < 0.10.4,
diff --git a/benchmarks/Escape.hs b/benchmarks/Escape.hs
new file mode 100644
--- /dev/null
+++ b/benchmarks/Escape.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main (main) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Criterion.Main
+import qualified "aeson-benchmarks" Data.Aeson.Parser.UnescapeFFI as FFI
+import qualified "aeson-benchmarks" Data.Aeson.Parser.UnescapePure as Pure
+
+import qualified Data.ByteString.Char8 as BS
+
+n :: Int
+n = 10000
+
+input :: BS.ByteString
+input = BS.concat $ replicate n $ BS.pack "\\\""
+
+main :: IO ()
+main = defaultMain
+    [ bench "ffi"  $ whnf FFI.unescapeText input
+    , bench "pure" $ whnf Pure.unescapeText input
+    ]
diff --git a/benchmarks/aeson-benchmarks.cabal b/benchmarks/aeson-benchmarks.cabal
--- a/benchmarks/aeson-benchmarks.cabal
+++ b/benchmarks/aeson-benchmarks.cabal
@@ -80,6 +80,20 @@
   ghc-options: -O2 -Wall
   cpp-options: -DGENERICS
 
+executable aeson-benchmark-escape
+  main-is: Escape.hs
+  hs-source-dirs: ../examples .
+  ghc-options: -Wall -O2 -rtsopts
+  build-depends:
+    aeson-benchmarks,
+    base,
+    base-compat,
+    bytestring,
+    criterion >= 1.0,
+    deepseq,
+    ghc-prim,
+    text
+
 executable aeson-benchmark-compare
   main-is: Compare.hs
   hs-source-dirs: ../examples .
diff --git a/changelog.md b/changelog.md
--- a/changelog.md
+++ b/changelog.md
@@ -1,5 +1,12 @@
 For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md).
 
+### 1.2.3.0
+
+* Added `withEmbeddedJSON` to help parse JSON embedded inside a JSON string, thanks to Jesse Kempf.
+* Memory usage improvements to the default (pure) parser, thanks to Jonathan Paugh. Also thanks to Neil Mitchell & Oleg Grenrus for contributing a benchmark.
+* `omitNothingFields` now works for the `Option` newtype, thanks to Xia Li-yao.
+* Some documentation fixes, thanks to Jonathan Paug & Philippe Crama.
+
 ### 1.2.2.0
 
 * Add `FromJSON` and `ToJSON` instances for
diff --git a/pure/Data/Aeson/Parser/UnescapePure.hs b/pure/Data/Aeson/Parser/UnescapePure.hs
--- a/pure/Data/Aeson/Parser/UnescapePure.hs
+++ b/pure/Data/Aeson/Parser/UnescapePure.hs
@@ -119,8 +119,6 @@
     w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word)
     _                          -> throwDecodeError
 
-{-# INLINE decode #-}
-
 decodeHex :: Word8 -> Word16
 decodeHex 48  = 0  -- '0'
 decodeHex 49  = 1  -- '1'
@@ -145,13 +143,13 @@
 decodeHex 70  = 15 -- 'F'
 decodeHex 102 = 15 -- 'f'
 decodeHex _ = throwDecodeError
-{-# INLINE decodeHex #-}
 
 unescapeText' :: ByteString -> Text
 unescapeText' bs = runText $ \done -> do
     dest <- A.new len
-    (pos, finalState) <- B.foldl' (f' dest) (return (0, StateNone)) bs
 
+    (pos, finalState) <- loop dest (0, StateNone) 0
+
     -- Check final state. Currently pos gets only increased over time, so this check should catch overflows.
     when ( finalState /= StateNone || pos > len)
       throwDecodeError
@@ -172,11 +170,12 @@
         (st', p) ->
             return (pos, StateUtf st' p)
 
-      {-# INLINE runUtf #-}
-
-      f' dest m c = m >>= \s -> f dest s c
-
-      {-# INLINE f' #-}
+      loop :: A.MArray s -> (Int, State) -> Int -> ST s (Int, State)
+      loop _ ps i | i >= len = return ps
+      loop dest ps i = do
+        let c = B.index bs i -- JP: We can use unsafe index once we prove bounds with Liquid Haskell.
+        ps' <- f dest ps c
+        loop dest ps' $ i+1
 
       -- No pending state.
       f dest (pos, StateNone) c = runUtf dest pos UtfGround 0 c
@@ -253,8 +252,6 @@
         else
           writeAndReturn dest pos u StateNone
 
-      {-# INLINE f #-}
-
 write :: A.MArray s -> Int -> Word16 -> ST s ()
 write dest pos char =
     A.unsafeWrite dest pos char
@@ -270,8 +267,6 @@
 throwDecodeError =
     let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" in
     throw (DecodeError desc Nothing)
-{-# INLINE throwDecodeError #-}
 
 unescapeText :: ByteString -> Either UnicodeException Text
 unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'
-{-# INLINE unescapeText #-}
diff --git a/stack-ffi-unescape.yaml b/stack-ffi-unescape.yaml
new file mode 100644
--- /dev/null
+++ b/stack-ffi-unescape.yaml
@@ -0,0 +1,7 @@
+resolver: nightly-2017-09-04
+packages:
+- '.'
+flags:
+  aeson:
+    fast: true
+    cffi: true
diff --git a/stack-lts6.yaml b/stack-lts6.yaml
--- a/stack-lts6.yaml
+++ b/stack-lts6.yaml
@@ -4,12 +4,16 @@
 - attoparsec-iso8601
 extra-deps:
 - integer-logarithms-1
-- QuickCheck-2.9.2
-- quickcheck-instances-0.3.14
 - semigroups-0.18.2
 - tagged-0.8.5
-- th-abstraction-0.2.2.0
 - transformers-compat-0.5.1.4
+- QuickCheck-2.10.0.1
+- base-compat-0.9.3
+- hashable-1.2.6.1
+- integer-logarithms-1
+- quickcheck-instances-0.3.16
+- test-framework-quickcheck2-0.3.0.4
+- th-abstraction-0.2.2.0
 flags:
 flags:
   aeson:
diff --git a/stack-lts7.yaml b/stack-lts7.yaml
--- a/stack-lts7.yaml
+++ b/stack-lts7.yaml
@@ -3,8 +3,12 @@
 - '.'
 - attoparsec-iso8601
 extra-deps:
+- QuickCheck-2.10.0.1
+- base-compat-0.9.3
+- hashable-1.2.6.1
 - integer-logarithms-1
-- quickcheck-instances-0.3.14
+- quickcheck-instances-0.3.16
+- test-framework-quickcheck2-0.3.0.4
 - th-abstraction-0.2.2.0
 flags:
   aeson:
diff --git a/stack-lts8.yaml b/stack-lts8.yaml
--- a/stack-lts8.yaml
+++ b/stack-lts8.yaml
@@ -3,8 +3,11 @@
 - '.'
 - attoparsec-iso8601
 extra-deps:
-- quickcheck-instances-0.3.14
+- QuickCheck-2.10.0.1
+- base-compat-0.9.3
+- quickcheck-instances-0.3.16
 - th-abstraction-0.2.2.0
+- test-framework-quickcheck2-0.3.0.4
 flags:
   aeson:
     fast: true
diff --git a/stack-pure-unescape.yaml b/stack-pure-unescape.yaml
deleted file mode 100644
--- a/stack-pure-unescape.yaml
+++ /dev/null
@@ -1,10 +0,0 @@
-resolver: lts-8.1
-packages:
-- '.'
-extra-deps:
-- quickcheck-instances-0.3.14
-- th-abstraction-0.2.2.0
-flags:
-  aeson:
-    fast: true
-    cffi: false
diff --git a/tests/Encoders.hs b/tests/Encoders.hs
--- a/tests/Encoders.hs
+++ b/tests/Encoders.hs
@@ -235,6 +235,33 @@
 gSomeTypeToEncodingOmitNothingFields :: SomeType Int -> Encoding
 gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields
 
+
+--------------------------------------------------------------------------------
+-- Option fields
+--------------------------------------------------------------------------------
+
+thOptionFieldToJSON :: OptionField -> Value
+thOptionFieldToJSON = $(mkToJSON optsOptionField 'OptionField)
+
+thOptionFieldToEncoding :: OptionField -> Encoding
+thOptionFieldToEncoding = $(mkToEncoding optsOptionField 'OptionField)
+
+thOptionFieldParseJSON :: Value -> Parser OptionField
+thOptionFieldParseJSON = $(mkParseJSON optsOptionField 'OptionField)
+
+gOptionFieldToJSON :: OptionField -> Value
+gOptionFieldToJSON = genericToJSON optsOptionField
+
+gOptionFieldToEncoding :: OptionField -> Encoding
+gOptionFieldToEncoding = genericToEncoding optsOptionField
+
+gOptionFieldParseJSON :: Value -> Parser OptionField
+gOptionFieldParseJSON = genericParseJSON optsOptionField
+
+thMaybeFieldToJSON :: MaybeField -> Value
+thMaybeFieldToJSON = $(mkToJSON optsOptionField 'MaybeField)
+
+
 --------------------------------------------------------------------------------
 -- IncoherentInstancesNeeded
 --------------------------------------------------------------------------------
diff --git a/tests/Instances.hs b/tests/Instances.hs
--- a/tests/Instances.hs
+++ b/tests/Instances.hs
@@ -22,31 +22,12 @@
 import qualified Data.DList as DList
 import qualified Data.HashMap.Strict as HM
 
-#if !MIN_VERSION_QuickCheck(2,9,0)
-import Control.Applicative (Const(..))
-import Data.Functor.Identity (Identity (..))
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.Version
-import Test.QuickCheck (getNonNegative, listOf1, resize)
-#endif
-
-#if !MIN_VERSION_QuickCheck(2,10,0)
-import Data.Functor.Compose (Compose (..))
-import Data.Proxy (Proxy(..))
-#endif
-
 import Data.Orphans ()
 import Test.QuickCheck.Instances ()
 #if MIN_VERSION_base(4,7,0)
 import Data.Hashable.Time ()
 #endif
 
-#if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,8,3)
-import Numeric.Natural
-#endif
-
-{-# ANN module ("HLint: ignore Use fewer imports"::String) #-}
-
 -- "System" types.
 
 instance Arbitrary DotNetTime where
@@ -174,49 +155,15 @@
 instance Arbitrary (GADT String) where
     arbitrary = GADT <$> arbitrary
 
+instance Arbitrary OptionField where
+    arbitrary = OptionField <$> arbitrary
+
+
 instance ApproxEq Char where
     (=~) = (==)
 
 instance (ApproxEq a) => ApproxEq [a] where
     a =~ b = length a == length b && all (uncurry (=~)) (zip a b)
 
--- Version tags are deprecated, so we avoid using them in the Arbitrary
--- instance. However, the recommended constructor 'makeVersion' is not
--- exported by "Data.Version" until base-4.8.0.0. For previous versions,
--- a definition is given below.
-
-
-#if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,8,3)
-instance Arbitrary Natural where
-  arbitrary = fromInteger . abs <$> arbitrary
-#endif
-
-#if !MIN_VERSION_QuickCheck(2,10,0)
-instance Arbitrary (Proxy a) where
-    arbitrary = pure Proxy
-
-instance Arbitrary (f (g a)) => Arbitrary (Compose f g a) where
-    arbitrary = Compose <$> arbitrary
-#endif
-
 instance Arbitrary a => Arbitrary (DList.DList a) where
     arbitrary = DList.fromList <$> arbitrary
-
-#if !MIN_VERSION_QuickCheck(2,9,0)
-instance Arbitrary a => Arbitrary (Const a b) where
-    arbitrary = Const <$> arbitrary
-
-instance Arbitrary a => Arbitrary (NonEmpty a) where
-    arbitrary = (:|) <$> arbitrary <*> arbitrary
-
-instance Arbitrary Version where
-    arbitrary = makeVersion . fmap getNonNegative <$> resize 4 (listOf1 arbitrary)
-
-#if !MIN_VERSION_base(4,8,0)
-makeVersion :: [Int] -> Version
-makeVersion b = Version b []
-#endif
-
-instance Arbitrary a => Arbitrary (Identity a) where
-    arbitrary = Identity <$> arbitrary
-#endif
diff --git a/tests/Options.hs b/tests/Options.hs
--- a/tests/Options.hs
+++ b/tests/Options.hs
@@ -48,3 +48,9 @@
                             { tagSingleConstructors = True
                             , allNullaryToStringTag = False
                             }
+
+optsOptionField :: Options
+optsOptionField = optsDefault
+                  { fieldLabelModifier = const "field"
+                  , omitNothingFields = True
+                  }
diff --git a/tests/Properties.hs b/tests/Properties.hs
--- a/tests/Properties.hs
+++ b/tests/Properties.hs
@@ -25,6 +25,7 @@
 import Data.Map (Map)
 import Data.Proxy (Proxy)
 import Data.Ratio (Ratio)
+import Data.Semigroup (Option(..))
 import Data.Sequence (Seq)
 import Data.Tagged (Tagged)
 import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)
@@ -142,7 +143,10 @@
 -- variation in JSON object key ordering.
 sameAs :: (a -> Value) -> (a -> Encoding) -> a -> Property
 sameAs toVal toEnc v =
-  eitherDecode (encodingToLazyByteString (toEnc v)) === Right (toVal v)
+  counterexample (show s) $
+    eitherDecode s === Right (toVal v)
+  where
+    s = encodingToLazyByteString (toEnc v)
 
 sameAs1
     :: (forall a. LiftToJSON f a)
@@ -376,6 +380,11 @@
           , testProperty "Tagged"  (toParseJSON gOneConstructorParseJSONTagged  gOneConstructorToJSONTagged)
           ]
         ]
+      , testGroup "OptionField" [
+          testProperty "like Maybe" $
+          \x -> gOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)
+        , testProperty "roundTrip" (toParseJSON gOptionFieldParseJSON gOptionFieldToJSON)
+        ]
       ]
     , testGroup "toEncoding" [
         testProperty "NullaryString" $
@@ -429,6 +438,9 @@
         gOneConstructorToJSONDefault `sameAs` gOneConstructorToEncodingDefault
       , testProperty "OneConstructorTagged" $
         gOneConstructorToJSONTagged `sameAs` gOneConstructorToEncodingTagged
+
+      , testProperty "OptionField" $
+        gOptionFieldToJSON `sameAs` gOptionFieldToEncoding
       ]
     ]
   , testGroup "template-haskell" [
@@ -489,6 +501,11 @@
           , testProperty "Tagged"  (toParseJSON thOneConstructorParseJSONTagged  thOneConstructorToJSONTagged)
           ]
         ]
+      , testGroup "OptionField" [
+          testProperty "like Maybe" $
+          \x -> thOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)
+        , testProperty "roundTrip" (toParseJSON thOptionFieldParseJSON thOptionFieldToJSON)
+        ]
       ]
     , testGroup "toEncoding" [
         testProperty "NullaryString" $
@@ -533,6 +550,9 @@
         thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault
       , testProperty "OneConstructorTagged" $
         thOneConstructorToJSONTagged `sameAs` thOneConstructorToEncodingTagged
+
+      , testProperty "OptionField" $
+        thOptionFieldToJSON `sameAs` thOptionFieldToEncoding
       ]
     ]
   ]
diff --git a/tests/Types.hs b/tests/Types.hs
--- a/tests/Types.hs
+++ b/tests/Types.hs
@@ -17,6 +17,7 @@
 import Data.Functor.Compose (Compose (..))
 import Data.Functor.Identity (Identity (..))
 import Data.Hashable (Hashable (..))
+import Data.Semigroup (Option)
 import Data.Text
 import Data.Time (Day (..), fromGregorian)
 import GHC.Generics
@@ -104,6 +105,10 @@
 deriving instance Eq   (GADT a)
 deriving instance Show (GADT a)
 
+newtype MaybeField = MaybeField { maybeField :: Maybe Int }
+newtype OptionField = OptionField { optionField :: Option Int }
+  deriving (Eq, Show)
+
 deriving instance Generic Foo
 deriving instance Generic UFoo
 deriving instance Generic OneConstructor
@@ -116,6 +121,7 @@
 #if __GLASGOW_HASKELL__ >= 706
 deriving instance Generic1 SomeType
 #endif
+deriving instance Generic OptionField
 deriving instance Generic EitherTextInt
 
 failure :: Show a => String -> String -> a -> Property
diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs
--- a/tests/UnitTests.hs
+++ b/tests/UnitTests.hs
@@ -8,17 +8,22 @@
 -- For Data.Aeson.Types.camelTo
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
 
+#if MIN_VERSION_base(4,9,0)
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+#endif
+
 module UnitTests
     (
       ioTests
     , tests
+    , withEmbeddedJSONTest
     ) where
 
 import Prelude ()
 import Prelude.Compat
 
 import Control.Monad (forM, forM_)
-import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject)
+import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject, withEmbeddedJSON)
 import Data.Aeson.Internal (JSONPathElement(..), formatError)
 import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1)
 import Data.Aeson.Text (encodeToTextBuilder)
@@ -93,6 +98,7 @@
   , testCase "Unescape string (PR #477)" unescapeString
   , testCase "Show Options" showOptions
   , testGroup "SingleMaybeField" singleMaybeField
+  , testCase "withEmbeddedJSON" withEmbeddedJSONTest
   ]
 
 roundTripCamel :: String -> Assertion
@@ -514,6 +520,19 @@
   where
     v = SingleMaybeField Nothing
     opts = defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True}
+
+
+newtype EmbeddedJSONTest = EmbeddedJSONTest Int
+  deriving (Eq, Show)
+
+instance FromJSON EmbeddedJSONTest where
+  parseJSON =
+    withObject "Object" $ \o ->
+      EmbeddedJSONTest <$> (o .: "prop" >>= withEmbeddedJSON "Quoted Int" parseJSON)
+
+withEmbeddedJSONTest :: Assertion
+withEmbeddedJSONTest =
+  assertEqual "Unquote embedded JSON" (Right $ EmbeddedJSONTest 1) (eitherDecode "{\"prop\":\"1\"}")
 
 deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord