Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-th-abstraction for openSUSE:Factory checked in at 2021-09-10 23:41:13 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-th-abstraction (Old) and /work/SRC/openSUSE:Factory/.ghc-th-abstraction.new.1899 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-th-abstraction" Fri Sep 10 23:41:13 2021 rev:16 rq:917498 version:0.4.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-th-abstraction/ghc-th-abstraction.changes 2021-05-05 20:40:57.214666644 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-th-abstraction.new.1899/ghc-th-abstraction.changes 2021-09-10 23:41:30.830572318 +0200 @@ -1,0 +2,11 @@ +Thu Sep 2 08:31:58 UTC 2021 - [email protected] + +- Update th-abstraction to version 0.4.3.0. + ## 0.4.3.0 -- 2021.08.30 + * Make `applySubstitution` avoid capturing type variable binders when + substituting into `forall`s. + * Fix a bug in which `resolveTypeSynonyms` would incorrectly expand type + synonyms that are not applied to enough arguments. + * Allow the test suite to build with GHC 9.2. + +------------------------------------------------------------------- Old: ---- th-abstraction-0.4.2.0.tar.gz th-abstraction.cabal New: ---- th-abstraction-0.4.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-th-abstraction.spec ++++++ --- /var/tmp/diff_new_pack.YzYtgB/_old 2021-09-10 23:41:31.310572829 +0200 +++ /var/tmp/diff_new_pack.YzYtgB/_new 2021-09-10 23:41:31.314572833 +0200 @@ -19,13 +19,12 @@ %global pkg_name th-abstraction %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.4.2.0 +Version: 0.4.3.0 Release: 0 Summary: Nicer interface for reified information about data types License: ISC 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-containers-devel BuildRequires: ghc-rpm-macros @@ -50,7 +49,6 @@ %prep %autosetup -n %{pkg_name}-%{version} -cp -p %{SOURCE1} %{pkg_name}.cabal %build %ghc_lib_build ++++++ th-abstraction-0.4.2.0.tar.gz -> th-abstraction-0.4.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/th-abstraction-0.4.2.0/ChangeLog.md new/th-abstraction-0.4.3.0/ChangeLog.md --- old/th-abstraction-0.4.2.0/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200 +++ new/th-abstraction-0.4.3.0/ChangeLog.md 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,12 @@ # Revision history for th-abstraction +## 0.4.3.0 -- 2021.08.30 +* Make `applySubstitution` avoid capturing type variable binders when + substituting into `forall`s. +* Fix a bug in which `resolveTypeSynonyms` would incorrectly expand type + synonyms that are not applied to enough arguments. +* Allow the test suite to build with GHC 9.2. + ## 0.4.2.0 -- 2020-12-30 * Explicitly mark modules as Safe (or Trustworthy for GHC versions prior to 8.4). diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/th-abstraction-0.4.2.0/README.md new/th-abstraction-0.4.3.0/README.md --- old/th-abstraction-0.4.2.0/README.md 2001-09-09 03:46:40.000000000 +0200 +++ new/th-abstraction-0.4.3.0/README.md 2001-09-09 03:46:40.000000000 +0200 @@ -13,4 +13,4 @@ Contact Information ------------------- -Please contact me via GitHub or on the #haskell IRC channel on irc.freenode.net +Please contact me via GitHub or on the #haskell IRC channel on irc.libera.chat diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/th-abstraction-0.4.2.0/src/Language/Haskell/TH/Datatype.hs new/th-abstraction-0.4.3.0/src/Language/Haskell/TH/Datatype.hs --- old/th-abstraction-0.4.2.0/src/Language/Haskell/TH/Datatype.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/th-abstraction-0.4.3.0/src/Language/Haskell/TH/Datatype.hs 2001-09-09 03:46:40.000000000 +0200 @@ -126,7 +126,7 @@ import Data.Data (Typeable, Data) import Data.Foldable (foldMap, foldl') -import Data.List (nub, find, union, (\\)) +import Data.List (mapAccumL, nub, find, union, (\\)) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe @@ -1073,9 +1073,12 @@ 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 + -- The use of substTyVarBndrKinds below will never capture, as the + -- range of the substitution will always use distinct names from + -- exTyvars due to the alpha-renaming pass above. + exTyvars' = substTyVarBndrKinds subst exTyvars + context2 = applySubstitution subst (context1 ++ renamedContext) + fields' = applySubstitution subst renamedFields in sequence [ ConstructorInfo name exTyvars' context2 fields' stricts <$> variantQ | name <- names @@ -1254,9 +1257,13 @@ resolveTypeSynonyms :: Type -> Q Type resolveTypeSynonyms t = let (f, xs) = decomposeTypeArgs t + normal_xs = filterTANormals xs - notTypeSynCase :: Type -> Q Type - notTypeSynCase ty = foldl appTypeArg ty <$> mapM resolveTypeArgSynonyms xs + -- Either the type is not headed by a type synonym, or it is headed by a + -- type synonym that is not applied to enough arguments. Leave the type + -- alone and only expand its arguments. + defaultCase :: Type -> Q Type + defaultCase ty = foldl appTypeArg ty <$> mapM resolveTypeArgSynonyms xs expandCon :: Name -- The Name to check whether it is a type synonym or not -> Type -- The argument type to fall back on if the supplied @@ -1266,8 +1273,9 @@ mbInfo <- reifyMaybe n case mbInfo of Just (TyConI (TySynD _ synvars def)) - -> resolveTypeSynonyms $ expandSynonymRHS synvars (filterTANormals xs) def - _ -> notTypeSynCase ty + | length normal_xs >= length synvars -- Don't expand undersaturated type synonyms (#88) + -> resolveTypeSynonyms $ expandSynonymRHS synvars normal_xs def + _ -> defaultCase ty in case f of ForallT tvbs ctxt body -> @@ -1277,8 +1285,8 @@ SigT ty ki -> do ty' <- resolveTypeSynonyms ty ki' <- resolveKindSynonyms ki - notTypeSynCase $ SigT ty' ki' - ConT n -> expandCon n (ConT n) + defaultCase $ SigT ty' ki' + ConT n -> expandCon n f #if MIN_VERSION_template_haskell(2,11,0) InfixT t1 n t2 -> do t1' <- resolveTypeSynonyms t1 @@ -1298,7 +1306,7 @@ ForallVisT `fmap` mapM resolve_tvb_syns tvbs `ap` resolveTypeSynonyms body #endif - _ -> notTypeSynCase f + _ -> defaultCase f -- | Expand all of the type synonyms in a 'TypeArg'. resolveTypeArgSynonyms :: TypeArg -> Q TypeArg @@ -1338,6 +1346,7 @@ mbInfo <- reifyMaybe n case mbInfo of Just (TyConI (TySynD _ synvars def)) + | length ts >= length synvars -- Don't expand undersaturated type synonyms (#88) -> resolvePredSynonyms $ typeToPred $ expandSynonymRHS synvars ts def _ -> ClassP n <$> mapM resolveTypeSynonyms ts resolvePredSynonyms (EqualP t1 t2) = do @@ -1744,29 +1753,6 @@ -- | Class for types that support type variable substitution. class TypeSubstitution a where -- | 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] @@ -1779,8 +1765,8 @@ applySubstitution subst = go where go (ForallT tvs context t) = - subst_tvbs tvs $ \subst' -> - ForallT (map (mapTVKind (applySubstitution subst')) tvs) + let (subst', tvs') = substTyVarBndrs subst tvs in + ForallT tvs' (applySubstitution subst' context) (applySubstitution subst' t) go (AppT f x) = AppT (go f) (go x) @@ -1798,8 +1784,8 @@ #endif #if MIN_VERSION_template_haskell(2,16,0) go (ForallVisT tvs t) = - subst_tvbs tvs $ \subst' -> - ForallVisT (map (mapTVKind (applySubstitution subst')) tvs) + let (subst', tvs') = substTyVarBndrs subst tvs in + ForallVisT tvs' (applySubstitution subst' t) #endif go t = t @@ -1868,12 +1854,55 @@ applySubstitution _ k = k #endif --- | Substitutes into the kinds of type variable binders. --- Not capture-avoiding. -substTyVarBndrs :: Map Name Type -> [TyVarBndr_ flag] -> [TyVarBndr_ flag] -substTyVarBndrs subst = map go +-- | Substitutes into the kinds of type variable binders. This makes an effort +-- to avoid capturing the 'TyVarBndr' names during substitution by +-- alpha-renaming names if absolutely necessary. For a version of this function +-- which does /not/ avoid capture, see 'substTyVarBndrKinds'. +substTyVarBndrs :: Map Name Type -> [TyVarBndr_ flag] -> (Map Name Type, [TyVarBndr_ flag]) +substTyVarBndrs = mapAccumL substTyVarBndr + +-- | The workhorse for 'substTyVarBndrs'. +substTyVarBndr :: Map Name Type -> TyVarBndr_ flag -> (Map Name Type, TyVarBndr_ flag) +substTyVarBndr subst tvb + | tvbName `Map.member` subst + = (Map.delete tvbName subst, mapTVKind (applySubstitution subst) tvb) + | tvbName `Set.notMember` substRangeFVs + = (subst, mapTVKind (applySubstitution subst) tvb) + | otherwise + = let tvbName' = evade tvbName in + ( Map.insert tvbName (VarT tvbName') subst + , mapTV (\_ -> tvbName') id (applySubstitution subst) tvb + ) where - go = mapTVKind (applySubstitution subst) + tvbName :: Name + tvbName = tvName tvb + + substRangeFVs :: Set Name + substRangeFVs = Set.fromList $ freeVariables $ Map.elems subst + + evade :: Name -> Name + evade n | n `Set.member` substRangeFVs + = evade $ bump n + | otherwise + = n + + -- An improvement would be to try a variety of different characters instead + -- of prepending the same character repeatedly. Let's wait to see if + -- someone complains about this before making this more complicated, + -- however. + bump :: Name -> Name + bump n = mkName $ 'f':nameBase n + +-- | Substitutes into the kinds of type variable binders. This is slightly more +-- efficient than 'substTyVarBndrs', but at the expense of not avoiding +-- capture. Only use this function in situations where you know that none of +-- the 'TyVarBndr' names are contained in the range of the substitution. +substTyVarBndrKinds :: Map Name Type -> [TyVarBndr_ flag] -> [TyVarBndr_ flag] +substTyVarBndrKinds subst = map (substTyVarBndrKind subst) + +-- | The workhorse for 'substTyVarBndrKinds'. +substTyVarBndrKind :: Map Name Type -> TyVarBndr_ flag -> TyVarBndr_ flag +substTyVarBndrKind subst = mapTVKind (applySubstitution subst) ------------------------------------------------------------------------ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/th-abstraction-0.4.2.0/test/Main.hs new/th-abstraction-0.4.3.0/test/Main.hs --- old/th-abstraction-0.4.2.0/test/Main.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/th-abstraction-0.4.3.0/test/Main.hs 2001-09-09 03:46:40.000000000 +0200 @@ -31,7 +31,7 @@ import Control.Monad (zipWithM_) #endif -import Control.Monad (unless) +import Control.Monad (unless, when) import qualified Data.Map as Map #if MIN_VERSION_base(4,7,0) @@ -104,6 +104,8 @@ regressionTest44 t63Test t70Test + t88Test + captureAvoidanceTest adt1Test :: IO () adt1Test = @@ -1072,3 +1074,26 @@ check fvsBAExpected fvsBAActual [| return () |]) + +t88Test :: IO () +t88Test = + $(do let unexpandedType = ConT ''Id + expected = unexpandedType + actual <- resolveTypeSynonyms (ConT ''Id) + unless (expected == actual) $ + fail $ "resolveTypeSynonyms incorrectly expands an undersaturated type synonym: " + ++ unlines [ "Expected: " ++ pprint expected + , "Actual: " ++ pprint actual + ] + [| return () |]) + +captureAvoidanceTest :: IO () +captureAvoidanceTest = do + let a = mkName "a" + b = mkName "b" + subst = Map.singleton b (VarT a) + origTy = ForallT [plainTVSpecified a] [] (VarT b) + substTy = applySubstitution subst origTy + wrongTy = ForallT [plainTVSpecified a] [] (VarT a) + when (substTy == wrongTy) $ + fail $ "applySubstitution captures during substitution" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/th-abstraction-0.4.2.0/test/Types.hs new/th-abstraction-0.4.3.0/test/Types.hs --- old/th-abstraction-0.4.2.0/test/Types.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/th-abstraction-0.4.3.0/test/Types.hs 2001-09-09 03:46:40.000000000 +0200 @@ -85,7 +85,7 @@ # else data family DF1 (a :: *) # endif -data instance DF1 b = DF1 b +data instance DF1 (b :: *) = DF1 b data family Quoted (a :: *) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/th-abstraction-0.4.2.0/th-abstraction.cabal new/th-abstraction-0.4.3.0/th-abstraction.cabal --- old/th-abstraction-0.4.2.0/th-abstraction.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/th-abstraction-0.4.3.0/th-abstraction.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,5 @@ name: th-abstraction -version: 0.4.2.0 +version: 0.4.3.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.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, 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 +tested-with: GHC==9.2.*, GHC==9.0.1, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, 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,7 +29,7 @@ other-modules: Language.Haskell.TH.Datatype.Internal build-depends: base >=4.3 && <5, ghc-prim, - template-haskell >=2.5 && <2.18, + template-haskell >=2.5 && <2.19, containers >=0.4 && <0.7 hs-source-dirs: src default-language: Haskell2010
