Do not use a Functor instance when none exists when deriving for type…

… application fields

src/Data/Bifunctor/TH.hs

@@ -1124,10 +1124,22 @@ functorLikeTraverse tvMap FT { ft_triv = caseTrivial,     ft_var = caseVar
       let (f, args) = unapplyTy t
       (_,   fc)  <- go co f
       (xrs, xcs) <- unzip <$> mapM (go co) args
-      let (xcFirsts, xcLasts) = break id xcs
-          numLastArgs, numFirstArgs :: Int
-          numFirstArgs = length xcFirsts
-          numLastArgs = length xcLasts
+      let
+          -- Because we only have 'Bifunctor' (or BiSomethingElse) instances
+          -- for type variables with kind `* -> * -> *` available we're unable
+          -- to just the single relevant var to `caseTuple` as it'll depend on
+          -- an instance we don't necessarily have available. A better
+          -- implementation would emit the correct constraint and allow us to
+          -- always use the `haveFunctorInstance = True` case. See:
+          -- https://github.com/ekmett/bifunctors/pull/125#issuecomment-1556367498
+          -- We could also take this case when 'Functor' is a "superclass" of
+          -- 'Bifunctor', however we'd still be emitting an unnecessary
+          -- 'Bifunctor' instance
+          haveFunctorInstance = case f of ConT _ -> True; _ -> False
+          numLastArgs = if haveFunctorInstance
+                          then length . dropWhile not $ xcs
+                          else min 2 (length xcs)
+          numFirstArgs = length xcs - numLastArgs
 
           tuple :: TupleSort -> Q (a, Bool)
           tuple tupSort = return (caseTuple tupSort xrs, True)
@@ -1144,7 +1156,11 @@ functorLikeTraverse tvMap FT { ft_triv = caseTrivial,     ft_var = caseVar
           -> tuple $ Boxed len
           |  UnboxedTupleT len <- f
           -> tuple $ Unboxed len
-          |  fc || numLastArgs > 2
+          |  -- There may be a type variable in the "firstArgs" when
+             -- `haveFunctorInstance = False`
+             -- There may be more than 2 "lastArgs" when
+             -- `haveFunctorInstance = True`
+             fc || or (take numFirstArgs xcs) || numLastArgs > 2
           -> wrongArg                    -- T (..var..)    ty_1 ... ty_n
           |  otherwise                   -- T (..no var..) ty_1 ... ty_n
           -> do itf <- isInTypeFamilyApp tyVarNames f args

tests/BifunctorSpec.hs

@@ -299,31 +299,31 @@ $(deriveBifunctor     ''OneTwoCompose)
 $(deriveBifoldable    ''OneTwoCompose)
 $(deriveBitraversable ''OneTwoCompose)
 
-instance (Functor g, Functor (f Int Int)) =>
+instance (Bifunctor (f Int), Functor g) =>
   Bifunctor (ComplexConstraint f g) where
     bimap = $(makeBimap ''ComplexConstraint)
 
-instance (Foldable g, Foldable (f Int Int)) =>
+instance (Bifoldable (f Int), Foldable g) =>
   Bifoldable (ComplexConstraint f g) where
     bifoldr   = $(makeBifoldr ''ComplexConstraint)
     bifoldMap = $(makeBifoldMap ''ComplexConstraint)
 
 bifoldlComplexConstraint
-  :: (Foldable g, Foldable (f Int Int))
+  :: (Bifoldable (f Int), Foldable g)
   => (c -> a -> c) -> (c -> b -> c) -> c -> ComplexConstraint f g a b -> c
 bifoldlComplexConstraint = $(makeBifoldl ''ComplexConstraint)
 
 bifoldComplexConstraint
-  :: (Foldable g, Monoid m, Foldable (f Int Int))
+  :: (Bifoldable (f Int), Foldable g, Monoid m)
   => ComplexConstraint f g m m -> m
 bifoldComplexConstraint = $(makeBifold ''ComplexConstraint)
 
-instance (Traversable g, Traversable (f Int Int)) =>
+instance (Bitraversable (f Int), Traversable g) =>
   Bitraversable (ComplexConstraint f g) where
     bitraverse = $(makeBitraverse ''ComplexConstraint)
 
 bisequenceAComplexConstraint
-  :: (Traversable g, Applicative t, Traversable (f Int Int))
+  :: (Bitraversable (f Int), Traversable g, Applicative t)
   => ComplexConstraint f g (t a) (t b) -> t (ComplexConstraint f g a b)
 bisequenceAComplexConstraint = $(makeBisequenceA ''ComplexConstraint)
 
@@ -372,31 +372,31 @@ $(deriveBifunctor     'OneTwoComposeFam)
 $(deriveBifoldable    'OneTwoComposeFam)
 $(deriveBitraversable 'OneTwoComposeFam)
 
-instance (Functor g, Functor (f Int Int)) =>
+instance (Bifunctor (f Int), Functor g) =>
   Bifunctor (ComplexConstraintFam f g) where
     bimap = $(makeBimap 'ComplexConstraintFam)
 
-instance (Foldable g, Foldable (f Int Int)) =>
+instance (Bifoldable (f Int), Foldable g) =>
   Bifoldable (ComplexConstraintFam f g) where
     bifoldr   = $(makeBifoldr 'ComplexConstraintFam)
     bifoldMap = $(makeBifoldMap 'ComplexConstraintFam)
 
 bifoldlComplexConstraintFam
-  :: (Foldable g, Foldable (f Int Int))
+  :: (Bifoldable (f Int), Foldable g)
   => (c -> a -> c) -> (c -> b -> c) -> c -> ComplexConstraintFam f g a b -> c
 bifoldlComplexConstraintFam = $(makeBifoldl 'ComplexConstraintFam)
 
 bifoldComplexConstraintFam
-  :: (Foldable g, Monoid m, Foldable (f Int Int))
+  :: (Bifoldable (f Int), Foldable g, Monoid m)
   => ComplexConstraintFam f g m m -> m
 bifoldComplexConstraintFam = $(makeBifold 'ComplexConstraintFam)
 
-instance (Traversable g, Traversable (f Int Int)) =>
+instance (Bitraversable (f Int), Traversable g) =>
   Bitraversable (ComplexConstraintFam f g) where
     bitraverse = $(makeBitraverse 'ComplexConstraintFam)
 
 bisequenceAComplexConstraintFam
-  :: (Traversable g, Applicative t, Traversable (f Int Int))
+  :: (Bitraversable (f Int), Traversable g, Applicative t)
   => ComplexConstraintFam f g (t a) (t b) -> t (ComplexConstraintFam f g a b)
 bisequenceAComplexConstraintFam = $(makeBisequenceA 'ComplexConstraintFam)
 

tests/T124Spec.hs

@@ -35,6 +35,17 @@ deriveBifunctor ''Foo
 deriveBifoldable ''Foo
 deriveBitraversable ''Foo
 
+data Baz f g b c where
+  Baz1 :: f c -> Baz f g b c
+  Baz2 :: g Int c -> Baz f g b c
+
+-- Requires `Functor f` and `Bifunctor g` (even though just `Functor g` would
+-- be sufficient), see discussion here:
+-- https://github.com/ekmett/bifunctors/pull/125#issuecomment-1556367498
+deriveBifunctor ''Baz
+deriveBifoldable ''Baz
+deriveBitraversable ''Baz
+
 main :: IO ()
 main = hspec spec