Introduce DerivingVia

This implements the `DerivingVia` proposal put forth in
https://github.com/ghc-proposals/ghc-proposals/pull/120.

This introduces the `DerivingVia` deriving strategy. This is a
generalization of `GeneralizedNewtypeDeriving` that permits the user
to specify the type to `coerce` from.

The major change in this patch is the introduction of the
`ViaStrategy` constructor to `DerivStrategy`, which takes a type
as a field. As a result, `DerivStrategy` is no longer a simple
enumeration type, but rather something that must be renamed and
typechecked. The process by which this is done is explained more
thoroughly in section 3 of this paper
( https://www.kosmikus.org/DerivingVia/deriving-via-paper.pdf ),
although I have inlined the relevant parts into Notes where possible.

There are some knock-on changes as well. I took the opportunity to
do some refactoring of code in `TcDeriv`, especially the
`mkNewTypeEqn` function, since it was bundling all of the logic for
(1) deriving instances for newtypes and
(2) `GeneralizedNewtypeDeriving`
into one huge broth. `DerivingVia` reuses much of part (2), so that
was factored out as much as possible.

Bumps the Haddock submodule.

Test Plan: ./validate

Reviewers: simonpj, bgamari, goldfire, alanz

Subscribers: alanz, goldfire, rwbarton, thomie, mpickering, carter

GHC Trac Issues: #15178

Differential Revision: https://phabricator.haskell.org/D4684

12 files changed, 596 insertions, 0 deletions

diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 0e0494f7e2..61b888ea01 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -36,6 +36,8 @@ test('T5939', normal, compile, [''])
 test('drv-functor1', normal, compile, [''])
 test('drv-functor2', normal, compile, [''])
 test('drv-foldable-traversable1', normal, compile, [''])
+test('deriving-via-compile', normal, compile, [''])
+test('deriving-via-standalone', normal, compile, [''])
 test('T6031', [], multimod_compile, ['T6031', '-v0 -O'])
 # Adding -O on T6031 to expose Trac #11245 regardless of way
 test('T1133', [], run_command, ['$MAKE --no-print-directory -s T1133'])
diff --git a/testsuite/tests/deriving/should_compile/deriving-via-compile.hs b/testsuite/tests/deriving/should_compile/deriving-via-compile.hs
new file mode 100644
index 0000000000..b679acb8cd
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/deriving-via-compile.hs
@@ -0,0 +1,459 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+module DerivingViaCompile where
+
+import Data.Void
+import Data.Complex
+import Data.Functor.Const
+import Data.Functor.Identity
+import Data.Ratio
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+import Control.Applicative hiding (WrappedMonad(..))
+
+import Data.Bifunctor
+import Data.Monoid
+import Data.Kind
+
+type f ~> g = forall xx. f xx -> g xx
+
+-----
+-- Simple example
+-----
+
+data Foo a = MkFoo a a
+  deriving Show
+       via (Identity (Foo a))
+
+-----
+-- Eta reduction at work
+-----
+
+newtype Flip p a b = Flip { runFlip :: p b a }
+
+instance Bifunctor p => Bifunctor (Flip p) where
+  bimap f g = Flip . bimap g f . runFlip
+
+instance Bifunctor p => Functor (Flip p a) where
+  fmap f = Flip . first f . runFlip
+
+newtype Bar a = MkBar (Either a Int)
+  deriving Functor
+       via (Flip Either Int)
+
+-----
+-- Monad transformers
+-----
+
+type MTrans = (Type -> Type) -> (Type -> Type)
+
+-- From `constraints'
+data Dict c where
+  Dict :: c => Dict c
+
+newtype a :- b = Sub (a => Dict b)
+
+infixl 1 \\
+(\\) :: a => (b => r) -> (a :- b) -> r
+r \\ Sub Dict = r
+
+-- With `-XQuantifiedConstraints' this just becomes
+--
+--    type Lifting cls  trans = forall mm. cls mm => cls (trans mm)
+--
+--    type LiftingMonad trans = Lifting Monad trans
+--
+class LiftingMonad (trans :: MTrans) where
+  proof :: Monad m :- Monad (trans m)
+
+instance LiftingMonad (StateT s :: MTrans) where
+  proof :: Monad m :- Monad (StateT s m)
+  proof = Sub Dict
+
+instance Monoid w => LiftingMonad (WriterT w :: MTrans) where
+  proof :: Monad m :- Monad (WriterT w m)
+  proof = Sub Dict
+
+instance (LiftingMonad trans, LiftingMonad trans') => LiftingMonad (ComposeT trans trans' :: MTrans) where
+  proof :: forall m. Monad m :- Monad (ComposeT trans trans' m)
+  proof = Sub (Dict \\ proof @trans @(trans' m) \\ proof @trans' @m)
+
+newtype Stack :: MTrans where
+  Stack :: ReaderT Int (StateT Bool (WriterT String m)) a -> Stack m a
+  deriving newtype
+    ( Functor
+    , Applicative
+    , Monad
+    , MonadReader Int
+    , MonadState Bool
+    , MonadWriter String
+    )
+  deriving (MonadTrans, MFunctor)
+       via (ReaderT Int `ComposeT` StateT Bool `ComposeT` WriterT String)
+
+class MFunctor (trans :: MTrans) where
+  hoist :: Monad m => (m ~> m') -> (trans m ~> trans m')
+
+instance MFunctor (ReaderT r :: MTrans) where
+  hoist :: Monad m => (m ~> m') -> (ReaderT r m ~> ReaderT r m')
+  hoist nat = ReaderT . fmap nat . runReaderT
+
+instance MFunctor (StateT s :: MTrans) where
+  hoist :: Monad m => (m ~> m') -> (StateT s m ~> StateT s m')
+  hoist nat = StateT . fmap nat . runStateT
+
+instance MFunctor (WriterT w :: MTrans) where
+  hoist :: Monad m => (m ~> m') -> (WriterT w m ~> WriterT w m')
+  hoist nat = WriterT . nat . runWriterT
+
+infixr 9 `ComposeT`
+newtype ComposeT :: MTrans -> MTrans -> MTrans where
+  ComposeT :: { getComposeT :: f (g m) a } -> ComposeT f g m a
+  deriving newtype (Functor, Applicative, Monad)
+
+instance (MonadTrans f, MonadTrans g, LiftingMonad g) => MonadTrans (ComposeT f g) where
+  lift :: forall m. Monad m => m ~> ComposeT f g m
+  lift = ComposeT . lift . lift
+    \\ proof @g @m
+
+instance (MFunctor f, MFunctor g, LiftingMonad g) => MFunctor (ComposeT f g) where
+  hoist :: forall m m'. Monad m => (m ~> m') -> (ComposeT f g m ~> ComposeT f g m')
+  hoist f = ComposeT . hoist (hoist f) . getComposeT
+    \\ proof @g @m
+
+-----
+-- Using tuples in a `via` type
+-----
+
+newtype X a = X (a, a)
+  deriving (Semigroup, Monoid)
+       via (Product a, Sum a)
+
+  deriving (Show, Eq)
+       via (a, a)
+
+-----
+-- Abstract data types
+-----
+
+class C f where
+  c :: f a -> Int
+
+newtype X2 f a = X2 (f a)
+
+instance C (X2 f) where
+  c = const 0
+
+deriving via (X2 IO) instance C IO
+
+----
+-- Testing parser
+----
+
+newtype P0 a = P0 a             deriving Show via a
+newtype P1 a = P1 [a]           deriving Show via [a]
+newtype P2 a = P2 (a, a)        deriving Show via (a, a)
+newtype P3 a = P3 (Maybe a)     deriving Show via (First a)
+newtype P4 a = P4 (Maybe a)     deriving Show via (First $ a)
+newtype P5 a = P5 a             deriving Show via (Identity $ a)
+newtype P6 a = P6 [a]           deriving Show via ([] $ a)
+newtype P7 a = P7 (a, a)        deriving Show via (Identity $ (a, a))
+newtype P8 a = P8 (Either () a) deriving Functor via (($) (Either ()))
+
+newtype f $ a = APP (f a) deriving newtype Show deriving newtype Functor
+
+----
+-- From Baldur's notes
+----
+
+----
+-- 1
+----
+newtype WrapApplicative f a = WrappedApplicative (f a)
+  deriving (Functor, Applicative)
+
+instance (Applicative f, Num a) => Num (WrapApplicative f a) where
+  (+)         = liftA2 (+)
+  (*)         = liftA2 (*)
+  negate      = fmap negate
+  fromInteger = pure . fromInteger
+  abs         = fmap abs
+  signum      = fmap signum
+
+instance (Applicative f, Fractional a) => Fractional (WrapApplicative f a) where
+  recip        = fmap recip
+  fromRational = pure . fromRational
+
+instance (Applicative f, Floating a) => Floating (WrapApplicative f a) where
+  pi    = pure pi
+  sqrt  = fmap sqrt
+  exp   = fmap exp
+  log   = fmap log
+  sin   = fmap sin
+  cos   = fmap cos
+  asin  = fmap asin
+  atan  = fmap atan
+  acos  = fmap acos
+  sinh  = fmap sinh
+  cosh  = fmap cosh
+  asinh = fmap asinh
+  atanh = fmap atanh
+  acosh = fmap acosh
+
+instance (Applicative f, Semigroup s) => Semigroup (WrapApplicative f s) where
+  (<>) = liftA2 (<>)
+
+instance (Applicative f, Monoid m) => Monoid (WrapApplicative f m) where
+  mempty = pure mempty
+
+----
+-- 2
+----
+class Pointed p where
+  pointed :: a -> p a
+
+newtype WrapMonad f a = WrappedMonad (f a)
+  deriving newtype (Pointed, Monad)
+
+instance (Monad m, Pointed m) => Functor (WrapMonad m) where
+  fmap = liftM
+
+instance (Monad m, Pointed m) => Applicative (WrapMonad m) where
+  pure  = pointed
+  (<*>) = ap
+
+-- data
+data Sorted a = Sorted a a a
+  deriving (Functor, Applicative)
+    via (WrapMonad Sorted)
+  deriving (Num, Fractional, Floating, Semigroup, Monoid)
+    via (WrapApplicative Sorted a)
+
+
+instance Monad Sorted where
+  (>>=) :: Sorted a -> (a -> Sorted b) -> Sorted b
+  Sorted a b c >>= f = Sorted a' b' c' where
+    Sorted a' _  _  = f a
+    Sorted _  b' _  = f b
+    Sorted _  _  c' = f c
+
+instance Pointed Sorted where
+  pointed :: a -> Sorted a
+  pointed a = Sorted a a a
+
+----
+-- 3
+----
+class IsZero a where
+  isZero :: a -> Bool
+
+newtype WrappedNumEq  a = WrappedNumEq a
+newtype WrappedShow   a = WrappedShow  a
+newtype WrappedNumEq2 a = WrappedNumEq2 a
+
+instance (Num a, Eq a) => IsZero (WrappedNumEq a) where
+  isZero :: WrappedNumEq a -> Bool
+  isZero (WrappedNumEq a) = 0 == a
+
+instance Show a => IsZero (WrappedShow a) where
+  isZero :: WrappedShow a -> Bool
+  isZero (WrappedShow a) = "0" == show a
+
+instance (Num a, Eq a) => IsZero (WrappedNumEq2 a) where
+  isZero :: WrappedNumEq2 a -> Bool
+  isZero (WrappedNumEq2 a) = a + a == a
+
+newtype INT = INT Int
+  deriving newtype Show
+  deriving IsZero via (WrappedNumEq Int)
+
+newtype VOID = VOID Void deriving IsZero via (WrappedShow Void)
+
+----
+-- 4
+----
+class Bifunctor p => Biapplicative p where
+  bipure :: a -> b -> p a b
+
+  biliftA2
+    :: (a  -> b  -> c)
+    -> (a' -> b' -> c')
+    -> p a a'
+    -> p b b'
+    -> p c c'
+
+instance Biapplicative (,) where
+  bipure = (,)
+
+  biliftA2 f f' (a, a') (b, b') =
+    (f a b, f' a' b')
+
+newtype WrapBiapp p a b = WrapBiap (p a b)
+  deriving newtype (Bifunctor, Biapplicative, Eq)
+
+instance (Biapplicative p, Num a, Num b) => Num (WrapBiapp p a b) where
+  (+) = biliftA2 (+) (+)
+  (-) = biliftA2 (*) (*)
+  (*) = biliftA2 (*) (*)
+  negate = bimap negate negate
+  abs = bimap abs abs
+  signum = bimap signum signum
+  fromInteger n = fromInteger n `bipure` fromInteger n
+
+newtype INT2 = INT2 (Int, Int)
+  deriving IsZero via (WrappedNumEq2 (WrapBiapp (,) Int Int))
+
+----
+-- 5
+----
+class Monoid a => MonoidNull a where
+  null :: a -> Bool
+
+newtype WrpMonNull a = WRM a deriving (Eq, Semigroup, Monoid)
+
+instance (Eq a, Monoid a) => MonoidNull (WrpMonNull a) where
+  null :: WrpMonNull a -> Bool
+  null = (== mempty)
+
+deriving via (WrpMonNull Any) instance MonoidNull Any
+deriving via ()               instance MonoidNull ()
+deriving via Ordering         instance MonoidNull Ordering
+
+----
+-- 6
+----
+-- https://github.com/mikeizbicki/subhask/blob/f53fd8f465747681c88276c7dabe3646fbdf7d50/src/SubHask/Algebra.hs#L635
+
+class Lattice a where
+  sup   :: a -> a -> a
+  (.>=) :: a -> a -> Bool
+  (.>)  :: a -> a -> Bool
+
+newtype WrapOrd a = WrappedOrd a
+  deriving newtype (Eq, Ord)
+
+instance Ord a => Lattice (WrapOrd a) where
+  sup   = max
+  (.>=) = (>=)
+  (.>)  = (>)
+
+deriving via [a]    instance Ord a          => Lattice [a]
+deriving via (a, b) instance (Ord a, Ord b) => Lattice (a, b)
+--mkLattice_(Bool)
+deriving via Bool instance Lattice Bool
+--mkLattice_(Char)
+deriving via Char instance Lattice Char
+--mkLattice_(Int)
+deriving via Int instance Lattice Int
+--mkLattice_(Integer)
+deriving via Integer instance Lattice Integer
+--mkLattice_(Float)
+deriving via Float instance Lattice Float
+--mkLattice_(Double)
+deriving via Double instance Lattice Double
+--mkLattice_(Rational)
+deriving via Rational instance Lattice Rational
+
+----
+-- 7
+----
+-- https://hackage.haskell.org/package/linear-1.20.7/docs/src/Linear-Affine.html
+
+class Functor f => Additive f where
+  zero :: Num a => f a
+  (^+^) :: Num a => f a -> f a -> f a
+  (^+^) = liftU2 (+)
+  (^-^) :: Num a => f a -> f a -> f a
+  x ^-^ y = x ^+^ fmap negate y
+  liftU2 :: (a -> a -> a) -> f a -> f a -> f a
+
+instance Additive [] where
+  zero = []
+  liftU2 f = go where
+    go (x:xs) (y:ys) = f x y : go xs ys
+    go [] ys = ys
+    go xs [] = xs
+
+instance Additive Maybe where
+  zero = Nothing
+  liftU2 f (Just a) (Just b) = Just (f a b)
+  liftU2 _ Nothing ys = ys
+  liftU2 _ xs Nothing = xs
+
+instance Applicative f => Additive (WrapApplicative f) where
+  zero   = pure 0
+  liftU2 = liftA2
+
+deriving via (WrapApplicative ((->) a)) instance Additive ((->) a)
+deriving via (WrapApplicative Complex)  instance Additive Complex
+deriving via (WrapApplicative Identity) instance Additive Identity
+
+instance Additive ZipList where
+  zero = ZipList []
+  liftU2 f (ZipList xs) (ZipList ys) = ZipList (liftU2 f xs ys)
+
+class Additive (Diff p) => Affine p where
+  type Diff p :: Type -> Type
+
+  (.-.) :: Num a => p a -> p a -> Diff p a
+  (.+^) :: Num a => p a -> Diff p a -> p a
+  (.-^) :: Num a => p a -> Diff p a -> p a
+  p .-^ v = p .+^ fmap negate v
+
+-- #define ADDITIVEC(CTX,T) instance CTX => Affine T where type Diff T = T ; \
+--   (.-.) = (^-^) ; {-# INLINE (.-.) #-} ; (.+^) = (^+^) ; {-# INLINE (.+^) #-} ; \
+--   (.-^) = (^-^) ; {-# INLINE (.-^) #-}
+-- #define ADDITIVE(T) ADDITIVEC((), T)
+newtype WrapAdditive f a = WrappedAdditive (f a)
+
+instance Additive f => Affine (WrapAdditive f) where
+  type Diff (WrapAdditive f) = f
+
+  WrappedAdditive a .-. WrappedAdditive b = a ^-^ b
+  WrappedAdditive a .+^ b = WrappedAdditive (a ^+^ b)
+  WrappedAdditive a .-^ b = WrappedAdditive (a ^-^ b)
+
+-- ADDITIVE(((->) a))
+deriving via (WrapAdditive ((->) a)) instance Affine ((->) a)
+-- ADDITIVE([])
+deriving via (WrapAdditive [])       instance Affine []
+-- ADDITIVE(Complex)
+deriving via (WrapAdditive Complex)  instance Affine Complex
+-- ADDITIVE(Maybe)
+deriving via (WrapAdditive Maybe)    instance Affine Maybe
+-- ADDITIVE(ZipList)
+deriving via (WrapAdditive ZipList)  instance Affine ZipList
+-- ADDITIVE(Identity)
+deriving via (WrapAdditive Identity) instance Affine Identity
+
+----
+-- 8
+----
+
+class C2 a b c where
+  c2 :: a -> b -> c
+
+instance C2 a b (Const a b) where
+  c2 x _ = Const x
+
+newtype Fweemp a = Fweemp a
+  deriving (C2 a b)
+       via (Const a (b :: Type))
diff --git a/testsuite/tests/deriving/should_compile/deriving-via-standalone.hs b/testsuite/tests/deriving/should_compile/deriving-via-standalone.hs
new file mode 100644
index 0000000000..0fa71d7e36
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/deriving-via-standalone.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module DerivingViaStandalone where
+
+import Control.Applicative
+import Data.Functor.Compose
+import Data.Proxy
+import Data.Semigroup
+
+newtype App (f :: * -> *) a = App (f a)
+  deriving newtype
+    (Functor, Applicative)
+
+instance (Applicative f, Semigroup a) => Semigroup (App f a) where
+  (<>) = liftA2 (<>)
+
+deriving via (App (Compose (f :: * -> *) g) a)
+         instance (Applicative f, Applicative g, Semigroup a)
+               => Semigroup (Compose f g a)
+
+class C (a :: k -> *)
+instance C Proxy
+
+newtype MyProxy a = MyProxy (Proxy a)
+deriving via (Proxy :: * -> *) instance C MyProxy
+
+class Z a b
+data T a
+data X1 a
+data X2 a
+data X3 a
+
+deriving via (forall a. T a) instance           Z a (X1 b)
+deriving via           (T a) instance forall b. Z a (X2 b)
+deriving via (forall a. T a) instance forall b. Z a (X3 b)
diff --git a/testsuite/tests/deriving/should_fail/all.T b/testsuite/tests/deriving/should_fail/all.T
index f1d8261e4b..0cc85ea4aa 100644
--- a/testsuite/tests/deriving/should_fail/all.T
+++ b/testsuite/tests/deriving/should_fail/all.T
@@ -74,3 +74,7 @@ test('T14728b', normal, compile_fail, [''])
 test('T14916', normal, compile_fail, [''])
 test('T15073', [extra_files(['T15073a.hs'])], multimod_compile_fail,
                ['T15073', '-v0'])
+test('deriving-via-fail', normal, compile_fail, [''])
+test('deriving-via-fail2', normal, compile_fail, [''])
+test('deriving-via-fail3', normal, compile_fail, [''])
+test('deriving-via-fail4', normal, compile_fail, [''])
diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail.hs b/testsuite/tests/deriving/should_fail/deriving-via-fail.hs
new file mode 100644
index 0000000000..fbae1e7d13
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/deriving-via-fail.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module DerivingViaFail where
+
+import Control.Category
+import Data.Functor.Identity
+
+newtype Foo1 a = Foo1 a deriving Show via (Identity b)
+
+newtype Foo2 a b = Foo2 (a -> b)
+  deriving Category
+    via fooo
+
+data Foo3 deriving Eq via (forall a. a)
+
+newtype Foo4 a = Foo4 a
+deriving via (Identity b)
+  instance Show (Foo4 a)
diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail.stderr b/testsuite/tests/deriving/should_fail/deriving-via-fail.stderr
new file mode 100644
index 0000000000..51907e02cf
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/deriving-via-fail.stderr
@@ -0,0 +1,16 @@
+
+deriving-via-fail.hs:9:34: error:
+    Type variable ‘b’ is bound in the ‘via’ type ‘(Identity b)’
+    but is not mentioned in the derived class ‘Show’, which is illegal
+
+deriving-via-fail.hs:12:12: error:
+    Type variable ‘fooo’ is bound in the ‘via’ type ‘fooo’
+    but is not mentioned in the derived class ‘Category’, which is illegal
+
+deriving-via-fail.hs:15:20: error:
+    Type variable ‘a’ is bound in the ‘via’ type ‘(forall a. a)’
+    but is not mentioned in the derived class ‘Eq’, which is illegal
+
+deriving-via-fail.hs:19:12: error:
+    Type variable ‘b’ is bound in the ‘via’ type ‘(Identity b)’
+    but is not mentioned in the derived instance ‘Show (Foo4 a)’, which is illegal
diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail2.hs b/testsuite/tests/deriving/should_fail/deriving-via-fail2.hs
new file mode 100644
index 0000000000..e9a456d048
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/deriving-via-fail2.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module DerivingViaFail2 where
+
+class C a
+data A = A
+deriving via Maybe instance C A
diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail2.stderr b/testsuite/tests/deriving/should_fail/deriving-via-fail2.stderr
new file mode 100644
index 0000000000..d5692ad6b2
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/deriving-via-fail2.stderr
@@ -0,0 +1,6 @@
+
+deriving-via-fail2.hs:7:1: error:
+    • Cannot derive instance via ‘Maybe’
+        Class ‘C’ expects an argument of kind ‘*’,
+        but ‘Maybe’ has kind ‘* -> *’
+    • In the stand-alone deriving instance for ‘C A’
diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail3.hs b/testsuite/tests/deriving/should_fail/deriving-via-fail3.hs
new file mode 100644
index 0000000000..ad8e0be542
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/deriving-via-fail3.hs
@@ -0,0 +1,3 @@
+module DerivingViaFail3 where
+
+data F deriving Eq via F
diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail3.stderr b/testsuite/tests/deriving/should_fail/deriving-via-fail3.stderr
new file mode 100644
index 0000000000..f2af73a01f
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/deriving-via-fail3.stderr
@@ -0,0 +1,4 @@
+
+deriving-via-fail3.hs:3:1: error:
+    Illegal deriving strategy: via
+    Use DerivingVia to enable this extension
diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail4.hs b/testsuite/tests/deriving/should_fail/deriving-via-fail4.hs
new file mode 100644
index 0000000000..1436d994c0
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/deriving-via-fail4.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module DerivingViaFail4 where
+
+class C a b where
+  c :: a -> b -> Bool
+
+instance C a a where
+  c _ _ = True
+
+newtype F1 = F1 Int
+  deriving Eq via Char
+
+newtype F2 a = MkF2 a
+  deriving (C a) via (forall a. a)
diff --git a/testsuite/tests/deriving/should_fail/deriving-via-fail4.stderr b/testsuite/tests/deriving/should_fail/deriving-via-fail4.stderr
new file mode 100644
index 0000000000..caa2bfe93b
--- /dev/null
+++ b/testsuite/tests/deriving/should_fail/deriving-via-fail4.stderr
@@ -0,0 +1,18 @@
+
+deriving-via-fail4.hs:14:12: error:
+    • Couldn't match representation of type ‘Int’ with that of ‘Char’
+        arising from the coercion of the method ‘==’
+          from type ‘Char -> Char -> Bool’ to type ‘F1 -> F1 -> Bool’
+    • When deriving the instance for (Eq F1)
+
+deriving-via-fail4.hs:17:13: error:
+    • Couldn't match representation of type ‘a1’ with that of ‘a’
+        arising from the coercion of the method ‘c’
+          from type ‘a -> a -> Bool’ to type ‘a -> F2 a1 -> Bool’
+      ‘a1’ is a rigid type variable bound by
+        the deriving clause for ‘C a (F2 a1)’
+        at deriving-via-fail4.hs:17:13-15
+      ‘a’ is a rigid type variable bound by
+        the deriving clause for ‘C a (F2 a1)’
+        at deriving-via-fail4.hs:17:13-15
+    • When deriving the instance for (C a (F2 a1))