diff options
Diffstat (limited to 'libraries/template-haskell/Language')
5 files changed, 81 insertions, 33 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index ea5df6b1f9..22f434d4e5 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -89,6 +89,7 @@ module Language.Haskell.TH( -- ** Types Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..), Syntax.Specificity(..), + Syntax.BndrVis(..), FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, BangType, VarBangType, -- ** Documentation diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index b52de5b0d3..33a60d771d 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -24,7 +24,7 @@ module Language.Haskell.TH.Lib ( BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ, PatSynArgsQ, FamilyResultSigQ, DerivStrategyQ, - TyVarBndrUnit, TyVarBndrSpec, + TyVarBndrUnit, TyVarBndrSpec, TyVarBndrVis, -- ** Constructors lifted to 'Q' -- *** Literals @@ -77,9 +77,12 @@ module Language.Haskell.TH.Lib ( varK, conK, tupleK, arrowK, listK, appK, starK, constraintK, -- *** Type variable binders + DefaultBndrFlag(defaultBndrFlag), plainTV, kindedTV, plainInvisTV, kindedInvisTV, + plainBndrTV, kindedBndrTV, specifiedSpec, inferredSpec, + bndrReq, bndrInvis, -- *** Roles nominalR, representationalR, phantomR, inferR, @@ -192,10 +195,10 @@ import Prelude hiding (Applicative(..)) ------------------------------------------------------------------------------- -- * Dec -tySynD :: Quote m => Name -> [TyVarBndr ()] -> m Type -> m Dec +tySynD :: Quote m => Name -> [TyVarBndr BndrVis] -> m Type -> m Dec tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } -dataD :: Quote m => m Cxt -> Name -> [TyVarBndr ()] -> Maybe Kind -> [m Con] -> [m DerivClause] +dataD :: Quote m => m Cxt -> Name -> [TyVarBndr BndrVis] -> Maybe Kind -> [m Con] -> [m DerivClause] -> m Dec dataD ctxt tc tvs ksig cons derivs = do @@ -204,7 +207,7 @@ dataD ctxt tc tvs ksig cons derivs = derivs1 <- sequenceA derivs return (DataD ctxt1 tc tvs ksig cons1 derivs1) -newtypeD :: Quote m => m Cxt -> Name -> [TyVarBndr ()] -> Maybe Kind -> m Con -> [m DerivClause] +newtypeD :: Quote m => m Cxt -> Name -> [TyVarBndr BndrVis] -> Maybe Kind -> m Con -> [m DerivClause] -> m Dec newtypeD ctxt tc tvs ksig con derivs = do @@ -213,14 +216,14 @@ newtypeD ctxt tc tvs ksig con derivs = derivs1 <- sequenceA derivs return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) -typeDataD :: Quote m => Name -> [TyVarBndr ()] -> Maybe Kind -> [m Con] +typeDataD :: Quote m => Name -> [TyVarBndr BndrVis] -> Maybe Kind -> [m Con] -> m Dec typeDataD tc tvs ksig cons = do cons1 <- sequenceA cons return (TypeDataD tc tvs ksig cons1) -classD :: Quote m => m Cxt -> Name -> [TyVarBndr ()] -> [FunDep] -> [m Dec] -> m Dec +classD :: Quote m => m Cxt -> Name -> [TyVarBndr BndrVis] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs = do decs1 <- sequenceA decs @@ -255,16 +258,16 @@ newtypeInstD ctxt tc tys ksig con derivs = derivs1 <- sequenceA derivs return (NewtypeInstD ctxt1 Nothing ty1 ksig con1 derivs1) -dataFamilyD :: Quote m => Name -> [TyVarBndr ()] -> Maybe Kind -> m Dec +dataFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> Maybe Kind -> m Dec dataFamilyD tc tvs kind = pure $ DataFamilyD tc tvs kind -openTypeFamilyD :: Quote m => Name -> [TyVarBndr ()] -> FamilyResultSig +openTypeFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> FamilyResultSig -> Maybe InjectivityAnn -> m Dec openTypeFamilyD tc tvs res inj = pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj) -closedTypeFamilyD :: Quote m => Name -> [TyVarBndr ()] -> FamilyResultSig +closedTypeFamilyD :: Quote m => Name -> [TyVarBndr BndrVis] -> FamilyResultSig -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec closedTypeFamilyD tc tvs result injectivity eqns = do eqns1 <- sequenceA eqns @@ -298,11 +301,23 @@ sigT t k ------------------------------------------------------------------------------- -- * Kind -plainTV :: Name -> TyVarBndr () -plainTV n = PlainTV n () +class DefaultBndrFlag flag where + defaultBndrFlag :: flag -kindedTV :: Name -> Kind -> TyVarBndr () -kindedTV n k = KindedTV n () k +instance DefaultBndrFlag () where + defaultBndrFlag = () + +instance DefaultBndrFlag Specificity where + defaultBndrFlag = SpecifiedSpec + +instance DefaultBndrFlag BndrVis where + defaultBndrFlag = BndrReq + +plainTV :: DefaultBndrFlag flag => Name -> TyVarBndr flag +plainTV n = PlainTV n defaultBndrFlag + +kindedTV :: DefaultBndrFlag flag => Name -> Kind -> TyVarBndr flag +kindedTV n k = KindedTV n defaultBndrFlag k starK :: Kind starK = StarT diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index 35bca47d25..b066061944 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -79,6 +79,7 @@ type InjectivityAnn = TH.InjectivityAnn type TyVarBndrUnit = TyVarBndr () type TyVarBndrSpec = TyVarBndr Specificity +type TyVarBndrVis = TyVarBndr BndrVis ---------------------------------------------------------- -- * Lowercase pattern syntax functions @@ -412,14 +413,14 @@ funD nm cs = ; pure (FunD nm cs1) } -tySynD :: Quote m => Name -> [m (TyVarBndr ())] -> m Type -> m Dec +tySynD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> m Type -> m Dec tySynD tc tvs rhs = do { tvs1 <- sequenceA tvs ; rhs1 <- rhs ; pure (TySynD tc tvs1 rhs1) } -dataD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> [m Con] +dataD :: Quote m => m Cxt -> Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> [m Con] -> [m DerivClause] -> m Dec dataD ctxt tc tvs ksig cons derivs = do @@ -430,7 +431,7 @@ dataD ctxt tc tvs ksig cons derivs = derivs1 <- sequenceA derivs pure (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1) -newtypeD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> m Con +newtypeD :: Quote m => m Cxt -> Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> m Con -> [m DerivClause] -> m Dec newtypeD ctxt tc tvs ksig con derivs = do @@ -441,7 +442,7 @@ newtypeD ctxt tc tvs ksig con derivs = derivs1 <- sequenceA derivs pure (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1) -typeDataD :: Quote m => Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> [m Con] +typeDataD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> [m Con] -> m Dec typeDataD tc tvs ksig cons = do @@ -450,7 +451,7 @@ typeDataD tc tvs ksig cons = cons1 <- sequenceA cons pure (TypeDataD tc tvs1 ksig1 cons1) -classD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> [FunDep] -> [m Dec] -> m Dec +classD :: Quote m => m Cxt -> Name -> [m (TyVarBndr BndrVis)] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs = do tvs1 <- sequenceA tvs @@ -571,20 +572,20 @@ tySynInstD eqn = eqn1 <- eqn pure (TySynInstD eqn1) -dataFamilyD :: Quote m => Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> m Dec +dataFamilyD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> m Dec dataFamilyD tc tvs kind = do tvs' <- sequenceA tvs kind' <- sequenceA kind pure $ DataFamilyD tc tvs' kind' -openTypeFamilyD :: Quote m => Name -> [m (TyVarBndr ())] -> m FamilyResultSig +openTypeFamilyD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> m FamilyResultSig -> Maybe InjectivityAnn -> m Dec openTypeFamilyD tc tvs res inj = do tvs' <- sequenceA tvs res' <- res pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj) -closedTypeFamilyD :: Quote m => Name -> [m (TyVarBndr ())] -> m FamilyResultSig +closedTypeFamilyD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> m FamilyResultSig -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec closedTypeFamilyD tc tvs result injectivity eqns = do tvs1 <- sequenceA tvs @@ -879,18 +880,30 @@ plainTV n = pure $ PlainTV n () plainInvisTV :: Quote m => Name -> Specificity -> m (TyVarBndr Specificity) plainInvisTV n s = pure $ PlainTV n s +plainBndrTV :: Quote m => Name -> BndrVis -> m (TyVarBndr BndrVis) +plainBndrTV n v = pure $ PlainTV n v + kindedTV :: Quote m => Name -> m Kind -> m (TyVarBndr ()) kindedTV n = fmap (KindedTV n ()) kindedInvisTV :: Quote m => Name -> Specificity -> m Kind -> m (TyVarBndr Specificity) kindedInvisTV n s = fmap (KindedTV n s) +kindedBndrTV :: Quote m => Name -> BndrVis -> m Kind -> m (TyVarBndr BndrVis) +kindedBndrTV n v = fmap (KindedTV n v) + specifiedSpec :: Specificity specifiedSpec = SpecifiedSpec inferredSpec :: Specificity inferredSpec = InferredSpec +bndrReq :: BndrVis +bndrReq = BndrReq + +bndrInvis :: BndrVis +bndrInvis = BndrInvis + varK :: Name -> Kind varK = VarT @@ -1091,7 +1104,7 @@ funD_doc nm cs mfun_doc arg_docs = do Nothing -> funD nm cs -- | Variant of 'dataD' that attaches Haddock documentation. -dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind) +dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind) -> [(Q Con, Maybe String, [Maybe String])] -- ^ List of constructors, documentation for the constructor, and -- documentation for the arguments @@ -1105,7 +1118,7 @@ dataD_doc ctxt tc tvs ksig cons_with_docs derivs mdoc = do maybe dec (flip withDecDoc dec) mdoc -- | Variant of 'newtypeD' that attaches Haddock documentation. -newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind) +newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind) -> (Q Con, Maybe String, [Maybe String]) -- ^ The constructor, documentation for the constructor, and -- documentation for the arguments @@ -1119,7 +1132,7 @@ newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do maybe dec (flip withDecDoc dec) mdoc -- | Variant of 'typeDataD' that attaches Haddock documentation. -typeDataD_doc :: Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind) +typeDataD_doc :: Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind) -> [(Q Con, Maybe String, [Maybe String])] -- ^ List of constructors, documentation for the constructor, and -- documentation for the arguments diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index cedb974976..33fbcf8427 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -947,6 +947,14 @@ instance PprFlag Specificity where pprTyVarBndr (KindedTV nm SpecifiedSpec k) = parens (ppr nm <+> dcolon <+> ppr k) pprTyVarBndr (KindedTV nm InferredSpec k) = braces (ppr nm <+> dcolon <+> ppr k) +instance PprFlag BndrVis where + pprTyVarBndr (PlainTV nm vis) = pprBndrVis vis (ppr nm) + pprTyVarBndr (KindedTV nm vis k) = pprBndrVis vis (parens (ppr nm <+> dcolon <+> ppr k)) + +pprBndrVis :: BndrVis -> Doc -> Doc +pprBndrVis BndrReq d = d +pprBndrVis BndrInvis d = char '@' <> d + instance PprFlag flag => Ppr (TyVarBndr flag) where ppr bndr = pprTyVarBndr bndr diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 0304eb130b..af1ae4f8ab 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -3,7 +3,8 @@ RankNTypes, RoleAnnotations, ScopedTypeVariables, MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds, GADTs, UnboxedTuples, UnboxedSums, TypeOperators, - Trustworthy, DeriveFunctor, BangPatterns, RecordWildCards, ImplicitParams #-} + Trustworthy, DeriveFunctor, DeriveTraversable, + BangPatterns, RecordWildCards, ImplicitParams #-} {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} @@ -2392,22 +2393,22 @@ data Range = FromR Exp | FromThenR Exp Exp data Dec = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@ | ValD Pat Body [Dec] -- ^ @{ p = b where decs }@ - | DataD Cxt Name [TyVarBndr ()] + | DataD Cxt Name [TyVarBndr BndrVis] (Maybe Kind) -- Kind signature (allowed only for GADTs) [Con] [DerivClause] -- ^ @{ data Cxt x => T x = A x | B (T x) -- deriving (Z,W) -- deriving stock Eq }@ - | NewtypeD Cxt Name [TyVarBndr ()] + | NewtypeD Cxt Name [TyVarBndr BndrVis] (Maybe Kind) -- Kind signature Con [DerivClause] -- ^ @{ newtype Cxt x => T x = A (B x) -- deriving (Z,W Q) -- deriving stock Eq }@ - | TypeDataD Name [TyVarBndr ()] + | TypeDataD Name [TyVarBndr BndrVis] (Maybe Kind) -- Kind signature (allowed only for GADTs) [Con] -- ^ @{ type data T x = A x | B (T x) }@ - | TySynD Name [TyVarBndr ()] Type -- ^ @{ type T x = (x,x) }@ - | ClassD Cxt Name [TyVarBndr ()] + | TySynD Name [TyVarBndr BndrVis] Type -- ^ @{ type T x = (x,x) }@ + | ClassD Cxt Name [TyVarBndr BndrVis] [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@ | InstanceD (Maybe Overlap) Cxt Type [Dec] -- ^ @{ instance {\-\# OVERLAPS \#-\} @@ -2424,7 +2425,7 @@ data Dec | PragmaD Pragma -- ^ @{ {\-\# INLINE [1] foo \#-\} }@ -- | data families (may also appear in [Dec] of 'ClassD' and 'InstanceD') - | DataFamilyD Name [TyVarBndr ()] + | DataFamilyD Name [TyVarBndr BndrVis] (Maybe Kind) -- ^ @{ data family T a b c :: * }@ @@ -2548,7 +2549,7 @@ type PatSynType = Type -- @TypeFamilyHead@ is defined to be the elements of the declaration -- between @type family@ and @where@. data TypeFamilyHead = - TypeFamilyHead Name [TyVarBndr ()] FamilyResultSig (Maybe InjectivityAnn) + TypeFamilyHead Name [TyVarBndr BndrVis] FamilyResultSig (Maybe InjectivityAnn) deriving( Show, Eq, Ord, Data, Generic ) -- | One equation of a type family instance or closed type family. The @@ -2804,9 +2805,19 @@ data Specificity = SpecifiedSpec -- ^ @a@ | InferredSpec -- ^ @{a}@ deriving( Show, Eq, Ord, Data, Generic ) +-- | The @flag@ type parameter is instantiated to one of the following types: +-- +-- * 'Specificity' (examples: 'ForallC', 'ForallT') +-- * 'BndrVis' (examples: 'DataD', 'ClassD', etc.) +-- * '()', a catch-all type for other forms of binders, including 'ForallVisT', 'DataInstD', 'RuleP', and 'TyVarSig' +-- data TyVarBndr flag = PlainTV Name flag -- ^ @a@ | KindedTV Name flag Kind -- ^ @(a :: k)@ - deriving( Show, Eq, Ord, Data, Generic, Functor ) + deriving( Show, Eq, Ord, Data, Generic, Functor, Foldable, Traversable ) + +data BndrVis = BndrReq -- ^ @a@ + | BndrInvis -- ^ @\@a@ + deriving( Show, Eq, Ord, Data, Generic ) -- | Type family result signature data FamilyResultSig = NoSig -- ^ no signature |