diff --git a/.gitignore b/.gitignore
new file mode 100644
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,4 @@
+.stack-work/
+*~
+.ghc.environment.*
+dist-newstyle/
diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,9 @@
 # Revision history for barbies-th
 
+## 0.1.9
+
+* Added `passthroughBareB`
+
 ## 0.1.8
 
 * `declareBareB` can now generate nested barbies when multiple data declarations are passed (#7)
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -33,9 +33,21 @@
 instance ProductBC (Foo Covered)
 ```
 
-Typically you need the following extensions to make `declareBareB` work:
+`passthroughBareB` generates a type synonym for the bare type,
+preserving the semantics of the original definition.
 
+```haskell
+data FooB sw h = Foo
+    { foo :: Wear sw h Int,
+    , bar :: Wear sw h String
+    }
+type Foo = Foo Bare Identity
+type FooH = Foo Covered
 ```
+
+Typically you need the following extensions to make `declareBareB` work:
+
+```haskell
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -54,16 +66,20 @@
 stock deriving does not work on HKDs. Instead, it transforms deriving clauses into standalone ones via the `Barbie` wrapper,
 as well as ones for the `Bare` counterpart. For example,
 
-`data Foo = ... deriving (Show, Eq)`
+```haskell
+data Foo = ... deriving (Show, Eq)
+```
 
 generates
 
-```
+```haskell
 deriving instance Show (Foo Bare Identity)
 deriving instance Eq (Foo Bare Identity)
 deriving via Barbie (Foo Covered) h instance Show (Barbie (Foo Covered) h) => Show (Foo Covered h)
 deriving via Barbie (Foo Covered) h instance Eq (Barbie (Foo Covered) h) => Eq (Foo Covered h)
 ```
+
+Note that `Barbies` module must be imported manually in order to make use of coercions.
 
 Matryoshka barbies
 ----
diff --git a/barbies-th.cabal b/barbies-th.cabal
--- a/barbies-th.cabal
+++ b/barbies-th.cabal
@@ -1,24 +1,34 @@
 cabal-version:       2.4
 name:                barbies-th
-version:             0.1.8
+version:             0.1.9
 synopsis:            Create strippable HKD via TH
 description:         Please see Data.Barbie.TH
-bug-reports:         https://github.com/fumieval/barbies-th
+homepage:            https://github.com/fumieval/barbies-th
+bug-reports:         https://github.com/fumieval/barbies-th/issues
 license:             BSD-3-Clause
 license-file:        LICENSE
 author:              Fumiaki Kinoshita
 maintainer:          fumiexcel@gmail.com
-copyright:           Copyright (c) 2020 Fumiaki Kinoshita
-category:            Data, Generics
-extra-source-files:  CHANGELOG.md, README.md
+copyright:           Copyright (c) 2021 Fumiaki Kinoshita
+category:            Data, Generics, Data Structures
+extra-source-files:
+  CHANGELOG.md
+  README.md
+  cabal.project
+  .gitignore
 
+source-repository head
+  type: git
+  location: https://github.com/fumieval/barbies-th.git
+
 library
   exposed-modules:
     Barbies.TH
+    Barbies.TH.Config
     Data.Barbie.TH
   other-extensions:    RankNTypes, PolyKinds, DataKinds, KindSignatures, TemplateHaskell, TypeFamilies
-  build-depends:       base >= 4.12
-    , template-haskell >= 2.14 && <2.17
+  build-depends:       base >= 4.12 && <4.17
+    , template-haskell >= 2.14 && <2.18
     , barbies ^>= 2.0.1
     , split ^>= 0.2
   hs-source-dirs:      src
@@ -28,6 +38,17 @@
 test-suite th
   type: exitcode-stdio-1.0
   main-is: Main.hs
+  hs-source-dirs:
+      tests
+  build-depends:
+      base >=4.7 && <5
+    , barbies
+    , barbies-th
+  default-language: Haskell2010
+
+test-suite th-passthrough
+  type: exitcode-stdio-1.0
+  main-is: passthrough.hs
   hs-source-dirs:
       tests
   build-depends:
diff --git a/cabal.project b/cabal.project
new file mode 100644
--- /dev/null
+++ b/cabal.project
@@ -0,0 +1,3 @@
+packages: .
+allow-newer:
+  split:base
diff --git a/src/Barbies/TH.hs b/src/Barbies/TH.hs
--- a/src/Barbies/TH.hs
+++ b/src/Barbies/TH.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PolyKinds #-}
@@ -12,12 +13,16 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RecordWildCards #-}
 module Barbies.TH (FieldNamesB(..)
   , LensB(..)
   , getLensB
   , AccessorsB(..)
   , declareBareB
+  , declareBareBWith
   , declareBareBWithOtherBarbies
+  , passthroughBareB
   ) where
 
 import Language.Haskell.TH hiding (cxt)
@@ -28,14 +33,14 @@
 import Barbies
 import Barbies.Constraints
 import Barbies.Bare
+import Barbies.TH.Config
 import Data.Functor.Product
 import GHC.Generics (Generic)
 import Control.Applicative
 import Data.Functor.Identity (Identity(..))
 import Data.Functor.Compose (Compose(..))
 import Data.List.Split
-import Data.Maybe (mapMaybe)
-import Data.Bool (bool)
+import Data.Maybe
 
 -- | A pair of a getter and a setter
 -- Not van Laarhoven to avoid dictionary passing
@@ -48,10 +53,12 @@
 nestLensB l (LensB lv ls) =
   LensB (lv . snd . l) (\n h -> let (s, x) = l h in s (ls n x))
 
+-- | Obtain a van-laarhoven lens (compatible with the lens library) from 'LensB'
 getLensB :: Functor f => LensB b a -> (h a -> f (h a)) -> b h -> f (b h)
 getLensB (LensB v s) f b = (\x -> s x b) <$> f (v b)
 {-# INLINE getLensB #-}
 
+-- | The class of higher-kinded datatypes where lenses can be defined
 class AccessorsB b where
   -- | A collection of lenses (getter-setter pairs)
   baccessors :: b (LensB b)
@@ -75,18 +82,29 @@
 -- @data User t f = User { uid :: Wear t f Int, name :: Wear t f String }@
 --
 declareBareB :: DecsQ -> DecsQ
-declareBareB = declareBareBWithOtherBarbies []
+declareBareB = declareBareBWith classic
 
+-- | Defines a synonym for the bare type with the same name.
+-- The strippable definition is suffixed by B, and the covered type is suffixed by H.
+passthroughBareB :: DecsQ -> DecsQ
+passthroughBareB = declareBareBWith passthrough
+
 -- | Like 'declareBareB' except that one can specify the 'Name's of other
 -- barbies. Members with these types won't be wrapped with 'Wear'.
 declareBareBWithOtherBarbies :: [Name] -> DecsQ -> DecsQ
-declareBareBWithOtherBarbies friends decsQ = do
+declareBareBWithOtherBarbies xs = declareBareBWith classic { friends = xs }
+
+-- | Generate a higher-kinded data declaration using a custom config
+declareBareBWith :: DeclareBareBConfig -> DecsQ -> DecsQ
+declareBareBWith DeclareBareBConfig{..} decsQ = do
   decs <- decsQ
-  let newTypeNames = dataDecNames decs
-  decs' <- traverse (go (newTypeNames <> friends)) decs
+  let otherBarbieNames = [ (k, mkName $ barbieName $ nameBase k) | k <- dataDecNames decs ]
+          ++ map (\x -> (x, x)) friends
+  decs' <- traverse (go otherBarbieNames) decs
   return $ concat decs'
   where
-    go otherBarbieNames (DataD _ dataName tvbs _ [con@(RecC nDataCon mangledfields)] classes) = do
+    go otherBarbieNames (DataD _ dataName0 tvbs _ [con@(RecC nDataCon mangledfields)] classes) = do
+      let dataName = mkName $ barbieName $ nameBase dataName0
       let fields = [(unmangle name, c, t) | (name, c, t) <- mangledfields]
       nSwitch <- newName "sw"
       nWrap <- newName "h"
@@ -95,12 +113,12 @@
       -- 'mapMembers' applies one of two functions to elements of a list
       -- according to whether or not they align with another barbie
       let otherBarbieMask = [ case t of
-                                ConT n | n `elem` otherBarbieNames -> True
-                                _ -> False
+                                ConT n | Just v <- lookup n otherBarbieNames -> Just v
+                                _ -> Nothing
                             | (_, _, t) <- fields
                             ]
       let mapMembers :: (b -> c) -> (b -> c) -> [b] -> [c]
-          mapMembers normal otherBarbie = zipWith (bool normal otherBarbie) otherBarbieMask
+          mapMembers normal otherBarbie = zipWith (maybe normal (const otherBarbie)) otherBarbieMask
       nData <- newName "b"
       nConstr <- newName "c"
       nX <- newName "x"
@@ -109,7 +127,7 @@
           -- field names for FieldNamesB
           fieldNamesE = reconE $ mapMembers
             (\(name,_,_) -> [|Const $ fromString $(litE $ StringL $ nameBase name)|])
-            (const [|bfieldNames|])
+            (\_ -> [|bfieldNames|])
             fields
           accessors = reconE $ mapMembers
             (\name -> [|LensB
@@ -132,25 +150,36 @@
           -- Turn TyVarBndr into just a Name such that we can
           -- reconstruct the constructor applied to already-present
           -- type variables below.
+#if MIN_VERSION_template_haskell(2,17,0)
+          varName (PlainTV n _) = n
+          varName (KindedTV n _ _) = n
+#else
           varName (PlainTV n) = n
           varName (KindedTV n _) = n
+#endif
 
           -- The type name as present originally along with its type
           -- variables.
           vanillaType = foldl' appT (conT dataName) (varT . varName <$> tvbs)
 
-          -- max arity = 62
-          typeChunks = chunksOf 62 (mapMembers
-              (\t -> varT nConstr `appT` t)
-              (\t -> [t| AllB $(varT nConstr) ($t Covered)|])
-              [pure t | (_, _, t) <- fields]
-            )
+      -- bare/covered types
+      bareType <- [t| $(vanillaType) Bare Identity |]
+      coveredType <- [t| $(vanillaType) Covered |]
+
+      -- max arity = 62
+      let typeChunks = chunksOf 62
+            [ case mask of
+              Just t' -> [t| AllB $(varT nConstr) ($(conT t') Covered)|]
+              Nothing -> varT nConstr `appT` pure t
+            | ((_, _, t), mask) <- zip fields otherBarbieMask
+            ]
           mkConstraints ps = foldl appT (tupleT $ length ps) ps
           allConstr = case typeChunks of
             [ps] -> mkConstraints ps
             pss -> mkConstraints $ map mkConstraints pss
 
-      let datC = vanillaType `appT` conT ''Covered
+
+      let datC = pure coveredType
       decs <- [d|
         instance BareB $(vanillaType) where
           bcover $(conP nDataCon $ map varP xs)
@@ -159,12 +188,12 @@
           bstrip $(conP nDataCon $ map varP xs)
             = $(reconE $ mapMembers (appE (varE 'runIdentity)) (appE (varE 'bstrip)) (varE <$> xs))
           {-# INLINE bstrip #-}
-        instance FieldNamesB $(datC) where bfieldNames = $(fieldNamesE)
-        instance AccessorsB $(datC) where baccessors = $(accessors)
-        instance FunctorB $(datC) where
+        instance FieldNamesB $(pure coveredType) where bfieldNames = $(fieldNamesE)
+        instance AccessorsB $(pure coveredType) where baccessors = $(accessors)
+        instance FunctorB $(pure coveredType) where
           bmap f $(conP nDataCon $ map varP xs)
             = $(reconE (mapMembers (appE (varE 'f)) (appE [|bmap f|]) (varE <$> xs)))
-        instance DistributiveB $(datC) where
+        instance DistributiveB $(pure coveredType) where
           bdistribute fb = $(reconE $
               -- TODO: NoFieldSelectors
               mapMembers
@@ -172,22 +201,22 @@
                 (\fd -> [| bdistribute ($fd <$> fb) |])
                 [varE fd | (fd, _, _) <- fields]
             )
-        instance TraversableB $(datC) where
+        instance TraversableB $(pure coveredType) where
           btraverse f $(conP nDataCon $ map varP xs) = $(fst $ foldl'
               (\(l, op) r -> (infixE (Just l) (varE op) (Just r), '(<*>)))
               (conE nDataCon, '(<$>))
               (mapMembers (appE (varE 'f)) (\x -> [|btraverse f $x|]) (varE <$> xs))
             )
           {-# INLINE btraverse #-}
-        instance ConstraintsB $(datC) where
-          type AllB $(varT nConstr) $(datC) = $(allConstr)
+        instance ConstraintsB $(pure coveredType) where
+          type AllB $(varT nConstr) $(pure coveredType) = $(allConstr)
           baddDicts $(conP nDataCon $ map varP xs)
             = $(reconE $ mapMembers
                  (\x -> [|Pair Dict $x|])
                  (\x -> [|baddDicts $x|])
                  (varE <$> xs)
                )
-        instance ApplicativeB $(datC) where
+        instance ApplicativeB $(pure coveredType) where
           bpure $(varP nX) = $(reconE $ mapMembers
                                  (const (varE nX))
                                  (const [|bpure $(varE nX)|])
@@ -195,13 +224,14 @@
                               )
           bprod $(conP nDataCon $ map varP xs) $(conP nDataCon $ map varP ys) = $(foldl'
             (\r (isOtherBarbie, x, y) ->
-              if isOtherBarbie
+              if isJust isOtherBarbie
                 then [|$r (bprod $(varE x) $(varE y))|]
                 else [|$r (Pair $(varE x) $(varE y))|])
             (conE nDataCon) (zip3 otherBarbieMask xs ys))
         |]
       -- strip deriving Generic
       let classes' = map (\(DerivClause strat cs) -> fmap (DerivClause strat) $ partition (== ConT ''Generic) cs) classes
+
       -- For the covered type, derive instances via 'Barbie' wrapper instead.
       coverDrvs <- traverse (\cls ->
         [d|deriving via Barbie $(datC) $(varT nWrap)
@@ -209,14 +239,20 @@
         [ pure t | (_, DerivClause _ preds) <- classes', t <- preds ]
       -- Redefine instances of the bare type with the original strategy
       bareDrvs <- traverse (\(strat, cls) ->
-        standaloneDerivWithStrategyD strat (pure []) [t|$(cls) ($(vanillaType) Bare Identity)|])
+        standaloneDerivWithStrategyD strat (pure []) [t|$(cls) $(pure bareType)|])
         [ (strat, pure t) | (_, DerivClause strat preds) <- classes', t <- preds ]
       return $ DataD [] dataName
+#if MIN_VERSION_template_haskell(2,17,0)
+        (tvbs ++ [PlainTV nSwitch (), PlainTV nWrap ()])
+#else
         (tvbs ++ [PlainTV nSwitch, PlainTV nWrap])
+#endif
         Nothing
         [transformed]
         [DerivClause Nothing $ concatMap fst classes']
         : decs ++ concat coverDrvs ++ bareDrvs
+        ++ [ TySynD (mkName name) tvbs bareType | name <- maybeToList $ bareName $ nameBase dataName0]
+        ++ [ TySynD (mkName name) tvbs coveredType | name <- maybeToList $ coveredName $ nameBase dataName0]
     go _ d = pure [d]
 
 dataDecNames :: [Dec] -> [Name]
@@ -230,7 +266,7 @@
 varNames :: String -> [VarBangType] -> [Name]
 varNames p vbt = [mkName (p ++ nameBase v) | (v, _, _) <- vbt]
 
-transformCon :: [Name] -- ^ Names of other barbies
+transformCon :: [(Name, Name)] -- ^ Names of other barbies
   -> Name -- ^ switch variable
   -> Name -- ^ wrapper variable
   -> Con -- ^ original constructor
@@ -241,8 +277,8 @@
   | (v, b, t) <- xs
   , let
     t' = case t of
-      ConT n | n `elem` otherBarbieNames ->
-        ConT n `AppT` VarT switchName `AppT` VarT wrapperName
+      ConT n | Just n' <- lookup n otherBarbieNames ->
+        ConT n' `AppT` VarT switchName `AppT` VarT wrapperName
       _ -> ConT ''Wear `AppT` VarT switchName `AppT` VarT wrapperName `AppT` t
   ]
 transformCon otherBarbieNames var w (ForallC tvbs cxt con) =
diff --git a/src/Barbies/TH/Config.hs b/src/Barbies/TH/Config.hs
new file mode 100644
--- /dev/null
+++ b/src/Barbies/TH/Config.hs
@@ -0,0 +1,36 @@
+module Barbies.TH.Config
+  ( DeclareBareBConfig(..)
+  , classic
+  , passthrough
+  ) where
+import Language.Haskell.TH
+
+-- | Keep it in a separate module until NoFieldSelectors gets widespread
+data DeclareBareBConfig = DeclareBareBConfig
+  { friends :: [Name] -- ^ Members with these types won't be wrapped with 'Wear'
+  , bareName :: String -> Maybe String
+  -- ^ generate a type synonym for the 'Barbies.Bare.Bare' type?
+  , coveredName :: String -> Maybe String
+  -- ^ generate a type synonym for the 'Barbies.Bare.Covered' type?
+  , barbieName :: String -> String
+  -- ^ modify the name of the datatype
+  }
+
+-- | Does not define any type synonyms
+classic :: DeclareBareBConfig
+classic = DeclareBareBConfig
+  { friends = []
+  , bareName = const Nothing
+  , coveredName = const Nothing
+  , barbieName = id
+  }
+
+-- | Defines a synonym for the bare type with the same name.
+-- The strippable definition is suffixed by B, and the covered type is suffixed by H.
+passthrough :: DeclareBareBConfig
+passthrough = DeclareBareBConfig
+  { friends = []
+  , bareName = Just
+  , coveredName = Just . (++"H")
+  , barbieName = (++"B")
+  }
diff --git a/tests/Main.hs b/tests/Main.hs
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -19,7 +19,7 @@
     { foo :: Int
     , bar :: String
     } deriving (Show, Eq, Generic)|]
- 
+
 declareBareB [d|
   data Inner = Inner
     { inner :: Int
diff --git a/tests/passthrough.hs b/tests/passthrough.hs
new file mode 100644
--- /dev/null
+++ b/tests/passthrough.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS -ddump-splices #-}
+module Main where
+import Barbies.TH
+import GHC.Generics
+import Barbies
+import Barbies.Bare
+import Data.Functor.Identity
+
+passthroughBareB [d|
+  data Foo = Foo
+    { foo :: Int
+    , bar :: String
+    } deriving (Show, Eq, Generic)|]
+
+passthroughBareB [d|
+  data Inner = Inner
+    { inner :: Int
+    } deriving (Show, Eq, Generic)
+  data Outer = Outer
+    { outer :: Inner
+    , other :: Bool
+    } deriving (Show, Eq, Generic)
+    |]
+
+test_con :: FooH []
+test_con = Foo
+  { foo = [0]
+  , bar = ["Haskell"]
+  }
+
+test_bare :: Inner
+test_bare = Inner 0 :: InnerB Bare Identity
+
+test_sel :: ([Int], [String])
+test_sel = (foo test_con, bar test_con)
+
+test_upd :: FooH []
+test_upd = test_con { foo = [], bar = [] }
+
+main = pure ()
+