downhill 0.1.0.0 → 0.2.0.0

raw patch · 16 files changed

+398/−1328 lines, 16 filesdep +hedgehogdep +tasty-hedgehogPVP ok

version bump matches the API change (PVP)

Dependencies added: hedgehog, tasty-hedgehog

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−1
• downhill.cabal +10/−4
• src/Downhill/BVar.hs +54/−13
• src/Downhill/BVar/Num.hs +5/−13
• src/Downhill/BVar/Traversable.hs +22/−42
• src/Downhill/Grad.hs +44/−125
• src/Downhill/Linear/BackGrad.hs +6/−8
• src/Downhill/Linear/Backprop.hs +2/−3
• src/Downhill/Linear/Expr.hs +84/−48
• src/Downhill/Linear/Lift.hs +4/−4
• src/Downhill/Metric.hs +65/−0
• src/Downhill/TH.hs +0/−917
• test/DownhillTest/Bilinear.hs +92/−0
• test/DownhillTest/TH.hs +0/−102
• test/DownhillTest/TestTHOptions.hs +0/−46
• test/Main.hs +2/−2

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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) ->

@@ -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

@@ -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*^))])

@@ -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

@@ -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

@@ -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) ->

@@ -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

@@ -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)

@@ -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+     ]

@@ -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...

@@ -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 = []-    }-

@@ -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