th-abstraction 0.4.2.0 → 0.4.3.0
raw patch · 6 files changed
+110/−49 lines, 6 filesdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: template-haskell
API changes (from Hackage documentation)
Files
- ChangeLog.md +7/−0
- README.md +1/−1
- src/Language/Haskell/TH/Datatype.hs +72/−43
- test/Main.hs +26/−1
- test/Types.hs +1/−1
- th-abstraction.cabal +3/−3
ChangeLog.md view
@@ -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).
README.md view
@@ -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
src/Language/Haskell/TH/Datatype.hs view
@@ -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) ------------------------------------------------------------------------
test/Main.hs view
@@ -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"
test/Types.hs view
@@ -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 :: *)
th-abstraction.cabal view
@@ -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