Hello community,
here is the log from the commit of package ghc-invariant for openSUSE:Factory
checked in at 2020-10-23 15:14:09
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-invariant (Old)
and /work/SRC/openSUSE:Factory/.ghc-invariant.new.3463 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-invariant"
Fri Oct 23 15:14:09 2020 rev:10 rq:842751 version:0.5.4
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-invariant/ghc-invariant.changes
2020-09-07 22:02:50.294087778 +0200
+++ /work/SRC/openSUSE:Factory/.ghc-invariant.new.3463/ghc-invariant.changes
2020-10-23 15:14:11.114129542 +0200
@@ -1,0 +2,13 @@
+Tue Oct 6 08:56:25 UTC 2020 - psim...@suse.com
+
+- Update invariant to version 0.5.4.
+ # 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.
+
+-------------------------------------------------------------------
Old:
----
invariant-0.5.3.tar.gz
invariant.cabal
New:
----
invariant-0.5.4.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-invariant.spec ++++++
--- /var/tmp/diff_new_pack.Nte2Hu/_old 2020-10-23 15:14:11.758129853 +0200
+++ /var/tmp/diff_new_pack.Nte2Hu/_new 2020-10-23 15:14:11.758129853 +0200
@@ -19,13 +19,12 @@
%global pkg_name invariant
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 0.5.3
+Version: 0.5.4
Release: 0
Summary: Haskell98 invariant functors
License: BSD-2-Clause
URL: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
-Source1:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/1.cabal#/%{pkg_name}.cabal
BuildRequires: ghc-Cabal-devel
BuildRequires: ghc-StateVar-devel
BuildRequires: ghc-array-devel
@@ -66,7 +65,6 @@
%prep
%autosetup -n %{pkg_name}-%{version}
-cp -p %{SOURCE1} %{pkg_name}.cabal
%build
%ghc_lib_build
++++++ invariant-0.5.3.tar.gz -> invariant-0.5.4.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/invariant-0.5.3/CHANGELOG.md
new/invariant-0.5.4/CHANGELOG.md
--- old/invariant-0.5.3/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200
+++ new/invariant-0.5.4/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200
@@ -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.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/invariant-0.5.3/invariant.cabal
new/invariant-0.5.4/invariant.cabal
--- old/invariant-0.5.3/invariant.cabal 2001-09-09 03:46:40.000000000 +0200
+++ new/invariant-0.5.4/invariant.cabal 2001-09-09 03:46:40.000000000 +0200
@@ -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.fri...@gmail.com>,
Ryan Scott <ryan.gl.sc...@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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/invariant-0.5.3/src/Data/Functor/Invariant/TH/Internal.hs
new/invariant-0.5.4/src/Data/Functor/Invariant/TH/Internal.hs
--- old/invariant-0.5.3/src/Data/Functor/Invariant/TH/Internal.hs
2001-09-09 03:46:40.000000000 +0200
+++ new/invariant-0.5.4/src/Data/Functor/Invariant/TH/Internal.hs
2001-09-09 03:46:40.000000000 +0200
@@ -241,23 +241,52 @@
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?
--
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/invariant-0.5.3/src/Data/Functor/Invariant/TH.hs
new/invariant-0.5.4/src/Data/Functor/Invariant/TH.hs
--- old/invariant-0.5.3/src/Data/Functor/Invariant/TH.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/invariant-0.5.4/src/Data/Functor/Invariant/TH.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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
-
- 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@(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
+ }
+
+ -- 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]
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/invariant-0.5.3/test/THSpec.hs
new/invariant-0.5.4/test/THSpec.hs
--- old/invariant-0.5.3/test/THSpec.hs 2001-09-09 03:46:40.000000000 +0200
+++ new/invariant-0.5.4/test/THSpec.hs 2001-09-09 03:46:40.000000000 +0200
@@ -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
-------------------------------------------------------------------------------
