diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 --git a/src/Language/Haskell/TH/Datatype.hs b/src/Language/Haskell/TH/Datatype.hs --- a/src/Language/Haskell/TH/Datatype.hs +++ b/src/Language/Haskell/TH/Datatype.hs @@ -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 --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 --git a/test/Types.hs b/test/Types.hs --- a/test/Types.hs +++ b/test/Types.hs @@ -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 --git a/th-abstraction.cabal b/th-abstraction.cabal --- a/th-abstraction.cabal +++ b/th-abstraction.cabal @@ -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