diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,3 +1,11 @@
+## 1.4
+
+* Added an instance for `NonEmpty`
+* Removed the instance for `Option`
+* Added `withSchema`
+* Added `alterSchemaGen` and `alterExtractor`
+* Removed long-deprecated `unwrapExtractor`, `bundleRecord`, `bundleRecordDefault`, `bundleVariant`
+
 ## 1.3.2
 
 * Inlined methods of various `Serialise` instances
diff --git a/src/Codec/Winery.hs b/src/Codec/Winery.hs
--- a/src/Codec/Winery.hs
+++ b/src/Codec/Winery.hs
@@ -42,7 +42,6 @@
   , deserialiseSchema
   , Extractor(..)
   , mkExtractor
-  , unwrapExtractor
   , Decoder
   , evalDecoder
   , serialiseOnly
@@ -51,6 +50,7 @@
   -- * Decoding combinators
   , Term(..)
   , encodeTerm
+  , decodeTerm
   , Subextractor(..)
   , buildExtractor
   , extractListBy
@@ -75,6 +75,7 @@
   , unexpectedSchema
   , SchemaGen
   , getSchema
+  , withSchema
   -- * DerivingVia
   , WineryRecord(..)
   , WineryVariant(..)
@@ -103,10 +104,9 @@
   , decodeCurrentDefault
   -- * Bundles
   , BundleSerialise(..)
-  , bundleRecord
-  , bundleRecordDefault
-  , bundleVariant
   , bundleVia
+  , alterExtractor
+  , alterSchemaGen
   -- * Preset schema
   , bootstrapSchema
   ) where
@@ -196,7 +196,7 @@
 --
 -- /"No tears in the writer, no tears in the reader. No surprise in the writer, no surprise in the reader."/
 testSerialise :: forall a. (Eq a, Show a, Serialise a) => a -> QC.Property
-testSerialise x = case getDecoderBy extractor (schema (Proxy @ a)) of
+testSerialise x = case getDecoderBy extractor (schema (Proxy @a)) of
   Left e -> QC.counterexample (show e) False
   Right f -> QC.counterexample "extractor" (evalDecoder f b QC.=== x)
     QC..&&. QC.counterexample "decodeCurrent" (evalDecoder decodeCurrent b QC.=== x)
@@ -205,7 +205,7 @@
 
 -- | 'decodeCurrent' in terms of 'extractor'; note that it's very slow.
 decodeCurrentDefault :: forall a. Serialise a => Decoder a
-decodeCurrentDefault = case getDecoderBy extractor (schema (Proxy @ a)) of
+decodeCurrentDefault = case getDecoderBy extractor (schema (Proxy @a)) of
   Left err -> error $ "decodeCurrentDefault: failed to get a decoder from the current schema"
     ++ show err
   Right a -> a
@@ -215,7 +215,7 @@
 -- /"A reader lives a thousand lives before he dies... The man who never reads lives only one."/
 getDecoder :: forall a. Serialise a => Schema -> Either WineryException (Decoder a)
 getDecoder sch
-  | sch == schema (Proxy @ a) = Right decodeCurrent
+  | sch == schema (Proxy @a) = Right decodeCurrent
   | otherwise = getDecoderBy extractor sch
 {-# INLINE getDecoder #-}
 
@@ -241,7 +241,7 @@
 -- | Serialise a value with the schema.
 toBuilderWithSchema :: forall a. Serialise a => a -> BB.Builder
 toBuilderWithSchema a = mappend (BB.word8 currentSchemaVersion)
-  $ toBuilder (schema (Proxy @ a), a)
+  $ toBuilder (schema (Proxy @a), a)
 {-# INLINE toBuilderWithSchema #-}
 
 -- | Split a 'Schema' from a 'B.ByteString'.
@@ -361,7 +361,7 @@
 newtype WineryRecord a = WineryRecord { unWineryRecord :: a }
 
 instance (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a) => Serialise (WineryRecord a) where
-  schemaGen _ = gschemaGenRecord (Proxy @ a)
+  schemaGen _ = gschemaGenRecord (Proxy @a)
   toBuilder = gtoBuilderRecord . unWineryRecord
   extractor = WineryRecord <$> gextractorRecord Nothing
   decodeCurrent = WineryRecord <$> gdecodeCurrentRecord
@@ -374,7 +374,7 @@
 newtype WineryProduct a = WineryProduct { unWineryProduct :: a }
 
 instance (GEncodeProduct (Rep a), GSerialiseProduct (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a) => Serialise (WineryProduct a) where
-  schemaGen _ = gschemaGenProduct (Proxy @ a)
+  schemaGen _ = gschemaGenProduct (Proxy @a)
   toBuilder = gtoBuilderProduct . unWineryProduct
   extractor = WineryProduct <$> gextractorProduct
   decodeCurrent = WineryProduct <$> gdecodeCurrentProduct
@@ -387,7 +387,7 @@
 newtype WineryVariant a = WineryVariant { unWineryVariant :: a }
 
 instance (GConstructorCount (Rep a), GSerialiseVariant (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a, Typeable a) => Serialise (WineryVariant a) where
-  schemaGen _ = gschemaGenVariant (Proxy @ a)
+  schemaGen _ = gschemaGenVariant (Proxy @a)
   toBuilder = gtoBuilderVariant . unWineryVariant
   extractor = WineryVariant <$> gextractorVariant
   decodeCurrent = WineryVariant <$> gdecodeCurrentVariant
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
@@ -30,7 +30,6 @@
   , Strategy'
   , StrategyBind(..)
   , StrategyEnv(..)
-  , unwrapExtractor
   , WineryException(..)
   , pushTrace
   , prettyWineryException
@@ -144,7 +143,7 @@
     SFix sch -> group $ nest 2 $ sep ["μ", enclose "{ " " }" $ pretty sch]
     SVar i -> "$" <> pretty i
     STag t s -> nest 2 $ sep [pretty t <> ":", pretty s]
-    SLet s t -> sep ["let" <+> pretty s, pretty t]
+    SLet s t -> group $ nest 2 $ sep ["let" <+> pretty s, pretty t]
 
 -- | Schema generator
 newtype SchemaGen a = SchemaGen { unSchemaGen :: S.Set TypeRep -> (S.Set TypeRep, [TypeRep] -> a) }
@@ -264,12 +263,6 @@
 data StrategyEnv = StrategyEnv !Int ![StrategyBind]
 
 type Strategy' = Strategy WineryException StrategyEnv
-
--- | Run an 'Extractor'.
-unwrapExtractor :: Extractor a -> Schema -> Strategy' (Term -> a)
-unwrapExtractor (Extractor m) = m
-{-# INLINE unwrapExtractor #-}
-{-# DEPRECATED unwrapExtractor "Use runExtractor instead" #-}
 
 pushTrace :: TypeRep -> WineryException -> WineryException
 pushTrace t (UnexpectedSchema xs d s) = UnexpectedSchema (t : xs) d s
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
@@ -1,4 +1,5 @@
 {-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
@@ -22,11 +23,11 @@
 module Codec.Winery.Class (Serialise(..)
   , VarInt(..)
   , BundleSerialise(..)
-  , bundleRecord
-  , bundleRecordDefault
-  , bundleVariant
+  , alterSchemaGen
+  , alterExtractor
   , getSchema
   , schema
+  , withSchema
   , unexpectedSchema
   , mkExtractor
   , extractListBy
@@ -81,6 +82,7 @@
 import Data.Functor.Identity
 import qualified Data.Functor.Product as F
 import Data.List (elemIndex)
+import qualified Data.List.NonEmpty as NE
 import Data.Monoid as M
 import Data.Kind (Type)
 import Data.Proxy
@@ -138,7 +140,7 @@
   --
   -- It must not return a function if an unsupported schema is supplied.
   --
-  -- @getDecoderBy extractor (schema (Proxy @ a))@ must be @Right d@
+  -- @getDecoderBy extractor (schema (Proxy @a))@ must be @Right d@
   -- where @d@ is equivalent to 'decodeCurrent'.
   --
   extractor :: Extractor a
@@ -171,45 +173,28 @@
   , bundleDecodeCurrent :: Decoder a
   }
 
--- | A bundle of generic implementations for records
-bundleRecord :: (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a)
-  => (Extractor a -> Extractor a) -- extractor modifier
-  -> BundleSerialise a
-bundleRecord f = BundleSerialise
-  { bundleSchemaGen = gschemaGenRecord
-  , bundleToBuilder = gtoBuilderRecord
-  , bundleExtractor = f $ gextractorRecord Nothing
-  , bundleDecodeCurrent = gdecodeCurrentRecord
-  }
-{-# INLINE bundleRecord #-}
-{-# DEPRECATED bundleRecord "Use bundleVia instead" #-}
+-- | Modify 'bundleSchemaGen'
+alterSchemaGen :: (SchemaGen Schema -> SchemaGen Schema)
+  -> BundleSerialise a -> BundleSerialise a
+alterSchemaGen f bundle = bundle { bundleSchemaGen = f . bundleSchemaGen bundle }
 
--- | A bundle of generic implementations for records, with a default value
-bundleRecordDefault :: (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a)
-  => a -- default value
-  -> (Extractor a -> Extractor a) -- extractor modifier
-  -> BundleSerialise a
-bundleRecordDefault def f = BundleSerialise
-  { bundleSchemaGen = gschemaGenRecord
-  , bundleToBuilder = gtoBuilderRecord
-  , bundleExtractor = f $ gextractorRecord $ Just def
-  , bundleDecodeCurrent = gdecodeCurrentRecord
-  }
-{-# INLINE bundleRecordDefault #-}
-{-# DEPRECATED bundleRecordDefault "Use bundleVia instead" #-}
+-- | Modify 'bundleExtractor'
+alterExtractor :: (Extractor a -> Extractor a)
+  -> BundleSerialise a -> BundleSerialise a
+alterExtractor f bundle = bundle { bundleExtractor = f (bundleExtractor bundle) }
 
--- | A bundle of generic implementations for variants
-bundleVariant :: (GSerialiseVariant (Rep a), GConstructorCount (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a, Typeable a)
-  => (Extractor a -> Extractor a) -- extractor modifier
-  -> BundleSerialise a
-bundleVariant f = BundleSerialise
-  { bundleSchemaGen = gschemaGenVariant
-  , bundleToBuilder = gtoBuilderVariant
-  , bundleExtractor = f $ gextractorVariant
-  , bundleDecodeCurrent = gdecodeCurrentVariant
-  }
-{-# INLINE bundleVariant #-}
-{-# DEPRECATED bundleVariant "Use bundleVia instead" #-}
+-- | Bind a schema. While this does not change the semantics, it helps reducing the schema size
+-- when it has multiple children with the specified type (use TypeApplications to specify a type).
+withSchema :: forall a. Serialise a => SchemaGen Schema -> SchemaGen Schema
+withSchema gen = SchemaGen $ \seen -> if S.member rep seen
+  then unSchemaGen gen seen
+  else do
+    let seen' = S.insert rep seen
+    let (reps', g) = unSchemaGen (getSchema (Proxy @a)) seen
+    let (reps, f) = unSchemaGen gen seen'
+    (reps <> reps', \xs -> SLet (g xs) $ f $ rep : xs)
+  where
+    rep = typeRep (Proxy @a)
 
 -- | Obtain a schema on 'SchemaGen', binding a fixpoint when necessary.
 -- If you are hand-rolling a definition of 'schemaGen', you should call this
@@ -220,7 +205,7 @@
     Just i -> SVar i
     Nothing -> error $ "getSchema: impossible " ++ show (rep, seen, xs))
     -- request a fixpoint for rep when it detects a recursion
-  else case unSchemaGen (schemaGen (Proxy @ a)) (S.insert rep seen) of
+  else case unSchemaGen (schemaGen (Proxy @a)) (S.insert rep seen) of
     (reps, f)
       | S.member rep reps -> (reps, \xs -> SFix $ f (rep : xs))
       | otherwise -> (reps, f)
@@ -231,7 +216,7 @@
 --
 -- /"Tell me what you drink, and I will tell you what you are."/
 schema :: forall proxy a. Serialise a => proxy a -> Schema
-schema p = case unSchemaGen (schemaGen (Proxy @ a)) (S.singleton rep) of
+schema p = case unSchemaGen (schemaGen (Proxy @a)) (S.singleton rep) of
   (reps, f)
     | S.member rep reps -> SFix $ f [rep]
     | otherwise -> f []
@@ -240,12 +225,12 @@
 
 unexpectedSchema :: forall f a. Serialise a => Schema -> Strategy' (f a)
 unexpectedSchema actual = throwStrategy
-  $ UnexpectedSchema [] (pretty $ schema (Proxy @ a)) actual
+  $ UnexpectedSchema [] (pretty $ schema (Proxy @a)) actual
 
 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
+    Left e -> Left $! pushTrace (typeRep (Proxy @a)) e
     Right a -> Right a
 {-# INLINE mkExtractor #-}
 
@@ -257,7 +242,7 @@
       BoundSchema ofs' sch' -> recursiveStrategy k sch' `unStrategy` StrategyEnv ofs' (drop (ofs - ofs') decs)
       DynDecoder dyn -> case fromDynamic dyn of
         Nothing -> Left $ TypeMismatch [] i
-          (typeRep (Proxy @ (Term -> a)))
+          (typeRep (Proxy @(Term -> a)))
           (dynTypeRep dyn)
         Just a -> Right a
     | otherwise -> Left $ UnboundVariable [] i
@@ -539,7 +524,7 @@
 {-# INLINE extractListBy #-}
 
 instance Serialise a => Serialise [a] where
-  schemaGen _ = SVector <$> getSchema (Proxy @ a)
+  schemaGen _ = SVector <$> getSchema (Proxy @a)
   toBuilder xs = varInt (length xs)
       <> foldMap toBuilder xs
   {-# INLINE toBuilder #-}
@@ -548,8 +533,15 @@
     n <- decodeVarInt
     replicateM n decodeCurrent
 
+instance Serialise a => Serialise (NE.NonEmpty a) where
+  schemaGen _ = SVector <$> getSchema (Proxy @a)
+  toBuilder = toBuilder . NE.toList
+  {-# INLINE toBuilder #-}
+  extractor = NE.fromList . V.toList <$> extractListBy extractor
+  decodeCurrent = NE.fromList <$> decodeCurrent
+
 instance Serialise a => Serialise (V.Vector a) where
-  schemaGen _ = SVector <$> getSchema (Proxy @ a)
+  schemaGen _ = SVector <$> getSchema (Proxy @a)
   toBuilder xs = varInt (V.length xs)
     <> foldMap toBuilder xs
   {-# INLINE toBuilder #-}
@@ -559,7 +551,7 @@
     V.replicateM n decodeCurrent
 
 instance (SV.Storable a, Serialise a) => Serialise (SV.Vector a) where
-  schemaGen _ = SVector <$> getSchema (Proxy @ a)
+  schemaGen _ = SVector <$> getSchema (Proxy @a)
   toBuilder = toBuilder . (SV.convert :: SV.Vector a -> V.Vector a)
   {-# INLINE toBuilder #-}
   extractor = SV.convert <$> extractListBy extractor
@@ -568,7 +560,7 @@
     SV.replicateM n decodeCurrent
 
 instance (UV.Unbox a, Serialise a) => Serialise (UV.Vector a) where
-  schemaGen _ = SVector <$> getSchema (Proxy @ a)
+  schemaGen _ = SVector <$> getSchema (Proxy @a)
   toBuilder = toBuilder . (UV.convert :: UV.Vector a -> V.Vector a)
   {-# INLINE toBuilder #-}
   extractor = UV.convert <$> extractListBy extractor
@@ -577,7 +569,7 @@
     UV.replicateM n decodeCurrent
 
 instance (Ord k, Serialise k, Serialise v) => Serialise (M.Map k v) where
-  schemaGen _ = schemaGen (Proxy @ [(k, v)])
+  schemaGen _ = schemaGen (Proxy @[(k, v)])
   toBuilder m = toBuilder (M.size m)
     <> M.foldMapWithKey (curry toBuilder) m
   {-# INLINE toBuilder #-}
@@ -585,7 +577,7 @@
   decodeCurrent = M.fromList <$> decodeCurrent
 
 instance (Eq k, Hashable k, Serialise k, Serialise v) => Serialise (HM.HashMap k v) where
-  schemaGen _ = schemaGen (Proxy @ [(k, v)])
+  schemaGen _ = schemaGen (Proxy @[(k, v)])
   toBuilder m = toBuilder (HM.size m)
     <> HM.foldrWithKey (\k v r -> toBuilder (k, v) <> r) mempty m
   {-# INLINE toBuilder #-}
@@ -593,7 +585,7 @@
   decodeCurrent = HM.fromList <$> decodeCurrent
 
 instance (Serialise v) => Serialise (IM.IntMap v) where
-  schemaGen _ = schemaGen (Proxy @ [(Int, v)])
+  schemaGen _ = schemaGen (Proxy @[(Int, v)])
   toBuilder m = toBuilder (IM.size m)
     <> IM.foldMapWithKey (curry toBuilder) m
   {-# INLINE toBuilder #-}
@@ -601,35 +593,35 @@
   decodeCurrent = IM.fromList <$> decodeCurrent
 
 instance (Ord a, Serialise a) => Serialise (S.Set a) where
-  schemaGen _ = schemaGen (Proxy @ [a])
+  schemaGen _ = schemaGen (Proxy @[a])
   toBuilder s = toBuilder (S.size s) <> foldMap toBuilder s
   {-# INLINE toBuilder #-}
   extractor = S.fromList <$> extractor
   decodeCurrent = S.fromList <$> decodeCurrent
 
 instance Serialise IS.IntSet where
-  schemaGen _ = schemaGen (Proxy @ [Int])
+  schemaGen _ = schemaGen (Proxy @[Int])
   toBuilder s = toBuilder (IS.size s) <> IS.foldr (mappend . toBuilder) mempty s
   {-# INLINE toBuilder #-}
   extractor = IS.fromList <$> extractor
   decodeCurrent = IS.fromList <$> decodeCurrent
 
 instance Serialise a => Serialise (Seq.Seq a) where
-  schemaGen _ = schemaGen (Proxy @ [a])
+  schemaGen _ = schemaGen (Proxy @[a])
   toBuilder s = toBuilder (length s) <> foldMap toBuilder s
   {-# INLINE toBuilder #-}
   extractor = Seq.fromList <$> extractor
   decodeCurrent = Seq.fromList <$> decodeCurrent
 
 instance (Integral a, Serialise a) => Serialise (Ratio a) where
-  schemaGen _ = schemaGen (Proxy @ (a, a))
+  schemaGen _ = schemaGen (Proxy @(a, a))
   toBuilder x = toBuilder (numerator x, denominator x)
   {-# INLINE toBuilder #-}
   extractor = uncurry (%) <$> extractor
   decodeCurrent = uncurry (%) <$> decodeCurrent
 
 instance Serialise Scientific where
-  schemaGen _ = schemaGen (Proxy @ (Integer, Int))
+  schemaGen _ = schemaGen (Proxy @(Integer, Int))
   toBuilder s = toBuilder (coefficient s, base10Exponent s)
   {-# INLINE toBuilder #-}
   extractor = mkExtractor $ \s -> case s of
@@ -720,7 +712,6 @@
 deriving instance Serialise a => Serialise (S.Last a)
 deriving instance Serialise a => Serialise (S.First a)
 deriving instance Serialise a => Serialise (ZipList a)
-deriving instance Serialise a => Serialise (Option a)
 deriving instance Serialise a => Serialise (Max a)
 deriving instance Serialise a => Serialise (Min a)
 deriving instance (Typeable k, Typeable f, Typeable a, Serialise (f a)) => Serialise (Alt f (a :: k))
@@ -765,7 +756,7 @@
 
 -- | Generic implementation of 'schemaGen' for a record.
 gschemaGenRecord :: forall proxy a. (GSerialiseRecord (Rep a), Generic a, Typeable a) => proxy a -> SchemaGen Schema
-gschemaGenRecord _ = SRecord . V.fromList <$> recordSchema (Proxy @ (Rep a))
+gschemaGenRecord _ = SRecord . V.fromList <$> recordSchema (Proxy @(Rep a))
 
 -- | Generic implementation of 'toBuilder' for a record.
 gtoBuilderRecord :: (GEncodeProduct (Rep a), Generic a) => a -> BB.Builder
@@ -853,7 +844,7 @@
   recordExtractor :: Maybe (f x) -> TransFusion (FieldDecoder T.Text) ((->) Term) (Term -> f x)
 
 instance (GSerialiseRecord f, GSerialiseRecord g) => GSerialiseRecord (f :*: g) where
-  recordSchema _ = (++) <$> recordSchema (Proxy @ f) <*> recordSchema (Proxy @ g)
+  recordSchema _ = (++) <$> recordSchema (Proxy @f) <*> recordSchema (Proxy @g)
   recordExtractor def = (\f g -> (:*:) <$> f <*> g)
     <$> recordExtractor ((\(x :*: _) -> x) <$> def)
     <*> recordExtractor ((\(_ :*: x) -> x) <$> def)
@@ -861,7 +852,7 @@
 
 instance (Serialise a, Selector c) => GSerialiseRecord (S1 c (K1 i a)) where
   recordSchema _ = do
-    s <- getSchema (Proxy @ a)
+    s <- getSchema (Proxy @a)
     pure [(T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x), s)]
   recordExtractor def = TransFusion $ \k -> fmap (fmap (M1 . K1)) $ k $ FieldDecoder
     (T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x))
@@ -870,11 +861,11 @@
   {-# INLINE recordExtractor #-}
 
 instance (GSerialiseRecord f) => GSerialiseRecord (C1 c f) where
-  recordSchema _ = recordSchema (Proxy @ f)
+  recordSchema _ = recordSchema (Proxy @f)
   recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def)
 
 instance (GSerialiseRecord f) => GSerialiseRecord (D1 c f) where
-  recordSchema _ = recordSchema (Proxy @ f)
+  recordSchema _ = recordSchema (Proxy @f)
   recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def)
 
 class GSerialiseProduct f where
@@ -886,21 +877,21 @@
   productExtractor = pure (pure U1)
 
 instance (Serialise a) => GSerialiseProduct (K1 i a) where
-  productSchema _ = pure <$> getSchema (Proxy @ a)
+  productSchema _ = pure <$> getSchema (Proxy @a)
   productExtractor = Compose $ State $ \i ->
     ( TransFusion $ \k -> fmap (fmap K1) $ k $ FieldDecoder i Nothing (runExtractor extractor)
     , i + 1)
 
 instance GSerialiseProduct f => GSerialiseProduct (M1 i c f) where
-  productSchema _ = productSchema (Proxy @ f)
+  productSchema _ = productSchema (Proxy @f)
   productExtractor = fmap M1 <$> productExtractor
 
 instance (GSerialiseProduct f, GSerialiseProduct g) => GSerialiseProduct (f :*: g) where
-  productSchema _ = (++) <$> productSchema (Proxy @ f) <*> productSchema (Proxy @ g)
+  productSchema _ = (++) <$> productSchema (Proxy @f) <*> productSchema (Proxy @g)
   productExtractor = liftA2 (:*:) <$> productExtractor <*> productExtractor
 
 gschemaGenProduct :: forall proxy a. (Generic a, GSerialiseProduct (Rep a)) => proxy a -> SchemaGen Schema
-gschemaGenProduct _ = SProduct . V.fromList <$> productSchema (Proxy @ (Rep a))
+gschemaGenProduct _ = SProduct . V.fromList <$> productSchema (Proxy @(Rep a))
 {-# INLINE gschemaGenProduct #-}
 
 gtoBuilderProduct :: (Generic a, GEncodeProduct (Rep a)) => a -> BB.Builder
@@ -940,7 +931,7 @@
 
 -- | Generic implementation of 'schemaGen' for an ADT.
 gschemaGenVariant :: forall proxy a. (GSerialiseVariant (Rep a), Typeable a, Generic a) => proxy a -> SchemaGen Schema
-gschemaGenVariant _ = SVariant . V.fromList <$> variantSchema (Proxy @ (Rep a))
+gschemaGenVariant _ = SVariant . V.fromList <$> variantSchema (Proxy @(Rep a))
 
 -- | Generic implementation of 'toBuilder' for an ADT.
 gtoBuilderVariant :: forall a. (GConstructorCount (Rep a), GEncodeVariant (Rep a), Generic a) => a -> BB.Builder
@@ -980,7 +971,7 @@
   variantCount :: proxy f -> Int
 
 instance (GConstructorCount f, GConstructorCount g) => GConstructorCount (f :+: g) where
-  variantCount _ = variantCount (Proxy @ f) + variantCount (Proxy @ g)
+  variantCount _ = variantCount (Proxy @f) + variantCount (Proxy @g)
   {-# INLINE variantCount #-}
 
 instance GConstructorCount (C1 i f) where
@@ -988,7 +979,7 @@
   {-# INLINE variantCount #-}
 
 instance GConstructorCount f => GConstructorCount (D1 i f) where
-  variantCount _ = variantCount (Proxy @ f)
+  variantCount _ = variantCount (Proxy @f)
   {-# INLINE variantCount #-}
 
 class GDecodeVariant f where
@@ -1037,24 +1028,24 @@
   variantExtractor :: HM.HashMap T.Text (Extractor (f x))
 
 instance (GSerialiseVariant f, GSerialiseVariant g) => GSerialiseVariant (f :+: g) where
-  variantSchema _ = (++) <$> variantSchema (Proxy @ f) <*> variantSchema (Proxy @ g)
+  variantSchema _ = (++) <$> variantSchema (Proxy @f) <*> variantSchema (Proxy @g)
   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 = HM.singleton (T.pack $ symbolVal (Proxy @ name)) (M1 <$> Extractor extractorProduct')
+    s <- productSchema (Proxy @f)
+    return [(T.pack $ symbolVal (Proxy @name), SProduct $ V.fromList s)]
+  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 = HM.singleton (T.pack $ symbolVal (Proxy @ name)) (M1 <$> Extractor (extractorRecord' Nothing))
+    s <- recordSchema (Proxy @f)
+    return [(T.pack $ symbolVal (Proxy @name), SRecord $ V.fromList s)]
+  variantExtractor = HM.singleton (T.pack $ symbolVal (Proxy @name)) (M1 <$> Extractor (extractorRecord' Nothing))
 
 instance (GSerialiseVariant f) => GSerialiseVariant (D1 c f) where
-  variantSchema _ = variantSchema (Proxy @ f)
+  variantSchema _ = variantSchema (Proxy @f)
   variantExtractor = fmap M1 <$> variantExtractor
 
 -- | An extractor for individual fields. This distinction is required for
@@ -1089,7 +1080,7 @@
 instance (Typeable k, Typeable b, Typeable h, ApplicativeB b, ConstraintsB b, TraversableB b, AllBF Serialise h b, FieldNamesB b) => Serialise (Barbie b (h :: k -> Type)) where
   schemaGen _ = fmap (SRecord . V.fromList . (`appEndo`[]) . bfoldMap getConst)
     $ btraverse (\(F.Pair (Dict :: Dict (ClassF Serialise h) a) (Const k))
-        -> Const . Endo . (:) . (,) k <$> schemaGen (Proxy @ (h a)))
+        -> Const . Endo . (:) . (,) k <$> schemaGen (Proxy @(h a)))
     $ baddDicts (bfieldNames :: b (Const T.Text))
   toBuilder = bfoldMap (\(F.Pair (Dict :: Dict (ClassF Serialise h) a) x) -> toBuilder x) . baddDicts
   {-# INLINE toBuilder #-}
diff --git a/src/Codec/Winery/Internal.hs b/src/Codec/Winery/Internal.hs
--- a/src/Codec/Winery/Internal.hs
+++ b/src/Codec/Winery/Internal.hs
@@ -52,7 +52,6 @@
 import qualified Data.ByteString.Internal as B
 import qualified Data.ByteString.Builder.Prim.Internal as BPI
 import Data.Bits
-import Data.Monoid ((<>))
 import Data.String
 import qualified Data.Vector.Unboxed as U
 import qualified Data.Vector as V
@@ -80,7 +79,7 @@
 {-# INLINEABLE[1] varInt #-}
 
 varIntFinite :: Int -> BB.Builder
-varIntFinite = BB.primBounded (BPI.boudedPrim 10 writeIntFinite)
+varIntFinite = BB.primBounded (BPI.boundedPrim 10 writeIntFinite)
 
 writeWord8 :: Word8 -> Ptr Word8 -> IO (Ptr Word8)
 writeWord8 w p = do
@@ -258,11 +257,10 @@
   deriving Functor
 
 instance Applicative (Strategy e r) where
-  pure = return
+  pure = Strategy . const . Right
   (<*>) = ap
 
 instance Monad (Strategy e r) where
-  return = Strategy . const . Right
   m >>= k = Strategy $ \decs -> case unStrategy m decs of
     Right a -> unStrategy (k a) decs
     Left e -> Left e
diff --git a/src/Codec/Winery/Test.hs b/src/Codec/Winery/Test.hs
--- a/src/Codec/Winery/Test.hs
+++ b/src/Codec/Winery/Test.hs
@@ -69,7 +69,7 @@
 
 -- | Gather all test cases involved in the specified type.
 allTests :: forall a. (TestGen a, Tested a) => M.Map TypeRep [Test]
-allTests = M.insertWith (++) (typeRep (Proxy @ a)) (testCases @ a) (inheritedTests (Proxy @ a))
+allTests = M.insertWith (++) (typeRep (Proxy @a)) (testCases @a) (inheritedTests (Proxy @a))
 
 -- | Types with concrete test cases.
 --
@@ -80,7 +80,7 @@
   testCases :: [Test]
 
   default testCases :: (Serialise a, Eq a, Show a) => [Test]
-  testCases = [testCase sch b a | (sch, xs) <- testGroups @ a, (b, a) <- xs]
+  testCases = [testCase sch b a | (sch, xs) <- testGroups @a, (b, a) <- xs]
 
   testGroups :: [(Schema, [(B.ByteString, a)])]
   testGroups = []
@@ -101,7 +101,7 @@
 instance Tested T.Text where testCases = []
 instance Tested B.ByteString where testCases = []
 instance Tested a => Tested (Identity a) where
-  testCases = testCases @ a
+  testCases = testCases @a
 instance Tested a => Tested (S.Seq a) where testCases = []
 instance (Ord a, Tested a) => Tested (Set.Set a) where testCases = []
 instance Tested a => Tested [a] where testCases = []
@@ -121,7 +121,7 @@
 printTests = putStrLn $ showTests (genTestCases :: [a])
 
 buildTestGroups :: forall a. (TestGen a, Serialise a) => [(Schema, [(B.ByteString, a)])]
-buildTestGroups = [(schema (Proxy @ a), [(serialiseOnly a, a) | a <- genTestCases :: [a]])]
+buildTestGroups = [(schema (Proxy @a), [(serialiseOnly a, a) | a <- genTestCases :: [a]])]
 
 showTests :: (Serialise a, Show a) => [a] -> String
 showTests xs = showListWith ppTest xs ""
@@ -149,7 +149,7 @@
   genTestCases = fmap to ggenTestCases
 
   default inheritedTests :: (GTestGen (Rep a)) => Proxy a -> M.Map TypeRep [Test]
-  inheritedTests _ = ginheritedTests (Proxy @ (Rep a))
+  inheritedTests _ = ginheritedTests (Proxy @(Rep a))
 
 class GTestGen f where
   ggenTestCases :: [f x]
@@ -165,28 +165,28 @@
 
 instance GTestGen f => GTestGen (Rec1 f) where
   ggenTestCases = fmap Rec1 ggenTestCases
-  ginheritedTests _ = ginheritedTests (Proxy @ f)
+  ginheritedTests _ = ginheritedTests (Proxy @f)
 
 instance (Tested c, TestGen c) => GTestGen (K1 i c) where
   ggenTestCases = fmap K1 genTestCases
-  ginheritedTests _ = allTests @ c
+  ginheritedTests _ = allTests @c
 
 instance GTestGen f => GTestGen (M1 i c f) where
   ggenTestCases = fmap M1 ggenTestCases
-  ginheritedTests _ = ginheritedTests (Proxy @ f)
+  ginheritedTests _ = ginheritedTests (Proxy @f)
 
 instance (GTestGen f, GTestGen g) => GTestGen (f :+: g) where
   ggenTestCases = fmap L1 ggenTestCases ++ fmap R1 ggenTestCases
-  ginheritedTests _ = ginheritedTests (Proxy @ f)
-    `mappend` ginheritedTests (Proxy @ g)
+  ginheritedTests _ = ginheritedTests (Proxy @f)
+    `mappend` ginheritedTests (Proxy @g)
 
 instance (GTestGen f, GTestGen g) => GTestGen (f :*: g) where
   ggenTestCases = ((:*:) <$> ggenTestCases <*> xs)
     ++ ((:*:) <$> take 1 ggenTestCases <*> ys)
     where
       (xs, ys) = splitAt 1 ggenTestCases
-  ginheritedTests _ = ginheritedTests (Proxy @ f)
-    `mappend` ginheritedTests (Proxy @ g)
+  ginheritedTests _ = ginheritedTests (Proxy @f)
+    `mappend` ginheritedTests (Proxy @g)
 
 deriving instance TestGen a => TestGen (Identity a)
 instance TestGen ()
@@ -198,31 +198,31 @@
 
 instance Tested a => TestGen [a] where
   genTestCases = [[]]
-  inheritedTests _ = allTests @ a
+  inheritedTests _ = allTests @a
 
 instance (Ord a, Tested a) => TestGen (Set.Set a) where
   genTestCases = [mempty]
-  inheritedTests _ = allTests @ a
+  inheritedTests _ = allTests @a
 
 instance Tested a => TestGen (S.Seq a) where
   genTestCases = [mempty]
-  inheritedTests _ = allTests @ a
+  inheritedTests _ = allTests @a
 
 instance Tested a => TestGen (V.Vector a) where
   genTestCases = [V.empty]
-  inheritedTests _ = allTests @ a
+  inheritedTests _ = allTests @a
 
 instance (UV.Unbox a, Tested a) => TestGen (UV.Vector a) where
   genTestCases = [UV.empty]
-  inheritedTests _ = allTests @ a
+  inheritedTests _ = allTests @a
 
 instance (Hashable k, Tested k, Tested a) => TestGen (HM.HashMap k a) where
   genTestCases = HM.singleton <$> genTestCases <*> genTestCases
-  inheritedTests _ = allTests @ k `mappend` allTests @ a
+  inheritedTests _ = allTests @k `mappend` allTests @a
 
 instance (Ord k, Tested k, Tested a) => TestGen (M.Map k a) where
   genTestCases = [M.empty]
-  inheritedTests _ = allTests @ k `mappend` allTests @ a
+  inheritedTests _ = allTests @k `mappend` allTests @a
 
 instance TestGen Void where
   genTestCases = []
diff --git a/test/Schema.hs b/test/Schema.hs
new file mode 100644
--- /dev/null
+++ b/test/Schema.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE TypeApplications, DeriveGeneric #-}
+
+import Codec.Winery
+import Data.List (intercalate)
+import Data.Proxy
+import GHC.Generics
+import Prettyprinter
+import Test.QuickCheck
+import qualified Test.QuickCheck.Gen as Gen
+
+data BigUnion = BU0 | BU1 | BU2 | BU3 | BU4 deriving (Show, Eq, Generic, Enum)
+instance Serialise BigUnion where
+    bundleSerialise = bundleVia WineryVariant
+
+instance Arbitrary BigUnion where
+  arbitrary = toEnum <$> Gen.choose (0, 4)
+
+data BigRecord = BigRecord
+    { foo :: BigUnion
+    , bar :: BigUnion
+    , baz :: BigUnion
+    , qux :: BigUnion
+    } deriving (Show, Eq, Generic)
+
+instance Arbitrary BigRecord where
+  arbitrary = BigRecord <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+
+data BiggerRecord = BiggerRecord
+    { union :: BigUnion
+    , alpha :: BigRecord
+    , bravo :: BigRecord
+    } deriving (Show, Eq, Generic)
+
+instance Arbitrary BiggerRecord where
+  arbitrary = BiggerRecord <$> arbitrary <*> arbitrary <*> arbitrary
+
+instance Serialise BigRecord where
+    bundleSerialise = alterSchemaGen (withSchema @BigUnion)
+        $ bundleVia WineryRecord
+
+instance Serialise BiggerRecord where
+    bundleSerialise = alterSchemaGen (withSchema @BigUnion . withSchema @BigRecord)
+        $ bundleVia WineryRecord
+
+main :: IO ()
+main = do
+    let expected = intercalate "\n"
+            [ "let BU0 | BU1 | BU2 | BU3 | BU4"
+            , "  let { foo :: $0, bar :: $0, baz :: $0, qux :: $0 }"
+            , "    { union :: $1, alpha :: $0, bravo :: $0 }"
+            ]
+    let actual = show $ pretty $ schema (Proxy @BiggerRecord)
+    if expected == actual
+        then quickCheck $ testSerialise @BiggerRecord
+        else fail $ "Schema mismatch: \n" <> actual
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -46,44 +46,44 @@
 instance Arbitrary Nano where
   arbitrary = Nano . realToFrac . (1000*) <$> (arbitrary :: Gen Pico)
 
-prop_Unit = testSerialise @ ()
-prop_Bool = testSerialise @ Bool
-prop_Word8 = testSerialise @ Word8
-prop_Word16 = testSerialise @ Word16
-prop_Word32 = testSerialise @ Word32
-prop_Word64 = testSerialise @ Word64
-prop_Word = testSerialise @ Word
-prop_Int8 = testSerialise @ Int8
-prop_Int16 = testSerialise @ Int16
-prop_Int32 = testSerialise @ Int32
-prop_Int64 = testSerialise @ Int64
-prop_Int = testSerialise @ Int
-prop_Float = testSerialise @ Float
-prop_Double = testSerialise @ Double
-prop_Text = testSerialise @ Text
-prop_Integer = testSerialise @ Integer
-prop_Char = testSerialise @ Char
-prop_Maybe_Int = testSerialise @ (Maybe Int)
-prop_ByteString = testSerialise @ ByteString
-prop_ByteString_Lazy = testSerialise @ BL.ByteString
+prop_Unit = testSerialise @()
+prop_Bool = testSerialise @Bool
+prop_Word8 = testSerialise @Word8
+prop_Word16 = testSerialise @Word16
+prop_Word32 = testSerialise @Word32
+prop_Word64 = testSerialise @Word64
+prop_Word = testSerialise @Word
+prop_Int8 = testSerialise @Int8
+prop_Int16 = testSerialise @Int16
+prop_Int32 = testSerialise @Int32
+prop_Int64 = testSerialise @Int64
+prop_Int = testSerialise @Int
+prop_Float = testSerialise @Float
+prop_Double = testSerialise @Double
+prop_Text = testSerialise @Text
+prop_Integer = testSerialise @Integer
+prop_Char = testSerialise @Char
+prop_Maybe_Int = testSerialise @(Maybe Int)
+prop_ByteString = testSerialise @ByteString
+prop_ByteString_Lazy = testSerialise @BL.ByteString
 -- prop_UTCTime = testSerialise @ UTCTime
-prop_NominalDiffTime = testSerialise @ Nano
-prop_List_Int = testSerialise @ [Int]
-prop_Vector_Int = testSerialise @ (V.Vector Int) . V.fromList
-prop_Vector_Storable_Int = testSerialise @ (SV.Vector Int) . SV.fromList
-prop_Vector_Unboxed_Int = testSerialise @ (UV.Vector Int) . UV.fromList
-prop_Map_Int_Int = testSerialise @ (Map Int Int)
-prop_HashMap_String_Int = testSerialise @ (HM.HashMap String Int) . HM.fromList
-prop_IntMap_Int = testSerialise @ (IntMap Int)
-prop_Set_Int = testSerialise @ (Set Int)
-prop_IntSet = testSerialise @ IntSet
-prop_Seq_Int = testSerialise @ (Seq Int)
-prop_Scientific = testSerialise @ Scientific
-prop_Tuple2 = testSerialise @ (Bool, Int)
-prop_Tuple3 = testSerialise @ (Bool, Int, Text)
-prop_Tuple4 = testSerialise @ (Bool, Int, Text, Double)
-prop_Either_String_Int = testSerialise @ (Either String Int)
-prop_Ordering = testSerialise @ Ordering
+prop_NominalDiffTime = testSerialise @Nano
+prop_List_Int = testSerialise @[Int]
+prop_Vector_Int = testSerialise @(V.Vector Int) . V.fromList
+prop_Vector_Storable_Int = testSerialise @(SV.Vector Int) . SV.fromList
+prop_Vector_Unboxed_Int = testSerialise @(UV.Vector Int) . UV.fromList
+prop_Map_Int_Int = testSerialise @(Map Int Int)
+prop_HashMap_String_Int = testSerialise @(HM.HashMap String Int) . HM.fromList
+prop_IntMap_Int = testSerialise @(IntMap Int)
+prop_Set_Int = testSerialise @(Set Int)
+prop_IntSet = testSerialise @IntSet
+prop_Seq_Int = testSerialise @(Seq Int)
+prop_Scientific = testSerialise @Scientific
+prop_Tuple2 = testSerialise @(Bool, Int)
+prop_Tuple3 = testSerialise @(Bool, Int, Text)
+prop_Tuple4 = testSerialise @(Bool, Int, Text, Double)
+prop_Either_String_Int = testSerialise @(Either String Int)
+prop_Ordering = testSerialise @Ordering
 
 data TRec = TRec
   { foo :: !Int
@@ -96,7 +96,7 @@
 instance Serialise TRec where
   bundleSerialise = bundleVia WineryRecord
 
-prop_TRec = testSerialise @ TRec
+prop_TRec = testSerialise @TRec
 
 data TList a = TCons a (TList a) | TNil deriving (Show, Eq, Generic)
 
@@ -108,7 +108,7 @@
     then pure TNil
     else TCons <$> arbitrary <*> scale pred arbitrary
 
-prop_TList_Int = testSerialise @ (TList Int)
+prop_TList_Int = testSerialise @(TList Int)
 
 data Tree
   = Leaf
@@ -140,8 +140,8 @@
       <*> (extractField "right" <|> extractField "rightChild")
     }
 
-prop_tree = testSerialise @ Tree
-prop_node = testSerialise @ Node
+prop_tree = testSerialise @Tree
+prop_node = testSerialise @Node
 
 data Foo = Foo | Bar | Baz | Qux | FooBar | FooBaz | FooQux deriving (Generic, Eq, Show, Enum)
 
@@ -151,7 +151,7 @@
 instance Serialise Foo where
   bundleSerialise = bundleVia WineryVariant
 
-prop_Foo = testSerialise @ Foo
+prop_Foo = testSerialise @Foo
 
 data Soup = Shoyu | Miso | Tonkotsu deriving (Generic, Eq, Show, Enum)
 
@@ -180,7 +180,7 @@
     `extractConstructor` ("Pasta", uncurry Pasta)
     `extractConstructor` extractVoid
 
-prop_Food = testSerialise @ Food
+prop_Food = testSerialise @Food
 
 declareBareB [d|
   data HRecB = HRec
@@ -200,6 +200,6 @@
 
 instance Arbitrary HRec where
   arbitrary = HRec <$> arbitrary <*> arbitrary
-prop_HRec = testSerialise @ HRec
+prop_HRec = testSerialise @HRec
 return []
 main = $quickCheckAll >>= flip unless (error "Failed")
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.3.2
+version:        1.4
 synopsis:       A compact, well-typed seralisation format for Haskell values
 description:
   <<https://i.imgur.com/lTosHnE.png>>
@@ -100,6 +100,19 @@
     , bytestring
     , barbies
     , barbies-th >= 0.1.5
+  default-language: Haskell2010
+
+test-suite schema
+  type: exitcode-stdio-1.0
+  main-is: Schema.hs
+  ghc-options: -Wall -Wcompat
+  hs-source-dirs:
+      test
+  build-depends:
+    base >=4.7 && <5
+    , winery
+    , prettyprinter
+    , QuickCheck
   default-language: Haskell2010
 
 benchmark bench-winery