diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,8 @@
+Version 1.2
+---------------
+* Added the class instances for Data.Functor.Const
+* Fixed and optimized the Foldable/Traversable instance code generated for bare fields in Rank2.TH
+
 Version 1.1
 ---------------
 * Replaced own `Product` data type by the one from `Data.Functor.Product`
diff --git a/rank2classes.cabal b/rank2classes.cabal
--- a/rank2classes.cabal
+++ b/rank2classes.cabal
@@ -1,5 +1,5 @@
 name:                rank2classes
-version:             1.1.0.1
+version:             1.2
 synopsis:            standard type constructor class hierarchy, only with methods of rank 2 types
 description:
   A mirror image of the standard type constructor class hierarchy rooted in 'Functor', except with methods of rank 2
@@ -38,7 +38,7 @@
                        distributive < 0.7
 
   if flag(use-template-haskell)
-    build-depends: template-haskell >= 2.11 && < 2.14
+    build-depends: template-haskell >= 2.11 && < 2.15
     exposed-modules: Rank2.TH
 
 test-suite doctests
diff --git a/src/Rank2.hs b/src/Rank2.hs
--- a/src/Rank2.hs
+++ b/src/Rank2.hs
@@ -23,9 +23,11 @@
 import qualified Control.Monad as Rank1
 import qualified Data.Foldable as Rank1
 import qualified Data.Traversable as Rank1
+import Data.Coerce (coerce)
 import Data.Semigroup (Semigroup(..))
 import Data.Monoid (Monoid(..))
 import Data.Functor.Compose (Compose(..))
+import Data.Functor.Const (Const(..))
 import Data.Functor.Product (Product(..))
 import Data.Functor.Sum (Sum(..))
 
@@ -195,6 +197,9 @@
 instance Functor Empty where
    _ <$> _ = Empty
 
+instance Functor (Const a) where
+   _ <$> Const a = Const a
+
 instance Functor (Only a) where
    f <$> Only a = Only (f a)
 
@@ -211,6 +216,9 @@
 instance Foldable Empty where
    foldMap _ _ = mempty
 
+instance Foldable (Const x) where
+   foldMap _ _ = mempty
+
 instance Foldable (Only x) where
    foldMap f (Only x) = f x
 
@@ -227,6 +235,9 @@
 instance Traversable Empty where
    traverse _ _ = Rank1.pure Empty
 
+instance Traversable (Const x) where
+   traverse _ (Const x) = Rank1.pure (Const x)
+
 instance Traversable (Only x) where
    traverse f (Only x) = Only Rank1.<$> f x
 
@@ -244,6 +255,10 @@
    _ <*> _ = Empty
    liftA2 _ _ _ = Empty
 
+instance Semigroup x => Apply (Const x) where
+   Const x <*> Const y = Const (x <> y)
+   liftA2 _ (Const x) (Const y) = Const (x <> y)
+
 instance Apply (Only x) where
    Only f <*> Only x = Only (apply f x)
    liftA2 f (Only x) (Only y) = Only (f x y)
@@ -259,6 +274,9 @@
 instance Applicative Empty where
    pure = const Empty
 
+instance (Semigroup x, Monoid x) => Applicative (Const x) where
+   pure = const (Const mempty)
+
 instance Applicative (Only x) where
    pure = Only
 
@@ -278,6 +296,9 @@
 
 instance Distributive Empty where
    cotraverse _ _ = Empty
+
+instance Monoid x => DistributiveTraversable (Const x) where
+   cotraverseTraversable _ f = coerce (Rank1.fold f)
 
 instance Distributive (Only x) where
    cotraverse w f = Only (w $ Rank1.fmap fromOnly f)
diff --git a/src/Rank2/TH.hs b/src/Rank2/TH.hs
--- a/src/Rank2/TH.hs
+++ b/src/Rank2/TH.hs
@@ -2,7 +2,7 @@
 -- use it would be
 --
 -- > import qualified Rank2.TH
--- > data MyDataType = ...
+-- > data MyDataType f = ...
 -- > $(Rank2.TH.deriveAll ''MyDataType)
 --
 -- or, if you're picky, you can invoke only 'deriveFunctor' and whichever other instances you need instead.
@@ -268,19 +268,21 @@
    f          <- newName "f"
    fieldNames <- replicateM (length fieldTypes) (newName "x")
    let pats = [varP f, tildeP (conP name $ map varP fieldNames)]
-       body = normalB $ foldr append [| mempty |] $ zipWith newField fieldNames fieldTypes
+       body | null fieldNames = [| mempty |]
+            | otherwise = foldr1 append $ zipWith newField fieldNames fieldTypes
        append a b = [| $(a) <> $(b) |]
        newField :: Name -> BangType -> Q Exp
        newField x (_, fieldType) = genFoldMapField f fieldType (varE x) id
-   clause pats body []
+   clause pats (normalB body) []
 genFoldMapClause (RecC _name fields) = do
    f <- newName "f"
    x <- newName "x"
-   let body = normalB $ foldr append [| mempty |] $ map newField fields
+   let body | null fields = [| mempty |]
+            | otherwise = foldr1 append $ map newField fields
        append a b = [| $(a) <> $(b) |]
        newField :: VarBangType -> Q Exp
        newField (fieldName, _, fieldType) = genFoldMapField f fieldType (appE (varE fieldName) (varE x)) id
-   clause [varP f, varP x] body []
+   clause [varP f, varP x] (normalB body) []
 
 genFoldMapField :: Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
 genFoldMapField funcName fieldType fieldAccess wrap = do
@@ -291,7 +293,7 @@
      AppT t1 t2 | t1 /= VarT typeVar -> genFoldMapField funcName t2 fieldAccess (wrap . appE (varE 'foldMap))
      SigT ty _kind -> genFoldMapField funcName ty fieldAccess wrap
      ParensT ty -> genFoldMapField funcName ty fieldAccess wrap
-     _ -> fieldAccess
+     _ -> [| mempty |]
 
 genTraverseClause :: Con -> Q Clause
 genTraverseClause (NormalC name []) =
@@ -325,7 +327,7 @@
      AppT t1 t2 | t1 /= VarT typeVar -> genTraverseField fun t2 fieldAccess (wrap . appE (varE 'traverse))
      SigT ty _kind -> genTraverseField fun ty fieldAccess wrap
      ParensT ty -> genTraverseField fun ty fieldAccess wrap
-     _ -> fieldAccess
+     _ -> [| pure $fieldAccess |]
 
 genCotraverseClause :: Con -> Q Clause
 genCotraverseClause (NormalC name []) = genCotraverseClause (RecC name [])