diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,3 +1,10 @@
+## 1.3
+
+* Fixed an incorrect behaviour of `extractConstructor`
+* `WineryException` now contains a hierarchy of `TypeRep`s
+* Added `gvariantExtractors` and `buildVariantExtractor`
+* Added `SingleField`
+
 ## 1.2
 
 * Removed `Plan` and `mkPlan`
diff --git a/src/Codec/Winery.hs b/src/Codec/Winery.hs
--- a/src/Codec/Winery.hs
+++ b/src/Codec/Winery.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
@@ -40,6 +41,7 @@
   , schemaToBuilder
   , deserialiseSchema
   , Extractor(..)
+  , mkExtractor
   , unwrapExtractor
   , Decoder
   , evalDecoder
@@ -58,7 +60,9 @@
   , extractConstructorBy
   , extractProductItemBy
   , extractVoid
+  , buildVariantExtractor
   , ExtractException(..)
+  , SingleField(..)
   -- * Variable-length quantity
   , VarInt(..)
   -- * Internal
@@ -85,6 +89,7 @@
   , gtoBuilderVariant
   , gextractorVariant
   , gdecodeCurrentVariant
+  , gvariantExtractors
   , GEncodeProduct
   , GDecodeProduct
   , gschemaGenProduct
@@ -110,7 +115,6 @@
 import qualified Data.ByteString.FastBuilder as BB
 import Data.Function (fix)
 import qualified Data.Text as T
-import Data.Text.Prettyprint.Doc (pretty, dquotes)
 import Data.Typeable
 import qualified Data.Vector as V
 import GHC.Generics (Generic, Rep)
@@ -312,13 +316,10 @@
     Just (i, sch) -> do
       m <- g sch
       return $ \case
-        TRecord xs -> maybe (error msg) (m . snd) $ xs V.!? i
+        TRecord xs -> maybe (throw $ InvalidTerm (TRecord xs)) (m . snd) $ xs V.!? i
         t -> throw $ InvalidTerm t
-    _ -> throwStrategy $ FieldNotFound rep name (map fst $ V.toList schs)
-  s -> throwStrategy $ UnexpectedSchema rep "a record" s
-  where
-    rep = "extractFieldBy ... " <> dquotes (pretty name)
-    msg = "Codec.Winery.extractFieldBy ... " <> show name <> ": impossible"
+    _ -> throwStrategy $ FieldNotFound [] name (map fst $ V.toList schs)
+  s -> throwStrategy $ UnexpectedSchema [] "a record" s
 
 -- | Extract a field using the supplied 'Extractor'.
 extractProductItemBy :: Extractor a -> Int -> Subextractor a
@@ -327,13 +328,10 @@
     Just sch -> do
       m <- g sch
       return $ \case
-        TProduct xs -> maybe (error msg) m $ xs V.!? i
+        t@(TProduct xs) -> maybe (throw $ InvalidTerm t) m $ xs V.!? i
         t -> throw $ InvalidTerm t
-    _ -> throwStrategy $ ProductTooSmall i
-  s -> throwStrategy $ UnexpectedSchema rep "a record" s
-  where
-    rep = "extractProductItemBy ... " <> dquotes (pretty i)
-    msg = "Codec.Winery.extractProductItemBy ... " <> show i <> ": impossible"
+    _ -> throwStrategy $ ProductTooSmall [] i
+  s -> throwStrategy $ UnexpectedSchema [] "a record" s
 
 -- | Tries to extract a specific constructor of a variant. Useful for
 -- implementing backward-compatible extractors.
@@ -344,19 +342,24 @@
         run e s = runExtractor e s `unStrategy` decs
     case lookupWithIndexV name schs0 of
       Just (i, s) -> do
-        (j, dec) <- fmap ((,) i) $ run d $ case s of
-          SProduct [s'] -> s'
-          s' -> s'
+        dec <- case s of
+          -- Unwrap single-field constructor
+          SProduct [s'] -> do
+            dec <- runExtractor d s' `unStrategy` decs
+            pure $ \case
+              TProduct [v] -> dec v
+              t -> throw $ InvalidTerm t
+          _ -> runExtractor d s `unStrategy` decs
         let rest = SVariant $ V.filter ((/=name) . fst) schs0
         k <- run (unSubextractor cont) rest
         return $ \case
-          TVariant tag _ v
-            | tag == j -> f $ dec v
+          TVariant tag name' v
+            | tag == i -> f $ dec v
+            -- rest has fewer constructors
+            | tag > i -> k (TVariant (tag - 1) name' v)
           t -> k t
       _ -> run (unSubextractor cont) (SVariant schs0)
-  s -> throwStrategy $ UnexpectedSchema rep "a variant" s
-  where
-    rep = "extractConstructorBy ... " <> dquotes (pretty name)
+  s -> throwStrategy $ UnexpectedSchema [] "a variant" s
 
 -- | Tries to match on a constructor. If it doesn't match (or constructor
 -- doesn't exist at all), leave it to the successor.
@@ -371,7 +374,7 @@
 extractVoid = Subextractor $ mkExtractor $ \case
   SVariant schs0
     | V.null schs0 -> return $ throw . InvalidTerm
-  s -> throwStrategy $ UnexpectedSchema "extractVoid" "no constructors" s
+  s -> throwStrategy $ UnexpectedSchema [] "no constructors" s
 
 infixr 1 `extractConstructorBy`
 infixr 1 `extractConstructor`
@@ -408,3 +411,13 @@
   toBuilder = gtoBuilderVariant . unWineryVariant
   extractor = WineryVariant <$> gextractorVariant
   decodeCurrent = WineryVariant <$> gdecodeCurrentVariant
+
+-- | A product with one field. Useful when creating a custom extractor for constructors.
+newtype SingleField a = SingleField { getSingleField :: a }
+  deriving (Show, Eq, Ord, Generic)
+
+instance Serialise a => Serialise (SingleField a) where
+  schemaGen = gschemaGenProduct
+  toBuilder = gtoBuilderProduct
+  extractor = gextractorProduct
+  decodeCurrent = gdecodeCurrentProduct
diff --git a/src/Codec/Winery/Base.hs b/src/Codec/Winery/Base.hs
--- a/src/Codec/Winery/Base.hs
+++ b/src/Codec/Winery/Base.hs
@@ -32,6 +32,7 @@
   , StrategyEnv(..)
   , unwrapExtractor
   , WineryException(..)
+  , pushTrace
   , prettyWineryException
   )
   where
@@ -270,12 +271,23 @@
 {-# INLINE unwrapExtractor #-}
 {-# DEPRECATED unwrapExtractor "Use runExtractor instead" #-}
 
--- | Exceptions thrown when by an extractor
-data WineryException = UnexpectedSchema !(Doc AnsiStyle) !(Doc AnsiStyle) !Schema
-  | FieldNotFound !(Doc AnsiStyle) !T.Text ![T.Text]
-  | TypeMismatch !Int !TypeRep !TypeRep
-  | ProductTooSmall !Int
-  | UnboundVariable !Int
+pushTrace :: TypeRep -> WineryException -> WineryException
+pushTrace t (UnexpectedSchema xs d s) = UnexpectedSchema (t : xs) d s
+pushTrace t (FieldNotFound xs f fs) = FieldNotFound (t : xs) f fs
+pushTrace t (TypeMismatch xs i u v) = TypeMismatch (t : xs) i u v
+pushTrace t (ProductTooSmall xs i) = ProductTooSmall (t : xs) i
+pushTrace t (UnboundVariable xs i) = UnboundVariable (t : xs) i
+pushTrace _ x = x
+
+prettyTraces :: [TypeRep] -> Doc AnsiStyle
+prettyTraces = annotate (color Blue <> bold) . concatWith (\x y -> x <+> "/" <+> y) . map viaShow
+
+-- | Exceptions thrown by an extractor
+data WineryException = UnexpectedSchema ![TypeRep] !(Doc AnsiStyle) !Schema
+  | FieldNotFound ![TypeRep] !T.Text ![T.Text]
+  | TypeMismatch ![TypeRep] !Int !TypeRep !TypeRep
+  | ProductTooSmall ![TypeRep] !Int
+  | UnboundVariable ![TypeRep] !Int
   | EmptyInput
   | WineryMessage !(Doc AnsiStyle)
   | UnsupportedSchemaVersion !Word8
@@ -289,16 +301,19 @@
 -- | Pretty-print 'WineryException'
 prettyWineryException :: WineryException -> Doc AnsiStyle
 prettyWineryException = \case
-  UnexpectedSchema subject expected actual -> annotate bold subject
+  UnexpectedSchema subject expected actual -> prettyTraces subject
     <+> "expects" <+> annotate (color Green <> bold) expected
     <+> "but got " <+> pretty actual
-  FieldNotFound rep x xs -> rep <> ": field or constructor " <> pretty x <> " not found in " <> pretty xs
-  TypeMismatch i s t -> "A type mismatch in variable"
+  FieldNotFound rep x xs -> prettyTraces rep
+    <> ": field or constructor"
+    <+> annotate bold (pretty x)
+    <+> "not found in " <> pretty xs
+  TypeMismatch trace i s t -> prettyTraces trace <> ": A type mismatch in variable"
     <+> pretty i <> ":"
     <+> "expected" <> viaShow s
     <+> "but got " <> viaShow t
-  ProductTooSmall i -> "The product is too small; expecting " <> pretty i
-  UnboundVariable i -> "Unbound variable: " <> pretty i
+  ProductTooSmall trace i -> prettyTraces trace <> ": The product is too small; expecting " <> pretty i
+  UnboundVariable trace i -> prettyTraces trace <> ": Unbound variable: " <> pretty i
   EmptyInput -> "Unexpected empty string"
   UnsupportedSchemaVersion i -> "Unsupported schema version: " <> pretty i
   WineryMessage a -> a
diff --git a/src/Codec/Winery/Class.hs b/src/Codec/Winery/Class.hs
--- a/src/Codec/Winery/Class.hs
+++ b/src/Codec/Winery/Class.hs
@@ -29,6 +29,7 @@
   , unexpectedSchema
   , mkExtractor
   , extractListBy
+  , buildVariantExtractor
   , gschemaGenRecord
   , gtoBuilderRecord
   , gextractorRecord
@@ -51,6 +52,7 @@
   , gtoBuilderVariant
   , gextractorVariant
   , gdecodeCurrentVariant
+  , gvariantExtractors
   ) where
 
 import Control.Applicative
@@ -90,7 +92,6 @@
 import qualified Data.Vector.Storable as SV
 import qualified Data.Vector.Unboxed as UV
 import Data.Text.Prettyprint.Doc hiding ((<>), SText, SChar)
-import Data.Text.Prettyprint.Doc.Render.Terminal
 import Data.Time.Clock
 import Data.Time.Clock.POSIX
 import Data.Typeable
@@ -220,12 +221,15 @@
   where
     rep = typeRep p
 
-unexpectedSchema :: forall f a. Serialise a => Doc AnsiStyle -> Schema -> Strategy' (f a)
-unexpectedSchema subject actual = throwStrategy
-  $ UnexpectedSchema subject (pretty $ schema (Proxy @ a)) actual
+unexpectedSchema :: forall f a. Serialise a => Schema -> Strategy' (f a)
+unexpectedSchema actual = throwStrategy
+  $ UnexpectedSchema [] (pretty $ schema (Proxy @ a)) actual
 
-mkExtractor :: Typeable a => (Schema -> Strategy' (Term -> a)) -> Extractor a
-mkExtractor = Extractor . recursiveStrategy
+mkExtractor :: forall a. Typeable a => (Schema -> Strategy' (Term -> a)) -> Extractor a
+mkExtractor = Extractor . fmap addTrail . recursiveStrategy where
+  addTrail (Strategy f) = Strategy $ \env -> case f env of
+    Left e -> Left $! pushTrace (typeRep (Proxy @ a)) e
+    Right a -> Right a
 {-# INLINE mkExtractor #-}
 
 -- | Handle (recursive) schema bindings.
@@ -235,11 +239,11 @@
     | point : _ <- drop i decs -> case point of
       BoundSchema ofs' sch' -> recursiveStrategy k sch' `unStrategy` StrategyEnv ofs' (drop (ofs - ofs') decs)
       DynDecoder dyn -> case fromDynamic dyn of
-        Nothing -> Left $ TypeMismatch i
+        Nothing -> Left $ TypeMismatch [] i
           (typeRep (Proxy @ (Term -> a)))
           (dynTypeRep dyn)
         Just a -> Right a
-    | otherwise -> Left $ UnboundVariable i
+    | otherwise -> Left $ UnboundVariable [] i
   SFix s -> mfix $ \a -> recursiveStrategy k s `unStrategy` StrategyEnv (ofs + 1) (DynDecoder (toDyn a) : decs)
   SLet s t -> recursiveStrategy k t `unStrategy` StrategyEnv (ofs + 1) (BoundSchema ofs s : decs)
   s -> k s `unStrategy` StrategyEnv ofs decs
@@ -272,7 +276,7 @@
     SBool -> pure $ \case
       TBool b -> b
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Bool" s
+    s -> unexpectedSchema s
   decodeCurrent = (/=0) <$> getWord8
 
 instance Serialise Word8 where
@@ -283,7 +287,7 @@
     SWord8 -> pure $ \case
       TWord8 i -> i
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Word8" s
+    s -> unexpectedSchema s
   decodeCurrent = getWord8
 
 instance Serialise Word16 where
@@ -294,7 +298,7 @@
     SWord16 -> pure $ \case
       TWord16 i -> i
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Word16" s
+    s -> unexpectedSchema s
   decodeCurrent = getWord16
 
 instance Serialise Word32 where
@@ -305,7 +309,7 @@
     SWord32 -> pure $ \case
       TWord32 i -> i
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Word32" s
+    s -> unexpectedSchema s
   decodeCurrent = getWord32
 
 instance Serialise Word64 where
@@ -316,7 +320,7 @@
     SWord64 -> pure $ \case
       TWord64 i -> i
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Word64" s
+    s -> unexpectedSchema s
   decodeCurrent = getWord64
 
 instance Serialise Word where
@@ -327,7 +331,7 @@
     SWord64 -> pure $ \case
       TWord64 i -> fromIntegral i
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Word" s
+    s -> unexpectedSchema s
   decodeCurrent = fromIntegral <$> getWord64
 
 instance Serialise Int8 where
@@ -338,7 +342,7 @@
     SInt8 -> pure $ \case
       TInt8 i -> i
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Int8" s
+    s -> unexpectedSchema s
   decodeCurrent = fromIntegral <$> getWord8
 
 instance Serialise Int16 where
@@ -349,7 +353,7 @@
     SInt16 -> pure $ \case
       TInt16 i -> i
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Int16" s
+    s -> unexpectedSchema s
   decodeCurrent = fromIntegral <$> getWord16
 
 instance Serialise Int32 where
@@ -360,7 +364,7 @@
     SInt32 -> pure $ \case
       TInt32 i -> i
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Int32" s
+    s -> unexpectedSchema s
   decodeCurrent = fromIntegral <$> getWord32
 
 instance Serialise Int64 where
@@ -371,7 +375,7 @@
     SInt64 -> pure $ \case
       TInt64 i -> i
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Int64" s
+    s -> unexpectedSchema s
   decodeCurrent = fromIntegral <$> getWord64
 
 instance Serialise Int where
@@ -382,7 +386,7 @@
     SInteger -> pure $ \case
       TInteger i -> fromIntegral i
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Int" s
+    s -> unexpectedSchema s
   decodeCurrent = decodeVarIntFinite
 
 instance Serialise Float where
@@ -393,7 +397,7 @@
     SFloat -> pure $ \case
       TFloat x -> x
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Float" s
+    s -> unexpectedSchema s
   decodeCurrent = castWord32ToFloat <$> getWord32
 
 instance Serialise Double where
@@ -404,7 +408,7 @@
     SDouble -> pure $ \case
       TDouble x -> x
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Double" s
+    s -> unexpectedSchema s
   decodeCurrent = castWord64ToDouble <$> getWord64
 
 instance Serialise T.Text where
@@ -415,7 +419,7 @@
     SText -> pure $ \case
       TText t -> t
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Text" s
+    s -> unexpectedSchema s
   decodeCurrent = do
     len <- decodeVarInt
     T.decodeUtf8With T.lenientDecode <$> getBytes len
@@ -432,7 +436,7 @@
     SInteger -> pure $ \case
       TInteger i -> fromIntegral i
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise (VarInt a)" s
+    s -> unexpectedSchema s
   decodeCurrent = VarInt <$> decodeVarInt
 
 instance Serialise Integer where
@@ -456,7 +460,7 @@
     SChar -> pure $ \case
       TChar c -> c
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise Char" s
+    s -> unexpectedSchema s
   decodeCurrent = toEnum <$> decodeVarInt
 
 instance Serialise a => Serialise (Maybe a) where
@@ -473,7 +477,7 @@
     SBytes -> pure $ \case
       TBytes bs -> bs
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise ByteString" s
+    s -> unexpectedSchema s
   decodeCurrent = decodeVarInt >>= getBytes
 
 instance Serialise BL.ByteString where
@@ -495,7 +499,7 @@
     SUTCTime -> pure $ \case
       TUTCTime bs -> bs
       t -> throw $ InvalidTerm t
-    s -> unexpectedSchema "Serialise UTCTime" s
+    s -> unexpectedSchema s
   decodeCurrent = posixSecondsToUTCTime <$> decodeCurrent
 
 instance Serialise NominalDiffTime where
@@ -514,7 +518,7 @@
     return $ \case
       TVector xs -> V.map getItem xs
       t -> throw $ InvalidTerm t
-  s -> throwStrategy $ UnexpectedSchema "extractListBy ..." "[a]" s
+  s -> throwStrategy $ UnexpectedSchema [] "SVector" s
 {-# INLINE extractListBy #-}
 
 instance Serialise a => Serialise [a] where
@@ -737,27 +741,25 @@
   -> Extractor a
 gextractorRecord def = mkExtractor
   $ fmap (fmap (to .)) $ extractorRecord'
-  ("gextractorRecord :: Extractor " <> viaShow (typeRep (Proxy @ a)))
   (from <$> def)
 
 -- | Generic implementation of 'extractor' for a record.
 extractorRecord' :: (GSerialiseRecord f)
-  => Doc AnsiStyle
-  -> Maybe (f x) -- ^ default value (optional)
+  => Maybe (f x) -- ^ default value (optional)
   -> Schema -> Strategy' (Term -> f x)
-extractorRecord' rep def (SRecord schs) = Strategy $ \decs -> do
+extractorRecord' def (SRecord schs) = Strategy $ \decs -> do
     let go :: FieldDecoder T.Text x -> Either WineryException (Term -> x)
         go (FieldDecoder name def' p) = case lookupWithIndexV name schs of
           Nothing -> case def' of
             Just d -> Right (const d)
-            Nothing -> Left $ FieldNotFound rep name (map fst $ V.toList schs)
+            Nothing -> Left $ FieldNotFound [] name (map fst $ V.toList schs)
           Just (i, sch) -> case p sch `unStrategy` decs of
             Right getItem -> Right $ \case
-              TRecord xs -> maybe (error (show rep)) (getItem . snd) $ xs V.!? i
+              t@(TRecord xs) -> maybe (throw $ InvalidTerm t) (getItem . snd) $ xs V.!? i
               t -> throw $ InvalidTerm t
             Left e -> Left e
     unTransFusion (recordExtractor def) go
-extractorRecord' rep _ s = throwStrategy $ UnexpectedSchema rep "a record" s
+extractorRecord' _ s = throwStrategy $ UnexpectedSchema [] "a record" s
 {-# INLINE gextractorRecord #-}
 
 -- | Synonym for 'gdecodeCurrentProduct'
@@ -885,7 +887,7 @@
         go (FieldDecoder i _ p) = do
           getItem <- if i < length schs
             then p (schs V.! i) `unStrategy` recs
-            else Left $ ProductTooSmall $ length schs
+            else Left $ ProductTooSmall [] $ length schs
           return $ \case
             TProduct xs -> getItem $ maybe (throw $ InvalidTerm (TProduct xs)) id
               $ xs V.!? i
@@ -895,7 +897,7 @@
     strip (SProduct xs) = Just xs
     strip (SRecord xs) = Just $ V.map snd xs
     strip _ = Nothing
-extractorProduct' sch = throwStrategy $ UnexpectedSchema "extractorProduct'" "a product" sch
+extractorProduct' sch = throwStrategy $ UnexpectedSchema [] "a product" sch
 
 -- | Generic implementation of 'schemaGen' for an ADT.
 gschemaGenVariant :: forall proxy a. (GSerialiseVariant (Rep a), Typeable a, Generic a) => proxy a -> SchemaGen Schema
@@ -907,20 +909,28 @@
 {-# INLINE gtoBuilderVariant #-}
 
 -- | Generic implementation of 'extractor' for an ADT.
-gextractorVariant :: forall a. (GSerialiseVariant (Rep a), Generic a, Typeable a)
+gextractorVariant :: (GSerialiseVariant (Rep a), Generic a, Typeable a)
   => Extractor a
-gextractorVariant = mkExtractor $ \case
+gextractorVariant = buildVariantExtractor gvariantExtractors
+{-# INLINE gextractorVariant #-}
+
+gvariantExtractors :: (GSerialiseVariant (Rep a), Generic a) => HM.HashMap T.Text (Extractor a)
+gvariantExtractors = fmap to <$> variantExtractor
+{-# INLINE gvariantExtractors #-}
+
+-- | Bundle a 'HM.HashMap' of 'Extractor's into an extractor of a variant.
+buildVariantExtractor :: (Generic a, Typeable a)
+  => HM.HashMap T.Text (Extractor a)
+  -> Extractor a
+buildVariantExtractor extractors = mkExtractor $ \case
   SVariant schs0 -> Strategy $ \decs -> do
-    ds' <- traverse (\(name, sch) -> case lookup name variantExtractor of
-      Nothing -> Left $ FieldNotFound rep name (map fst $ V.toList schs0)
-      Just f -> f sch `unStrategy` decs) schs0
+    ds' <- traverse (\(name, sch) -> case HM.lookup name extractors of
+      Nothing -> Left $ FieldNotFound [] name (HM.keys extractors)
+      Just f -> runExtractor f sch `unStrategy` decs) schs0
     return $ \case
-      TVariant i _ v -> to $ maybe (throw InvalidTag) ($ v) $ ds' V.!? i
+      TVariant i _ v -> maybe (throw InvalidTag) ($ v) $ ds' V.!? i
       t -> throw $ InvalidTerm t
-  s -> throwStrategy $ UnexpectedSchema rep "a variant" s
-  where
-    rep = "gextractorVariant :: Extractor "
-      <> viaShow (typeRep (Proxy @ a))
+  s -> throwStrategy $ UnexpectedSchema [] "a variant" s
 
 gdecodeCurrentVariant :: forall a. (GConstructorCount (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a) => Decoder a
 gdecodeCurrentVariant = decodeVarInt >>= fmap to . variantDecoder (variantCount (Proxy :: Proxy (Rep a)))
@@ -984,25 +994,25 @@
 
 class GSerialiseVariant f where
   variantSchema :: proxy f -> SchemaGen [(T.Text, Schema)]
-  variantExtractor :: [(T.Text, Schema -> Strategy' (Term -> f x))]
+  variantExtractor :: HM.HashMap T.Text (Extractor (f x))
 
 instance (GSerialiseVariant f, GSerialiseVariant g) => GSerialiseVariant (f :+: g) where
   variantSchema _ = (++) <$> variantSchema (Proxy @ f) <*> variantSchema (Proxy @ g)
-  variantExtractor = fmap (fmap (fmap (fmap (fmap L1)))) variantExtractor
-    ++ fmap (fmap (fmap (fmap (fmap R1)))) variantExtractor
+  variantExtractor = fmap (fmap L1) variantExtractor
+    <> fmap (fmap R1) variantExtractor
 
 instance (GSerialiseProduct f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'False) f) where
   variantSchema _ = do
     s <- productSchema (Proxy @ f)
     return [(T.pack $ symbolVal (Proxy @ name), SProduct $ V.fromList s)]
-  variantExtractor = [(T.pack $ symbolVal (Proxy @ name), fmap (fmap M1) . extractorProduct') ]
+  variantExtractor = HM.singleton (T.pack $ symbolVal (Proxy @ name)) (M1 <$> Extractor extractorProduct')
 
 instance (GSerialiseRecord f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'True) f) where
   variantSchema _ = do
     s <- recordSchema (Proxy @ f)
     return [(T.pack $ symbolVal (Proxy @ name), SRecord $ V.fromList s)]
-  variantExtractor = [(T.pack $ symbolVal (Proxy @ name), fmap (fmap M1) . extractorRecord' "" Nothing) ]
+  variantExtractor = HM.singleton (T.pack $ symbolVal (Proxy @ name)) (M1 <$> Extractor (extractorRecord' Nothing))
 
 instance (GSerialiseVariant f) => GSerialiseVariant (D1 c f) where
   variantSchema _ = variantSchema (Proxy @ f)
-  variantExtractor = fmap (fmap (fmap (fmap M1))) <$> variantExtractor
+  variantExtractor = fmap M1 <$> variantExtractor
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -138,5 +138,33 @@
 
 prop_Foo = testSerialise @ Foo
 
+data Soup = Shoyu | Miso | Tonkotsu deriving (Generic, Eq, Show, Enum)
+
+instance Arbitrary Soup where
+  arbitrary = toEnum <$> Gen.choose (0, 2)
+
+instance Serialise Soup where
+  bundleSerialise = bundleVariant id
+
+data Food = Rice | Ramen Soup | Pasta Text Text deriving (Generic, Eq, Show)
+
+instance Arbitrary Food where
+  arbitrary = Gen.oneof
+    [ pure Rice
+    , Ramen <$> arbitrary
+    , Pasta
+      <$> Gen.elements ["Spaghetti", "Rigatoni", "Linguine"]
+      <*> Gen.elements ["Aglio e olio", "L'amatriciana", "Carbonara"]
+    ]
+
+instance Serialise Food where
+  bundleSerialise = bundleVariant $ const $ buildExtractor
+    $ ("Rice", \() -> Rice)
+    `extractConstructor` ("Ramen", Ramen)
+    `extractConstructor` ("Pasta", uncurry Pasta)
+    `extractConstructor` extractVoid
+
+prop_Food = testSerialise @ Food
+
 return []
 main = void $ $quickCheckAll
diff --git a/winery.cabal b/winery.cabal
--- a/winery.cabal
+++ b/winery.cabal
@@ -1,6 +1,6 @@
 cabal-version:  2.0
 name:           winery
-version:        1.2
+version:        1.3
 synopsis:       A compact, well-typed seralisation format for Haskell values
 description:
   <<https://i.imgur.com/lTosHnE.png>>
@@ -11,10 +11,10 @@
 bug-reports:    https://github.com/fumieval/winery/issues
 author:         Fumiaki Kinoshita
 maintainer:     fumiexcel@gmail.com
-copyright:      Copyright (c) 2019 Fumiaki Kinoshita
+copyright:      Copyright (c) 2020 Fumiaki Kinoshita
 license:        BSD3
 license-file:   LICENSE
-tested-with:    GHC == 8.4.4, GHC == 8.6.3, GHC ==8.8.1
+tested-with:    GHC == 8.4.4, GHC == 8.6.4, GHC ==8.8.3, GHC ==8.10.2
 build-type:     Simple
 extra-source-files:
   README.md