diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,12 @@
 # Revision history for downhill
 
-## 0.1.0.0 -- 2021-12-12
+## 0.2.0.0
+* `MetricTensor` is no longer required to be a `VectorSpace`
+* `T2`, `T3` pattern synonyms for `BVar`
+* `L2` metric
+* Generics for `BasicVector`, `Dual`
+* Template Haskell scrapped
+
+## 0.1.0.0
 
 * First version
diff --git a/downhill.cabal b/downhill.cabal
--- a/downhill.cabal
+++ b/downhill.cabal
@@ -1,7 +1,7 @@
 cabal-version:       2.4
 
 name:                downhill
-version:             0.1.0.0
+version:             0.2.0.0
 synopsis:            Reverse mode automatic differentiation
 homepage:            https://andriusstank.github.io/downhill/
 description:
@@ -33,7 +33,7 @@
                        Downhill.BVar.Num
                        Downhill.BVar.Prelude,
                        Downhill.BVar.Traversable,
-                       Downhill.TH
+                       Downhill.Metric
   -- other-modules:
   -- other-extensions:
   build-depends:       base                  >= 4.12.0.0 && <4.17,
@@ -52,7 +52,13 @@
 test-suite downhill-test
   type:                exitcode-stdio-1.0
   main-is:             Main.hs
-  other-modules:       DownhillTest.Point, DownhillTest.Traversable, DownhillTest.TH, DownhillTest.TestTHOptions
-  build-depends:       base, downhill, tasty, tasty-hunit, vector-space
+  other-modules:       DownhillTest.Point,
+                       DownhillTest.Traversable,
+                       DownhillTest.Bilinear
+  build-depends:       base,
+                       downhill,
+                       tasty, tasty-hunit, tasty-hedgehog,
+                       vector-space,
+                       hedgehog
   hs-source-dirs:      test
   default-language:    Haskell2010
diff --git a/src/Downhill/BVar.hs b/src/Downhill/BVar.hs
--- a/src/Downhill/BVar.hs
+++ b/src/Downhill/BVar.hs
@@ -12,12 +12,17 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Downhill.BVar
   ( BVar (..),
     var,
     constant,
     backprop,
+    -- * Pattern synonyms
+    pattern T2,
+    pattern T3
   )
 where
 
@@ -26,23 +31,24 @@
 import qualified Data.AffineSpace as AffineSpace
 import Data.VectorSpace
   ( AdditiveGroup (..),
+    InnerSpace ((<.>)),
     VectorSpace ((*^)),
   )
 import qualified Data.VectorSpace as VectorSpace
 import Downhill.Grad
   ( Dual (evalGrad),
-    HasFullGrad,
-    HasGrad (Grad, MScalar, Tang),
-    HasGradAffine,
+    HasGrad (Grad, Tang),
+    HasGradAffine, MScalar
   )
 import Downhill.Linear.BackGrad
   ( BackGrad (..),
     realNode,
   )
 import qualified Downhill.Linear.Backprop as BP
-import Downhill.Linear.Expr (BasicVector, Expr (ExprVar), FullVector)
+import Downhill.Linear.Expr (BasicVector, Expr (ExprVar))
 import Downhill.Linear.Lift (lift2_dense)
 import Prelude hiding (id, (.))
+import qualified Downhill.Linear.Prelude as Linear
 
 -- | Variable is a value paired with derivative.
 data BVar r a = BVar
@@ -50,13 +56,13 @@
     bvarGrad :: BackGrad r (Grad a)
   }
 
-instance (AdditiveGroup b, HasFullGrad b) => AdditiveGroup (BVar r b) where
+instance (AdditiveGroup b, HasGrad b) => AdditiveGroup (BVar r b) where
   zeroV = BVar zeroV zeroV
   negateV (BVar y0 dy) = BVar (negateV y0) (negateV dy)
   BVar y0 dy ^-^ BVar z0 dz = BVar (y0 ^-^ z0) (dy ^-^ dz)
   BVar y0 dy ^+^ BVar z0 dz = BVar (y0 ^+^ z0) (dy ^+^ dz)
 
-instance (Num b, HasFullGrad b, MScalar b ~ b) => Num (BVar r b) where
+instance (Num b, HasGrad b, MScalar b ~ b) => Num (BVar r b) where
   (BVar f0 df) + (BVar g0 dg) = BVar (f0 + g0) (df ^+^ dg)
   (BVar f0 df) - (BVar g0 dg) = BVar (f0 - g0) (df ^-^ dg)
   (BVar f0 df) * (BVar g0 dg) = BVar (f0 * g0) (f0 *^ dg ^+^ g0 *^ df)
@@ -71,14 +77,14 @@
 rsqrt :: Floating a => a -> a
 rsqrt x = recip (sqrt x)
 
-instance (Fractional b, HasFullGrad b, MScalar b ~ b) => Fractional (BVar r b) where
+instance (Fractional b, HasGrad b, MScalar b ~ b) => Fractional (BVar r b) where
   fromRational x = BVar (fromRational x) zeroV
   recip (BVar x dx) = BVar (recip x) (df *^ dx)
     where
       df = negate (recip (sqr x))
   BVar x dx / BVar y dy = BVar (x / y) ((recip y *^ dx) ^-^ ((x / sqr y) *^ dy))
 
-instance (Floating b, HasFullGrad b, MScalar b ~ b) => Floating (BVar r b) where
+instance (Floating b, HasGrad b, MScalar b ~ b) => Floating (BVar r b) where
   pi = BVar pi zeroV
   exp (BVar x dx) = BVar (exp x) (exp x *^ dx)
   log (BVar x dx) = BVar (log x) (recip x *^ dx)
@@ -95,9 +101,9 @@
 
 instance
   ( VectorSpace v,
-    HasFullGrad v,
+    HasGrad v,
     Tang v ~ v,
-    FullVector (MScalar v),
+    BasicVector (MScalar v),
     Grad (MScalar v) ~ MScalar v
   ) =>
   VectorSpace (BVar r v)
@@ -110,13 +116,32 @@
       bpV :: Grad v -> Grad v
       bpV dz = a *^ dz
 
-instance (HasFullGrad p, HasGradAffine p) => AffineSpace (BVar r p) where
+instance (HasGrad p, HasGradAffine p) => AffineSpace (BVar r p) where
   type Diff (BVar r p) = BVar r (Tang p)
   BVar y0 dy .+^ BVar z0 dz = BVar (y0 .+^ z0) (dy ^+^ dz)
   BVar y0 dy .-. BVar z0 dz = BVar (y0 .-. z0) (dy ^-^ dz)
 
+instance
+  ( VectorSpace v,
+    HasGrad v,
+    Grad v ~ v,
+    Tang v ~ v,
+    BasicVector (MScalar v),
+    Grad (MScalar v) ~ MScalar v,
+    InnerSpace v,
+    HasGrad (MScalar v)
+  ) =>
+  InnerSpace (BVar r v)
+  where
+  BVar u du <.> BVar v dv = BVar (u <.> v) (lift2_dense bpU bpV du dv)
+    where
+      bpU :: MScalar v -> Grad v
+      bpU dz = dz *^ v
+      bpV :: MScalar v -> Grad v
+      bpV dz = dz *^ u
+
 -- | A variable with derivative of zero.
-constant :: forall r a. FullVector (Grad a) => a -> BVar r a
+constant :: forall r a. (BasicVector (Grad a), AdditiveGroup (Grad a)) => a -> BVar r a
 constant x = BVar x zeroV
 
 -- | A variable with identity derivative.
@@ -129,5 +154,21 @@
 -- | Reverse mode differentiation.
 --
 -- 
-backprop :: forall r a. (HasGrad a, FullVector (Grad a), BasicVector r) => BVar r a -> Grad a -> r
+backprop :: forall r a. (HasGrad a, BasicVector r) => BVar r a -> Grad a -> r
 backprop (BVar _y0 x) = BP.backprop x
+
+
+splitPair :: (BasicVector (Grad a), BasicVector (Grad b)) => BVar r (a, b) -> (BVar r a, BVar r b)
+splitPair (BVar (a, b) (Linear.T2 da db)) = (BVar a da, BVar b db)
+
+pattern T2 :: forall r a b. (BasicVector (Grad a), BasicVector (Grad b)) => BVar r a -> BVar r b -> BVar r (a, b)
+pattern T2 a b <- (splitPair -> (a, b))
+  where T2 (BVar a da) (BVar b db) = BVar (a, b) (Linear.T2 da db)
+
+splitTriple :: (BasicVector (Grad a), BasicVector (Grad b), BasicVector (Grad c)) => BVar r (a, b, c) -> (BVar r a, BVar r b, BVar r c)
+splitTriple (BVar (a, b, c) (Linear.T3 da db dc)) = (BVar a da, BVar b db, BVar c dc)
+
+pattern T3 :: forall r a b c. (BasicVector (Grad a), BasicVector (Grad b), BasicVector (Grad c))
+ => BVar r a -> BVar r b -> BVar r c -> BVar r (a, b, c)
+pattern T3 a b c <- (splitTriple -> (a, b, c))
+  where T3 (BVar a da) (BVar b db) (BVar c dc) = BVar (a, b, c) (Linear.T3 da db dc)
diff --git a/src/Downhill/BVar/Num.hs b/src/Downhill/BVar/Num.hs
--- a/src/Downhill/BVar/Num.hs
+++ b/src/Downhill/BVar/Num.hs
@@ -34,10 +34,10 @@
 import qualified Downhill.BVar as BVar
 import Downhill.Grad
   ( Dual (evalGrad),
-    HasGrad (Grad, Metric, MScalar, Tang),
-    MetricTensor (MtCovector, MtVector, evalMetric),
+    HasGrad (Grad, Tang)
   )
-import Downhill.Linear.Expr (BasicVector (..), FullVector (identityBuilder, negateBuilder, scaleBuilder))
+import Downhill.Linear.Expr (BasicVector (..))
+import Downhill.Metric (MetricTensor (evalMetric))
 
 -- | @AsNum a@ implements many instances in terms of @Num a@ instance.
 newtype AsNum a = AsNum {unAsNum :: a}
@@ -46,18 +46,14 @@
   deriving (Fractional) via a
   deriving (Floating) via a
 
-instance Num a => Dual (AsNum a) (AsNum a) (AsNum a) where
+instance Num a => Dual (AsNum a) (AsNum a) where
   evalGrad = (*)
 
 instance Num a => HasGrad (AsNum a) where
-  type MScalar (AsNum a) = AsNum a
   type Grad (AsNum a) = AsNum a
   type Tang (AsNum a) = AsNum a
-  type Metric (AsNum a) = AsNum a
 
-instance Num a => MetricTensor (AsNum a) where
-  type MtVector (AsNum a) = AsNum a
-  type MtCovector (AsNum a) = AsNum a
+instance Num a => MetricTensor (AsNum a) (AsNum a) where
   evalMetric (AsNum m) (AsNum x) = AsNum (m * x)
 
 instance Num a => AdditiveGroup (AsNum a) where
@@ -73,11 +69,7 @@
 instance Num a => BasicVector (AsNum a) where
   type VecBuilder (AsNum a) = Sum a
   sumBuilder = AsNum . getSum
-
-instance Num a => FullVector (AsNum a) where
   identityBuilder = Sum . unAsNum
-  negateBuilder = Sum . negate . unAsNum
-  scaleBuilder (AsNum x) (AsNum y) = Sum $ x * y
 
 instance Num a => AffineSpace (AsNum a) where
   type Diff (AsNum a) = AsNum a
diff --git a/src/Downhill/BVar/Traversable.hs b/src/Downhill/BVar/Traversable.hs
--- a/src/Downhill/BVar/Traversable.hs
+++ b/src/Downhill/BVar/Traversable.hs
@@ -4,13 +4,12 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- | Easy backpropagation when all variables have the same type.
 --
@@ -20,7 +19,7 @@
 --
 -- deriving via (TraversableVar MyRecord a) instance HasGrad a => HasGrad (MyRecord a)
 -- @
--- 
+--
 -- = Gradient type
 -- One might excect gradient type to be @type Grad (MyRecord a) = MyRecord (Grad a)@, but it's not
 -- the case, because record could contain additional members apart from @a@s, for example:
@@ -37,15 +36,13 @@
 -- and @MyPoint (Grad a)@ can't be made @VectorSpace@. Gradient type @Grad (MyRecord a)@
 -- is a newtype wrapper over @IntMap@
 -- that is not exported.
---
-
 module Downhill.BVar.Traversable
   ( -- * Backpropagate
     backpropTraversable,
     backpropTraversable_GradOnly,
     backpropTraversable_ValueAndGrad,
 
-     -- * Split
+    -- * Split
     splitTraversable,
 
     -- * TraversableVar
@@ -58,62 +55,48 @@
 import Data.Foldable (toList)
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
+import Data.Kind (Type)
 import Data.Maybe (fromMaybe)
 import Data.VectorSpace (AdditiveGroup (negateV, zeroV, (^+^), (^-^)), VectorSpace (Scalar, (*^)))
 import qualified Data.VectorSpace as VectorSpace
 import Downhill.BVar (BVar (BVar, bvarGrad, bvarValue), backprop, var)
 import Downhill.Grad
   ( Dual (evalGrad),
-    HasGrad (Grad, MScalar, Metric, Tang),
-    MetricTensor
-      ( MtCovector,
-        MtVector,
-        evalMetric
-      ),
+    HasGrad (Grad, Tang)
   )
 import Downhill.Linear.BackGrad (BackGrad (BackGrad), castBackGrad, realNode)
 import Downhill.Linear.Expr
-  ( BasicVector (VecBuilder, sumBuilder),
+  ( BasicVector (VecBuilder, identityBuilder, sumBuilder),
     Expr (ExprSum),
-    FullVector,
     SparseVector (unSparseVector),
     Term,
   )
 import Downhill.Linear.Lift (lift1_sparse)
 import GHC.Generics (Generic)
+import Downhill.Metric (MetricTensor (evalMetric))
 
 -- | Provides HasGrad instance for use in deriving via
 newtype TraversableVar f a = TraversableVar {unTraversableVar :: f a}
   deriving stock (Functor, Foldable, Traversable)
 
-newtype TraversableMetric f a = TraversableMetric (Metric a)
+newtype TraversableMetric (f :: Type -> Type) g = TraversableMetric g
   deriving (Generic)
 
-instance AdditiveGroup (Metric a) => AdditiveGroup (TraversableMetric f a)
+instance AdditiveGroup g => AdditiveGroup (TraversableMetric f g)
 
-instance VectorSpace (Metric a) => VectorSpace (TraversableMetric f a) where
-  type Scalar (TraversableMetric f a) = Scalar (Metric a)
+instance VectorSpace g => VectorSpace (TraversableMetric f g) where
+  type Scalar (TraversableMetric f g) = Scalar g
 
-instance
-  ( MetricTensor (Metric a),
-    MtVector (Metric a) ~ Tang a,
-    MtCovector (Metric a) ~ Grad a,
-    Dual s (Tang a) (Grad a)
-  ) =>
-  MetricTensor (TraversableMetric f a)
-  where
-  type MtVector (TraversableMetric f a) = IntmapVector f (Tang a)
-  type MtCovector (TraversableMetric f a) = IntmapVector f (Grad a)
-  evalMetric (TraversableMetric m) (IntmapVector da) = IntmapVector (IntMap.map (evalMetric m) da)
+instance MetricTensor p g => MetricTensor (TraversableVar f p) (TraversableMetric f g) where
+  evalMetric (TraversableMetric m) (IntmapVector da) =
+    IntmapVector (IntMap.map (evalMetric @p @g m) da)
 
 instance HasGrad a => HasGrad (TraversableVar f a) where
-  type MScalar (TraversableVar f a) = MScalar a
   type Tang (TraversableVar f a) = IntmapVector f (Tang a)
   type Grad (TraversableVar f a) = IntmapVector f (Grad a)
-  type Metric (TraversableVar f a) = TraversableMetric f a
 
 -- | @IntmapVector@ serves as a gradient of 'TraversableVar'.
-newtype IntmapVector f v = IntmapVector {unIntmapVector :: IntMap v}
+newtype IntmapVector (f :: Type -> Type) v = IntmapVector {unIntmapVector :: IntMap v}
   deriving (Show)
 
 instance AdditiveGroup a => AdditiveGroup (IntmapVector f a) where
@@ -130,7 +113,7 @@
   type Scalar (IntmapVector f v) = VectorSpace.Scalar v
   a *^ (IntmapVector v) = IntmapVector (fmap (a *^) v)
 
-instance Dual s dv v => Dual s (IntmapVector f dv) (IntmapVector f v) where
+instance Dual dv v => Dual (IntmapVector f dv) (IntmapVector f v) where
   evalGrad (IntmapVector dv) (IntmapVector v) = sumV $ IntMap.intersectionWith evalGrad dv v
 
 deriving via (IntMap v) instance Semigroup v => Semigroup (IntmapVector f v)
@@ -140,6 +123,7 @@
 instance BasicVector v => BasicVector (IntmapVector f v) where
   type VecBuilder (IntmapVector f v) = IntmapVector f (VecBuilder v)
   sumBuilder (IntmapVector v) = IntmapVector (fmap sumBuilder v)
+  identityBuilder (IntmapVector x) = IntmapVector (identityBuilder <$> x)
 
 imap ::
   forall t a b.
@@ -156,7 +140,7 @@
       return (mkBVar' index x)
 
 -- | Note that @splitTraversable@ won't be useful
--- for top level @BVar@, because the type @Grad (f a)@ is not exposed. 
+-- for top level @BVar@, because the type @Grad (f a)@ is not exposed.
 splitTraversable ::
   forall f r a.
   ( Traversable f,
@@ -188,8 +172,7 @@
   forall f r a.
   ( Traversable f,
     Grad (f a) ~ Grad (TraversableVar f a),
-    HasGrad a,
-    FullVector (Grad a)
+    HasGrad a
   ) =>
   f (BVar r a) ->
   BVar r (f a)
@@ -224,8 +207,7 @@
   ( Traversable f,
     Grad (f a) ~ Grad (TraversableVar f a),
     HasGrad a,
-    HasGrad p,
-    FullVector (Grad p)
+    HasGrad p
   ) =>
   Grad p ->
   (a -> Grad a -> b) ->
@@ -256,8 +238,7 @@
   ( Traversable f,
     Grad (f a) ~ Grad (TraversableVar f a),
     HasGrad a,
-    HasGrad p,
-    FullVector (Grad p)
+    HasGrad p
   ) =>
   Grad p ->
   (forall r. f (BVar r a) -> BVar r p) ->
@@ -274,8 +255,7 @@
   ( Traversable f,
     Grad (f a) ~ Grad (TraversableVar f a),
     HasGrad a,
-    HasGrad p,
-    FullVector (Grad p)
+    HasGrad p
   ) =>
   Grad p ->
   (forall r. f (BVar r a) -> BVar r p) ->
diff --git a/src/Downhill/Grad.hs b/src/Downhill/Grad.hs
--- a/src/Downhill/Grad.hs
+++ b/src/Downhill/Grad.hs
@@ -1,103 +1,65 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Downhill.Grad
   ( Dual (..),
-    MetricTensor (..),
-    HasGrad (..),
+    HasGrad (..), MScalar,
     GradBuilder,
-    HasFullGrad,
     HasGradAffine,
   )
 where
 
 import Data.AffineSpace (AffineSpace (Diff))
 import Data.Kind (Type)
-import Data.VectorSpace (AdditiveGroup ((^+^)), VectorSpace (Scalar, (*^)))
-import qualified Data.VectorSpace as VectorSpace
-import Downhill.Linear.Expr (BasicVector (VecBuilder), FullVector)
-import GHC.Generics (Generic)
+import Data.VectorSpace (AdditiveGroup ((^+^), zeroV), VectorSpace(Scalar))
+import Downhill.Linear.Expr (BasicVector (VecBuilder))
+import GHC.Generics (Generic (Rep, from), K1 (K1), M1 (M1), U1 (U1), V1, (:*:) ((:*:)))
 
 -- | Dual of a vector @v@ is a linear map @v -> Scalar v@.
 class
-  ( AdditiveGroup s,
+  ( 
+    Scalar v ~ Scalar dv,
+    AdditiveGroup (Scalar v),
     VectorSpace v,
-    VectorSpace dv,
-    VectorSpace.Scalar v ~ s,
-    VectorSpace.Scalar dv ~ s
+    VectorSpace dv
   ) =>
-  Dual s v dv
+  Dual v dv
   where
   -- if evalGrad goes to HasGrad class, parameter p is ambiguous
-  evalGrad :: dv -> v -> s
-
--- | @MetricTensor@ converts gradients to vectors.
---
--- It is really inverse of a metric tensor, because it maps cotangent
--- space into tangent space. Gradient descent doesn't need metric tensor,
--- it needs inverse.
-
-class
-  ( Dual (Scalar g) (MtVector g) (MtCovector g),
-    VectorSpace g
-  ) =>
-  MetricTensor g
-  where
-  type MtVector g :: Type
-  type MtCovector g :: Type
-
-  -- | @m@ must be symmetric:
-  --
-  -- @evalGrad x (evalMetric m y) = evalGrad y (evalMetric m x)@
-  evalMetric :: g -> MtCovector g -> MtVector g
-
-  -- | @innerProduct m x y = evalGrad x (evalMetric m y)@
-  innerProduct :: g -> MtCovector g -> MtCovector g -> Scalar g
-  innerProduct g x y = evalGrad x (evalMetric g y)
-
-  -- | @sqrNorm m x = innerProduct m x x@
-  sqrNorm :: g -> MtCovector g -> Scalar g
-  sqrNorm g x = innerProduct g x x
+  evalGrad :: dv -> v -> Scalar v
+  default evalGrad :: (GDual (Scalar v) (Rep v) (Rep dv), Generic dv, Generic v) => dv -> v -> Scalar v
+  evalGrad dv v = gevalGrad (from dv) (from v)
 
--- | @HasGrad@ is a collection of types and constraints that are useful
--- in many places. It helps to keep type signatures short.
+type MScalar p = Scalar (Tang p)
 
--- TODO: FullVector or not?
--- TODO: Metric or not?
+-- | Differentiable functions don't need to be constrained to vector spaces, they
+-- can be defined on other smooth manifolds, too.
 class
-  ( Dual (MScalar p) (Tang p) (Grad p),
-    MetricTensor (Metric p),
-    MtVector (Metric p) ~ Tang p,
-    MtCovector (Metric p) ~ Grad p,
-    BasicVector (Tang p),
-    BasicVector (Grad p)
+  ( Dual (Tang p) (Grad p),
+    BasicVector (Grad p),
+    Scalar (Tang p) ~ Scalar (Grad p)
   ) =>
   HasGrad p
   where
-  -- | Scalar of @Tang p@ and @Grad p@.
-  type MScalar p :: Type
-
-  -- | Tangent vector of manifold @p@. If p is 'AffineSpace', @Tang p@ should
-  -- be @'Diff' p@. If @p@ is 'VectorSpace', @Tang p@ might be the same as @p@ itself.
+  -- | Tangent space.
   type Tang p :: Type
 
-  -- | Dual of tangent space of @p@.
+  -- | Cotangent space.
   type Grad p :: Type
 
-  -- | A 'MetricTensor'.
-  type Metric p :: Type
-
 type GradBuilder v = VecBuilder (Grad v)
 
-type HasFullGrad p = (HasGrad p, FullVector (Grad p))
-
 type HasGradAffine p =
   ( AffineSpace p,
     HasGrad p,
@@ -107,32 +69,19 @@
     Grad (Tang p) ~ Grad p
   )
 
-instance Dual Integer Integer Integer where
+instance Dual Integer Integer where
   evalGrad = (*)
 
-instance MetricTensor Integer where
-  type MtVector Integer = Integer
-  type MtCovector Integer = Integer
-  evalMetric m x = m * x
-
 instance HasGrad Integer where
-  type MScalar Integer = Integer
   type Tang Integer = Integer
   type Grad Integer = Integer
-  type Metric Integer = Integer
 
-instance (Dual s a da, Dual s b db) => Dual s (a, b) (da, db) where
+instance (Scalar a ~ Scalar b, Dual a da, Dual b db) => Dual (a, b) (da, db) where
   evalGrad (a, b) (x, y) = evalGrad a x ^+^ evalGrad b y
 
-instance (Dual s a da, Dual s b db, Dual s c dc) => Dual s (a, b, c) (da, db, dc) where
+instance (Scalar a ~ Scalar b, Scalar a ~ Scalar c, Dual a da, Dual b db, Dual c dc) => Dual (a, b, c) (da, db, dc) where
   evalGrad (a, b, c) (x, y, z) = evalGrad a x ^+^ evalGrad b y ^+^ evalGrad c z
 
-instance (MetricTensor ma, MetricTensor mb, Scalar ma ~ Scalar mb) => MetricTensor (ma, mb) where
-  type MtVector (ma, mb) = (MtVector ma, MtVector mb)
-  type MtCovector (ma, mb) = (MtCovector ma, MtCovector mb)
-  evalMetric (ma, mb) (a, b) = (evalMetric ma a, evalMetric mb b)
-  sqrNorm (ma, mb) (a, b) = sqrNorm ma a ^+^ sqrNorm mb b
-
 instance
   ( HasGrad a,
     HasGrad b,
@@ -140,26 +89,10 @@
   ) =>
   HasGrad (a, b)
   where
-  type MScalar (a, b) = MScalar a
   type Grad (a, b) = (Grad a, Grad b)
   type Tang (a, b) = (Tang a, Tang b)
-  type Metric (a, b) = (Metric a, Metric b)
 
 instance
-  ( MetricTensor ma,
-    MetricTensor mb,
-    MetricTensor mc,
-    Scalar ma ~ Scalar mb,
-    Scalar ma ~ Scalar mc
-  ) =>
-  MetricTensor (ma, mb, mc)
-  where
-  type MtVector (ma, mb, mc) = (MtVector ma, MtVector mb, MtVector mc)
-  type MtCovector (ma, mb, mc) = (MtCovector ma, MtCovector mb, MtCovector mc)
-  evalMetric (ma, mb, mc) (a, b, c) = (evalMetric ma a, evalMetric mb b, evalMetric mc c)
-  sqrNorm (ma, mb, mc) (a, b, c) = sqrNorm ma a ^+^ sqrNorm mb b ^+^ sqrNorm mc c
-
-instance
   ( HasGrad a,
     HasGrad b,
     HasGrad c,
@@ -168,51 +101,37 @@
   ) =>
   HasGrad (a, b, c)
   where
-  type MScalar (a, b, c) = MScalar a
   type Grad (a, b, c) = (Grad a, Grad b, Grad c)
   type Tang (a, b, c) = (Tang a, Tang b, Tang c)
-  type Metric (a, b, c) = (Metric a, Metric b, Metric c)
 
-instance Dual Float Float Float where
+instance Dual Float Float where
   evalGrad = (*)
 
-instance MetricTensor Float where
-  type MtVector Float = Float
-  type MtCovector Float = Float
-  evalMetric m dv = m * dv
-
 instance HasGrad Float where
-  type MScalar Float = Float
   type Grad Float = Float
   type Tang Float = Float
-  type Metric Float = Float
 
-instance Dual Double Double Double where
+instance Dual Double Double where
   evalGrad = (*)
 
-instance MetricTensor Double where
-  type MtVector Double = Double
-  type MtCovector Double = Double
-  evalMetric m dv = m * dv
-
 instance HasGrad Double where
-  type MScalar Double = Double
   type Grad Double = Double
   type Tang Double = Double
-  type Metric Double = Double
 
-newtype L2 v = L2 (Scalar v)
-  deriving (Generic)
+class GDual s v dv where
+  gevalGrad :: dv p -> v p -> s
 
-instance AdditiveGroup (Scalar v) => AdditiveGroup (L2 v)
+instance (s ~ Scalar v, Dual v dv) => GDual s (K1 x v) (K1 x dv) where
+  gevalGrad (K1 dv) (K1 v) = evalGrad dv v
 
-instance (AdditiveGroup (Scalar v), Num (Scalar v)) => VectorSpace (L2 v) where
-  type Scalar (L2 v) = Scalar v
-  x *^ L2 y = L2 (x * y)
+instance (GDual s v dv) => GDual s (M1 x y v) (M1 x y' dv) where
+  gevalGrad (M1 dv) (M1 v) = gevalGrad dv v
 
-instance (AdditiveGroup a, Num a, a ~ Scalar v, Dual a v v) => MetricTensor (L2 v) where
-  type MtVector (L2 v) = v
-  type MtCovector (L2 v) = v
-  evalMetric (L2 a) u = a *^ u
-  innerProduct (L2 a) x y = a * evalGrad x y
-  sqrNorm g x = innerProduct g x x
+instance (AdditiveGroup s, GDual s u du, GDual s v dv) => GDual s (u :*: v) (du :*: dv) where
+  gevalGrad (du :*: dv) (u :*: v) = gevalGrad du u ^+^ gevalGrad dv v
+
+instance GDual s V1 V1 where
+  gevalGrad = \case {}
+
+instance AdditiveGroup s => GDual s U1 U1 where
+  gevalGrad U1 = zeroV
diff --git a/src/Downhill/Linear/BackGrad.hs b/src/Downhill/Linear/BackGrad.hs
--- a/src/Downhill/Linear/BackGrad.hs
+++ b/src/Downhill/Linear/BackGrad.hs
@@ -4,7 +4,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE TypeApplications #-}
 
 module Downhill.Linear.BackGrad
   ( BackGrad (..),
@@ -21,9 +20,8 @@
     VectorSpace (..),
   )
 import Downhill.Linear.Expr
-  ( BasicVector (VecBuilder),
+  ( BasicVector (VecBuilder, identityBuilder),
     Expr (ExprSum),
-    FullVector (identityBuilder, negateBuilder, scaleBuilder),
     Term (Term), SparseVector (unSparseVector),
   )
 
@@ -79,12 +77,12 @@
   BackGrad r z
 castBackGrad (BackGrad g) = BackGrad g
 
-instance (FullVector v) => AdditiveGroup (BackGrad r v) where
+instance (BasicVector v, AdditiveGroup v) => AdditiveGroup (BackGrad r v) where
   zeroV = realNode (ExprSum [])
-  negateV (BackGrad x) = realNode (ExprSum [x negateBuilder])
+  negateV (BackGrad x) = realNode (ExprSum [x (identityBuilder . negateV)])
   BackGrad x ^+^ BackGrad y = realNode (ExprSum [x identityBuilder, y identityBuilder])
-  BackGrad x ^-^ BackGrad y = realNode (ExprSum [x identityBuilder, y negateBuilder])
+  BackGrad x ^-^ BackGrad y = realNode (ExprSum [x identityBuilder, y (identityBuilder . negateV)])
 
-instance FullVector v => VectorSpace (BackGrad r v) where
+instance (BasicVector v, VectorSpace v) => VectorSpace (BackGrad r v) where
   type Scalar (BackGrad r v) = Scalar v
-  a *^ BackGrad v = realNode (ExprSum [v (scaleBuilder a)])
+  a *^ BackGrad v = realNode (ExprSum [v (identityBuilder . (a*^))])
diff --git a/src/Downhill/Linear/Backprop.hs b/src/Downhill/Linear/Backprop.hs
--- a/src/Downhill/Linear/Backprop.hs
+++ b/src/Downhill/Linear/Backprop.hs
@@ -25,8 +25,7 @@
 import Downhill.Internal.Graph.Types (BackFun, flipBackFun)
 import Downhill.Linear.BackGrad (BackGrad (..), castBackGrad)
 import Downhill.Linear.Expr
-  ( BasicVector (VecBuilder),
-    FullVector (identityBuilder),
+  ( BasicVector (VecBuilder, identityBuilder),
     SparseVector (SparseVector, unSparseVector),
     Term,
   )
@@ -65,5 +64,5 @@
 -- | Purity of this function depends on laws of arithmetic
 -- and linearity law of 'Term'. If your addition is approximately
 -- associative, then this function is approximately pure. Fair?
-backprop :: forall a v. (BasicVector a, FullVector v) => BackGrad a v -> v -> a
+backprop :: forall a v. (BasicVector a, BasicVector v) => BackGrad a v -> v -> a
 backprop dvar = abstractBackprop dvar identityBuilder
diff --git a/src/Downhill/Linear/Expr.hs b/src/Downhill/Linear/Expr.hs
--- a/src/Downhill/Linear/Expr.hs
+++ b/src/Downhill/Linear/Expr.hs
@@ -1,13 +1,18 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Downhill.Linear.Expr
@@ -17,12 +22,17 @@
 
     -- * Vectors
     BasicVector (..),
-    FullVector (..),
     SparseVector (..),
     DenseVector (..),
     DenseBuilder (..),
     toDenseBuilder,
 
+    -- * Generics
+    genericSumBuilder,
+    genericIdentityBuilder,
+    genericSumMaybeBuilder,
+    genericIdentityMaybeBuilder,
+
     -- * Misc
     maybeToMonoid,
   )
@@ -31,7 +41,8 @@
 import Data.Kind (Type)
 import Data.Maybe (fromMaybe)
 import Data.Semigroup (Sum (Sum, getSum))
-import Data.VectorSpace (AdditiveGroup (..), VectorSpace (..))
+import Data.VectorSpace (AdditiveGroup (..), VectorSpace (..), zeroV)
+import GHC.Generics (Generic (Rep, from, to), K1 (K1), M1 (M1), U1 (U1), V1, (:*:) ((:*:)))
 
 -- | Argument @f@ in @Term f x@ must be /linear/ function. That's a law.
 data Term a v where
@@ -57,69 +68,67 @@
   type VecBuilder v :: Type
 
   sumBuilder :: VecBuilder v -> v
+  identityBuilder :: v -> VecBuilder v
 
+  default sumBuilder ::
+    forall b.
+    ( VecBuilder v ~ Maybe b,
+      Generic b,
+      Generic v,
+      GBasicVector (Rep b) (Rep v),
+      AdditiveGroup v
+    ) =>
+    VecBuilder v ->
+    v
+  sumBuilder = genericSumMaybeBuilder @b @v
+
+  default identityBuilder ::
+    forall b.
+    ( VecBuilder v ~ Maybe b,
+      Generic b,
+      Generic v,
+      GBasicVector (Rep b) (Rep v),
+      AdditiveGroup v
+    ) =>
+    v ->
+    VecBuilder v
+  identityBuilder = genericIdentityMaybeBuilder @b @v
+
 maybeToMonoid :: Monoid m => Maybe m -> m
 maybeToMonoid = fromMaybe mempty
 
+_maybeToVector :: AdditiveGroup v => Maybe v -> v
+_maybeToVector = fromMaybe zeroV
+
 instance BasicVector Integer where
   type VecBuilder Integer = Sum Integer
   sumBuilder = getSum
+  identityBuilder = Sum
 
 instance (BasicVector a, BasicVector b) => BasicVector (a, b) where
   type VecBuilder (a, b) = Maybe (VecBuilder a, VecBuilder b)
   sumBuilder = sumPair . maybeToMonoid
     where
       sumPair (a, b) = (sumBuilder a, sumBuilder b)
+  identityBuilder (x, y) = Just (identityBuilder x, identityBuilder y)
 
 instance (BasicVector a, BasicVector b, BasicVector c) => BasicVector (a, b, c) where
   type VecBuilder (a, b, c) = Maybe (VecBuilder a, VecBuilder b, VecBuilder c)
   sumBuilder = sumTriple . maybeToMonoid
     where
       sumTriple (a, b, c) = (sumBuilder a, sumBuilder b, sumBuilder c)
+  identityBuilder (x, y, z) = Just (identityBuilder x, identityBuilder y, identityBuilder z)
 
 instance BasicVector Float where
   type VecBuilder Float = Sum Float
   sumBuilder = getSum
+  identityBuilder = Sum
 
 instance BasicVector Double where
   type VecBuilder Double = Sum Double
   sumBuilder = getSum
-
--- | Full-featured vector.
---
--- Gradients are linear functions and form a vector space.
--- @FullVector@ class provides functionality that is needed to
--- make 'VectorSpace' instances.
-class (BasicVector v, VectorSpace v) => FullVector v where
-  identityBuilder :: v -> VecBuilder v
-  negateBuilder :: v -> VecBuilder v
-  scaleBuilder :: Scalar v -> v -> VecBuilder v
-
-instance FullVector Float where
   identityBuilder = Sum
-  negateBuilder = Sum . negate
-  scaleBuilder x = Sum . (x *)
 
-instance FullVector Double where
-  identityBuilder = Sum
-  negateBuilder = Sum . negate
-  scaleBuilder x = Sum . (x *)
-
-instance FullVector Integer where
-  identityBuilder = Sum
-  negateBuilder = Sum . negate
-  scaleBuilder x = Sum . (x *)
-
-instance (Scalar a ~ Scalar b, FullVector a, FullVector b) => FullVector (a, b) where
-  identityBuilder (x, y) = Just (identityBuilder x, identityBuilder y)
-  negateBuilder (x, y) = Just (negateBuilder x, negateBuilder y)
-  scaleBuilder a (x, y) = Just (scaleBuilder a x, scaleBuilder a y)
-
-instance (s ~ Scalar a, s ~ Scalar b, s ~ Scalar c, FullVector a, FullVector b, FullVector c) => FullVector (a, b, c) where
-  identityBuilder (x, y, z) = Just (identityBuilder x, identityBuilder y, identityBuilder z)
-  negateBuilder (x, y, z) = Just (negateBuilder x, negateBuilder y, negateBuilder z)
-  scaleBuilder a (x, y, z) = Just (scaleBuilder a x, scaleBuilder a y, scaleBuilder a z)
-
 -- |  Normally graph node would compute the sum of gradients and then
 -- propagate it to ancestor nodes. That's the best strategy when
 -- some computation needs to be performed for backpropagation.
@@ -135,6 +144,7 @@
 instance Monoid (VecBuilder v) => BasicVector (SparseVector v) where
   type VecBuilder (SparseVector v) = VecBuilder v
   sumBuilder = SparseVector
+  identityBuilder = unSparseVector
 
 newtype DenseSemibuilder v = DenseSemibuilder {_unDenseSemibuilder :: v}
 
@@ -156,18 +166,44 @@
   type VecBuilder (DenseVector v) = DenseBuilder v
   sumBuilder (DenseBuilder Nothing) = DenseVector zeroV
   sumBuilder (DenseBuilder (Just x)) = DenseVector x
-
-instance VectorSpace v => FullVector (DenseVector v) where
   identityBuilder (DenseVector v) = DenseBuilder (Just v)
-  negateBuilder (DenseVector v) = DenseBuilder (Just (negateV v))
-  scaleBuilder a (DenseVector v) = DenseBuilder (Just (a *^ v))
 
-instance FullVector v => AdditiveGroup (Expr a v) where
-  zeroV = ExprSum []
-  negateV x = ExprSum [Term negateBuilder x]
-  x ^+^ y = ExprSum [Term identityBuilder x, Term identityBuilder y]
-  x ^-^ y = ExprSum [Term identityBuilder x, Term negateBuilder y]
+class GBasicVector b v where
+  gsumBuilder :: b p -> v p
+  gidentityBuilder :: v p -> b p
 
-instance FullVector dv => VectorSpace (Expr da dv) where
-  type Scalar (Expr da dv) = Scalar dv
-  a *^ v = ExprSum [Term (scaleBuilder a) v]
+instance (BasicVector v, b ~ VecBuilder v) => GBasicVector (K1 x b) (K1 x v) where
+  gsumBuilder (K1 x) = K1 (sumBuilder x)
+  gidentityBuilder (K1 x) = K1 (identityBuilder x)
+
+instance (GBasicVector b v) => GBasicVector (M1 x y b) (M1 x y' v) where
+  gsumBuilder (M1 x) = M1 (gsumBuilder x)
+  gidentityBuilder (M1 x) = M1 (gidentityBuilder x)
+
+instance (GBasicVector bu u, GBasicVector bv v) => GBasicVector (bu :*: bv) (u :*: v) where
+  gsumBuilder (x1 :*: x2) = gsumBuilder x1 :*: gsumBuilder x2
+  gidentityBuilder (x1 :*: x2) = gidentityBuilder x1 :*: gidentityBuilder x2
+
+instance GBasicVector V1 V1 where
+  gsumBuilder = \case {}
+  gidentityBuilder = \case {}
+
+instance GBasicVector U1 U1 where
+  gsumBuilder U1 = U1
+  gidentityBuilder U1 = U1
+
+genericSumBuilder :: forall b v. (Generic b, Generic v, GBasicVector (Rep b) (Rep v)) => b -> v
+genericSumBuilder = to . gsumBuilder . from
+
+genericIdentityBuilder :: forall b v. (Generic b, Generic v, GBasicVector (Rep b) (Rep v)) => v -> b
+genericIdentityBuilder = to . gidentityBuilder . from
+
+genericSumMaybeBuilder ::
+  forall b v.
+  (Generic b, Generic v, AdditiveGroup v, GBasicVector (Rep b) (Rep v)) =>
+  Maybe b ->
+  v
+genericSumMaybeBuilder = maybe zeroV genericSumBuilder
+
+genericIdentityMaybeBuilder :: forall b v. (Generic b, Generic v, GBasicVector (Rep b) (Rep v)) => v -> Maybe b
+genericIdentityMaybeBuilder = Just . genericIdentityBuilder
diff --git a/src/Downhill/Linear/Lift.hs b/src/Downhill/Linear/Lift.hs
--- a/src/Downhill/Linear/Lift.hs
+++ b/src/Downhill/Linear/Lift.hs
@@ -29,7 +29,7 @@
 where
 
 import Downhill.Linear.BackGrad (BackGrad (..), castBackGrad, realNode)
-import Downhill.Linear.Expr (BasicVector (..), Expr (ExprSum), FullVector (identityBuilder), SparseVector (unSparseVector))
+import Downhill.Linear.Expr (BasicVector (..), Expr (ExprSum), SparseVector (unSparseVector))
 import Prelude hiding (fst, snd, zip)
 
 lift1 ::
@@ -111,12 +111,12 @@
     fc' = fc . unSparseVector
 
 lift1_dense ::
-  (BasicVector v, FullVector a) =>
+  (BasicVector v, BasicVector a) =>
   ((v -> a) -> BackGrad r a -> BackGrad r v)
 lift1_dense fa = lift1 (identityBuilder . fa)
 
 lift2_dense ::
-  (BasicVector v, FullVector a, FullVector b) =>
+  (BasicVector v, BasicVector a, BasicVector b) =>
   (v -> a) ->
   (v -> b) ->
   BackGrad r a ->
@@ -125,7 +125,7 @@
 lift2_dense fa fb = lift2 (identityBuilder . fa) (identityBuilder . fb)
 
 lift3_dense ::
-  (BasicVector v, FullVector a, FullVector b, FullVector c) =>
+  (BasicVector v, BasicVector a, BasicVector b, BasicVector c) =>
   (v -> a) ->
   (v -> b) ->
   (v -> c) ->
diff --git a/src/Downhill/Metric.hs b/src/Downhill/Metric.hs
new file mode 100644
--- /dev/null
+++ b/src/Downhill/Metric.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Downhill.Metric
+  ( MetricTensor (..)
+  )
+where
+
+import Data.VectorSpace ((^+^))
+import Downhill.Grad (Dual (evalGrad), HasGrad (Grad, Tang), MScalar)
+
+-- | @MetricTensor@ converts gradients to vectors.
+--
+-- It is really inverse of a metric tensor, because it maps cotangent
+-- space into tangent space. Gradient descent doesn't need metric tensor,
+-- it needs inverse.
+class Dual (Tang p) (Grad p) => MetricTensor p g where
+  -- | @m@ must be symmetric:
+  --
+  -- @evalGrad x (evalMetric m y) = evalGrad y (evalMetric m x)@
+  evalMetric :: g -> Grad p -> Tang p
+
+  -- | @innerProduct m x y = evalGrad x (evalMetric m y)@
+  innerProduct :: g -> Grad p -> Grad p -> MScalar p
+  innerProduct g x y = evalGrad @(Tang p) @(Grad p) x (evalMetric @p g y)
+
+  -- | @sqrNorm m x = innerProduct m x x@
+  sqrNorm :: g -> Grad p -> MScalar p
+  sqrNorm g x = innerProduct @p g x x
+
+instance MetricTensor Integer Integer where
+  evalMetric m x = m * x
+
+instance (MScalar a ~ MScalar b, MetricTensor a ma, MetricTensor b mb) => MetricTensor (a, b) (ma, mb) where
+  evalMetric (ma, mb) (a, b) = (evalMetric @a ma a, evalMetric @b mb b)
+  sqrNorm (ma, mb) (a, b) = sqrNorm @a ma a ^+^ sqrNorm @b mb b
+
+instance
+  ( MScalar a ~ MScalar b,
+    MScalar a ~ MScalar c,
+    MetricTensor a ma,
+    MetricTensor b mb,
+    MetricTensor c mc
+  ) =>
+  MetricTensor (a, b, c) (ma, mb, mc)
+  where
+  evalMetric (ma, mb, mc) (a, b, c) = (evalMetric @a ma a, evalMetric @b mb b, evalMetric @c mc c)
+  sqrNorm (ma, mb, mc) (a, b, c) = sqrNorm @a ma a ^+^ sqrNorm @b mb b ^+^ sqrNorm @c mc c
+
+instance MetricTensor Float Float where
+  evalMetric m dv = m * dv
+
+instance MetricTensor Double Double where
+  evalMetric m dv = m * dv
+
+data L2 = L2
+
+instance (Dual (Tang p) (Grad p), Grad p ~ Tang p) => MetricTensor p L2 where
+  evalMetric L2 v = v
diff --git a/src/Downhill/TH.hs b/src/Downhill/TH.hs
deleted file mode 100644
--- a/src/Downhill/TH.hs
+++ /dev/null
@@ -1,917 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE UndecidableInstances #-}
-
--- | Use like this:
---
--- @
--- mkHasGradInstances
---   defaultBVarOptions
---   [d|
---     instance HasGrad MyRecord where
---       type MScalar MyRecord = Float
---     |]
--- @
---
--- Instance declaration passed to @mkHasGradInstances@ gives two important bits of information:
---
---   * Type variables for @MyRecord@, which can be concrete types (such as @instance HasGrad (MyRecord Float)@)
---     or regular type variables (@instance HasGrad (MyRecord a)@)
---
---   * Scalar type.
---
-module Downhill.TH
-  (
-    mkHasGradInstances,
-    AffineSpaceOptions (..),
-    RecordNamer (..),
-    BVarOptions (..),
-    defaultBVarOptions,
-  )
-where
-
-import Control.Monad
-import Data.AdditiveGroup ((^+^), (^-^))
-import Data.AffineSpace (AffineSpace (Diff, (.+^), (.-.)))
-import Data.Foldable (traverse_)
-import qualified Data.Map as Map
-import Data.Maybe (catMaybes)
-import Data.VectorSpace (AdditiveGroup (negateV, zeroV), VectorSpace (Scalar, (*^)))
-import Downhill.BVar (BVar (BVar))
-import Downhill.Grad
-  ( Dual (evalGrad),
-    HasGrad (Grad, MScalar, Metric, Tang),
-    MetricTensor (MtCovector, MtVector, evalMetric, sqrNorm),
-  )
-import Downhill.Linear.Expr (BasicVector (VecBuilder, sumBuilder))
-import Downhill.Linear.Lift (lift1_sparse)
-import GHC.Records (HasField (getField))
-import Language.Haskell.TH
-  ( Bang (Bang),
-    Con (NormalC, RecC),
-    Cxt,
-    Dec (DataD, InstanceD, NewtypeD, SigD),
-    Exp (AppE, ConE, InfixE, VarE),
-    Name,
-    Pat (VarP),
-    Q,
-    SourceStrictness (NoSourceStrictness),
-    SourceUnpackedness (NoSourceUnpackedness),
-    Type (AppT, ConT, VarT),
-    nameBase,
-    newName,
-  )
-import Language.Haskell.TH.Datatype (ConstructorInfo (constructorFields, constructorName, constructorVariant), ConstructorVariant (InfixConstructor, NormalConstructor, RecordConstructor), DatatypeInfo (datatypeCons, datatypeInstTypes, datatypeName, datatypeVariant, datatypeVars), DatatypeVariant (Newtype), TypeSubstitution (applySubstitution), reifyDatatype)
-import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrUnit)
-import Language.Haskell.TH.Syntax
-  ( BangType,
-    Body (NormalB),
-    Clause (Clause),
-    Dec (FunD, TySynInstD, ValD),
-    Exp (AppTypeE),
-    TyLit (StrTyLit),
-    TySynEqn (TySynEqn),
-    Type (ArrowT, EqualityT, LitT, SigT),
-    VarBangType,
-    mkNameS,
-  )
-import qualified  Language.Haskell.TH
-
-data DatatypeFields
-  = NormalFields [Type]
-  | RecordFields [(String, Type)]
-  deriving (Show)
-
-data DownhillRecord = DownhillRecord
-  { ddtTypeConName :: Name,
-    ddtDataConName :: Name,
-    ddtFieldTypes :: [Type],
-    ddtFieldNames :: Maybe [String],
-    ddtTypeVars :: [TyVarBndrUnit],
-    ddtFieldCount :: Int,
-    ddtVariant :: DatatypeVariant
-  }
-  deriving (Show)
-
-data RecordNamer = RecordNamer
-  { typeConNamer :: String -> String,
-    dataConNamer :: String -> String,
-    fieldNamer :: String -> String
-  }
-
-data RecordTranstorm = RecordTranstorm RecordNamer (Type -> Type)
-
-data AffineSpaceOptions
-  = -- | Generate AffineSpace instance
-    MakeAffineSpace
-  | -- | Don't generate AffineSpace instance
-    NoAffineSpace
-  | -- | Generate AffineSpace instance if @optExcludeFields@ is empty
-    AutoAffineSpace
-
-data BVarOptions = BVarOptions
-  { optTangNamer :: RecordNamer,
-    optGradNamer :: RecordNamer,
-    optMetricNamer :: RecordNamer,
-    optBuilderNamer :: RecordNamer,
-    optAffineSpace :: AffineSpaceOptions,
-     -- | List of fields that take no part in differentiation
-    optExcludeFields :: [String]
-  }
-
-pattern ConP :: Name -> [Pat] -> Pat
-#if MIN_VERSION_template_haskell(2,18,0)
-pattern ConP x y = Language.Haskell.TH.ConP x [] y
-#else
-pattern ConP x y = Language.Haskell.TH.ConP x y
-#endif
-
-defaultTangRecordNamer :: RecordNamer
-defaultTangRecordNamer =
-  RecordNamer
-    { typeConNamer = (++ "Tang"),
-      dataConNamer = (++ "Tang"),
-      fieldNamer = id
-    }
-
-defaultGradRecordNamer :: RecordNamer
-defaultGradRecordNamer =
-  RecordNamer
-    { typeConNamer = (++ "Grad"),
-      dataConNamer = (++ "Grad"),
-      fieldNamer = id
-    }
-
-defaultMetricRecordNamer :: RecordNamer
-defaultMetricRecordNamer =
-  RecordNamer
-    { typeConNamer = (++ "Metric"),
-      dataConNamer = (++ "Metric"),
-      fieldNamer = id
-    }
-
-defaultBuilderRecordNamer :: RecordNamer
-defaultBuilderRecordNamer =
-  RecordNamer
-    { typeConNamer = (++ "Builder"),
-      dataConNamer = (++ "Builder"),
-      fieldNamer = id
-    }
-
-defaultBVarOptions :: BVarOptions
-defaultBVarOptions =
-  BVarOptions
-    { optTangNamer = defaultTangRecordNamer,
-      optGradNamer = defaultGradRecordNamer,
-      optMetricNamer = defaultMetricRecordNamer,
-      optBuilderNamer = defaultBuilderRecordNamer,
-      optAffineSpace = AutoAffineSpace,
-      optExcludeFields = []
-    }
-
-mkConstructor :: DownhillRecord -> Con
-mkConstructor record =
-  case ddtFieldNames record of
-    Nothing ->
-      NormalC newConstrName (map mkType (ddtFieldTypes record))
-    Just names ->
-      RecC newConstrName (zipWith mkRecType names (ddtFieldTypes record))
-  where
-    newConstrName :: Name
-    newConstrName = ddtDataConName record
-    mkRecType :: String -> Type -> VarBangType
-    mkRecType name type_ =
-      ( mkNameS name,
-        Bang NoSourceUnpackedness NoSourceStrictness,
-        type_
-      )
-    mkType :: Type -> BangType
-    mkType type_ =
-      ( Bang NoSourceUnpackedness NoSourceStrictness,
-        type_
-      )
-
-parseGradConstructor :: Name -> DatatypeInfo -> ConstructorInfo -> [TyVarBndrUnit] -> Q DownhillRecord
-parseGradConstructor tyName dinfo cinfo typevars = do
-  let types = constructorFields cinfo
-      n = length types
-  (fieldTypes, fieldNames) <- case constructorVariant cinfo of
-    NormalConstructor -> return (types, Nothing)
-    InfixConstructor -> return (types, Nothing)
-    RecordConstructor fieldNames -> do
-      return (types, Just (nameBase <$> fieldNames))
-  return
-    DownhillRecord
-      { ddtTypeConName = tyName,
-        ddtDataConName = constructorName cinfo,
-        ddtTypeVars = typevars,
-        ddtFieldCount = n,
-        ddtFieldTypes = fieldTypes,
-        ddtFieldNames = fieldNames,
-        ddtVariant = datatypeVariant dinfo
-      }
-
-parseDownhillRecord :: Name -> DatatypeInfo -> Q (DownhillRecord, ConstructorInfo)
-parseDownhillRecord recordName record' = do
-  let name = datatypeName record'
-  let typevars = datatypeVars record'
-      constructors' = datatypeCons record'
-  constr' <- case constructors' of
-    [] -> fail (show recordName <> " has no data constructors")
-    [constr''] -> return constr''
-    _ -> fail (show recordName <> " has multiple data constructors")
-
-  r <- parseGradConstructor name record' constr' typevars
-  return (r, constr')
-
-elementwiseOp :: DownhillRecord -> Name -> Q Dec
-elementwiseOp record = elementwiseOp' record record record
-
-elementwiseOp' :: DownhillRecord -> DownhillRecord -> DownhillRecord -> Name -> Q Dec
-elementwiseOp' leftRecord rightRecord resRecord func = do
-  let n = ddtFieldCount resRecord
-  --dataConName :: Name
-  --dataConName = ddtDataConName record
-  xs <- replicateM n (newName "x")
-  ys <- replicateM n (newName "y")
-  let fieldOp :: Name -> Name -> Exp
-      fieldOp x y = InfixE (Just (VarE x)) (VarE func) (Just (VarE y))
-      resultFields :: [Exp]
-      resultFields = zipWith fieldOp xs ys
-      leftPat = ConP (ddtDataConName leftRecord) (map VarP xs)
-      rightPat = ConP (ddtDataConName rightRecord) (map VarP ys)
-      rhs :: Exp
-      rhs = foldl AppE (ConE (ddtDataConName resRecord)) resultFields
-      dec =
-        FunD
-          func
-          [ Clause
-              [leftPat, rightPat]
-              (NormalB rhs)
-              []
-          ]
-  return dec
-
-elementwiseValue :: DownhillRecord -> Name -> Q Dec
-elementwiseValue record func = do
-  let n = ddtFieldCount record
-      dataConName :: Name
-      dataConName = ddtDataConName record
-      rhs :: Exp
-      rhs = foldl AppE (ConE dataConName) (replicate n (VarE 'zeroV))
-      dec = ValD (VarP func) (NormalB rhs) []
-  return dec
-
-elementwiseFunc :: DownhillRecord -> Name -> Q Dec
-elementwiseFunc record func = do
-  let n = ddtFieldCount record
-      dataConName :: Name
-      dataConName = ddtDataConName record
-      rhsConName = ddtDataConName record
-  xs <- case ddtFieldNames record of
-    Nothing -> replicateM n (newName "x")
-    Just names -> traverse newName names
-  let fieldOp :: Name -> Exp
-      fieldOp = AppE (VarE func) . VarE
-      resultFields :: [Exp]
-      resultFields = map fieldOp xs
-      leftPat = ConP dataConName (map VarP xs)
-      rhs :: Exp
-      rhs = foldl AppE (ConE rhsConName) resultFields
-      dec =
-        FunD
-          func
-          [ Clause
-              [leftPat]
-              (NormalB rhs)
-              []
-          ]
-  return dec
-
-mkClassInstance :: Name -> Cxt -> DownhillRecord -> [Type] -> [Dec] -> Q [Dec]
-mkClassInstance className cxt record instVars decs = do
-  let recordType = ConT (ddtTypeConName record)
-      ihead = AppT (ConT className) (foldl AppT recordType instVars)
-  return [InstanceD Nothing cxt ihead decs]
-
-mkSemigroupInstance :: Cxt -> DownhillRecord -> [Type] -> Q [Dec]
-mkSemigroupInstance cxt record instVars = do
-  dec <- elementwiseOp record '(<>)
-  mkClassInstance ''Semigroup cxt record instVars [dec]
-
-mkAdditiveGroupInstance :: Cxt -> DownhillRecord -> [Type] -> Q [Dec]
-mkAdditiveGroupInstance cxt record instVars = do
-  zeroVDec <- elementwiseValue record 'zeroV
-  negateDec <- elementwiseFunc record 'negateV
-  plusDec <- elementwiseOp record '(^+^)
-  minusDec <- elementwiseOp record '(^-^)
-  let decs =
-        [ zeroVDec,
-          negateDec,
-          plusDec,
-          minusDec
-        ]
-  mkClassInstance ''AdditiveGroup cxt record instVars decs
-
-mkVectorSpaceInstance :: DownhillRecord -> Type -> Cxt -> [Type] -> Q [Dec]
-mkVectorSpaceInstance record scalarType cxt instVars = do
-  let n = ddtFieldCount record
-      dataConName :: Name
-      dataConName = ddtDataConName record
-  xs <- case ddtFieldNames record of
-    Nothing -> replicateM n (newName "x")
-    Just names -> traverse newName names
-
-  lhsName <- newName "s"
-  let rightPat = ConP (ddtDataConName record) (map VarP xs)
-      recordType = foldl AppT (ConT (ddtTypeConName record)) instVars
-      mulField :: Name -> Exp
-      mulField y = InfixE (Just (VarE lhsName)) (VarE '(*^)) (Just (VarE y))
-      rhsMulV :: Exp
-      rhsMulV = foldl AppE (ConE dataConName) (map mulField xs)
-  let vmulDec =
-        FunD
-          '(*^)
-          [ Clause
-              [VarP lhsName, rightPat]
-              (NormalB rhsMulV)
-              []
-          ]
-      scalarTypeDec =
-        TySynInstD
-          ( TySynEqn
-              Nothing
-              (AppT (ConT ''Scalar) recordType)
-              scalarType
-          )
-      decs = [scalarTypeDec, vmulDec]
-  mkClassInstance ''VectorSpace cxt record instVars decs
-
-mkBasicVectorInstance :: DownhillRecord -> BVarOptions -> Cxt -> [Type] -> Q [Dec]
-mkBasicVectorInstance vectorRecord options cxt instVars = do
-  sumBuilderDec <- mkSumBuilder
-  mkClassInstance ''BasicVector cxt vectorRecord instVars [vecbuilderDec, sumBuilderDec]
-  where
-    n = ddtFieldCount vectorRecord
-    builderRecord = renameDownhillRecord (builderTransform options) vectorRecord
-
-    -- not an elementiseOp, because right hand side is wrapped in Maybe
-    mkSumBuilder :: Q Dec
-    mkSumBuilder = do
-      builders <- replicateM n (newName "x")
-      let pat :: Pat
-          pat = ConP (ddtDataConName builderRecord) (map VarP builders)
-          rhs :: Exp
-          rhs =
-            foldl
-              AppE
-              (ConE (ddtDataConName vectorRecord))
-              [AppE (VarE 'sumBuilder) (VarE x) | x <- builders]
-      return $
-        FunD
-          'sumBuilder
-          [ Clause [ConP 'Nothing []] (NormalB (VarE 'zeroV)) [],
-            Clause [ConP 'Just [pat]] (NormalB rhs) []
-          ]
-
-    vecbuilderDec =
-      TySynInstD
-        ( TySynEqn
-            Nothing
-            (AppT (ConT ''VecBuilder) vectorType)
-            (AppT (ConT ''Maybe) builderType)
-        )
-      where
-        vectorType = foldl AppT (ConT (ddtTypeConName vectorRecord)) instVars
-        builderType = foldl AppT (ConT (ddtTypeConName builderRecord)) instVars
-
-sumVExpr :: [Exp] -> Exp
-sumVExpr = \case
-  [] -> VarE 'zeroV
-  exps -> foldl1 (zipExpInfix '(^+^)) exps
-  where
-    zipExpInfix :: Name -> Exp -> Exp -> Exp
-    zipExpInfix f x y = InfixE (Just x) (VarE f) (Just y)
-
-mkDualInstance ::
-  DownhillRecord ->
-  DownhillRecord ->
-  Type ->
-  Cxt ->
-  [Type] ->
-  Q [Dec]
-mkDualInstance tangRecord gradRecord scalarType cxt instVars = do
-  when (ddtFieldCount tangRecord /= ddtFieldCount gradRecord) $
-    fail "mkDualInstance: ddtFieldCount tangRecord /= ddtFieldCount gradRecord"
-  scalarTypeName <- newName "s"
-  mkClassDec (VarT scalarTypeName)
-  where
-    n = ddtFieldCount tangRecord
-
-    -- instance (cxt, AdditiveGroup s, s ~ scalarType) => AdditiveGroup (Record a1 … an) where
-    --   …
-    mkClassDec :: Type -> Q [Dec]
-    mkClassDec scalarVar = do
-      evalGradDec <- mkEvalGradDec
-      return [InstanceD Nothing (cxt ++ newConstraints) ihead [evalGradDec]]
-      where
-        -- Dual s (RecordTang a1 … an) (RecordGrad a1 … an)
-        ihead :: Type
-        ihead = ConT ''Dual `AppT` scalarVar `AppT` vecType `AppT` gradType
-          where
-            vecType = foldl AppT (ConT $ ddtTypeConName tangRecord) instVars
-            gradType = foldl AppT (ConT $ ddtTypeConName gradRecord) instVars
-        newConstraints :: Cxt
-        newConstraints =
-          [ -- AdditiveGroup s
-            AppT (ConT ''AdditiveGroup) scalarVar,
-            -- s ~ scalarType
-            AppT (AppT EqualityT scalarVar) scalarType
-          ]
-
-        -- evalGrad (RecordGrad x1 … xn) (RecordTang y1 … yn) = evalGrad x1 y1 ^+^ … ^+^ evalGrad xn yn
-        mkEvalGradDec :: Q Dec
-        mkEvalGradDec = do
-          xs <- replicateM n (newName "x")
-          ys <- replicateM n (newName "y")
-          let leftPat = ConP (ddtDataConName gradRecord) (map VarP xs)
-              rightPat = ConP (ddtDataConName tangRecord) (map VarP ys)
-              -- terms = [evalGrad x1 y1, …, evalGrad xn yn]
-              terms :: [Exp]
-              terms = zipWith evalGradExp xs ys
-                where
-                  evalGradExp :: Name -> Name -> Exp
-                  evalGradExp x y = VarE 'evalGrad `AppE` VarE x `AppE` VarE y
-              rhs = sumVExpr terms
-          return $
-            FunD
-              'evalGrad
-              [ Clause
-                  [leftPat, rightPat]
-                  (NormalB rhs)
-                  []
-              ]
-
-mkMetricInstance ::
-  DownhillRecord ->
-  DownhillRecord ->
-  DownhillRecord ->
-  Type ->
-  Cxt ->
-  [Type] ->
-  Q [Dec]
-mkMetricInstance metricRecord tangRecord gradRecord scalarType cxt instVars = do
-  scalarTypeName <- newName "s"
-  mkClassDec (VarT scalarTypeName)
-  where
-    -- instance (ctx, s ~ scalarType) => MetricTensor s (RecordMetric a1 … an) where
-    --   …
-    mkClassDec :: Type -> Q [Dec]
-    mkClassDec scalarVar = do
-      let newConstraints =
-            [ -- s ~ scalarType
-              AppT (AppT EqualityT scalarVar) scalarType
-            ]
-          -- MetricTensor s (RecordMetric a1 … an)
-          ihead = ConT ''MetricTensor `AppT` metricType
-      evalMetricDec <- mkEvalMetric
-      sqrNormDec <- mkSqrNorm
-      return
-        [ InstanceD
-            Nothing
-            (cxt ++ newConstraints)
-            ihead
-            [vectypeDec, covectorTypeDec, evalMetricDec, sqrNormDec]
-        ]
-      where
-        vectorType :: Type
-        vectorType = foldl AppT (ConT $ ddtTypeConName tangRecord) instVars
-        covectorType :: Type
-        covectorType = foldl AppT (ConT $ ddtTypeConName gradRecord) instVars
-        metricType :: Type
-        metricType = foldl AppT (ConT $ ddtTypeConName metricRecord) instVars
-        -- type MtVector (RecordMetric a1 … an) = RecordTang a1 … an
-        vectypeDec =
-          TySynInstD
-            ( TySynEqn
-                Nothing
-                (AppT (ConT ''MtVector) metricType)
-                vectorType
-            )
-        -- type MtCovector (RecordMetric a1 … an) = RecordGrad a1 … an
-        covectorTypeDec =
-          TySynInstD
-            ( TySynEqn
-                Nothing
-                (AppT (ConT ''MtCovector) metricType)
-                covectorType
-            )
-
-        mkEvalMetric :: Q Dec
-        mkEvalMetric = do
-          let n = ddtFieldCount metricRecord
-          xs <- replicateM n (newName "m")
-          ys <- replicateM n (newName "dv")
-          let leftPat, rightPat :: Pat
-              leftPat = ConP (ddtDataConName metricRecord) (map VarP xs)
-              rightPat = ConP (ddtDataConName gradRecord) (map VarP ys)
-              terms :: [Exp]
-              terms = zipWith evalGradExp xs ys
-                where
-                  evalGradExp :: Name -> Name -> Exp
-                  evalGradExp x y = VarE 'evalMetric `AppE` VarE x `AppE` VarE y
-              rhs =
-                foldl
-                  AppE
-                  (ConE (ddtDataConName tangRecord))
-                  terms
-          return $
-            FunD
-              'evalMetric
-              [ Clause
-                  [leftPat, rightPat]
-                  (NormalB rhs)
-                  []
-              ]
-
-        mkSqrNorm :: Q Dec
-        mkSqrNorm = do
-          let n = ddtFieldCount metricRecord
-          xs <- replicateM n (newName "m")
-          ys <- replicateM n (newName "dv")
-          let leftPat, rightPat :: Pat
-              leftPat = ConP (ddtDataConName metricRecord) (map VarP xs)
-              rightPat = ConP (ddtDataConName gradRecord) (map VarP ys)
-              terms :: [Exp]
-              terms = zipWith evalSqrtNorm xs ys
-                where
-                  evalSqrtNorm :: Name -> Name -> Exp
-                  evalSqrtNorm x y = VarE 'sqrNorm `AppE` VarE x `AppE` VarE y
-              rhs = sumVExpr terms
-          return $
-            FunD
-              'sqrNorm
-              [ Clause
-                  [leftPat, rightPat]
-                  (NormalB rhs)
-                  []
-              ]
-
-mkRecord :: DownhillRecord -> Q [Dec]
-mkRecord record = do
-  let newConstr = mkConstructor record
-  let newRecordName = ddtTypeConName record
-  let dataType = case ddtVariant record of
-        Newtype -> NewtypeD [] newRecordName (ddtTypeVars record) Nothing newConstr []
-        _ -> DataD [] newRecordName (ddtTypeVars record) Nothing [newConstr] []
-  return [dataType]
-
-renameTypeS :: (String -> String) -> Name -> Name
-renameTypeS f = mkNameS . f . nameBase
-
-data FieldInfo = FieldInfo
-  { fiName :: String,
-    fiIndex :: Int,
-    fiType :: Type
-  }
-
-mkGetField ::
-  DownhillRecord ->
-  DownhillRecord ->
-  Cxt ->
-  [Type] ->
-  FieldInfo ->
-  Q [Dec]
-mkGetField pointRecord gradBuilderRecord cxt instVars field = do
-  rName <- newName "r"
-  xName <- newName "x"
-  dxName <- newName "dx"
-  goName <- newName "go"
-  dxdaName <- newName "dx_da"
-  let rhsFieldList :: [Exp]
-      rhsFieldList =
-        replicate (fiIndex field) (VarE 'mempty)
-          ++ [VarE dxdaName]
-          ++ replicate (n - fiIndex field - 1) (VarE 'mempty)
-      -- rhs = MyRecordGradBuilder mempty … mempty dx_da_a6SX mempty … mempty
-      rhs :: Exp
-      rhs = foldl AppE (ConE (ddtDataConName gradBuilderRecord)) rhsFieldList
-  return
-    [ InstanceD
-        Nothing
-        cxt
-        ( AppT
-            ( AppT
-                (AppT (ConT ''HasField) (LitT (StrTyLit (fiName field))))
-                (AppT (AppT (ConT ''BVar) (VarT rName)) pointType)
-            )
-            (AppT (AppT (ConT ''BVar) (VarT rName)) (fiType field))
-        )
-        [ FunD
-            'getField
-            [ Clause
-                [ConP 'BVar [VarP xName, VarP dxName]]
-                ( NormalB
-                    ( AppE
-                        ( AppE
-                            (ConE 'BVar)
-                            (AppE (AppTypeE (VarE 'getField) (LitT (StrTyLit (fiName field)))) (VarE xName))
-                        )
-                        (AppE (AppE (VarE 'lift1_sparse) (VarE goName)) (VarE dxName))
-                    )
-                )
-                [ SigD
-                    goName
-                    ( AppT
-                        ( AppT
-                            ArrowT
-                            ( ConT ''VecBuilder
-                                `AppT` AppT (ConT ''Grad) (fiType field)
-                            )
-                        )
-                        (ConT ''Maybe `AppT` gradBuilderType)
-                    ),
-                  FunD
-                    goName
-                    [ Clause
-                        [VarP dxdaName]
-                        ( NormalB
-                            ( AppE
-                                (ConE 'Just)
-                                rhs
-                            )
-                        )
-                        []
-                    ]
-                ]
-            ]
-        ]
-    ]
-  where
-    n = ddtFieldCount pointRecord
-    applyVars :: Type -> Type
-    applyVars x = foldl AppT x instVars
-    pointType :: Type
-    pointType = applyVars (ConT $ ddtTypeConName pointRecord)
-    gradBuilderType = applyVars (ConT $ ddtTypeConName gradBuilderRecord)
-
-renameDownhillRecord :: RecordTranstorm -> DownhillRecord -> DownhillRecord
-renameDownhillRecord (RecordTranstorm namer typeFun) record =
-  DownhillRecord
-    { ddtTypeConName = renameTypeS (typeConNamer namer) (ddtTypeConName record),
-      ddtDataConName = renameTypeS (dataConNamer namer) (ddtDataConName record),
-      ddtTypeVars = ddtTypeVars record,
-      ddtFieldCount = ddtFieldCount record,
-      ddtFieldTypes = typeFun <$> ddtFieldTypes record,
-      ddtFieldNames = fmap (fmap (fieldNamer namer)) (ddtFieldNames record),
-      ddtVariant = ddtVariant record
-    }
-
-builderTransform :: BVarOptions -> RecordTranstorm
-builderTransform options = RecordTranstorm (optBuilderNamer options) (AppT (ConT ''VecBuilder))
-
-tangTransform :: BVarOptions -> RecordTranstorm
-tangTransform options = RecordTranstorm (optTangNamer options) (AppT (ConT ''Tang))
-
-gradTransform :: BVarOptions -> RecordTranstorm
-gradTransform options = RecordTranstorm (optGradNamer options) (AppT (ConT ''Grad))
-
-metricTransform :: BVarOptions -> RecordTranstorm
-metricTransform options = RecordTranstorm (optMetricNamer options) (AppT (ConT ''Metric))
-
-mkVec :: Cxt -> [Type] -> Type -> DownhillRecord -> BVarOptions -> Q [Dec]
-mkVec cxt instVars scalarType vectorType options = do
-  let builderType = renameDownhillRecord (builderTransform options) vectorType
-  tangDec <- mkRecord vectorType
-  tangBuilderDec <- mkRecord builderType
-  tangSemigroup <- mkSemigroupInstance cxt builderType instVars
-  tangInst <- mkBasicVectorInstance vectorType options cxt instVars
-  additiveTang <- mkAdditiveGroupInstance cxt vectorType instVars
-  vspaceTang <- mkVectorSpaceInstance vectorType scalarType cxt instVars
-  return
-    ( concat
-        [ tangDec,
-          tangBuilderDec,
-          tangInst,
-          tangSemigroup,
-          additiveTang,
-          vspaceTang
-        ]
-    )
-
-mkDVar'' ::
-  Cxt ->
-  DownhillRecord ->
-  BVarOptions ->
-  Type ->
-  [Type] ->
-  ConstructorInfo ->
-  Q [Dec]
-mkDVar'' cxt pointRecord options scalarType instVars substitutedCInfo = do
-  let tangRecord = renameDownhillRecord (tangTransform options) pointRecord
-      gradRecord = renameDownhillRecord (gradTransform options) pointRecord
-      metricRecord = renameDownhillRecord (metricTransform options) pointRecord
-
-  tangDecs <- mkVec cxt instVars scalarType tangRecord options
-  gradDecs <- mkVec cxt instVars scalarType gradRecord options
-
-  metricDec <- mkRecord metricRecord
-  additiveMetric <- mkAdditiveGroupInstance cxt metricRecord instVars
-  vspaceMetric <- mkVectorSpaceInstance metricRecord scalarType cxt instVars
-  dualInstance <- mkDualInstance tangRecord gradRecord scalarType cxt instVars
-  metricInstance <- mkMetricInstance metricRecord tangRecord gradRecord scalarType cxt instVars
-  let needAffineSpace = case optAffineSpace options of
-        MakeAffineSpace -> True
-        NoAffineSpace -> False
-        AutoAffineSpace -> null (optExcludeFields options)
-
-  affineSpaceInstance <-
-    if needAffineSpace
-      then mkAffineSpaceInstance cxt pointRecord tangRecord instVars
-      else return []
-
-  hasFieldInstance <- case ddtFieldNames pointRecord of
-    Nothing -> return []
-    Just names ->
-      let info :: Int -> String -> Type -> FieldInfo
-          info index name = FieldInfo name index
-          substitutedFields = constructorFields substitutedCInfo
-          fields :: [FieldInfo]
-          fields = zipWith3 info [0 ..] names substitutedFields
-       in concat
-            <$> traverse
-              ( mkGetField
-                  pointRecord
-                  ( renameDownhillRecord (builderTransform options) gradRecord
-                  )
-                  cxt
-                  instVars
-              )
-              fields
-
-  let decs =
-        [ tangDecs,
-          gradDecs,
-          additiveMetric,
-          vspaceMetric,
-          dualInstance,
-          metricDec,
-          metricInstance,
-          hasFieldInstance,
-          affineSpaceInstance
-        ]
-  return (concat decs)
-
-parseRecordType :: Type -> [Type] -> Q (Name, [Type])
-parseRecordType type_ vars = case type_ of
-  AppT inner typeVar -> parseRecordType inner (typeVar : vars)
-  ConT recordName -> return (recordName, vars)
-  _ -> fail "Expected (T a1 ... an) in constraint"
-
-mkAffineSpaceInstance :: Cxt -> DownhillRecord -> DownhillRecord -> [Type] -> Q [Dec]
-mkAffineSpaceInstance cxt recordPoint recordTang instVars = do
-  plusDec <- elementwiseOp' recordPoint recordTang recordPoint '(.+^)
-  minusDec <- elementwiseOp' recordPoint recordPoint recordTang '(.-.)
-  let recordTypePoint = foldl AppT (ConT (ddtTypeConName recordPoint)) instVars
-      recordTypeTang = foldl AppT (ConT (ddtTypeConName recordTang)) instVars
-      diffTypeDec =
-        TySynInstD
-          ( TySynEqn
-              Nothing
-              (AppT (ConT ''Diff) recordTypePoint)
-              recordTypeTang
-          )
-  let decs =
-        [ plusDec,
-          minusDec,
-          diffTypeDec
-        ]
-  mkClassInstance ''AffineSpace cxt recordPoint instVars decs
-
-filterFields :: forall m. MonadFail m => BVarOptions -> DownhillRecord -> m DownhillRecord
-filterFields options record =
-  case optExcludeFields options of
-    [] -> return record
-    _ -> do
-      fieldList <- case ddtFieldNames record of
-        Just fields -> return fields
-        Nothing -> fail (nameBase (ddtTypeConName record) ++ " is not a records, can't exclude fields")
-      doFilterFields fieldList
-  where
-    doFilterFields fieldList = do
-      traverse_ check (optExcludeFields options)
-      return
-        record
-          { ddtFieldTypes = go (ddtFieldTypes record),
-            ddtFieldNames = go <$> ddtFieldNames record,
-            ddtFieldCount = goN (ddtFieldCount record)
-          }
-      where
-        check :: String -> m ()
-        check name
-          | name `elem` fieldList = return ()
-          | otherwise = fail ("Field " ++ name ++ " is not a member of " ++ nameBase (ddtTypeConName record))
-        excludeZipList :: [x -> Maybe x]
-        excludeZipList = filterField <$> fieldList
-          where
-            filterField :: String -> x -> Maybe x
-            filterField fieldName x
-              | fieldName `elem` optExcludeFields options = Nothing
-              | otherwise = Just x
-        go :: [a] -> [a]
-        go = catMaybes . zipWith ($) excludeZipList
-        goN :: Int -> Int
-        goN n = length . go $ replicate n ()
-
-mkDVarC1 :: BVarOptions -> Dec -> Q [Dec]
-mkDVarC1 options = \case
-  InstanceD mayOverlap cxt type_ decs -> do
-    case mayOverlap of
-      Just _ -> fail "Overlapping instances not implemented"
-      _ -> return ()
-    case type_ of
-      AppT (ConT hasgradCtx) recordInConstraintType -> do
-        when (hasgradCtx /= ''HasGrad) $
-          fail $ "Constraint must be `HasGrad`, got " ++ show hasgradCtx
-        (recordName, instVars) <- parseRecordType recordInConstraintType []
-        record' <- reifyDatatype recordName
-
-        (fullParsedRecord, cinfo) <- parseDownhillRecord recordName record'
-        parsedRecord <- filterFields options fullParsedRecord
-        recordTypeVarNames <- do
-          let getName x = case x of
-                SigT (VarT y) _ -> return y
-                _ -> fail "Type variable is not VarT"
-          traverse getName (datatypeInstTypes record')
-        -- We have two sets of type variables: one in record definition (as in `data MyRecord a b c = ...`)
-        -- and another one in instance head (`instance HasGrad (MyRecord a' b' c')). We need
-        -- those from instance head for HasField instances.
-        let substPairs = zip recordTypeVarNames instVars
-            substitutedRecord = applySubstitution (Map.fromList substPairs) cinfo
-
-        scalarType <- case decs of
-          [] -> fail "`HasGrad` instance has no declarations"
-          [dec1] -> case dec1 of
-            TySynInstD (TySynEqn _ (AppT (ConT scalarName) _) scalarType) -> do
-              when (scalarName /= ''MScalar) $
-                fail ("Expected `Scalar` equation, got " ++ show scalarName)
-              return scalarType
-            _ -> fail "HasGrad instance must contain `Scalar ... = ...` declaration"
-          _ -> fail "`HasGrad` has multiple declarations"
-
-        dvar <- mkDVar'' cxt parsedRecord options scalarType instVars substitutedRecord
-
-        let tangName = ddtTypeConName (renameDownhillRecord (tangTransform options) parsedRecord)
-            gradName = ddtTypeConName (renameDownhillRecord (gradTransform options) parsedRecord)
-            metricName = ddtTypeConName (renameDownhillRecord (metricTransform options) parsedRecord)
-            tangTypeDec =
-              TySynInstD
-                ( TySynEqn
-                    Nothing
-                    (AppT (ConT ''Tang) recordInConstraintType)
-                    (foldl AppT (ConT tangName) instVars)
-                )
-            gradTypeDec =
-              TySynInstD
-                ( TySynEqn
-                    Nothing
-                    (AppT (ConT ''Grad) recordInConstraintType)
-                    (foldl AppT (ConT gradName) instVars)
-                )
-            metricTypeDec =
-              TySynInstD
-                ( TySynEqn
-                    Nothing
-                    (AppT (ConT ''Metric) recordInConstraintType)
-                    (foldl AppT (ConT metricName) instVars)
-                )
-
-            hasgradInstance =
-              InstanceD
-                Nothing
-                cxt
-                type_
-                ( decs
-                    ++ [ tangTypeDec,
-                         gradTypeDec,
-                         metricTypeDec
-                       ]
-                )
-        return $ dvar ++ [hasgradInstance]
-      _ -> fail "Instance head is not a constraint"
-  _ -> fail "Expected instance declaration"
-
--- | Generates @HasGrad@ instance, along with @Tang@ and @Grad@ types,
--- @VecBuilder@ types and all other instances needed for @HasGrad@.
-mkHasGradInstances :: BVarOptions -> Q [Dec] -> Q [Dec]
-mkHasGradInstances options decs = concat <$> (traverse (mkDVarC1 options) =<< decs)
diff --git a/test/DownhillTest/Bilinear.hs b/test/DownhillTest/Bilinear.hs
new file mode 100644
--- /dev/null
+++ b/test/DownhillTest/Bilinear.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module DownhillTest.Bilinear where
+
+import Data.AffineSpace ((.+^))
+import Data.VectorSpace (AdditiveGroup, VectorSpace ((*^), Scalar), (^+^))
+import Downhill.BVar (BVar (bvarValue))
+import qualified Downhill.BVar as BVar
+import Downhill.Grad (Dual (evalGrad), HasGrad (Grad), MScalar)
+import Hedgehog
+  ( Gen,
+    Property,
+    forAll,
+    property,
+    (===),
+  )
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Hedgehog (testProperty, testPropertyNamed)
+import GHC.Base (VecElem(DoubleElemRep))
+import Hedgehog.Internal.Show (Value(Integer))
+import qualified Hedgehog.Internal.Show as Gen
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import GHC.Generics (Generic)
+import Downhill.Linear.Expr (BasicVector, DenseVector (DenseVector))
+
+testBilinear ::
+  ( Show u,
+    Show v,
+    HasGrad u,
+    HasGrad v,
+    Show (Grad z),
+    HasGrad z,
+    Eq z,
+    AdditiveGroup u,
+    Show z,
+    AdditiveGroup z,
+    Dual (Grad u) u,
+    Eq (Scalar u),
+    Show (Scalar u),
+    Scalar u ~ Scalar z,
+    Scalar v ~ Scalar z,
+    Dual (Grad z) z, Show (MScalar z), Dual (Grad v) v) =>
+  (u -> v -> z) ->
+  (forall r. BVar r u -> BVar r v -> BVar r z) ->
+  Gen u ->
+  Gen v ->
+  Gen (Grad z) ->
+  Property
+testBilinear f bf genU genV genDZ = property $ do
+  u <- forAll genU
+  v <- forAll genV
+  dz <- forAll genDZ
+  let z = f u v
+      BVar.T2 bu bv = BVar.var (u, v)
+      bz = bf bu bv
+      (du, dv) = BVar.backprop bz dz
+  bvarValue bz === z -- check that `f` and `bf` is the same function
+  evalGrad u du === evalGrad z dz
+  evalGrad v dv === evalGrad z dz
+
+data Vector = Vector Integer Integer
+  deriving Generic
+
+instance AdditiveGroup Vector
+instance VectorSpace Vector
+
+bilinearIntMulProperty :: Property
+bilinearIntMulProperty = testBilinear ((*) @Integer) (*) genInt genInt genInt
+  where
+    scalarMul :: Integer -> Integer -> Integer
+    scalarMul = (*)
+    genInt :: Gen Integer
+    genInt = Gen.integral (Range.linear (-100) 100)
+
+
+bilinearTests :: TestTree
+bilinearTests =
+   testGroup "Bilinear operations"
+     [ testPropertyNamed "Scalar multiplication" "bilinearIntMulProperty" bilinearIntMulProperty
+       -- TODO: scalar-vector product, inner product
+     ]
diff --git a/test/DownhillTest/TH.hs b/test/DownhillTest/TH.hs
deleted file mode 100644
--- a/test/DownhillTest/TH.hs
+++ /dev/null
@@ -1,102 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeApplications #-}
-
-module DownhillTest.TH (thTest) where
-
-import Data.AffineSpace (AffineSpace (..))
-import Downhill.Grad (HasGrad (MScalar, Tang))
-import Downhill.TH (BVarOptions (..), RecordNamer (..), mkHasGradInstances)
-import Test.Tasty (TestTree, testGroup)
-import DownhillTest.TestTHOptions (defaultDVarOptions)
-
-{-# ANN module "HLint: ignore Use newtype instead of data" #-}
-newtype MyRecord1 = MyRecord1 Float
-
-data MyRecord2 = MyRecord2 Float
-
-mkHasGradInstances
-  defaultDVarOptions
-  [d|
-    instance HasGrad MyRecord1 where
-      type MScalar MyRecord1 = Float
-    |]
-
-mkHasGradInstances
-  defaultDVarOptions
-  [d|
-    instance HasGrad MyRecord2 where
-      type MScalar MyRecord2 = Float
-    |]
-
-data MyRecord3 = MyRecord3
-
-mkHasGradInstances
-  defaultDVarOptions
-  [d|
-    instance HasGrad MyRecord3 where
-      type MScalar MyRecord3 = ()
-    |]
-
-data MyRecord4 a = MyRecord4 a
-
-mkHasGradInstances
-  defaultDVarOptions
-  [d|
-    instance (AffineSpace a, HasGrad a, Diff a ~ Tang a) => HasGrad (MyRecord4 a) where
-      type MScalar (MyRecord4 a) = MScalar a
-    |]
-
-data MyRecord5 a b = MyRecord5 a b
-
-mkHasGradInstances
-  defaultDVarOptions
-  [d|
-    instance
-      ( AffineSpace a,
-        AffineSpace b,
-        HasGrad a,
-        HasGrad b,
-        MScalar a ~ MScalar b,
-        Diff a ~ Tang a,
-        Diff b ~ Tang b
-      ) =>
-      HasGrad (MyRecord5 a b)
-      where
-      type MScalar (MyRecord5 a b) = MScalar a
-    |]
-
-data MyRecord6 a b = MyRecord6 a b
-
-mkHasGradInstances
-  defaultDVarOptions
-  [d|
-    instance
-      ( AffineSpace a,
-        HasGrad a,
-        MScalar a ~ Float,
-        Diff a ~ Tang a
-      ) =>
-      HasGrad (MyRecord6 a Float)
-      where
-      type MScalar (MyRecord6 a Float) = Float
-    |]
-
-data MyRecord7 a = MyRecord7
-  { myField7 :: a
-  , myLabel7 :: String
-  }
-
-mkHasGradInstances
-  defaultDVarOptions {optExcludeFields = ["myLabel7"]}
-  [d|
-    instance HasGrad a => HasGrad (MyRecord7 a) where
-      type MScalar (MyRecord7 a) = MScalar a
-    |]
-
-thTest :: TestTree
-thTest = testGroup "Template Haskell" [] -- just test if it compiles...
diff --git a/test/DownhillTest/TestTHOptions.hs b/test/DownhillTest/TestTHOptions.hs
deleted file mode 100644
--- a/test/DownhillTest/TestTHOptions.hs
+++ /dev/null
@@ -1,46 +0,0 @@
-module DownhillTest.TestTHOptions(defaultDVarOptions) where
-import Downhill.TH ( mkHasGradInstances, RecordNamer(..), BVarOptions(..), AffineSpaceOptions (AutoAffineSpace))
-
-defaultTangRecordNamer :: RecordNamer
-defaultTangRecordNamer =
-  RecordNamer
-    { typeConNamer = (++ "TangT"),
-      dataConNamer = (++ "TangD"),
-      fieldNamer = id
-    }
-
-defaultGradRecordNamer :: RecordNamer
-defaultGradRecordNamer =
-  RecordNamer
-    { typeConNamer = (++ "GradT"),
-      dataConNamer = (++ "GradD"),
-      fieldNamer = id
-    }
-
-defaultMetricRecordNamer :: RecordNamer
-defaultMetricRecordNamer =
-  RecordNamer
-    { typeConNamer = (++ "MetricT"),
-      dataConNamer = (++ "MetricD"),
-      fieldNamer = id
-    }
-
-defaultBuilderRecordNamer :: RecordNamer
-defaultBuilderRecordNamer =
-  RecordNamer
-    { typeConNamer = (++ "BuilderT"),
-      dataConNamer = (++ "BuilderD"),
-      fieldNamer = id
-    }
-
-defaultDVarOptions :: BVarOptions
-defaultDVarOptions =
-  BVarOptions
-    { optTangNamer = defaultTangRecordNamer,
-      optGradNamer = defaultGradRecordNamer,
-      optMetricNamer = defaultMetricRecordNamer,
-      optBuilderNamer = defaultBuilderRecordNamer,
-      optAffineSpace = AutoAffineSpace,
-      optExcludeFields = []
-    }
-
diff --git a/test/Main.hs b/test/Main.hs
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -5,7 +5,7 @@
 import qualified Test.Tasty as Tasty
 import Downhill.BVar.Num (NumBVar(..), backpropNum, constant, var, numbvarValue, AsNum)
 import DownhillTest.Traversable(recordTest)
-import DownhillTest.TH (thTest)
+import DownhillTest.Bilinear(bilinearTests)
 
 basicTests = testGroup "Basic tests"
   [ testCase "Derivative of constant == 0" testConstant
@@ -20,6 +20,6 @@
             in backpropNum ((2+3*x) * (5+7*x)) @?= 29 + 42 * numbvarValue x
 
 tests :: TestTree
-tests = testGroup "Tests" [basicTests, recordTest, thTest]
+tests = testGroup "Tests" [basicTests, recordTest, bilinearTests]
 
 main = defaultMain tests