Hello community,
here is the log from the commit of package ghc-th-abstraction for
openSUSE:Factory checked in at 2018-07-24 17:22:48
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-th-abstraction (Old)
and /work/SRC/openSUSE:Factory/.ghc-th-abstraction.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-th-abstraction"
Tue Jul 24 17:22:48 2018 rev:3 rq:623871 version:0.2.8.0
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-th-abstraction/ghc-th-abstraction.changes
2018-05-30 12:27:31.997804721 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-th-abstraction.new/ghc-th-abstraction.changes
2018-07-24 17:22:56.323342430 +0200
@@ -1,0 +2,34 @@
+Wed Jul 18 14:26:43 UTC 2018 - [email protected]
+
+- Cosmetic: replace tabs with blanks, strip trailing white space,
+ and update copyright headers with spec-cleaner.
+
+-------------------------------------------------------------------
+Fri Jul 13 14:31:53 UTC 2018 - [email protected]
+
+- Update th-abstraction to version 0.2.8.0.
+ ## 0.2.8.0 -- 2018-06-29
+ * GADT reification is now much more robust with respect to `PolyKinds`:
+ * A bug in which universally quantified kind variables were mistakenly
+ flagged as existential has been fixed.
+ * A bug in which the kinds of existentially quantified type variables
+ were not substituted properly has been fixed.
+ * More kind equalities are detected than before. For example, in the
+ following data type:
+
+ ```haskell
+ data T (a :: k) where
+ MkT :: forall (a :: Bool). T a
+ ```
+
+ We now catch the `k ~ Bool` equality.
+ * Tweak `resolveTypeSynonyms` so that failing to reify a type constructor
+ name so longer results in an error. Among other benefits, this makes
+ it possible to pass data types with GADT syntax to `normalizeDec`.
+
+ ## 0.2.7.0 -- 2018-06-17
+ * Fix bug in which data family instances with duplicate occurrences of type
+ variables in the left-hand side would have redundant equality constraints
+ in their contexts.
+
+-------------------------------------------------------------------
@@ -34 +67,0 @@
-
Old:
----
th-abstraction-0.2.6.0.tar.gz
New:
----
th-abstraction-0.2.8.0.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-th-abstraction.spec ++++++
--- /var/tmp/diff_new_pack.zA8LiY/_old 2018-07-24 17:22:58.883345702 +0200
+++ /var/tmp/diff_new_pack.zA8LiY/_new 2018-07-24 17:22:58.883345702 +0200
@@ -19,7 +19,7 @@
%global pkg_name th-abstraction
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 0.2.6.0
+Version: 0.2.8.0
Release: 0
Summary: Nicer interface for reified information about data types
License: ISC
++++++ th-abstraction-0.2.6.0.tar.gz -> th-abstraction-0.2.8.0.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/th-abstraction-0.2.6.0/ChangeLog.md
new/th-abstraction-0.2.8.0/ChangeLog.md
--- old/th-abstraction-0.2.6.0/ChangeLog.md 2017-09-05 04:55:33.000000000
+0200
+++ new/th-abstraction-0.2.8.0/ChangeLog.md 2018-06-29 18:03:23.000000000
+0200
@@ -1,5 +1,29 @@
# Revision history for th-abstraction
+## 0.2.8.0 -- 2018-06-29
+* GADT reification is now much more robust with respect to `PolyKinds`:
+ * A bug in which universally quantified kind variables were mistakenly
+ flagged as existential has been fixed.
+ * A bug in which the kinds of existentially quantified type variables
+ were not substituted properly has been fixed.
+ * More kind equalities are detected than before. For example, in the
+ following data type:
+
+ ```haskell
+ data T (a :: k) where
+ MkT :: forall (a :: Bool). T a
+ ```
+
+ We now catch the `k ~ Bool` equality.
+* Tweak `resolveTypeSynonyms` so that failing to reify a type constructor
+ name so longer results in an error. Among other benefits, this makes
+ it possible to pass data types with GADT syntax to `normalizeDec`.
+
+## 0.2.7.0 -- 2018-06-17
+* Fix bug in which data family instances with duplicate occurrences of type
+ variables in the left-hand side would have redundant equality constraints
+ in their contexts.
+
## 0.2.6.0 -- 2017-09-04
* Fix bug in which `applySubstitution` and `freeVariables` would ignore
type variables in the kinds of type variable binders.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/th-abstraction-0.2.6.0/src/Language/Haskell/TH/Datatype.hs
new/th-abstraction-0.2.8.0/src/Language/Haskell/TH/Datatype.hs
--- old/th-abstraction-0.2.6.0/src/Language/Haskell/TH/Datatype.hs
2017-09-05 04:55:33.000000000 +0200
+++ new/th-abstraction-0.2.8.0/src/Language/Haskell/TH/Datatype.hs
2018-06-29 18:03:23.000000000 +0200
@@ -776,16 +776,9 @@
-> ConstructorVariant
-> Q [ConstructorInfo]
dataFamCase' n tyvars stricts variant = do
- info <- reifyRecover n $ fail $ unlines
- [ "normalizeCon: Cannot reify constructor " ++ nameBase n
- , "You are likely calling normalizeDec on GHC 7.6 or 7.8
on a data family"
- , "whose type variables have been eta-reduced due to GHC
Trac #9692."
- , "Unfortunately, without being able to reify the
constructor's type,"
- , "there is no way to recover the eta-reduced type
variables in general."
- , "A recommended workaround is to use reifyDatatype
instead."
- ]
- case info of
- DataConI _ ty _ _ -> do
+ mbInfo <- reifyMaybe n
+ case mbInfo of
+ Just (DataConI _ ty _ _) -> do
let (context, argTys :|- returnTy) = uncurryType ty
returnTy' <- resolveTypeSynonyms returnTy
-- Notice that we've ignored the Cxt and argument Types from
the
@@ -800,7 +793,14 @@
-- much easier.
normalizeGadtC typename params tyvars context [n]
returnTy' argTys stricts (const $ return
variant)
- _ -> fail "normalizeCon: impossible"
+ _ -> fail $ unlines
+ [ "normalizeCon: Cannot reify constructor " ++ nameBase n
+ , "You are likely calling normalizeDec on GHC 7.6 or 7.8
on a data family"
+ , "whose type variables have been eta-reduced due to GHC
Trac #9692."
+ , "Unfortunately, without being able to reify the
constructor's type,"
+ , "there is no way to recover the eta-reduced type
variables in general."
+ , "A recommended workaround is to use reifyDatatype
instead."
+ ]
-- A very ad hoc way of determining if we need to perform some extra
passes
-- to repair an eta-reduction bug for data family instances that
only occurs
@@ -909,13 +909,17 @@
case decomposeType innerType' of
ConT innerTyCon :| ts | typename == innerTyCon ->
- let (substName, context1) = mergeArguments params ts
- subst = VarT <$> substName
- tyvars' = [ tv | tv <- renamedTyvars, Map.notMember (tvName tv)
subst ]
-
- context2 = applySubstitution subst (context1 ++ renamedContext)
- fields' = applySubstitution subst renamedFields
- in sequence [ ConstructorInfo name tyvars' context2
+ let (substName, context1) =
+ closeOverKinds (kindsOfFVsOfTvbs renamedTyvars)
+ (kindsOfFVsOfTypes params)
+ (mergeArguments params ts)
+ subst = VarT <$> substName
+ exTyvars = [ tv | tv <- renamedTyvars, Map.notMember (tvName tv)
subst ]
+
+ exTyvars' = substTyVarBndrs subst exTyvars
+ context2 = applySubstitution subst (context1 ++ renamedContext)
+ fields' = applySubstitution subst renamedFields
+ in sequence [ ConstructorInfo name exTyvars' context2
fields' stricts <$> variantQ
| name <- names
, let variantQ = getVariant name
@@ -923,25 +927,163 @@
_ -> fail "normalizeGadtC: Expected type constructor application"
+{-
+Extend a type variable renaming subtitution and a list of equality
+predicates by looking into kind information as much as possible.
+
+Why is this necessary? Consider the following example:
+
+ data (a1 :: k1) :~: (b1 :: k1) where
+ Refl :: forall k2 (a2 :: k2). a2 :~: a2
+
+After an initial call to mergeArguments, we will have the following
+substitution and context:
+
+* Substitution: [a2 :-> a1]
+* Context: (a2 ~ b1)
+
+We shouldn't stop there, however! We determine the existentially quantified
+type variables of a constructor by filtering out those constructor-bound
+variables which do not appear in the substitution that mergeArguments
+returns. In this example, Refl's bound variables are k2 and a2. a2 appears
+in the returned substitution, but k2 does not, which means that we would
+mistakenly conclude that k2 is existential!
+
+Although we don't have the full power of kind inference to guide us here, we
+can at least do the next best thing. Generally, the datatype-bound type
+variables and the constructor type variable binders contain all of the kind
+information we need, so we proceed as follows:
+
+1. Construct a map from each constructor-bound variable to its kind. (Do the
+ same for each datatype-bound variable). These maps are the first and second
+ arguments to closeOverKinds, respectively.
+2. Call mergeArguments once on the GADT return type and datatype-bound types,
+ and pass that in as the third argument to closeOverKinds.
+3. For each name-name pair in the supplied substitution, check if the first and
+ second names map to kinds in the first and second kind maps in
+ closeOverKinds, respectively. If so, associate the first kind with the
+ second kind.
+4. For each kind association discovered in part (3), call mergeArguments
+ on the lists of kinds. This will yield a kind substitution and kind
+ equality context.
+5. If the kind substitution is non-empty, then go back to step (3) and repeat
+ the process on the new kind substitution and context.
+
+ Otherwise, if the kind substitution is empty, then we have reached a fixed-
+ point (i.e., we have closed over the kinds), so proceed.
+6. Union up all of the substitutions and contexts, and return those.
+
+This algorithm is not perfect, as it will only catch everything if all of
+the kinds are explicitly mentioned somewhere (and not left quantified
+implicitly). Thankfully, reifying data types via Template Haskell tends to
+yield a healthy amount of kind signatures, so this works quite well in
+practice.
+-}
+closeOverKinds :: Map Name Kind
+ -> Map Name Kind
+ -> (Map Name Name, Cxt)
+ -> (Map Name Name, Cxt)
+closeOverKinds domainFVKinds rangeFVKinds = go
+ where
+ go :: (Map Name Name, Cxt) -> (Map Name Name, Cxt)
+ go (subst, context) =
+ let substList = Map.toList subst
+ (kindsInner, kindsOuter) =
+ unzip $
+ mapMaybe (\(d, r) -> do d' <- Map.lookup d domainFVKinds
+ r' <- Map.lookup r rangeFVKinds
+ return (d', r'))
+ substList
+ (kindSubst, kindContext) = mergeArgumentKinds kindsOuter kindsInner
+ (restSubst, restContext)
+ = if Map.null kindSubst -- Fixed-point calculation
+ then (Map.empty, [])
+ else go (kindSubst, kindContext)
+ finalSubst = Map.unions [subst, kindSubst, restSubst]
+ finalContext = nub $ concat [context, kindContext, restContext]
+ -- Use `nub` here in an effort to minimize the number of
+ -- redundant equality constraints in the returned context.
+ in (finalSubst, finalContext)
+
+-- Look into a list of types and map each free variable name to its kind.
+kindsOfFVsOfTypes :: [Type] -> Map Name Kind
+kindsOfFVsOfTypes = foldMap go
+ where
+ go :: Type -> Map Name Kind
+ go (ForallT {}) = error "`forall` type used in data family pattern"
+ go (AppT t1 t2) = go t1 `Map.union` go t2
+ go (SigT t k) =
+ let kSigs =
+#if MIN_VERSION_template_haskell(2,8,0)
+ go k
+#else
+ Map.empty
+#endif
+ in case t of
+ VarT n -> Map.insert n k kSigs
+ _ -> go t `Map.union` kSigs
+ go _ = Map.empty
+
+-- Look into a list of type variable binder and map each free variable name
+-- to its kind (also map the names that KindedTVs bind to their respective
+-- kinds). This function considers the kind of a PlainTV to be *.
+kindsOfFVsOfTvbs :: [TyVarBndr] -> Map Name Kind
+kindsOfFVsOfTvbs = foldMap go
+ where
+ go :: TyVarBndr -> Map Name Kind
+ go (PlainTV n) = Map.singleton n starK
+ go (KindedTV n k) =
+ let kSigs =
+#if MIN_VERSION_template_haskell(2,8,0)
+ kindsOfFVsOfTypes [k]
+#else
+ Map.empty
+#endif
+ in Map.insert n k kSigs
+
mergeArguments ::
[Type] {- ^ outer parameters -} ->
[Type] {- ^ inner parameters (specializations ) -} ->
(Map Name Name, Cxt)
mergeArguments ns ts = foldr aux (Map.empty, []) (zip ns ts)
where
- aux (SigT x _, y) sc = aux (x,y) sc -- learn about kinds??
- aux (x, SigT y _) sc = aux (x,y) sc
aux (f `AppT` x, g `AppT` y) sc =
aux (x,y) (aux (f,g) sc)
aux (VarT n,p) (subst, context) =
case p of
- VarT m | Map.notMember m subst -> (Map.insert m n subst, context)
+ VarT m | m == n -> (subst, context)
+ -- If the two variables are the same, don't bother extending
+ -- the substitution. (This is purely an optimization.)
+ | Just n' <- Map.lookup m subst
+ , n == n' -> (subst, context)
+ -- If a variable is already in a substitution and it maps
+ -- to the variable that we are trying to unify with, then
+ -- leave the context alone. (Not doing so caused #46.)
+ | Map.notMember m subst -> (Map.insert m n subst, context)
_ -> (subst, equalPred (VarT n) p : context)
+ aux (SigT x _, y) sc = aux (x,y) sc -- learn about kinds??
+ -- This matches *after* VarT so that we can compute a substitution
+ -- that includes the kind signature.
+ aux (x, SigT y _) sc = aux (x,y) sc
+
aux _ sc = sc
+-- | A specialization of 'mergeArguments' to 'Kind'.
+-- Needed only for backwards compatibility with older versions of
+-- @template-haskell@.
+mergeArgumentKinds ::
+ [Kind] ->
+ [Kind] ->
+ (Map Name Name, Cxt)
+#if MIN_VERSION_template_haskell(2,8,0)
+mergeArgumentKinds = mergeArguments
+#else
+mergeArgumentKinds _ _ = (Map.empty, [])
+#endif
+
-- | Expand all of the type synonyms in a type.
resolveTypeSynonyms :: Type -> Q Type
resolveTypeSynonyms t =
@@ -951,10 +1093,9 @@
case f of
ConT n ->
- do info <- reifyRecover n $ fail
- "resolveTypeSynonyms: Cannot reify type synonym information"
- case info of
- TyConI (TySynD _ synvars def)
+ do mbInfo <- reifyMaybe n
+ case mbInfo of
+ Just (TyConI (TySynD _ synvars def))
-> resolveTypeSynonyms $ expandSynonymRHS synvars xs def
_ -> notTypeSynCase
_ -> notTypeSynCase
@@ -976,10 +1117,9 @@
resolvePredSynonyms = resolveTypeSynonyms
#else
resolvePredSynonyms (ClassP n ts) = do
- info <- reifyRecover n $ fail
- "resolvePredSynonyms: Cannot reify type synonym information"
- case info of
- TyConI (TySynD _ synvars def)
+ mbInfo <- reifyMaybe n
+ case mbInfo of
+ Just (TyConI (TySynD _ synvars def))
-> resolvePredSynonyms $ typeToPred $ expandSynonymRHS synvars ts def
_ -> ClassP n <$> mapM resolveTypeSynonyms ts
resolvePredSynonyms (EqualP t1 t2) = do
@@ -1170,7 +1310,30 @@
-- | Class for types that support type variable substitution.
class TypeSubstitution a where
- -- | Apply a type variable substitution
+ -- | Apply a type variable substitution.
+ --
+ -- Note that 'applySubstitution' is /not/ capture-avoiding. To illustrate
+ -- this, observe that if you call this function with the following
+ -- substitution:
+ --
+ -- * @b :-> a@
+ --
+ -- On the following 'Type':
+ --
+ -- * @forall a. b@
+ --
+ -- Then it will return:
+ --
+ -- * @forall a. a@
+ --
+ -- However, because the same @a@ type variable was used in the range of the
+ -- substitution as was bound by the @forall@, the substituted @a@ is now
+ -- captured by the @forall@, resulting in a completely different function.
+ --
+ -- For @th-abstraction@'s purposes, this is acceptable, as it usually only
+ -- deals with globally unique type variable 'Name's. If you use
+ -- 'applySubstitution' in a context where the 'Name's aren't globally unique,
+ -- however, be aware of this potential problem.
applySubstitution :: Map Name Type -> a -> a
-- | Compute the free type variables
freeVariables :: a -> [Name]
@@ -1248,6 +1411,14 @@
applySubstitution _ k = k
#endif
+-- | Substitutes into the kinds of type variable binders.
+-- Not capture-avoiding.
+substTyVarBndrs :: Map Name Type -> [TyVarBndr] -> [TyVarBndr]
+substTyVarBndrs subst = map go
+ where
+ go tvb@(PlainTV {}) = tvb
+ go (KindedTV n k) = KindedTV n (applySubstitution subst k)
+
------------------------------------------------------------------------
combineSubstitutions :: Map Name Type -> Map Name Type -> Map Name Type
@@ -1255,6 +1426,10 @@
-- | Compute the type variable substitution that unifies a list of types,
-- or fail in 'Q'.
+--
+-- All infix issue should be resolved before using 'unifyTypes'
+--
+-- Alpha equivalent quantified types are not unified.
unifyTypes :: [Type] -> Q (Map Name Type)
unifyTypes [] = return Map.empty
unifyTypes (t:ts) =
@@ -1277,20 +1452,23 @@
unify' (VarT n) (VarT m) | n == m = pure Map.empty
unify' (VarT n) t | n `elem` freeVariables t = Left (VarT n, t)
- | otherwise = pure (Map.singleton n t)
+ | otherwise = Right (Map.singleton n t)
unify' t (VarT n) | n `elem` freeVariables t = Left (VarT n, t)
- | otherwise = pure (Map.singleton n t)
-
-unify' (ConT n) (ConT m) | n == m = pure Map.empty
+ | otherwise = Right (Map.singleton n t)
unify' (AppT f1 x1) (AppT f2 x2) =
do sub1 <- unify' f1 f2
sub2 <- unify' (applySubstitution sub1 x1) (applySubstitution sub1 x2)
- return (combineSubstitutions sub1 sub2)
-
-unify' (TupleT n) (TupleT m) | n == m = pure Map.empty
+ Right (combineSubstitutions sub1 sub2)
-unify' t u = Left (t,u)
+-- Doesn't unify kind signatures
+unify' (SigT t _) u = unify' t u
+unify' t (SigT u _) = unify' t u
+
+-- only non-recursive cases should remain at this point
+unify' t u
+ | t == u = Right Map.empty
+ | otherwise = Left (t,u)
-- | Construct an equality constraint. The implementation of 'Pred' varies
@@ -1313,7 +1491,6 @@
ClassP
#endif
-
-- | Match a 'Pred' representing an equality constraint. Returns
-- arguments to the equality constraint if successful.
asEqualPred :: Pred -> Maybe (Type,Type)
@@ -1506,9 +1683,7 @@
_ -> Nothing
#endif
--- | Call 'reify' with an action to take if reification fails.
-reifyRecover ::
- Name ->
- Q Info {- ^ handle failure -} ->
- Q Info
-reifyRecover n failure = failure `recover` reify n
+-- | Call 'reify' and return @'Just' info@ if successful or 'Nothing' if
+-- reification failed.
+reifyMaybe :: Name -> Q (Maybe Info)
+reifyMaybe n = return Nothing `recover` fmap Just (reify n)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/th-abstraction-0.2.6.0/test/Harness.hs
new/th-abstraction-0.2.8.0/test/Harness.hs
--- old/th-abstraction-0.2.6.0/test/Harness.hs 2017-09-05 04:55:33.000000000
+0200
+++ new/th-abstraction-0.2.8.0/test/Harness.hs 2018-06-29 18:03:23.000000000
+0200
@@ -23,6 +23,8 @@
import Control.Monad
import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.Maybe
import Language.Haskell.TH
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib (starK)
@@ -75,14 +77,21 @@
let sub1 = Map.fromList (zip (map tvName (constructorVars con2))
(map VarT (map tvName (constructorVars
con1))))
- sub2 = Map.fromList (zip (freeVariables con2)
+ sub2 = Map.fromList (zip (freeVariables (map tvKind (constructorVars
con2)))
+ (map VarT (freeVariables
+ (map tvKind (constructorVars
con1)))))
+ sub3 = Map.fromList (zip (freeVariables con2)
(map VarT (freeVariables con1)))
- sub = sub1 `Map.union` sub2
+ sub = Map.unions [sub1, sub2, sub3]
zipWithM_ (equateCxt "constructorContext")
(constructorContext con1)
(applySubstitution sub (constructorContext con2))
+ check "constructorVars" id
+ (constructorVars con1)
+ (substIntoTyVarBndrs sub (constructorVars con2))
+
check "constructorFields" id
(constructorFields con1)
(applySubstitution sub (constructorFields con2))
@@ -98,6 +107,21 @@
i@InfixConstructor{} -> i
RecordConstructor fields -> RecordConstructor $ map (mkName .
nameBase) fields
+ -- Substitutes both type variable names and kinds.
+ substIntoTyVarBndrs :: Map Name Type -> [TyVarBndr] -> [TyVarBndr]
+ substIntoTyVarBndrs subst = map go
+ where
+ go (PlainTV n) = PlainTV $ substName subst n
+ go (KindedTV n k) = KindedTV (substName subst n)
+ (applySubstitution subst k)
+
+ substName :: Map Name Type -> Name -> Name
+ substName subst n = fromMaybe n $ do
+ nty <- Map.lookup n subst
+ case nty of
+ VarT n' -> Just n'
+ _ -> Nothing
+
equateStrictness :: FieldStrictness -> FieldStrictness -> Either String ()
equateStrictness fs1 fs2 =
check "constructorStrictness" oldGhcHack fs1 fs2
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/th-abstraction-0.2.6.0/test/Main.hs
new/th-abstraction-0.2.8.0/test/Main.hs
--- old/th-abstraction-0.2.6.0/test/Main.hs 2017-09-05 04:55:33.000000000
+0200
+++ new/th-abstraction-0.2.8.0/test/Main.hs 2018-06-29 18:03:23.000000000
+0200
@@ -26,10 +26,8 @@
import Control.Monad (zipWithM_)
#endif
-#if MIN_VERSION_template_haskell(2,8,0)
import Control.Monad (unless)
import qualified Data.Map as Map
-#endif
#if MIN_VERSION_base(4,7,0)
import Data.Type.Equality ((:~:)(..))
@@ -55,6 +53,9 @@
voidstosTest
strictDemoTest
recordVanillaTest
+#if MIN_VERSION_template_haskell(2,6,0)
+ t43Test
+#endif
#if MIN_VERSION_template_haskell(2,7,0)
dataFamilyTest
ghc78bugTest
@@ -64,6 +65,7 @@
famLocalDecTest1
famLocalDecTest2
recordFamTest
+ t46Test
#endif
fixityLookupTest
#if __GLASGOW_HASKELL__ >= 704
@@ -77,6 +79,11 @@
#if MIN_VERSION_template_haskell(2,8,0)
kindSubstTest
#endif
+#if __GLASGOW_HASKELL__ >= 800
+ t37Test
+ polyKindedExTyvarTest
+#endif
+ regressionTest44
adt1Test :: IO ()
adt1Test =
@@ -215,7 +222,7 @@
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'Showable
- , constructorVars = [PlainTV a]
+ , constructorVars = [KindedTV a starK]
, constructorContext = [classPred ''Show [VarT a]]
, constructorFields = [VarT a]
, constructorStrictness = [notStrictAnnot]
@@ -319,6 +326,47 @@
$(do info <- reifyRecord 'gadtrec1a
validateCI info gadtRecVanillaCI)
+#if MIN_VERSION_template_haskell(2,6,0)
+t43Test :: IO ()
+t43Test =
+ $(do [decPlain] <- [d| data T43Plain where MkT43Plain :: T43Plain |]
+ infoPlain <- normalizeDec decPlain
+ validateDI infoPlain
+ DatatypeInfo
+ { datatypeName = mkName "T43Plain"
+ , datatypeContext = []
+ , datatypeVars = []
+ , datatypeVariant = Datatype
+ , datatypeCons =
+ [ ConstructorInfo
+ { constructorName = mkName "MkT43Plain"
+ , constructorVars = []
+ , constructorContext = []
+ , constructorFields = []
+ , constructorStrictness = []
+ , constructorVariant = NormalConstructor } ]
+ }
+
+ [decFam] <- [d| data instance T43Fam where MkT43Fam :: T43Fam |]
+ infoFam <- normalizeDec decFam
+ validateDI infoFam
+ DatatypeInfo
+ { datatypeName = mkName "T43Fam"
+ , datatypeContext = []
+ , datatypeVars = []
+ , datatypeVariant = DataInstance
+ , datatypeCons =
+ [ ConstructorInfo
+ { constructorName = mkName "MkT43Fam"
+ , constructorVars = []
+ , constructorContext = []
+ , constructorFields = []
+ , constructorStrictness = []
+ , constructorVariant = NormalConstructor } ]
+ }
+ )
+#endif
+
#if MIN_VERSION_template_haskell(2,7,0)
dataFamilyTest :: IO ()
dataFamilyTest =
@@ -427,7 +475,7 @@
, constructorVariant = NormalConstructor }
, ConstructorInfo
{ constructorName = '(:&&:)
- , constructorVars = [PlainTV e]
+ , constructorVars = [KindedTV e starK]
, constructorContext = [equalPred cTy (AppT ListT eTy)]
, constructorFields = [eTy,dTy]
, constructorStrictness = [notStrictAnnot, notStrictAnnot]
@@ -453,7 +501,7 @@
, constructorVariant = NormalConstructor }
, ConstructorInfo
{ constructorName = 'MkGadtFam5
- , constructorVars = [PlainTV q]
+ , constructorVars = [KindedTV q starK]
, constructorContext = [ equalPred cTy (ConT ''Bool)
, equalPred dTy (ConT ''Bool)
, equalPred qTy (ConT ''Char)
@@ -512,6 +560,16 @@
recordFamTest =
$(do info <- reifyRecord 'famRec1
validateCI info gadtRecFamCI)
+
+t46Test :: IO ()
+t46Test =
+ $(do info <- reifyDatatype 'MkT46
+ case info of
+ DatatypeInfo { datatypeCons = [ConstructorInfo { constructorContext =
ctxt }]} ->
+ unless (null ctxt) (fail "regression test for ticket #46 failed")
+ _ -> fail "T46 should have exactly one constructor"
+ [| return () |])
+
#endif
fixityLookupTest :: IO ()
@@ -577,9 +635,7 @@
, datatypeCons =
[ ConstructorInfo
{ constructorName = 'Refl
- , constructorVars = [KindedTV k starK]
- -- This shouldn't happen, ideally. See #37.
-
+ , constructorVars = []
, constructorContext = [equalPred a b]
, constructorFields = []
, constructorStrictness = []
@@ -606,3 +662,101 @@
checkFreeVars substTy [k2]
[| return () |])
#endif
+
+#if __GLASGOW_HASKELL__ >= 800
+t37Test :: IO ()
+t37Test =
+ $(do infoA <- reifyDatatype ''T37a
+ let [k,a] = map (VarT . mkName) ["k","a"]
+ validateDI infoA
+ DatatypeInfo
+ { datatypeContext = []
+ , datatypeName = ''T37a
+ , datatypeVars = [SigT k starK, SigT a k]
+ , datatypeVariant = Datatype
+ , datatypeCons =
+ [ ConstructorInfo
+ { constructorName = 'MkT37a
+ , constructorVars = []
+ , constructorContext = [equalPred k (ConT ''Bool)]
+ , constructorFields = []
+ , constructorStrictness = []
+ , constructorVariant = NormalConstructor } ]
+ }
+
+ infoB <- reifyDatatype ''T37b
+ validateDI infoB
+ DatatypeInfo
+ { datatypeContext = []
+ , datatypeName = ''T37b
+ , datatypeVars = [SigT a k]
+ , datatypeVariant = Datatype
+ , datatypeCons =
+ [ ConstructorInfo
+ { constructorName = 'MkT37b
+ , constructorVars = []
+ , constructorContext = [equalPred k (ConT ''Bool)]
+ , constructorFields = []
+ , constructorStrictness = []
+ , constructorVariant = NormalConstructor } ]
+ }
+
+ infoC <- reifyDatatype ''T37c
+ validateDI infoC
+ DatatypeInfo
+ { datatypeContext = []
+ , datatypeName = ''T37c
+ , datatypeVars = [SigT a k]
+ , datatypeVariant = Datatype
+ , datatypeCons =
+ [ ConstructorInfo
+ { constructorName = 'MkT37c
+ , constructorVars = []
+ , constructorContext = [equalPred a (ConT ''Bool)]
+ , constructorFields = []
+ , constructorStrictness = []
+ , constructorVariant = NormalConstructor } ]
+ }
+ )
+
+polyKindedExTyvarTest :: IO ()
+polyKindedExTyvarTest =
+ $(do info <- reifyDatatype ''T48
+ let [a,x] = map mkName ["a","x"]
+ validateDI info
+ DatatypeInfo
+ { datatypeContext = []
+ , datatypeName = ''T48
+ , datatypeVars = [SigT (VarT a) starK]
+ , datatypeVariant = Datatype
+ , datatypeCons =
+ [ ConstructorInfo
+ { constructorName = 'MkT48
+ , constructorVars = [KindedTV x (VarT a)]
+ , constructorContext = []
+ , constructorFields = [ConT ''Prox `AppT` VarT x]
+ , constructorStrictness = [notStrictAnnot]
+ , constructorVariant = NormalConstructor } ]
+ }
+ -- Because validateCI uses a type variable substitution to normalize
+ -- away any alpha-renaming differences between constructors, it
+ -- unfortunately does not check if the uses of `a` in datatypeVars and
+ -- constructorVars are the same. We perform this check explicitly here.
+ case info of
+ DatatypeInfo { datatypeVars = [SigT (VarT a1) starK]
+ , datatypeCons =
+ [ ConstructorInfo
+ { constructorVars = [KindedTV _ (VarT a2)] } ] }
->
+ unless (a1 == a2) $
+ fail $ "Two occurrences of the same variable have different
names: "
+ ++ show [a1, a2]
+ [| return () |]
+ )
+#endif
+
+regressionTest44 :: IO ()
+regressionTest44 =
+ $(do intToInt <- [t| Int -> Int |]
+ unified <- unifyTypes [intToInt, intToInt]
+ unless (Map.null unified) (fail "regression test for ticket #44 failed")
+ [| return () |])
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/th-abstraction-0.2.6.0/test/Types.hs
new/th-abstraction-0.2.8.0/test/Types.hs
--- old/th-abstraction-0.2.6.0/test/Types.hs 2017-09-05 04:55:33.000000000
+0200
+++ new/th-abstraction-0.2.8.0/test/Types.hs 2018-06-29 18:03:23.000000000
+0200
@@ -1,4 +1,4 @@
-{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures,
TemplateHaskell, GADTs #-}
+{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures,
TemplateHaskell, GADTs, ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE ConstraintKinds #-}
@@ -8,6 +8,10 @@
{-# Language PolyKinds #-}
#endif
+#if __GLASGOW_HASKELL__ >= 800
+{-# Language TypeInType #-}
+#endif
+
{-|
Module : Types
Description : Test cases for the th-abstraction package
@@ -25,10 +29,14 @@
import GHC.Exts (Constraint)
#endif
-import Language.Haskell.TH
+import Language.Haskell.TH hiding (Type)
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib (starK)
+#if __GLASGOW_HASKELL__ >= 800
+import Data.Kind
+#endif
+
type Gadt1Int = Gadt1 Int
infixr 6 :**:
@@ -60,10 +68,10 @@
data StrictDemo = StrictDemo Int !Int {-# UNPACK #-} !Int
-#if MIN_VERSION_template_haskell(2,7,0)
-
-- Data families
+data family T43Fam
+#if MIN_VERSION_template_haskell(2,7,0)
data family DF (a :: *)
data instance DF (Maybe a) = DFMaybe Int [a]
@@ -95,6 +103,9 @@
data family FamLocalDec1 a
data family FamLocalDec2 a b c
+
+data family T46 a b c
+data instance T46 (f (p :: *)) (f p) q = MkT46 q
#endif
#if __GLASGOW_HASKELL__ >= 704
@@ -109,6 +120,22 @@
| PredSyn3 Int => MkPredSynT3 Int
#endif
+#if __GLASGOW_HASKELL__ >= 800
+data T37a (k :: Type) :: k -> Type where
+ MkT37a :: T37a Bool a
+
+data T37b (a :: k) where
+ MkT37b :: forall (a :: Bool). T37b a
+
+data T37c (a :: k) where
+ MkT37c :: T37c Bool
+
+data Prox (a :: k) = Prox
+
+data T48 :: Type -> Type where
+ MkT48 :: forall a (x :: a). Prox x -> T48 a
+#endif
+
-- We must define these here due to Template Haskell staging restrictions
justCI :: ConstructorInfo
justCI =
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/th-abstraction-0.2.6.0/th-abstraction.cabal
new/th-abstraction-0.2.8.0/th-abstraction.cabal
--- old/th-abstraction-0.2.6.0/th-abstraction.cabal 2017-09-05
04:55:33.000000000 +0200
+++ new/th-abstraction-0.2.8.0/th-abstraction.cabal 2018-06-29
18:03:23.000000000 +0200
@@ -1,5 +1,5 @@
name: th-abstraction
-version: 0.2.6.0
+version: 0.2.8.0
synopsis: Nicer interface for reified information about data types
description: This package normalizes variations in the interface for
inspecting datatype information via Template Haskell
@@ -17,7 +17,7 @@
build-type: Simple
extra-source-files: ChangeLog.md README.md
cabal-version: >=1.10
-tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3,
GHC==7.4.2, GHC==7.2.2, GHC==7.0.4
+tested-with: GHC==8.4.3, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3,
GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4
source-repository head
type: git
@@ -28,7 +28,7 @@
other-modules: Language.Haskell.TH.Datatype.Internal
build-depends: base >=4.3 && <5,
ghc-prim,
- template-haskell >=2.5 && <2.13,
+ template-haskell >=2.5 && <2.14,
containers >=0.4 && <0.6
hs-source-dirs: src
default-language: Haskell2010
++++++ th-abstraction.cabal ++++++
--- /var/tmp/diff_new_pack.zA8LiY/_old 2018-07-24 17:22:58.939345773 +0200
+++ /var/tmp/diff_new_pack.zA8LiY/_new 2018-07-24 17:22:58.939345773 +0200
@@ -1,5 +1,5 @@
name: th-abstraction
-version: 0.2.6.0
+version: 0.2.8.0
x-revision: 1
synopsis: Nicer interface for reified information about data types
description: This package normalizes variations in the interface for
@@ -18,7 +18,7 @@
build-type: Simple
extra-source-files: ChangeLog.md README.md
cabal-version: >=1.10
-tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3,
GHC==7.4.2, GHC==7.2.2, GHC==7.0.4
+tested-with: GHC==8.4.3, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3,
GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4
source-repository head
type: git
@@ -29,8 +29,8 @@
other-modules: Language.Haskell.TH.Datatype.Internal
build-depends: base >=4.3 && <5,
ghc-prim,
- template-haskell >=2.5 && <2.14,
- containers >=0.4 && <0.6
+ template-haskell >=2.5 && <2.15,
+ containers >=0.4 && <0.7
hs-source-dirs: src
default-language: Haskell2010
