invariant 0.5.3 → 0.5.4

raw patch · 5 files changed

+359/−163 lines, 5 filesdep ~template-haskelldep ~th-abstractionPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: template-haskell, th-abstraction

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• invariant.cabal +11/−6
• src/Data/Functor/Invariant/TH.hs +248/−133
• src/Data/Functor/Invariant/TH/Internal.hs +51/−24
• test/THSpec.hs +40/−0

@@ -1,3 +1,12 @@+# 0.5.4 [2020.10.01]+* Fix a bug in which `deriveInvariant2` would fail on certain data types with+  three or parameters if the first two parameters had phantom roles.+* Fix a bug in which `deriveInvariant(2)` would fail on sufficiently complex+  uses of rank-n types in constructor fields.+* Fix a bug in which `deriveInvariant(2)` would needlessly reject data types+  whose two last type parameters appear as oversaturated arguments to a type+  family.+ # 0.5.3 [2019.05.02] * Implement `foldMap'` in the `Foldable` instance for `WrappedFunctor` when   building with `base-4.13` or later.

@@ -1,5 +1,5 @@ name:                invariant-version:             0.5.3+version:             0.5.4 synopsis:            Haskell98 invariant functors description:         Haskell98 invariant functors (also known as exponential functors).                      .@@ -15,7 +15,7 @@ maintainer:          Nicolas Frisby <nicolas.frisby@gmail.com>,                      Ryan Scott <ryan.gl.scott@gmail.com> build-type:          Simple-cabal-version:       >= 1.9.2+cabal-version:       >= 1.10 tested-with:         GHC == 7.0.4                    , GHC == 7.2.2                    , GHC == 7.4.2@@ -26,7 +26,8 @@                    , GHC == 8.2.2                    , GHC == 8.4.4                    , GHC == 8.6.5-                   , GHC == 8.8.1+                   , GHC == 8.8.3+                   , GHC == 8.10.1 extra-source-files:  CHANGELOG.md, README.md  source-repository head@@ -39,6 +40,7 @@   other-modules:       Data.Functor.Invariant.TH.Internal                      , Paths_invariant   hs-source-dirs:      src+  default-language:    Haskell2010   build-depends:       array                >= 0.3    && < 0.6                      , base                 >= 4      && < 5                      , bifunctors           >= 5.2    && < 6@@ -50,8 +52,8 @@                      , StateVar             >= 1.1    && < 2                      , stm                  >= 2.2    && < 3                      , tagged               >= 0.7.3  && < 1-                     , template-haskell     >= 2.4    && < 2.16-                     , th-abstraction       >= 0.2.2  && < 0.4+                     , template-haskell     >= 2.4    && < 2.18+                     , th-abstraction       >= 0.4    && < 0.5                      , transformers         >= 0.2    && < 0.6                      , transformers-compat  >= 0.3    && < 1                      , unordered-containers >= 0.2.4  && < 0.3@@ -63,6 +65,7 @@ test-suite spec   type:                exitcode-stdio-1.0   hs-source-dirs:      test+  default-language:    Haskell2010   main-is:             Spec.hs   other-modules:       InvariantSpec                        THSpec@@ -70,6 +73,8 @@                      , hspec            >= 1.8                      , invariant                      , QuickCheck       >= 2.11 && < 3-                     , template-haskell >= 2.4  && < 2.16+                     , template-haskell >= 2.4  && < 2.18   build-tool-depends:  hspec-discover:hspec-discover   ghc-options:         -Wall+  if impl(ghc >= 8.6)+    ghc-options:       -Wno-star-is-type

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-}  {-| Module:      Data.Functor.Invariant.TH@@ -36,10 +37,11 @@  import           Data.Functor.Invariant.TH.Internal import           Data.List-import qualified Data.Map as Map (fromList, keys, lookup, size)+import qualified Data.Map as Map ((!), fromList, keys, lookup, member, size) import           Data.Maybe  import           Language.Haskell.TH.Datatype+import           Language.Haskell.TH.Datatype.TyVarBndr import           Language.Haskell.TH.Lib import           Language.Haskell.TH.Ppr import           Language.Haskell.TH.Syntax@@ -271,11 +273,7 @@   case info of     DatatypeInfo { datatypeContext   = ctxt                  , datatypeName      = parentName-#if MIN_VERSION_th_abstraction(0,3,0)                  , datatypeInstTypes = instTys-#else-                 , datatypeVars      = instTys-#endif                  , datatypeVariant   = variant                  , datatypeCons      = cons                  } -> do@@ -305,11 +303,7 @@   case info of     DatatypeInfo { datatypeContext   = ctxt                  , datatypeName      = parentName-#if MIN_VERSION_th_abstraction(0,3,0)                  , datatypeInstTypes = instTys-#else-                 , datatypeVars      = instTys-#endif                  , datatypeVariant   = variant                  , datatypeCons      = cons                  } ->@@ -329,7 +323,7 @@     contraMaps <- newNameList "contraMap" numNbs      let mapFuns    = zip covMaps contraMaps-        lastTyVars = map varTToName $ drop (length instTys - fromEnum iClass) instTys+        lastTyVars = map varTToName $ drop (length instTys - numNbs) instTys         tvMap      = Map.fromList $ zip lastTyVars mapFuns         argNames   = concat (transpose [covMaps, contraMaps]) ++ [value]     lamE (map varP argNames)@@ -352,7 +346,7 @@  #if MIN_VERSION_template_haskell(2,9,0)           | (length rroles >= numNbs) &&-            (all (== PhantomR) (take numNbs rroles))+            (all (== PhantomR) (drop (length rroles - numNbs) rroles))          -> varE coerceValName `appE` varE value #endif @@ -375,121 +369,51 @@     ghc7'8OrLater = False #endif --- | Generates a lambda expression for invmap(2) for a single constructor.+-- | Generates a match for invmap(2) for a single constructor. makeInvmapForCon :: InvariantClass -> TyVarMap -> ConstructorInfo -> Q Match makeInvmapForCon iClass tvMap-  (ConstructorInfo { constructorName    = conName-                   , constructorContext = ctxt-                   , constructorFields  = ts })= do-    ts'      <- mapM resolveTypeSynonyms ts-    argNames <- newNameList "arg" $ length ts'-    if any (`predMentionsName` Map.keys tvMap) ctxt-         || Map.size tvMap < fromEnum iClass-       then existentialContextError conName-       else makeInvmapForArgs iClass tvMap conName ts' argNames--makeInvmapForArgs :: InvariantClass-                  -> TyVarMap-                  -> Name-                  -> [Type]-                  -> [Name]-                  -> Q Match-makeInvmapForArgs iClass tvMap conName tys args =-    let mappedArgs :: [Q Exp]-        mappedArgs = zipWith (makeInvmapForArg iClass conName tvMap) tys args-     in match (conP conName $ map varP args)-              (normalB . appsE $ conE conName:mappedArgs)-              []---- | Generates a lambda expression for invmap(2) for an argument of a constructor.-makeInvmapForArg :: InvariantClass-                 -> Name-                 -> TyVarMap-                 -> Type-                 -> Name-                 -> Q Exp-makeInvmapForArg iClass conName tvis ty tyExpName =-    appE (makeInvmapForType iClass conName tvis True ty) (varE tyExpName)---- | Generates a lambda expression for invmap(2) for a specific type.--- The generated expression depends on the number of type variables.-makeInvmapForType :: InvariantClass-                  -> Name-                  -> TyVarMap-                  -> Bool-                  -> Type-                  -> Q Exp-makeInvmapForType _ _ tvMap covariant (VarT tyName) =-    case Map.lookup tyName tvMap of-         Just (covMap, contraMap) ->-             varE $ if covariant then covMap else contraMap-         Nothing -> do -- Produce a lambda expression rather than id, addressing Trac #7436-             x <- newName "x"-             lamE [varP x] $ varE x-makeInvmapForType iClass conName tvMap covariant (SigT ty _) =-    makeInvmapForType iClass conName tvMap covariant ty-makeInvmapForType iClass conName tvMap covariant (ForallT _ _ ty)-    = makeInvmapForType iClass conName tvMap covariant ty-makeInvmapForType iClass conName tvMap covariant ty =-    let tyCon  :: Type-        tyArgs :: [Type]-        tyCon:tyArgs = unapplyTy ty--        numLastArgs :: Int-        numLastArgs = min (fromEnum iClass) (length tyArgs)--        lhsArgs, rhsArgs :: [Type]-        (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs--        tyVarNames :: [Name]-        tyVarNames = Map.keys tvMap--        doubleMap :: (Bool -> Type -> Q Exp) -> [Type] -> [Q Exp]-        doubleMap _ []     = []-        doubleMap f (t:ts) = f covariant t : f (not covariant) t : doubleMap f ts--        mentionsTyArgs :: Bool-        mentionsTyArgs = any (`mentionsName` tyVarNames) tyArgs--        makeInvmapTuple :: ([Q Pat] -> Q Pat) -> ([Q Exp] -> Q Exp) -> Int -> Q Exp-        makeInvmapTuple mkTupP mkTupE n = do-            x  <- newName "x"-            xs <- newNameList "x" n-            lamE [varP x] $ caseE (varE x)-                [ match (mkTupP $ map varP xs)-                        (normalB . mkTupE $ zipWith makeInvmapTupleField tyArgs xs)-                        []-                ]--        makeInvmapTupleField :: Type -> Name -> Q Exp-        makeInvmapTupleField fieldTy fieldName =-            appE (makeInvmapForType iClass conName tvMap covariant fieldTy) $ varE fieldName+  con@(ConstructorInfo { constructorName    = conName+                       , constructorContext = ctxt }) = do+    when (any (`predMentionsName` Map.keys tvMap) ctxt+            || Map.size tvMap < fromEnum iClass) $+      existentialContextError conName+    parts <- foldDataConArgs iClass tvMap ft_invmap con+    match_for_con conName parts+  where+    ft_invmap :: FFoldType (Exp -> Q Exp)+    ft_invmap = FT { ft_triv   = return+                   , ft_var    = \v x -> return $ VarE (fst (tvMap Map.! v)) `AppE` x+                   , ft_co_var = \v x -> return $ VarE (snd (tvMap Map.! v)) `AppE` x+                   , ft_fun    = \g h x -> mkSimpleLam $ \b -> do+                       gg <- g b+                       h $ x `AppE` gg+                   , ft_tup    = mkSimpleTupleCase match_for_con+                   , ft_ty_app = \contravariant argGs x -> do+                       let inspect :: (Type, Exp -> Q Exp, Exp -> Q Exp) -> [Q Exp]+                           inspect (argTy, g, h)+                             -- If the argument type is a bare occurrence of one+                             -- of the data type's last type variables, then we+                             -- can generate more efficient code.+                             -- This was inspired by GHC#17880.+                             | Just argVar <- varTToName_maybe argTy+                             , Just (covMap, contraMap) <- Map.lookup argVar tvMap+                             = map (return . VarE) $+                               if contravariant+                                  then [contraMap, covMap]+                                  else [covMap, contraMap]+                             | otherwise+                             = [mkSimpleLam g, mkSimpleLam h]+                       appsE $ varE (invmapName (toEnum (length argGs)))+                             : concatMap inspect argGs+                            ++ [return x]+                   , ft_forall  = \_ g x -> g x+                   , ft_bad_app = \_ -> outOfPlaceTyVarError conName+                   } -     in case tyCon of-          ArrowT | mentionsTyArgs ->-              let [argTy, resTy] = tyArgs-               in do x <- newName "x"-                     b <- newName "b"-                     lamE [varP x, varP b] $-                       makeInvmapForType iClass conName tvMap covariant resTy `appE` (varE x `appE`-                         (makeInvmapForType iClass conName tvMap (not covariant) argTy `appE` varE b))-#if MIN_VERSION_template_haskell(2,6,0)-          UnboxedTupleT n-            | n > 0 && mentionsTyArgs -> makeInvmapTuple unboxedTupP unboxedTupE n-#endif-          TupleT n-            | n > 0 && mentionsTyArgs -> makeInvmapTuple tupP tupE n-          _ -> do-              itf <- isTyFamily tyCon-              if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs)-                   then outOfPlaceTyVarError conName tyVarNames-                   else if any (`mentionsName` tyVarNames) rhsArgs-                        then appsE $-                             ( varE (invmapName (toEnum numLastArgs))-                             : doubleMap (makeInvmapForType iClass conName tvMap) rhsArgs-                             )-                        else do x <- newName "x"-                                lamE [varP x] $ varE x+    -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...+    match_for_con :: Name -> [Exp -> Q Exp] -> Q Match+    match_for_con = mkSimpleConMatch $ \conName' xs ->+       appsE (conE conName':xs) -- Con x1 x2 ..  ------------------------------------------------------------------------------- -- Template Haskell reifying and AST manipulation@@ -721,8 +645,8 @@  -- | Either the given data type doesn't have enough type variables, or one of -- the type variables to be eta-reduced cannot realize kind *.-derivingKindError :: InvariantClass -> Name -> a-derivingKindError iClass tyConName = error+derivingKindError :: InvariantClass -> Name -> Q a+derivingKindError iClass tyConName = fail     . showString "Cannot derive well-kinded instance of form ‘"     . showString className     . showChar ' '@@ -741,8 +665,8 @@  -- | The data type has a DatatypeContext which mentions one of the eta-reduced -- type variables.-datatypeContextError :: Name -> Type -> a-datatypeContextError dataName instanceType = error+datatypeContextError :: Name -> Type -> Q a+datatypeContextError dataName instanceType = fail     . showString "Can't make a derived instance of ‘"     . showString (pprint instanceType)     . showString "‘:\n\tData type ‘"@@ -752,8 +676,8 @@  -- | The data type has an existential constraint which mentions one of the -- eta-reduced type variables.-existentialContextError :: Name -> a-existentialContextError conName = error+existentialContextError :: Name -> Q a+existentialContextError conName = fail     . showString "Constructor ‘"     . showString (nameBase conName)     . showString "‘ must be truly polymorphic in the last argument(s) of the data type"@@ -761,8 +685,8 @@  -- | The data type mentions one of the n eta-reduced type variables in a place other -- than the last nth positions of a data type in a constructor's field.-outOfPlaceTyVarError :: Name -> a-outOfPlaceTyVarError conName = error+outOfPlaceTyVarError :: Name -> Q a+outOfPlaceTyVarError conName = fail   . showString "Constructor ‘"   . showString (nameBase conName)   . showString "‘ must only use its last two type variable(s) within"@@ -771,7 +695,198 @@  -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce -- function for the criteria it would have to meet).-etaReductionError :: Type -> a-etaReductionError instanceType = error $+etaReductionError :: Type -> Q a+etaReductionError instanceType = fail $     "Cannot eta-reduce to an instance of form \n\tinstance (...) => "     ++ pprint instanceType++-------------------------------------------------------------------------------+-- Generic traversal for functor-like deriving+-------------------------------------------------------------------------------++-- Much of the code below is cargo-culted from the TcGenFunctor module in GHC.++data FFoldType a      -- Describes how to fold over a Type in a functor like way+   = FT { ft_triv    :: a+          -- ^ Does not contain variables+        , ft_var     :: Name -> a+          -- ^ A bare variable+        , ft_co_var  :: Name -> a+          -- ^ A bare variable, contravariantly+        , ft_fun     :: a -> a -> a+          -- ^ Function type+        , ft_tup     :: TupleSort -> [a] -> a+          -- ^ Tuple type. The [a] is the result of folding over the+          --   arguments of the tuple.+        , ft_ty_app  :: Bool -> [(Type, a, a)] -> a+          -- ^ Type app, variables only in last argument. The [(Type, a, a)]+          --   represents the last argument types. That is, they form the+          --   argument parts of @fun_ty arg_ty_1 ... arg_ty_n@.+          --+          --   The Bool is True if the Type is in a surrounding context that is+          --   contravariant, and False if the surrounding context is covariant.+          --   The two @a@ fields in [(Type, a, a)] represent the results of+          --   folding over the Type in a covariant and contravariant manner,+          --   respectively.+        , ft_bad_app :: a+          -- ^ Type app, variable other than in last arguments+        , ft_forall  :: [TyVarBndrSpec] -> a -> a+          -- ^ Forall type+     }++-- Note that in GHC, this function is pure. It must be monadic here since we:+--+-- (1) Expand type synonyms+-- (2) Detect type family applications+--+-- Which require reification in Template Haskell, but are pure in Core.+functorLikeTraverse :: InvariantClass -- ^ Invariant or Invariant2+                    -> TyVarMap       -- ^ Variables to look for+                    -> FFoldType a    -- ^ How to fold+                    -> Type           -- ^ Type to process+                    -> Q a+functorLikeTraverse iClass tvMap (FT { ft_triv = caseTrivial,     ft_var = caseVar+                                     , ft_co_var = caseCoVar,     ft_fun = caseFun+                                     , ft_tup = caseTuple,        ft_ty_app = caseTyApp+                                     , ft_bad_app = caseWrongArg, ft_forall = caseForAll })+                    ty+  = do ty' <- resolveTypeSynonyms ty+       (res, _) <- go False ty'+       return res+  where+    {-+    go :: Bool        -- Covariant or contravariant context+       -> Type+       -> Q (a, Bool) -- (result of type a, does type contain var)+    -}+    go co t@AppT{}+      | (ArrowT, [funArg, funRes]) <- unapplyTy t+      = do (funArgR, funArgC) <- go (not co) funArg+           (funResR, funResC) <- go      co  funRes+           if funArgC || funResC+              then return (caseFun funArgR funResR, True)+              else trivial+    go co t@AppT{} = do+      let (f, args) = unapplyTy t+      (_, fc) <- go co f+      (xrs,       xcs) <- fmap unzip $ mapM (go co) args+      (contraXrs, _)   <- fmap unzip $ mapM (go (not co)) args+      let numLastArgs, numFirstArgs :: Int+          numLastArgs  = min (fromEnum iClass) (length args)+          numFirstArgs = length args - numLastArgs++          -- tuple :: TupleSort -> Q (a, Bool)+          tuple tupSort = return (caseTuple tupSort xrs, True)++          -- wrongArg :: Q (a, Bool)+          wrongArg = return (caseWrongArg, True)++      case () of+        _ |  not (or xcs)+          -> trivial -- Variable does not occur+          -- At this point we know that xrs, xcs is not empty,+          -- and at least one xr is True+          |  TupleT len <- f+          -> tuple $ Boxed len+#if MIN_VERSION_template_haskell(2,6,0)+          |  UnboxedTupleT len <- f+          -> tuple $ Unboxed len+#endif+          |  fc || or (take numFirstArgs xcs)+          -> wrongArg                    -- T (..var..)    ty_1 ... ty_n+          |  otherwise                   -- T (..no var..) ty_1 ... ty_n+          -> do itf <- isInTypeFamilyApp tyVarNames f args+                if itf -- We can't decompose type families, so+                       -- error if we encounter one here.+                   then wrongArg+                   else return ( caseTyApp co $ drop numFirstArgs+                                              $ zip3 args xrs contraXrs+                               , True )+    go co (SigT t k) = do+      (_, kc) <- go_kind co k+      if kc+         then return (caseWrongArg, True)+         else go co t+    go co (VarT v)+      | Map.member v tvMap+      = return (if co then caseCoVar v else caseVar v, True)+      | otherwise+      = trivial+    go co (ForallT tvbs _ t) = do+      (tr, tc) <- go co t+      let tvbNames = map tvName tvbs+      if not tc || any (`elem` tvbNames) tyVarNames+         then trivial+         else return (caseForAll tvbs tr, True)+    go _ _ = trivial++    {-+    go_kind :: Bool+            -> Kind+            -> Q (a, Bool)+    -}+#if MIN_VERSION_template_haskell(2,9,0)+    go_kind = go+#else+    go_kind _ _ = trivial+#endif++    -- trivial :: Q (a, Bool)+    trivial = return (caseTrivial, False)++    tyVarNames :: [Name]+    tyVarNames = Map.keys tvMap++-- Fold over the arguments of a data constructor in a Functor-like way.+foldDataConArgs :: InvariantClass -> TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a]+foldDataConArgs iClass tvMap ft con = do+  fieldTys <- mapM resolveTypeSynonyms $ constructorFields con+  mapM foldArg fieldTys+  where+    -- foldArg :: Type -> Q a+    foldArg = functorLikeTraverse iClass tvMap ft++-- Make a 'LamE' using a fresh variable.+mkSimpleLam :: (Exp -> Q Exp) -> Q Exp+mkSimpleLam lam = do+  n <- newName "n"+  body <- lam (VarE n)+  return $ LamE [VarP n] body++-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"+--+-- @mkSimpleConMatch fold conName insides@ produces a match clause in+-- which the LHS pattern-matches on @extraPats@, followed by a match on the+-- constructor @conName@ and its arguments. The RHS folds (with @fold@) over+-- @conName@ and its arguments, applying an expression (from @insides@) to each+-- of the respective arguments of @conName@.+mkSimpleConMatch :: (Name -> [a] -> Q Exp)+                 -> Name+                 -> [Exp -> a]+                 -> Q Match+mkSimpleConMatch fold conName insides = do+  varsNeeded <- newNameList "_arg" $ length insides+  let pat = ConP conName (map VarP varsNeeded)+  rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded)+  return $ Match pat (NormalB rhs) []++-- Indicates whether a tuple is boxed or unboxed, as well as its number of+-- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #)+-- corresponds to @Unboxed 3@.+data TupleSort+  = Boxed   Int+#if MIN_VERSION_template_haskell(2,6,0)+  | Unboxed Int+#endif++-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"+mkSimpleTupleCase :: (Name -> [a] -> Q Match)+                  -> TupleSort -> [a] -> Exp -> Q Exp+mkSimpleTupleCase matchForCon tupSort insides x = do+  let tupDataName = case tupSort of+                      Boxed   len -> tupleDataName len+#if MIN_VERSION_template_haskell(2,6,0)+                      Unboxed len -> unboxedTupleDataName len+#endif+  m <- matchForCon tupDataName insides+  return $ CaseE x [m]

@@ -241,24 +241,53 @@ isTyVar (SigT t _) = isTyVar t isTyVar _          = False --- | Is the given type a type family constructor (and not a data family constructor)?-isTyFamily :: Type -> Q Bool-isTyFamily (ConT n) = do-    info <- reify n-    return $ case info of+-- | Detect if a Name in a list of provided Names occurs as an argument to some+-- type family. This makes an effort to exclude /oversaturated/ arguments to+-- type families. For instance, if one declared the following type family:+--+-- @+-- type family F a :: Type -> Type+-- @+--+-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,+-- but not @b@.+isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool+isInTypeFamilyApp names tyFun tyArgs =+  case tyFun of+    ConT tcName -> go tcName+    _           -> return False+  where+    go :: Name -> Q Bool+    go tcName = do+      info <- reify tcName+      case info of #if MIN_VERSION_template_haskell(2,11,0)-         FamilyI OpenTypeFamilyD{} _       -> True+        FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _+          -> withinFirstArgs bndrs #elif MIN_VERSION_template_haskell(2,7,0)-         FamilyI (FamilyD TypeFam _ _ _) _ -> True+        FamilyI (FamilyD TypeFam _ bndrs _) _+          -> withinFirstArgs bndrs #else-         TyConI  (FamilyD TypeFam _ _ _)   -> True+        TyConI (FamilyD TypeFam _ bndrs _)+          -> withinFirstArgs bndrs #endif-#if MIN_VERSION_template_haskell(2,9,0)-         FamilyI ClosedTypeFamilyD{} _     -> True++#if MIN_VERSION_template_haskell(2,11,0)+        FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _+          -> withinFirstArgs bndrs+#elif MIN_VERSION_template_haskell(2,9,0)+        FamilyI (ClosedTypeFamilyD _ bndrs _ _) _+          -> withinFirstArgs bndrs #endif-         _ -> False-isTyFamily _ = return False +        _ -> return False+      where+        withinFirstArgs :: [a] -> Q Bool+        withinFirstArgs bndrs =+          let firstArgs = take (length bndrs) tyArgs+              argFVs    = freeVariables firstArgs+          in return $ any (`elem` argFVs) names+ -- | Are all of the items in a list (which have an ordering) distinct? -- -- This uses Set (as opposed to nub) for better asymptotic time complexity.@@ -312,14 +341,17 @@ -- @ -- [Either, Int, Char] -- @-unapplyTy :: Type -> [Type]-unapplyTy = reverse . go+unapplyTy :: Type -> (Type, [Type])+unapplyTy ty = go ty ty []   where-    go :: Type -> [Type]-    go (AppT t1 t2)    = t2:go t1-    go (SigT t _)      = go t-    go (ForallT _ _ t) = go t-    go t               = [t]+    go :: Type -> Type -> [Type] -> (Type, [Type])+    go _      (AppT ty1 ty2)     args = go ty1 ty1 (ty2:args)+    go origTy (SigT ty' _)       args = go origTy ty' args+#if MIN_VERSION_template_haskell(2,11,0)+    go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args+    go origTy (ParensT ty')      args = go origTy ty' args+#endif+    go origTy _                  args = (origTy, args)  -- | Split a type signature by the arrows on its spine. For example, this: --@@ -398,8 +430,3 @@  seqValName :: Name seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq"--#if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,9,0))-starKindName :: Name-starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"-#endif

@@ -73,6 +73,17 @@ type role Empty2 nominal nominal #endif +data TyCon18 a b c = TyCon18 c (TyCon18 a a c)++data TyCon19 a b+    = TyCon19a (forall c. c -> (forall d. a -> d) -> a)+    | TyCon19b (Int -> forall c. c -> b)++type family F :: * -> * -> *+type instance F = Either++data TyCon20 a b = TyCon20 (F a b)+ -- Data families  data family   StrangeFam a b c@@ -116,6 +127,17 @@ data family   IntFunDFam a b data instance IntFunDFam a b = IntFunDFam (IntFun a b) +data family   TyFamily18 x y z+data instance TyFamily18 a b c = TyFamily18 c (TyFamily18 a a c)++data family   TyFamily19 x y+data instance TyFamily19 a b+    = TyFamily19a (forall c. c -> (forall d. a -> d) -> a)+    | TyFamily19b (Int -> forall c. c -> b)++data family   TyFamily20 x y+data instance TyFamily20 a b = TyFamily20 (F a b)+ -------------------------------------------------------------------------------  -- Plain data types@@ -152,6 +174,15 @@ $(deriveInvariantOptions  defaultOptions{emptyCaseBehavior = True} ''Empty2) $(deriveInvariant2Options defaultOptions{emptyCaseBehavior = True} ''Empty2) +$(deriveInvariant  ''TyCon18)+$(deriveInvariant2 ''TyCon18)++$(deriveInvariant  ''TyCon19)+$(deriveInvariant2 ''TyCon19)++$(deriveInvariant  ''TyCon20)+$(deriveInvariant2 ''TyCon20)+ #if MIN_VERSION_template_haskell(2,7,0) -- Data Families @@ -179,6 +210,15 @@  $(deriveInvariant  'IntFunDFam) $(deriveInvariant2 'IntFunDFam)++$(deriveInvariant  'TyFamily18)+$(deriveInvariant2 'TyFamily18)++$(deriveInvariant  'TyFamily19a)+$(deriveInvariant2 'TyFamily19a)++$(deriveInvariant  'TyFamily20)+$(deriveInvariant2 'TyFamily20) #endif  -------------------------------------------------------------------------------