th-abstraction 0.2.8.0 → 0.2.9.0
raw patch · 6 files changed
+231/−19 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Language.Haskell.TH.Datatype: freeVariablesWellScoped :: [Type] -> [TyVarBndr]
+ Language.Haskell.TH.Datatype: resolveKindSynonyms :: Kind -> Q Kind
Files
- ChangeLog.md +13/−0
- src/Language/Haskell/TH/Datatype.hs +155/−14
- src/Language/Haskell/TH/Datatype/Internal.hs +3/−1
- test/Main.hs +54/−0
- test/Types.hs +2/−0
- th-abstraction.cabal +4/−4
ChangeLog.md view
@@ -1,5 +1,18 @@ # Revision history for th-abstraction +## 0.2.9.0 -- 2018-12-20+* Fix a bug in which `resolveTypeSynonyms` would not look into `ForallT`s,+ `SigT`s, `InfixT`s, or `ParensT`s.+* Fix a bug in which `quantifyType` would not respect the dependency order of+ type variables (e.g., `Proxy (a :: k)` would have erroneously been quantified+ as `forall a k. Proxy (a :: k)`).+* Fix a bug in which `asEqualPred` would return incorrect results with GHC 8.7.+* Add a `freeVariablesWellScoped` function which computes the free variables of+ a list of types and sorts them according to dependency order.+* Add a `resolveKindSynonyms` function which expands all type synonyms in a+ `Kind`. This is mostly useful for supporting old GHCs where `Type` and `Kind`+ were not the same.+ ## 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
src/Language/Haskell/TH/Datatype.hs view
@@ -78,6 +78,7 @@ -- * Type variable manipulation , TypeSubstitution(..) , quantifyType+ , freeVariablesWellScoped , freshenFreeVariables -- * 'Pred' functions@@ -100,6 +101,7 @@ -- * Type simplification , resolveTypeSynonyms+ , resolveKindSynonyms , resolvePredSynonyms , resolveInfixT @@ -117,6 +119,7 @@ import Data.Data (Typeable, Data) import Data.Foldable (foldMap, foldl')+import Data.Graph import Data.List (nub, find, union, (\\)) import Data.Map (Map) import qualified Data.Map as Map@@ -136,6 +139,7 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..), (<$>))+import Data.Monoid (Monoid(..)) #endif -- | Normalized information about newtypes and data types.@@ -1085,21 +1089,62 @@ #endif -- | Expand all of the type synonyms in a type.+--+-- Note that this function will drop parentheses as a side effect. resolveTypeSynonyms :: Type -> Q Type resolveTypeSynonyms t = let f :| xs = decomposeType t - notTypeSynCase = foldl AppT f <$> mapM resolveTypeSynonyms xs in+ notTypeSynCase :: Type -> Q Type+ notTypeSynCase ty = foldl AppT ty <$> mapM resolveTypeSynonyms xs - case f of- ConT n ->- do mbInfo <- reifyMaybe n- case mbInfo of- Just (TyConI (TySynD _ synvars def))- -> resolveTypeSynonyms $ expandSynonymRHS synvars xs def- _ -> notTypeSynCase- _ -> notTypeSynCase+ 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+ -- Name isn't a type synonym+ -> Q Type+ expandCon n ty = do+ mbInfo <- reifyMaybe n+ case mbInfo of+ Just (TyConI (TySynD _ synvars def))+ -> resolveTypeSynonyms $ expandSynonymRHS synvars xs def+ _ -> notTypeSynCase ty + in case f of+ ForallT tvbs ctxt body ->+ ForallT `fmap` mapM resolve_tvb_syns tvbs+ `ap` mapM resolvePredSynonyms ctxt+ `ap` resolveTypeSynonyms body+ SigT ty ki -> do+ ty' <- resolveTypeSynonyms ty+ ki' <- resolveKindSynonyms ki+ notTypeSynCase $ SigT ty' ki'+ ConT n -> expandCon n (ConT n)+#if MIN_VERSION_template_haskell(2,11,0)+ InfixT t1 n t2 -> do+ t1' <- resolveTypeSynonyms t1+ t2' <- resolveTypeSynonyms t2+ expandCon n (InfixT t1' n t2')+ UInfixT t1 n t2 -> do+ t1' <- resolveTypeSynonyms t1+ t2' <- resolveTypeSynonyms t2+ expandCon n (UInfixT t1' n t2')+#endif+ _ -> notTypeSynCase f++-- | Expand all of the type synonyms in a 'Kind'.+resolveKindSynonyms :: Kind -> Q Kind+#if MIN_VERSION_template_haskell(2,8,0)+resolveKindSynonyms = resolveTypeSynonyms+#else+resolveKindSynonyms = return -- One simply couldn't put type synonyms into+ -- kinds on old versions of GHC.+#endif++-- | Expand all of the type synonyms in a the kind of a 'TyVarBndr'.+resolve_tvb_syns :: TyVarBndr -> Q TyVarBndr+resolve_tvb_syns tvb@PlainTV{} = return tvb+resolve_tvb_syns (KindedTV n k) = KindedTV n <$> resolveKindSynonyms k+ expandSynonymRHS :: [TyVarBndr] {- ^ Substitute these variables... -} -> [Type] {- ^ ...with these types... -} ->@@ -1156,8 +1201,11 @@ decomposeType :: Type -> NonEmpty Type decomposeType = go [] where- go args (AppT f x) = go (x:args) f- go args t = t :| args+ go args (AppT f x) = go (x:args) f+#if MIN_VERSION_template_haskell(2,11,0)+ go args (ParensT t) = go args t+#endif+ go args t = t :| args -- 'NonEmpty' didn't move into base until recently. Reimplementing it locally -- saves dependencies for supporting older GHCs@@ -1294,11 +1342,104 @@ -- contrast with being dependent upon the Ord instance for 'Name') quantifyType :: Type -> Type quantifyType t- | null vs = t- | otherwise = ForallT (PlainTV <$> vs) [] t+ | null tvbs = t+ | otherwise = ForallT tvbs [] t where- vs = freeVariables t+ tvbs = freeVariablesWellScoped [t] +-- | Take a list of 'Type's, find their free variables, and sort them+-- according to dependency order.+--+-- As an example of how this function works, consider the following type:+--+-- @+-- Proxy (a :: k)+-- @+--+-- Calling 'freeVariables' on this type would yield @[a, k]@, since that is+-- the order in which those variables appear in a left-to-right fashion. But+-- this order does not preserve the fact that @k@ is the kind of @a@. Moreover,+-- if you tried writing the type @forall a k. Proxy (a :: k)@, GHC would reject+-- this, since GHC would demand that @k@ come before @a@.+--+-- 'freeVariablesWellScoped' orders the free variables of a type in a way that+-- preserves this dependency ordering. If one were to call+-- 'freeVariablesWellScoped' on the type above, it would return+-- @[k, (a :: k)]@. (This is why 'freeVariablesWellScoped' returns a list of+-- 'TyVarBndr's instead of 'Name's, since it must make it explicit that @k@+-- is the kind of @a@.)+--+-- On older GHCs, this takes measures to avoid returning explicitly bound+-- kind variables, which was not possible before @TypeInType@.+freeVariablesWellScoped :: [Type] -> [TyVarBndr]+freeVariablesWellScoped tys =+ let fvs :: [Name]+ fvs = freeVariables tys++ varKindSigs :: Map Name Kind+ varKindSigs = foldMap go_ty tys+ where+ go_ty :: Type -> Map Name Kind+ go_ty (ForallT tvbs ctxt t) =+ foldr (\tvb -> Map.delete (tvName tvb))+ (foldMap go_pred ctxt `mappend` go_ty t) tvbs+ go_ty (AppT t1 t2) = go_ty t1 `mappend` go_ty t2+ go_ty (SigT t k) =+ let kSigs =+#if MIN_VERSION_template_haskell(2,8,0)+ go_ty k+#else+ mempty+#endif+ in case t of+ VarT n -> Map.insert n k kSigs+ _ -> go_ty t `mappend` kSigs+ go_ty _ = mempty++ go_pred :: Pred -> Map Name Kind+#if MIN_VERSION_template_haskell(2,10,0)+ go_pred = go_ty+#else+ go_pred (ClassP _ ts) = foldMap go_ty ts+ go_pred (EqualP t1 t2) = go_ty t1 `mappend` go_ty t2+#endif++ (g, gLookup, _)+ = graphFromEdges [ (fv, fv, kindVars)+ | fv <- fvs+ , let kindVars =+ case Map.lookup fv varKindSigs of+ Nothing -> []+ Just ks -> freeVariables ks+ ]+ tg = reverse $ topSort g++ lookupVertex x =+ case gLookup x of+ (n, _, _) -> n++ ascribeWithKind n+ | Just k <- Map.lookup n varKindSigs+ = KindedTV n k+ | otherwise+ = PlainTV n++ -- An annoying wrinkle: GHCs before 8.0 don't support explicitly+ -- quantifying kinds, so something like @forall k (a :: k)@ would be+ -- rejected. To work around this, we filter out any binders whose names+ -- also appear in a kind on old GHCs.+ isKindBinderOnOldGHCs+#if __GLASGOW_HASKELL__ >= 800+ = const False+#else+ = (`elem` kindVars)+ where+ kindVars = freeVariables $ Map.elems varKindSigs+#endif++ in map ascribeWithKind $+ filter (not . isKindBinderOnOldGHCs) $+ map lookupVertex tg -- | Substitute all of the free variables in a type with fresh ones freshenFreeVariables :: Type -> Q Type
src/Language/Haskell/TH/Datatype/Internal.hs view
@@ -15,7 +15,9 @@ import Language.Haskell.TH.Syntax eqTypeName :: Name-#if MIN_VERSION_base(4,9,0)+#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ < 807+ -- TODO: Replace __GLASGOW_HASKELL__ < 807 with+ -- !(MIN_VERSION_base(4,13,0)) once base-4.13 exists eqTypeName = mkNameG_tc "base" "Data.Type.Equality" "~" #else eqTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "~"
test/Main.hs view
@@ -78,6 +78,8 @@ #endif #if MIN_VERSION_template_haskell(2,8,0) kindSubstTest+ t59Test+ t61Test #endif #if __GLASGOW_HASKELL__ >= 800 t37Test@@ -660,6 +662,58 @@ checkFreeVars ty [k1] checkFreeVars substTy [k2]+ [| return () |])++t59Test :: IO ()+t59Test =+ $(do k <- newName "k"+ a <- newName "a"+ let proxyAK = ConT (mkName "Proxy") `AppT` SigT (VarT a) (VarT k)+ -- Proxy (a :: k)+ expected = ForallT+#if __GLASGOW_HASKELL__ >= 800+ [PlainTV k, KindedTV a (VarT k)]+#else+ [KindedTV a (VarT k)]+#endif+ [] proxyAK+ actual = quantifyType proxyAK+ unless (expected == actual) $+ fail $ "quantifyType does not respect dependency order: "+ ++ unlines [ "Expected: " ++ pprint expected+ , "Actual: " ++ pprint actual+ ]+ [| return () |])++t61Test :: IO ()+t61Test =+ $(do let test :: Type -> Type -> Q ()+ test orig expected = do+ actual <- resolveTypeSynonyms orig+ unless (expected == actual) $+ fail $ "Type synonym expansion failed: "+ ++ unlines [ "Expected: " ++ pprint expected+ , "Actual: " ++ pprint actual+ ]++ idAppT = (ConT ''Id `AppT`)+ a = mkName "a"+ test (SigT (idAppT $ ConT ''Int) (idAppT StarT))+ (SigT (ConT ''Int) StarT)+#if MIN_VERSION_template_haskell(2,10,0)+ test (ForallT [KindedTV a (idAppT StarT)]+ [idAppT (ConT ''Show `AppT` VarT a)]+ (idAppT $ VarT a))+ (ForallT [KindedTV a StarT]+ [ConT ''Show `AppT` VarT a]+ (VarT a))+#endif+#if MIN_VERSION_template_haskell(2,11,0)+ test (InfixT (idAppT $ ConT ''Int) ''Either (idAppT $ ConT ''Int))+ (InfixT (ConT ''Int) ''Either (ConT ''Int))+ test (ParensT (idAppT $ ConT ''Int))+ (ConT ''Int)+#endif [| return () |]) #endif
test/Types.hs view
@@ -71,6 +71,8 @@ -- Data families data family T43Fam +type Id (a :: *) = a+ #if MIN_VERSION_template_haskell(2,7,0) data family DF (a :: *) data instance DF (Maybe a) = DFMaybe Int [a]
th-abstraction.cabal view
@@ -1,5 +1,5 @@ name: th-abstraction-version: 0.2.8.0+version: 0.2.9.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.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+tested-with: GHC==8.6.3, 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,8 +28,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