th-abstraction 0.3.1.0 → 0.3.2.0
raw patch · 5 files changed
+136/−19 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +10/−0
- src/Language/Haskell/TH/Datatype.hs +60/−15
- test/Main.hs +57/−0
- test/Types.hs +6/−1
- th-abstraction.cabal +3/−3
ChangeLog.md view
@@ -1,5 +1,15 @@ # Revision history for th-abstraction +## 0.3.2.0 -- 2020-02-06+* Support substituting into and extracting free variables from `ForallVisT`s+ on `template-haskell-2.16.0.0` (GHC 8.10) or later.+* Fix a bug in which `freeVariables` could report duplicate kind variables when+ they occur in the kinds of the type variable binders in a `ForallT`.+* Fix a bug in which `resolveInfixT` would not resolve `UInfixT`s occurring in+ the kinds of type variable binders in a `ForallT`.+* Fix a bug in which the `TypeSubstitution ConstructorInfo` instance would not+ detect free kind variables in the `constructorVars`.+ ## 0.3.1.0 -- 2019-04-28 * Fix a bug which would cause data family information to be reified incorrectly with GHC 8.8+ in some situations.
src/Language/Haskell/TH/Datatype.hs view
@@ -1168,7 +1168,6 @@ 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 =@@ -1180,8 +1179,17 @@ in case t of VarT n -> Map.insert n k kSigs _ -> go t `Map.union` kSigs++ go (ForallT {}) = forallError+#if MIN_VERSION_template_haskell(2,16,0)+ go (ForallVisT {}) = forallError+#endif+ go _ = Map.empty + forallError :: a+ forallError = error "`forall` type used in data family pattern"+ -- 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 *.@@ -1285,8 +1293,13 @@ #endif #if MIN_VERSION_template_haskell(2,15,0) ImplicitParamT n t -> do- ImplicitParamT n `fmap` resolveTypeSynonyms t+ ImplicitParamT n <$> resolveTypeSynonyms t #endif+#if MIN_VERSION_template_haskell(2,16,0)+ ForallVisT tvbs body ->+ ForallVisT `fmap` mapM resolve_tvb_syns tvbs+ `ap` resolveTypeSynonyms body+#endif _ -> notTypeSynCase f -- | Expand all of the type synonyms in a 'TypeArg'.@@ -1457,7 +1470,9 @@ resolveInfixT :: Type -> Q Type #if MIN_VERSION_template_haskell(2,11,0)-resolveInfixT (ForallT vs cx t) = forallT vs (mapM resolveInfixT cx) (resolveInfixT t)+resolveInfixT (ForallT vs cx t) = ForallT <$> traverse (traverseTvbKind resolveInfixT) vs+ <*> mapM resolveInfixT cx+ <*> resolveInfixT t resolveInfixT (f `AppT` x) = resolveInfixT f `appT` resolveInfixT x resolveInfixT (ParensT t) = resolveInfixT t resolveInfixT (InfixT l o r) = conT o `appT` resolveInfixT l `appT` resolveInfixT r@@ -1468,6 +1483,10 @@ resolveInfixT (ImplicitParamT n t) = implicitParamT n $ resolveInfixT t # endif+# if MIN_VERSION_template_haskell(2,16,0)+resolveInfixT (ForallVisT vs t) = ForallVisT <$> traverse (traverseTvbKind resolveInfixT) vs+ <*> resolveInfixT t+# endif resolveInfixT t = return t gatherUInfixT :: Type -> InfixList@@ -1640,6 +1659,10 @@ go_ty (AppKindT t k) = go_ty t `mappend` go_ty k go_ty (ImplicitParamT _ t) = go_ty t #endif+#if MIN_VERSION_template_haskell(2,16,0)+ go_ty (ForallVisT tvbs t) =+ foldr (\tvb -> Map.delete (tvName tvb)) (go_ty t) tvbs+#endif go_ty _ = mempty go_pred :: Pred -> Map Name Kind@@ -1766,11 +1789,7 @@ applySubstitution subst = go where go (ForallT tvs context t) =- let subst' = foldl' (flip Map.delete) subst (map tvName tvs)-- mapTvbKind :: (Kind -> Kind) -> TyVarBndr -> TyVarBndr- mapTvbKind f (PlainTV n) = PlainTV n- mapTvbKind f (KindedTV n k) = KindedTV n (f k) in+ subst_tvbs tvs $ \subst' -> ForallT (map (mapTvbKind (applySubstitution subst')) tvs) (applySubstitution subst' context) (applySubstitution subst' t)@@ -1787,15 +1806,21 @@ go (ImplicitParamT n t) = ImplicitParamT n (go t) #endif+#if MIN_VERSION_template_haskell(2,16,0)+ go (ForallVisT tvs t) =+ subst_tvbs tvs $ \subst' ->+ ForallVisT (map (mapTvbKind (applySubstitution subst')) tvs)+ (applySubstitution subst' t)+#endif go t = t + subst_tvbs :: [TyVarBndr] -> (Map Name Type -> a) -> a+ subst_tvbs tvs k = k $ foldl' (flip Map.delete) subst (map tvName tvs)+ freeVariables t = case t of ForallT tvs context t' ->- (concatMap (freeVariables . tvKind) tvs- `union` freeVariables context- `union` freeVariables t')- \\ map tvName tvs+ fvs_under_forall tvs (freeVariables context `union` freeVariables t') AppT f x -> freeVariables f `union` freeVariables x SigT t' k -> freeVariables t' `union` freeVariables k VarT v -> [v]@@ -1809,19 +1834,39 @@ ImplicitParamT _ t -> freeVariables t #endif+#if MIN_VERSION_template_haskell(2,16,0)+ ForallVisT tvs t'+ -> fvs_under_forall tvs (freeVariables t')+#endif _ -> []+ where+ fvs_under_forall :: [TyVarBndr] -> [Name] -> [Name]+ fvs_under_forall tvs fvs =+ (freeVariables (map tvKind tvs) `union` fvs)+ \\ map tvName tvs instance TypeSubstitution ConstructorInfo where freeVariables ci =- (freeVariables (constructorContext ci) `union`- freeVariables (constructorFields ci))+ (freeVariables (map tvKind (constructorVars ci))+ `union` freeVariables (constructorContext ci)+ `union` freeVariables (constructorFields ci)) \\ (tvName <$> constructorVars ci) applySubstitution subst ci = let subst' = foldl' (flip Map.delete) subst (map tvName (constructorVars ci)) in- ci { constructorContext = applySubstitution subst' (constructorContext ci)+ ci { constructorVars = map (mapTvbKind (applySubstitution subst'))+ (constructorVars ci)+ , constructorContext = applySubstitution subst' (constructorContext ci) , constructorFields = applySubstitution subst' (constructorFields ci) }++mapTvbKind :: (Kind -> Kind) -> TyVarBndr -> TyVarBndr+mapTvbKind f tvb@PlainTV{} = tvb+mapTvbKind f (KindedTV n k) = KindedTV n (f k)++traverseTvbKind :: Applicative f => (Kind -> f Kind) -> TyVarBndr -> f TyVarBndr+traverseTvbKind f tvb@PlainTV{} = pure tvb+traverseTvbKind f (KindedTV n k) = KindedTV n <$> f k -- 'Pred' became a type synonym for 'Type' #if !MIN_VERSION_template_haskell(2,10,0)
test/Main.hs view
@@ -88,7 +88,11 @@ t59Test t61Test t66Test+ t80Test #endif+#if MIN_VERSION_template_haskell(2,11,0)+ t79Test+#endif #if __GLASGOW_HASKELL__ >= 800 t37Test polyKindedExTyvarTest@@ -851,8 +855,43 @@ , constructorVariant = NormalConstructor } ] } )++t80Test :: IO ()+t80Test = do+ let [k,a,b] = map mkName ["k","a","b"]+ -- forall k (a :: k) (b :: k). ()+ t = ForallT [PlainTV k, KindedTV a (VarT k), KindedTV b (VarT k)] [] (ConT ''())++ expected, actual :: [Name]+ expected = []+ actual = freeVariables t++ unless (expected == actual) $+ fail $ "Bug in ForallT substitution: "+ ++ unlines [ "Expected: " ++ pprint expected+ , "Actual: " ++ pprint actual+ ]+ return () #endif +#if MIN_VERSION_template_haskell(2,11,0)+t79Test :: IO ()+t79Test =+ $(do let [a,b,c] = map mkName ["a","b","c"]+ t = ForallT [KindedTV a (UInfixT (VarT b) ''(:+:) (VarT c))] []+ (ConT ''())+ expected = ForallT [KindedTV a (ConT ''(:+:) `AppT` VarT b `AppT` VarT c)] []+ (ConT ''())+ actual <- resolveInfixT t+ unless (expected == actual) $+ fail $ "resolveInfixT does not recur into the kinds of "+ ++ "ForallT type variable binders: "+ ++ unlines [ "Expected: " ++ pprint expected+ , "Actual: " ++ pprint actual+ ]+ [| return () |])+#endif+ #if __GLASGOW_HASKELL__ >= 800 t37Test :: IO () t37Test =@@ -950,6 +989,24 @@ unless (a1 == a2) $ fail $ "Two occurrences of the same variable have different names: " ++ show [a1, a2]+ [| return () |]+ )++t75Test :: IO ()+t75Test =+ $(do info <- reifyDatatype ''T75+ case datatypeCons info of+ [c] -> let datatypeVarTypes = map (VarT . tvName) $ datatypeVars info+ constructorVarKinds = map tvKind $ constructorVars c in+ unless (datatypeVarTypes == constructorVarKinds) $+ fail $ "Mismatch between datatypeVars and constructorVars' kinds: "+ ++ unlines [ "datatypeVars: "+ ++ pprint datatypeVarTypes+ , "constructorVars' kinds: "+ ++ pprint constructorVarKinds+ ]+ cs -> fail $ "Unexpected number of constructors for T75: "+ ++ show (length cs) [| return () |] ) #endif
test/Types.hs view
@@ -1,4 +1,4 @@-{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs, ScopedTypeVariables #-}+{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs, ScopedTypeVariables, TypeOperators #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE ConstraintKinds #-}@@ -68,6 +68,8 @@ data StrictDemo = StrictDemo Int !Int {-# UNPACK #-} !Int +type (:+:) = Either+ -- Data families data family T43Fam @@ -139,6 +141,9 @@ data T48 :: Type -> Type where MkT48 :: forall a (x :: a). Prox x -> T48 a++data T75 (k :: Type) where+ MkT75 :: forall k (a :: k). Prox a -> T75 k #endif -- We must define these here due to Template Haskell staging restrictions
th-abstraction.cabal view
@@ -1,5 +1,5 @@ name: th-abstraction-version: 0.3.1.0+version: 0.3.2.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.8.1, GHC==8.6.4, 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==8.10.1, GHC==8.8.1, 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@@ -28,7 +28,7 @@ other-modules: Language.Haskell.TH.Datatype.Internal build-depends: base >=4.3 && <5, ghc-prim,- template-haskell >=2.5 && <2.16,+ template-haskell >=2.5 && <2.17, containers >=0.4 && <0.7 hs-source-dirs: src default-language: Haskell2010