@@ -1304,9 +1304,8 @@ dispatchFunByType jc jf conName tvMap list ty = do
13041304 tyVarNames :: [Name]
13051305 tyVarNames = M.keys tvMap
13061306
1307− itf <- isTyFamily tyCon
1308− if any (`mentionsName` tyVarNames) lhsArgs
1309− || itf && any (`mentionsName` tyVarNames) tyArgs
1307+ itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs
1308+ if any (`mentionsName` tyVarNames) lhsArgs || itf
13101309 then outOfPlaceTyVarError jc conName
13111310 else if any (`mentionsName` tyVarNames) rhsArgs
13121311 then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs)
@@ -1657,19 +1656,44 @@ isTyVar (VarT _) = True
16571656isTyVar (SigT t _) = isTyVar t
16581657isTyVar _ = False
16591658
1660−-- | Is the given type a type family constructor (and not a data family constructor)?
1661−isTyFamily :: Type -> Q Bool
1662−isTyFamily (ConT n) = do
1663− info <- reify n
1664− return $ case info of
1659+-- | Detect if a Name in a list of provided Names occurs as an argument to some
1660+-- type family. This makes an effort to exclude /oversaturated/ arguments to
1661+-- type families. For instance, if one declared the following type family:
1662+--
1663+-- @
1664+-- type family F a :: Type -> Type
1665+-- @
1666+--
1667+-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,
1668+-- but not @b@.
1669+isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool
1670+isInTypeFamilyApp names tyFun tyArgs =
1671+ case tyFun of
1672+ ConT tcName -> go tcName
1673+ _ -> return False
1674+ where
1675+ go :: Name -> Q Bool
1676+ go tcName = do
1677+ info <- reify tcName
1678+ case info of
16651679#if MIN_VERSION_template_haskell(2,11,0)
1666− FamilyI OpenTypeFamilyD{} _ -> True
1680+ FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _
1681+ -> withinFirstArgs bndrs
1682+ FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _
1683+ -> withinFirstArgs bndrs
16671684#else
1668− FamilyI (FamilyD TypeFam _ _ _) _ -> True
1685+ FamilyI (FamilyD TypeFam _ bndrs _) _
1686+ -> withinFirstArgs bndrs
1687+ FamilyI (ClosedTypeFamilyD _ bndrs _ _) _
1688+ -> withinFirstArgs bndrs
16691689#endif
1670− FamilyI ClosedTypeFamilyD{} _ -> True
1671− _ -> False
1672−isTyFamily _ = return False
1690+ _ -> return False
1691+ where
1692+ withinFirstArgs :: [a] -> Q Bool
1693+ withinFirstArgs bndrs =
1694+ let firstArgs = take (length bndrs) tyArgs
1695+ argFVs = freeVariables firstArgs
1696+ in return $ any (`elem` argFVs) names
16731697
16741698-- | Peel off a kind signature from a Type (if it has one).
16751699unSigT :: Type -> Type