diff --git a/CHANGELOG b/CHANGELOG
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,5 +1,17 @@
 CHANGELOG
 
+1.0.1 -> 1.1
+  - Use derive-lifted-instances i/o algebraic-classes
+  - Add deriving instances for `HFree` and `HHFree`
+  - Fix `Traversable` and `Foldable` instances of `Free`
+
+1.0 -> 1.0.1
+  - Simpler `ShowHelper`
+
+0.8.4 -> 1.0
+  - Switch to using the QuantifiedConstraints extension
+  - Removed Data.Constraint.Class1
+
 0.8.3 -> 0.8.4
   - Updated to constraints-0.10
   - Updated for GHC 8.4
@@ -9,16 +21,16 @@
 
 0.8.2 -> 0.8.3
   - Added Data.Functor.Free.TH to other-modules
-  
+
 0.8.1 -> 0.8.2
   - Support for `deriveInstances` for classes which have one or more superclasses
   - `deriveInstances` now also derives the `HasSuperClasses` instance
   - Expose internal `ShowHelper` datatype
-  
+
 0.8 -> 0.8.1
   - Added HHCofree
   - Changes towards support for `SuperClass1` in TH code for `Free`
-  
+
 0.7.2 -> 0.8
   - Updated for GHC 8.2
     - Updated to base-4.10
diff --git a/examples/FreeNum.hs b/examples/FreeNum.hs
--- a/examples/FreeNum.hs
+++ b/examples/FreeNum.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies, FlexibleInstances, LambdaCase #-}
 module FreeNum where
 
 import Data.Functor.Free
@@ -17,7 +17,7 @@
 
 -- Monadic bind is variable substitution
 subst :: Free Num String -> Free Num a
-subst e = e >>= \v -> case v of 
+subst e = e >>= \case
   "x" -> 10
   _   -> 2
 
diff --git a/examples/NonEmptyList.hs b/examples/NonEmptyList.hs
--- a/examples/NonEmptyList.hs
+++ b/examples/NonEmptyList.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleInstances, UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}
 module NonEmptyList where
 
 import Data.Functor.Free
@@ -25,4 +25,4 @@
 
 -- Test the comonad and foldable instances, returns [15,14,12,9,5].
 test :: NonEmptyList Int
-test = extend sum $ (pure 1 <> pure 2) <> (pure 3 <> (pure 4 <> pure 5))
+test = extend sum $ ((pure 1 <> pure 2) <> pure 3 <> pure 4) <> pure 5
diff --git a/examples/Sem.hs b/examples/Sem.hs
new file mode 100644
--- /dev/null
+++ b/examples/Sem.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE TemplateHaskell, UndecidableInstances, QuantifiedConstraints, FlexibleInstances #-}
+module Sem where
+  
+import Data.Functor.Free
+
+class BaseSem a where
+  val :: Int -> a
+  add :: a -> a -> a
+
+instance BaseSem Int where
+  val = id
+  add = (+)
+
+class BaseSem a => AdvSem a where
+  mul :: a -> a -> a
+
+instance AdvSem Int where
+  mul = (*)
+
+deriveInstances ''BaseSem
+deriveInstances ''AdvSem
+
+
+test :: Free AdvSem String
+test = mul (add (pure "a") (val 3)) (val 5)
+
+evaluate :: Free AdvSem String -> Int
+evaluate = rightAdjunct lookupVar
+  where
+    lookupVar :: String -> Int
+    lookupVar "a" = 2
+    lookupVar v = error $ "Unknown variable: " ++ v
+
+main :: IO ()
+main = putStrLn $ show test ++ " = " ++ show (evaluate test)
+
+vars :: Free AdvSem a -> [a]
+vars = foldMap pure
diff --git a/examples/SemSum.hs b/examples/SemSum.hs
--- a/examples/SemSum.hs
+++ b/examples/SemSum.hs
@@ -1,12 +1,10 @@
 {-# LANGUAGE 
-  TemplateHaskell, TypeFamilies, DeriveTraversable, FlexibleInstances, UndecidableInstances,
+  TemplateHaskell, FlexibleInstances, UndecidableInstances, 
   TypeOperators, MultiParamTypeClasses, ConstraintKinds, UndecidableSuperClasses, QuantifiedConstraints 
   #-}
   
 module Sem where
   
-import GHC.Generics
-import Data.Algebra
 import Data.Functor.Free
 
 class BaseSem a where
@@ -32,13 +30,6 @@
 
 class (a x, b x) => (a + b) x
 instance (a x, b x) => (a + b) x
-
-type instance Signature (a + b) = Signature a :+: Signature b
-
-instance (AlgebraSignature f, AlgebraSignature g) => AlgebraSignature (f :+: g) where
-  type Class (f :+: g) = Class f + Class g
-  evaluate (L1 f) = evaluate f
-  evaluate (R1 f) = evaluate f
   
 
 deriveInstances ''BaseSem
diff --git a/free-functors.cabal b/free-functors.cabal
--- a/free-functors.cabal
+++ b/free-functors.cabal
@@ -1,5 +1,5 @@
 name:                free-functors
-version:             1.0.1
+version:             1.1
 synopsis:            Free functors, adjoint to functors that forget class constraints.
 description:         A free functor is a left adjoint to a forgetful functor. It used to be the case
                      that the only category that was easy to work with in Haskell was Hask itself, so
@@ -44,11 +44,11 @@
     Haskell2010
 
   build-depends:
-    base == 4.12.*,
-    template-haskell == 2.14.*,
+    base >= 4.13 && < 4.15,
+    template-haskell >= 2.15 && < 2.17,
     transformers == 0.5.*,
     comonad == 5.*,
-    algebraic-classes == 0.9.*,
+    derive-lifted-instances == 0,
     contravariant == 1.5.*,
     bifunctors == 5.*,
     profunctors == 5.*
diff --git a/src/Data/Functor/Cofree.hs b/src/Data/Functor/Cofree.hs
--- a/src/Data/Functor/Cofree.hs
+++ b/src/Data/Functor/Cofree.hs
@@ -34,7 +34,7 @@
 counit (Cofree k a) = k a
 
 leftAdjunct :: c a => (a -> b) -> a -> Cofree c b
-leftAdjunct f a = Cofree f a
+leftAdjunct = Cofree
 
 -- | @unit = leftAdjunct id@
 unit :: c b => b -> Cofree c b
diff --git a/src/Data/Functor/Free.hs b/src/Data/Functor/Free.hs
--- a/src/Data/Functor/Free.hs
+++ b/src/Data/Functor/Free.hs
@@ -1,6 +1,7 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-matches #-}
 {-# LANGUAGE
-    TypeFamilies
+    RankNTypes
+  , TypeFamilies
   , TypeOperators
   , DeriveFunctor
   , DeriveFoldable
@@ -27,6 +28,7 @@
 module Data.Functor.Free (
 
     Free(..)
+  , deriveFreeInstance
   , deriveInstances
   , unit
   , rightAdjunct
@@ -46,18 +48,79 @@
   , inR
   , InitialObject
   , initial
-  
-  -- * Internal
-  , ShowHelper(..)
 
   ) where
 
-import Data.Function
-
+import Data.Function (fix)
+import Data.Monoid (Ap(..))
 import Data.Void
+import Data.Traversable
+import Control.Comonad
 
+import Language.Haskell.TH.Syntax
 import Data.Functor.Free.Internal
+import Data.DeriveLiftedInstances (ShowsPrec(..), deriveInstance, apDeriv, idDeriv)
 
+
+-- | The free functor for class @c@.
+--
+--   @Free c a@ is basically an expression tree with operations from class @c@
+--   and variables/placeholders of type @a@, created with `unit`.
+--   Monadic bind allows you to replace each of these variables with another sub-expression.
+newtype Free c a = Free { runFree :: forall b. c b => (a -> b) -> b }
+
+-- | `unit` allows you to create @`Free` c@ values, together with the operations from the class @c@.
+unit :: a -> Free c a
+unit a = Free $ \k -> k a
+
+-- | `rightAdjunct` is the destructor of @`Free` c@ values.
+rightAdjunct :: c b => (a -> b) -> Free c a -> b
+rightAdjunct f g = runFree g f
+
+-- | @counit = rightAdjunct id@
+counit :: c a => Free c a -> a
+counit = rightAdjunct id
+
+-- | @leftAdjunct f = f . unit@
+leftAdjunct :: (Free c a -> b) -> a -> b
+leftAdjunct f = f . unit
+
+-- | @transform f as = as >>= f unit@
+--
+-- @transform f . transform g = transform (g . f)@
+transform :: (forall r. c r => (b -> r) -> a -> r) -> Free c a -> Free c b
+transform t (Free f) = Free (f . t)
+
+
+instance Functor (Free c) where
+  fmap f = transform (. f)
+
+instance Applicative (Free c) where
+  pure = unit
+  fs <*> as = transform (\k f -> rightAdjunct (k . f) as) fs
+
+instance Monad (Free c) where
+  return = unit
+  as >>= f = transform (\k -> rightAdjunct k . f) as
+
+instance (forall f x. Applicative f => c (Ap f (Free c x))) => Foldable (Free c) where
+  foldMap = foldMapDefault
+
+instance (forall f x. Applicative f => c (Ap f (Free c x))) => Traversable (Free c) where
+  traverse f = getAp . rightAdjunct (Ap . fmap unit . f)
+
+instance (Show a, c ShowsPrec) => Show (Free c a) where
+  showsPrec p = showsPrec p . rightAdjunct (\a -> ShowsPrec $ \d -> showParen (d > 10) $ showString "pure " . showsPrec 11 a)
+
+
+newtype Extract a = Extract { getExtract :: a }
+newtype Duplicate f a = Duplicate { getDuplicate :: f (f a) }
+instance (forall x. c (Extract x), forall x. c (Duplicate (Free c) x))
+  => Comonad (Free c) where
+  extract = getExtract . rightAdjunct Extract
+  duplicate = getDuplicate . rightAdjunct (Duplicate . unit . unit)
+
+
 -- | @unfold f = coproduct (unfold f) unit . f@
 --
 -- `inL` and `inR` are useful here. For example, the following creates the list @[1..10]@ as a @Free Monoid@:
@@ -94,9 +157,27 @@
 initial :: c r => InitialObject c -> r
 initial = rightAdjunct absurd
 
+-- | Derive the instance of @`Free` c a@ for the class @c@.
+--
+-- For example:
+--
+-- @deriveFreeInstance ''Num@
+deriveFreeInstance :: Name -> Q [Dec]
+deriveFreeInstance = deriveFreeInstance' ''Free 'Free 'runFree
 
-deriveInstances ''Num
-deriveInstances ''Fractional
-deriveInstances ''Floating
-deriveInstances ''Semigroup
-deriveInstances ''Monoid
+--- | Derive the instances of @`Free` c a@ for the class @c@, `Show`, `Foldable` and `Traversable`.
+--
+-- For example:
+--
+-- @deriveInstances ''Num@
+deriveInstances :: Name -> Q [Dec]
+deriveInstances = deriveInstances' ''Free 'Free 'runFree
+
+deriveFreeInstance' ''Free 'Free 'runFree ''Num
+deriveFreeInstance' ''Free 'Free 'runFree ''Fractional
+deriveFreeInstance' ''Free 'Free 'runFree ''Floating
+deriveFreeInstance' ''Free 'Free 'runFree ''Semigroup
+deriveFreeInstance' ''Free 'Free 'runFree ''Monoid
+
+deriveInstance (apDeriv idDeriv) [t|forall f a c. (Applicative f, Fractional a) => Fractional (Ap f a)|]
+deriveInstance (apDeriv idDeriv) [t|forall f a c. (Applicative f, Floating a) => Floating (Ap f a)|]
diff --git a/src/Data/Functor/Free/Internal.hs b/src/Data/Functor/Free/Internal.hs
--- a/src/Data/Functor/Free/Internal.hs
+++ b/src/Data/Functor/Free/Internal.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE
     GADTs
   , RankNTypes
+  , ViewPatterns
   , TypeOperators
   , DeriveFunctor
   , DeriveFoldable
@@ -16,112 +17,37 @@
   #-}
 module Data.Functor.Free.Internal where
 
-import Control.Comonad
-import Data.Algebra
-import Data.Algebra.TH
-import Language.Haskell.TH.Syntax
-import Data.Traversable
-
--- | The free functor for class @c@.
---
---   @Free c a@ is basically an expression tree with operations from class @c@
---   and variables/placeholders of type @a@, created with `unit`.
---   Monadic bind allows you to replace each of these variables with another sub-expression.
-newtype Free c a = Free { runFree :: forall b. c b => (a -> b) -> b }
-
--- | `unit` allows you to create @`Free` c@ values, together with the operations from the class @c@.
-unit :: a -> Free c a
-unit a = Free $ \k -> k a
-
--- | `rightAdjunct` is the destructor of @`Free` c@ values.
-rightAdjunct :: c b => (a -> b) -> Free c a -> b
-rightAdjunct f g = runFree g f
-
--- | @counit = rightAdjunct id@
-counit :: c a => Free c a -> a
-counit = rightAdjunct id
-
--- | @leftAdjunct f = f . unit@
-leftAdjunct :: (Free c a -> b) -> a -> b
-leftAdjunct f = f . unit
-
--- | @transform f as = as >>= f unit@
---
--- @transform f . transform g = transform (g . f)@
-transform :: (forall r. c r => (b -> r) -> a -> r) -> Free c a -> Free c b
-transform t (Free f) = Free (f . t)
-
-
-instance Functor (Free c) where
-  fmap f = transform (. f)
-
-instance Applicative (Free c) where
-  pure = unit
-  fs <*> as = transform (\k f -> rightAdjunct (k . f) as) fs
-
-instance Monad (Free c) where
-  return = unit
-  as >>= f = transform (\k -> rightAdjunct k . f) as
-
-newtype Extract a = Extract { getExtract :: a }
-newtype Duplicate f a = Duplicate { getDuplicate :: f (f a) }
-instance (forall x. c (Extract x), forall x. c (Duplicate (Free c) x))
-  => Comonad (Free c) where
-  extract = getExtract . rightAdjunct Extract
-  duplicate = getDuplicate . rightAdjunct (Duplicate . unit . unit)
-      
-
-class (Class f x) => Class' f x where evaluate' :: AlgebraSignature f => f x -> x
-instance (Class f x) => Class' f x where evaluate' = evaluate
-
-newtype LiftAFree c f a = LiftAFree { getLiftAFree :: f (Free c a) }
-
-instance (forall x. c x => Class' f x) => Algebra f (Free c a) where
-  algebra fa = Free $ \k -> evaluate' (fmap (rightAdjunct k) fa)
-      
-instance (Applicative f, forall x. c x => Class' s x) => Algebra s (LiftAFree c f a) where
-  algebra = LiftAFree . fmap algebra . traverse getLiftAFree
-
-instance (forall f x. Applicative f => c (LiftAFree c f x)) => Foldable (Free c) where
-  foldMap = foldMapDefault
+import Data.Monoid (Ap(..))
 
-instance (forall f x. Applicative f => c (LiftAFree c f x)) => Traversable (Free c) where
-  traverse f = getLiftAFree . rightAdjunct (LiftAFree . fmap unit . f)
+import Language.Haskell.TH.Syntax
+import Data.DeriveLiftedInstances
 
 
-data ShowHelper a where 
-  ShowUnit :: a -> ShowHelper a
-  ShowRec :: Show (f (ShowHelper a)) => f (ShowHelper a) -> ShowHelper a
+kExp :: Q Exp
+kExp = pure . VarE $ mkName "k"
 
-instance Show (f (ShowHelper a)) => Algebra f (ShowHelper a) where
-  algebra = ShowRec
+kPat :: Q Pat
+kPat = pure . VarP $ mkName "k"
 
-instance Show a => Show (ShowHelper a) where
-  showsPrec p (ShowUnit a) = showParen (p > 10) $ showString "unit " . showsPrec 11 a
-  showsPrec p (ShowRec f) = showsPrec p f
+freeDeriv :: Name -> Name -> Derivator
+freeDeriv (pure . ConE -> free) (pure . VarE -> runFree) = idDeriv {
+  res = \e -> [| $free (\ $kPat -> $e) |],
+  var = \fold v -> [| $(fold (\w -> [| fmap $w |]) [| \f -> $runFree f $kExp |]) $v |]
+}
 
-instance (Show a, Show (Signature c (ShowHelper a)), c (ShowHelper a)) => Show (Free c a) where
-  showsPrec p = showsPrec p . rightAdjunct ShowUnit
+deriveFreeInstance' :: Name -> Name -> Name -> Name -> Q [Dec]
+deriveFreeInstance' (pure . ConT -> free) cfree runFree (pure . ConT -> clss)
+  = deriveInstance
+      (freeDeriv cfree runFree)
+      [t| forall a c. (forall x. c x :=> $clss x) => $clss ($free c a) |]
 
+deriveInstances' :: Name -> Name -> Name -> Name -> Q [Dec]
+deriveInstances' tfree cfree runFree nm@(pure . ConT -> clss) =
+  concat <$> sequenceA
+    [ deriveFreeInstance' tfree cfree runFree nm
+    , deriveInstance showDeriv [t| $clss ShowsPrec |]
+    , deriveInstance (apDeriv idDeriv) [t| forall f a c. (Applicative f, $clss a) => $clss (Ap f a) |]
+    ]
 
 class (a => b) => a :=> b
 instance (a => b) => a :=> b
-
--- | Derive the instances of @`Free` c a@ for the class @c@, `Show`, `Foldable` and `Traversable`.
---
--- For example:
---
--- @deriveInstances ''Num@
-deriveInstances :: Name -> Q [Dec]
-deriveInstances nm = 
-  concat <$> sequenceA
-  [ deriveSignature nm
-  , deriveInstanceWith_skipSignature freeHeader $ return []
-  , deriveInstanceWith_skipSignature liftAFreeHeader $ return []
-  , deriveInstanceWith_skipSignature showHelperHeader $ return []
-  ]
-  where
-    freeHeader = [t|forall a c. (forall x. c x :=> $clss x) => $clss (Free c a)|]
-    liftAFreeHeader = [t|forall f a c. (Applicative f, forall x. c x :=> $clss x) => $clss (LiftAFree c f a)|]
-    showHelperHeader = [t|forall a. Show a => $clss (ShowHelper a)|]
-    clss = pure $ ConT nm
diff --git a/src/Data/Functor/HCofree.hs b/src/Data/Functor/HCofree.hs
--- a/src/Data/Functor/HCofree.hs
+++ b/src/Data/Functor/HCofree.hs
@@ -41,7 +41,7 @@
 counit (HCofree k fa) = k fa
 
 leftAdjunct :: c f => (f :~> g) -> f :~> HCofree c g
-leftAdjunct k fa = HCofree k fa
+leftAdjunct = HCofree
 
 -- | @unit = leftAdjunct id@
 unit :: c g => g :~> HCofree c g
@@ -55,7 +55,7 @@
 transform t (HCofree k a) = HCofree (t k) a
 
 hfmap :: (f :~> g) -> HCofree c f :~> HCofree c g
-hfmap f = transform (\k -> f . k)
+hfmap f = transform (f .)
 
 hextend :: (HCofree c f :~> g) -> HCofree c f :~> HCofree c g
 hextend f = transform (\k -> f . leftAdjunct k)
@@ -81,6 +81,7 @@
 
 instance (forall x. c x => Foldable x) => Foldable (HCofree c g) where
   foldMap f (HCofree _ a) = foldMap f a
+  foldMap' f (HCofree _ a) = foldMap' f a
   fold (HCofree _ a) = fold a
   foldr f z (HCofree _ a) = foldr f z a
   foldl f z (HCofree _ a) = foldl f z a
diff --git a/src/Data/Functor/HFree.hs b/src/Data/Functor/HFree.hs
--- a/src/Data/Functor/HFree.hs
+++ b/src/Data/Functor/HFree.hs
@@ -1,7 +1,9 @@
+{-# OPTIONS_GHC -fno-warn-unused-matches #-}
 {-# LANGUAGE
     RankNTypes
   , TypeOperators
   , ConstraintKinds
+  , TemplateHaskell
   , UndecidableInstances
   , QuantifiedConstraints
   #-}
@@ -24,17 +26,31 @@
 module Data.Functor.HFree where
 
 import Control.Applicative
+import Control.Monad (join)
 import Control.Monad.Trans.Class
 import Data.Functor.Identity
 import Data.Functor.Contravariant
 import Data.Functor.Contravariant.Divisible
 
+import Language.Haskell.TH.Syntax (Q, Name, Dec)
+import Data.Functor.Free.Internal
+
 -- | Natural transformations.
 type f :~> g = forall b. f b -> g b
 
 -- | The higher order free functor for constraint @c@.
 newtype HFree c f a = HFree { runHFree :: forall g. c g => (f :~> g) -> g a }
 
+
+-- | Derive the instance of @`HFree` c f a@ for the class @c@,.
+--
+-- For example:
+--
+-- @deriveHFreeInstance ''Functor@
+deriveHFreeInstance :: Name -> Q [Dec]
+deriveHFreeInstance = deriveFreeInstance' ''HFree 'HFree 'runHFree
+
+
 unit :: f :~> HFree c f
 unit fa = HFree $ \k -> k fa
 
@@ -54,7 +70,7 @@
 -- transform t = HFree . (. t) . runHFree
 
 hfmap :: (f :~> g) -> HFree c f :~> HFree c g
-hfmap f = transform (\k -> k . f)
+hfmap f = transform (. f)
 
 bind :: (f :~> HFree c g) -> HFree c f :~> HFree c g
 bind f = transform (\k -> rightAdjunct k . f)
@@ -72,44 +88,19 @@
 iter f = runIdentity . rightAdjunct (Identity . f)
 
 wrap :: f (HFree Monad f a) -> HFree Monad f a
-wrap as = unit as >>= id
+wrap as = join (unit as)
 
 
-instance (forall x. c x => Functor x) => Functor (HFree c f) where
-  fmap f (HFree g) = HFree $ \k -> fmap f (g k)
-  a <$ HFree g = HFree $ \k -> a <$ g k
-
-instance (forall x. c x => Applicative x) => Applicative (HFree c f) where
-  pure a = HFree $ const (pure a)
-  HFree f <*> HFree g = HFree $ \k -> f k <*> g k
-  HFree f <* HFree g = HFree $ \k -> f k <* g k
-  HFree f *> HFree g = HFree $ \k -> f k *> g k
-  liftA2 f (HFree g) (HFree h) = HFree $ \k -> liftA2 f (g k) (h k)
-
-instance (forall x. c x => Alternative x) => Alternative (HFree c f) where
-  empty = HFree $ const empty
-  HFree f <|> HFree g = HFree $ \k -> f k <|> g k
-  many (HFree f) = HFree $ \k -> many (f k)
-  some (HFree f) = HFree $ \k -> some (f k)
+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Functor
+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Applicative
+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Alternative
 
 -- | The free monad of a functor.
-instance (forall x. c x => Monad x) => Monad (HFree c f) where
-  return = pure
-  HFree f >>= g = HFree $ \k -> f k >>= rightAdjunct k . g
-  HFree f >> HFree g = HFree $ \k -> f k >> g k
-  fail s = HFree $ const (fail s)
+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Monad
 
 -- HFree Monad is only a monad transformer if rightAdjunct is called with monad morphisms.
 -- F.e. lift . return == return fails if the results are inspected with rightAdjunct (const Nothing).
 
-instance (forall x. c x => Contravariant x) => Contravariant (HFree c f) where
-  contramap f (HFree g) = HFree $ \k -> contramap f (g k)
-  a >$ HFree g = HFree $ \k -> a >$ g k
-
-instance (forall x. c x => Divisible x) => Divisible (HFree c f) where
-  divide f (HFree a) (HFree b) = HFree $ \k -> divide f (a k) (b k)
-  conquer = HFree $ const conquer
-
-instance (forall x. c x => Decidable x) => Decidable (HFree c f) where
-  choose f (HFree a) (HFree b) = HFree $ \k -> choose f (a k) (b k)
-  lose f = HFree $ const (lose f)
+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Contravariant
+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Divisible
+deriveFreeInstance' ''HFree 'HFree 'runHFree ''Decidable
diff --git a/src/Data/Functor/HHCofree.hs b/src/Data/Functor/HHCofree.hs
--- a/src/Data/Functor/HHCofree.hs
+++ b/src/Data/Functor/HHCofree.hs
@@ -48,7 +48,7 @@
 counit (HHCofree k fa) = k fa
 
 leftAdjunct :: c f => (f :~~> g) -> f :~~> HHCofree c g
-leftAdjunct k fa = HHCofree k fa
+leftAdjunct = HHCofree
 
 -- | @unit = leftAdjunct id@
 unit :: c g => g :~~> HHCofree c g
@@ -62,7 +62,7 @@
 transform t (HHCofree k a) = HHCofree (t k) a
 
 hfmap :: (f :~~> g) -> HHCofree c f :~~> HHCofree c g
-hfmap f = transform (\k -> f . k)
+hfmap f = transform (f .)
 
 hextend :: (HHCofree c f :~~> g) -> HHCofree c f :~~> HHCofree c g
 hextend f = transform (\k -> f . leftAdjunct k)
@@ -74,7 +74,7 @@
 instance BifunctorComonad (HHCofree c) where
   biextract = counit
   biextend = hextend
-  
+
 instance ProfunctorFunctor (HHCofree c) where
   promap = hfmap
 
@@ -87,21 +87,21 @@
   bimap f g (HHCofree k a) = HHCofree k (bimap f g a)
   first f (HHCofree k a) = HHCofree k (first f a)
   second f (HHCofree k a) = HHCofree k (second f a)
-      
+
 instance (forall x. c x => Profunctor x) => Profunctor (HHCofree c g) where
   dimap f g (HHCofree k a) = HHCofree k (dimap f g a)
   lmap f (HHCofree k a) = HHCofree k (lmap f a)
   rmap f (HHCofree k a) = HHCofree k (rmap f a)
   f #. HHCofree k g = HHCofree k (f #. g)
   HHCofree k g .# f = HHCofree k (g .# f)
-      
+
 instance (forall x. c x => Strong x) => Strong (HHCofree c f) where
   first' (HHCofree k a) = HHCofree k (first' a)
   second' (HHCofree k a) = HHCofree k (second' a)
-      
+
 instance (forall x. c x => Choice x) => Choice (HHCofree c f) where
   left' (HHCofree k a) = HHCofree k (left' a)
   right' (HHCofree k a) = HHCofree k (right' a)
-      
+
 instance (forall x. c x => Closed x) => Closed (HHCofree c f) where
   closed (HHCofree k a) = HHCofree k (closed a)
diff --git a/src/Data/Functor/HHFree.hs b/src/Data/Functor/HHFree.hs
--- a/src/Data/Functor/HHFree.hs
+++ b/src/Data/Functor/HHFree.hs
@@ -1,7 +1,9 @@
+{-# OPTIONS_GHC -fno-warn-unused-matches #-}
 {-# LANGUAGE
     RankNTypes
   , TypeOperators
   , ConstraintKinds
+  , TemplateHaskell
   , UndecidableInstances
   , QuantifiedConstraints
   #-}
@@ -26,20 +28,31 @@
 import Control.Arrow
 import Control.Category
 import Data.Bifunctor (Bifunctor)
-import qualified Data.Bifunctor as B (Bifunctor(..))
 import Data.Bifunctor.Functor
-import Data.Biapplicative (Biapplicative(..))
+import Data.Biapplicative (Biapplicative)
 import Data.Profunctor
-import Data.Profunctor.Unsafe
 import Data.Profunctor.Monad
 
+import Language.Haskell.TH.Syntax (Q, Name, Dec)
+import Data.Functor.Free.Internal
 
+
 -- | Natural transformations.
 type f :~~> g = forall a b. f a b -> g a b
 
 -- | The higher order free functor over two type parameters for constraint @c@.
 newtype HHFree c f a b = HHFree { runHHFree :: forall g. c g => (f :~~> g) -> g a b }
 
+
+-- | Derive the instance of @`HHFree` c f a b@ for the class @c@,.
+--
+-- For example:
+--
+-- @deriveHHFreeInstance ''Category@
+deriveHHFreeInstance :: Name -> Q [Dec]
+deriveHHFreeInstance = deriveFreeInstance' ''HHFree 'HHFree 'runHHFree
+
+
 unit :: f :~~> HHFree c f
 unit fa = HHFree $ \k -> k fa
 
@@ -59,7 +72,7 @@
 -- transform t = HHFree . (. t) . runHHFree
 
 hfmap :: (f :~~> g) -> HHFree c f :~~> HHFree c g
-hfmap f = transform (\k -> k . f)
+hfmap f = transform (. f)
 
 bind :: (f :~~> HHFree c g) -> HHFree c f :~~> HHFree c g
 bind f = transform (\k -> rightAdjunct k . f)
@@ -79,61 +92,19 @@
   projoin = bind id
 
 
-instance (forall x. c x => Category x) => Category (HHFree c f) where
-  id = HHFree $ const id
-  HHFree f . HHFree g = HHFree $ \k -> f k . g k
-
-instance (forall x. c x => Arrow x) => Arrow (HHFree c f) where
-  arr f = HHFree $ const (arr f)
-  first (HHFree f) = HHFree $ \k -> first (f k)
-  second (HHFree f) = HHFree $ \k -> second (f k)
-  HHFree f *** HHFree g = HHFree $ \k -> f k *** g k
-  HHFree f &&& HHFree g = HHFree $ \k -> f k &&& g k
-
-instance (forall x. c x => ArrowZero x) => ArrowZero (HHFree c f) where
-  zeroArrow = HHFree $ const zeroArrow
-
-instance (forall x. c x => ArrowPlus x) => ArrowPlus (HHFree c f) where
-  HHFree f <+> HHFree g = HHFree $ \k -> f k <+> g k
-
-instance (forall x. c x => ArrowChoice x) => ArrowChoice (HHFree c f) where
-  left (HHFree f) = HHFree $ \k -> left (f k)
-  right (HHFree f) = HHFree $ \k -> right (f k)
-  HHFree f +++ HHFree g = HHFree $ \k -> f k +++ g k
-  HHFree f ||| HHFree g = HHFree $ \k -> f k ||| g k
+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Category
+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Arrow
+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''ArrowZero
+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''ArrowPlus
+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''ArrowChoice
+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''ArrowLoop
 
 instance (forall x. c x => ArrowApply x) => ArrowApply (HHFree c f) where
   app = HHFree $ \k -> app . arr (first (rightAdjunct k))
 
-instance (forall x. c x => ArrowLoop x) => ArrowLoop (HHFree c f) where
-  loop (HHFree f) = HHFree $ \k -> loop (f k)
-
-instance (forall x. c x => Bifunctor x) => Bifunctor (HHFree c f) where
-  first f (HHFree g) = HHFree $ \k -> B.first f (g k)
-  second f (HHFree g) = HHFree $ \k -> B.second f (g k)
-  bimap p q (HHFree g) = HHFree $ \k -> B.bimap p q (g k)
-
-instance (forall x. c x => Biapplicative x) => Biapplicative (HHFree c f) where
-  bipure a b = HHFree $ const (bipure a b)
-  HHFree f <<*>> HHFree g = HHFree $ \k -> f k <<*>> g k
-  HHFree f *>> HHFree g = HHFree $ \k -> f k *>> g k
-  HHFree f <<* HHFree g = HHFree $ \k -> f k <<* g k
-  biliftA2 p q (HHFree g) (HHFree h) = HHFree $ \k -> biliftA2 p q (g k) (h k)
-
-instance (forall x. c x => Profunctor x) => Profunctor (HHFree c f) where
-  lmap f (HHFree g) = HHFree $ \k -> lmap f (g k)
-  rmap f (HHFree g) = HHFree $ \k -> rmap f (g k)
-  f #. HHFree g = HHFree $ \k -> f #. g k
-  HHFree g .# f = HHFree $ \k -> g k .# f
-  dimap p q (HHFree g) = HHFree $ \k -> dimap p q (g k)
-
-instance (forall x. c x => Strong x) => Strong (HHFree c f) where
-  first' (HHFree f) = HHFree $ \k -> first' (f k)
-  second' (HHFree f) = HHFree $ \k -> second' (f k)
-
-instance (forall x. c x => Choice x) => Choice (HHFree c f) where
-  left' (HHFree f) = HHFree $ \k -> left' (f k)
-  right' (HHFree f) = HHFree $ \k -> right' (f k)
-
-instance (forall x. c x => Closed x) => Closed (HHFree c f) where
-  closed (HHFree f) = HHFree $ \k -> closed (f k)
+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Bifunctor
+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Biapplicative
+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Profunctor
+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Strong
+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Choice
+deriveFreeInstance' ''HHFree 'HHFree 'runHHFree ''Closed