diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs --- a/Language/Haskell/TH.hs +++ b/Language/Haskell/TH.hs @@ -89,6 +89,7 @@ -- ** Types Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..), Syntax.Specificity(..), + Syntax.BndrVis(..), FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, BangType, VarBangType, -- ** Documentation diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs --- a/Language/Haskell/TH/Lib.hs +++ b/Language/Haskell/TH/Lib.hs @@ -24,7 +24,7 @@ BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ, PatSynArgsQ, FamilyResultSigQ, DerivStrategyQ, - TyVarBndrUnit, TyVarBndrSpec, + TyVarBndrUnit, TyVarBndrSpec, TyVarBndrVis, -- ** Constructors lifted to 'Q' -- *** Literals @@ -44,7 +44,7 @@ appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR, lamE, lam1E, lamCaseE, lamCasesE, tupE, unboxedTupE, unboxedSumE, condE, multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, - fieldExp, getFieldE, projectionE, + fieldExp, getFieldE, projectionE, typedSpliceE, typedBracketE, -- **** Ranges fromE, fromThenE, fromToE, fromThenToE, @@ -77,9 +77,12 @@ 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 @@ ------------------------------------------------------------------------------- -- * 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 @@ 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 @@ 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 @@ 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 @@ -296,13 +299,28 @@ return $ SigT t' k ------------------------------------------------------------------------------- --- * Kind +-- * Type variable binders -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 + +------------------------------------------------------------------------------- +-- * Kind starK :: Kind starK = StarT diff --git a/Language/Haskell/TH/Lib/Internal.hs b/Language/Haskell/TH/Lib/Internal.hs --- a/Language/Haskell/TH/Lib/Internal.hs +++ b/Language/Haskell/TH/Lib/Internal.hs @@ -79,6 +79,7 @@ type TyVarBndrUnit = TyVarBndr () type TyVarBndrSpec = TyVarBndr Specificity +type TyVarBndrVis = TyVarBndr BndrVis ---------------------------------------------------------- -- * Lowercase pattern syntax functions @@ -380,6 +381,12 @@ projectionE :: Quote m => NonEmpty String -> m Exp projectionE xs = pure (ProjectionE xs) +typedSpliceE :: Quote m => m Exp -> m Exp +typedSpliceE = fmap TypedSpliceE + +typedBracketE :: Quote m => m Exp -> m Exp +typedBracketE = fmap TypedBracketE + -- ** 'arithSeqE' Shortcuts fromE :: Quote m => m Exp -> m Exp fromE x = do { a <- x; pure (ArithSeqE (FromR a)) } @@ -412,14 +419,14 @@ ; 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 +437,7 @@ 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 +448,7 @@ 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 +457,7 @@ 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 +578,20 @@ 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 +886,30 @@ 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 +1110,7 @@ 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 +1124,7 @@ 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 +1138,7 @@ 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 @@ -1191,15 +1210,3 @@ | nm <- get_cons_names c' , (i, Just arg_doc) <- zip [0..] arg_docs ] - where - get_cons_names :: Con -> [Name] - get_cons_names (NormalC n _) = [n] - get_cons_names (RecC n _) = [n] - get_cons_names (InfixC _ n _) = [n] - get_cons_names (ForallC _ _ cons) = get_cons_names cons - -- GadtC can have multiple names, e.g - -- > data Bar a where - -- > MkBar1, MkBar2 :: a -> Bar a - -- Will have one GadtC with [MkBar1, MkBar2] as names - get_cons_names (GadtC ns _ _) = ns - get_cons_names (RecGadtC ns _ _) = ns diff --git a/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs --- a/Language/Haskell/TH/Ppr.hs +++ b/Language/Haskell/TH/Ppr.hs @@ -232,6 +232,8 @@ pprExp _ (ImplicitParamVarE n) = text ('?' : n) pprExp _ (GetFieldE e f) = pprExp appPrec e <> text ('.': f) pprExp _ (ProjectionE xs) = parens $ hcat $ map ((char '.'<>) . text) $ toList xs +pprExp _ (TypedBracketE e) = text "[||" <> ppr e <> text "||]" +pprExp _ (TypedSpliceE e) = text "$$" <> pprExp appPrec e pprFields :: [(Name,Exp)] -> Doc pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e) @@ -300,27 +302,28 @@ pprLit _ (BytesPrimL {}) = pprString "" pprLit i (RationalL rat) | withoutFactor 2 (withoutFactor 5 $ denominator rat) /= 1 - -- if the denominator has prime factors other than 2 and 5, show as fraction + -- if the denominator has prime factors other than 2 and 5 + -- or can't be represented as Double, show as fraction = parensIf (i > noPrec) $ integer (numerator rat) <+> char '/' <+> integer (denominator rat) - | rat /= 0 && (zeroes < -1 || zeroes > 7), - let (n, d) = properFraction (rat' / magnitude) - (rat', zeroes') - | abs rat < 1 = (10 * rat, zeroes - 1) - | otherwise = (rat, zeroes) + | rat /= 0 && (zeroes < -2 || zeroes > 6), + let (n, d) = properFraction (rat / magnitude) -- if < 0.01 or >= 100_000_000, use scientific notation = parensIf (i > noPrec && rat < 0) (integer n <> (if d == 0 then empty else char '.' <> decimals (abs d)) - <> char 'e' <> integer zeroes') + <> char 'e' <> integer zeroes) | let (n, d) = properFraction rat = parensIf (i > noPrec && rat < 0) (integer n <> char '.' <> if d == 0 then char '0' else decimals (abs d)) where zeroes :: Integer - zeroes = truncate (logBase 10 (abs (fromRational rat) :: Double) - * (1 - epsilon)) - epsilon = 0.0000001 + zeroes = log10 (abs rat) + log10 :: Rational -> Integer + log10 x + | x >= 10 = 1 + log10 (x / 10) + | x < 1 = -1 + log10 (x * 10) + | otherwise = 0 magnitude :: Rational magnitude = 10 ^^ zeroes withoutFactor :: Integer -> Integer -> Integer @@ -682,22 +685,22 @@ <+> pprName' Infix c <+> pprBangType st2 - ppr (ForallC ns ctxt (GadtC c sts ty)) - = commaSepApplied c <+> dcolon <+> pprForall ns ctxt + ppr (ForallC ns ctxt (GadtC cs sts ty)) + = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty - ppr (ForallC ns ctxt (RecGadtC c vsts ty)) - = commaSepApplied c <+> dcolon <+> pprForall ns ctxt + ppr (ForallC ns ctxt (RecGadtC cs vsts ty)) + = commaSepApplied cs <+> dcolon <+> pprForall ns ctxt <+> pprRecFields vsts ty ppr (ForallC ns ctxt con) = pprForall ns ctxt <+> ppr con - ppr (GadtC c sts ty) - = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty + ppr (GadtC cs sts ty) + = commaSepApplied cs <+> dcolon <+> pprGadtRHS sts ty - ppr (RecGadtC c vsts ty) - = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty + ppr (RecGadtC cs vsts ty) + = commaSepApplied cs <+> dcolon <+> pprRecFields vsts ty instance Ppr PatSynDir where ppr Unidir = text "<-" @@ -946,6 +949,14 @@ pprTyVarBndr (PlainTV nm InferredSpec) = braces (ppr nm) 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/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs --- a/Language/Haskell/TH/Syntax.hs +++ b/Language/Haskell/TH/Syntax.hs @@ -3,9 +3,12 @@ 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 #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE StandaloneKindSignatures #-} ----------------------------------------------------------------------------- -- | @@ -31,6 +34,7 @@ -- $infix ) where +import qualified Data.Fixed as Fixed import Data.Data hiding (Fixity(..)) import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) @@ -53,7 +57,8 @@ import GHC.CString ( unpackCString# ) import GHC.Generics ( Generic ) import GHC.Types ( Int(..), Word(..), Char(..), Double(..), Float(..), - TYPE, RuntimeRep(..) ) + TYPE, RuntimeRep(..), Multiplicity (..) ) +import qualified Data.Kind as Kind (Type) import GHC.Prim ( Int#, Word#, Char#, Double#, Float#, Addr# ) import GHC.Ptr ( Ptr, plusPtr ) import GHC.Lexeme ( startsVarSym, startsVarId ) @@ -64,7 +69,6 @@ import Foreign.ForeignPtr import Foreign.C.String import Foreign.C.Types -import GHC.Stack #if __GLASGOW_HASKELL__ >= 901 import GHC.Types ( Levity(..) ) @@ -330,43 +334,14 @@ -- ----------------------------------------------------- +type TExp :: TYPE r -> Kind.Type type role TExp nominal -- See Note [Role of TExp] -newtype TExp (a :: TYPE (r :: RuntimeRep)) = TExp +newtype TExp a = TExp { unType :: Exp -- ^ Underlying untyped Template Haskell expression } --- ^ Represents an expression which has type @a@. Built on top of 'Exp', typed --- expressions allow for type-safe splicing via: --- --- - typed quotes, written as @[|| ... ||]@ where @...@ is an expression; if --- that expression has type @a@, then the quotation has type --- @'Q' ('TExp' a)@ --- --- - typed splices inside of typed quotes, written as @$$(...)@ where @...@ --- is an arbitrary expression of type @'Q' ('TExp' a)@ --- --- Traditional expression quotes and splices let us construct ill-typed --- expressions: --- --- >>> fmap ppr $ runQ [| True == $( [| "foo" |] ) |] --- GHC.Types.True GHC.Classes.== "foo" --- >>> GHC.Types.True GHC.Classes.== "foo" --- error: --- • Couldn't match expected type ‘Bool’ with actual type ‘[Char]’ --- • In the second argument of ‘(==)’, namely ‘"foo"’ --- In the expression: True == "foo" --- In an equation for ‘it’: it = True == "foo" --- --- With typed expressions, the type error occurs when /constructing/ the --- Template Haskell expression: +-- ^ Typed wrapper around an 'Exp'. -- --- >>> fmap ppr $ runQ [|| True == $$( [|| "foo" ||] ) ||] --- error: --- • Couldn't match type ‘[Char]’ with ‘Bool’ --- Expected type: Q (TExp Bool) --- Actual type: Q (TExp [Char]) --- • In the Template Haskell quotation [|| "foo" ||] --- In the expression: [|| "foo" ||] --- In the Template Haskell splice $$([|| "foo" ||]) +-- This is the typed representation of terms produced by typed quotes. -- -- Representation-polymorphic since /template-haskell-2.16.0.0/. @@ -394,21 +369,56 @@ TExp's argument must have a nominal role, not phantom as would be inferred (#8459). Consider - e :: TExp Age - e = MkAge 3 + e :: Code Q Age + e = [|| MkAge 3 ||] foo = $(coerce e) + 4::Int The splice will evaluate to (MkAge 3) and you can't add that to -4::Int. So you can't coerce a (TExp Age) to a (TExp Int). -} +4::Int. So you can't coerce a (Code Q Age) to a (Code Q Int). -} -- Code constructor +type Code :: (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type type role Code representational nominal -- See Note [Role of TExp] -newtype Code m (a :: TYPE (r :: RuntimeRep)) = Code +newtype Code m a = Code { examineCode :: m (TExp a) -- ^ Underlying monadic value } +-- ^ Represents an expression which has type @a@, built in monadic context @m@. Built on top of 'TExp', typed +-- expressions allow for type-safe splicing via: +-- +-- - typed quotes, written as @[|| ... ||]@ where @...@ is an expression; if +-- that expression has type @a@, then the quotation has type +-- @Quote m => Code m a@ +-- +-- - typed splices inside of typed quotes, written as @$$(...)@ where @...@ +-- is an arbitrary expression of type @Quote m => Code m a@ +-- +-- Traditional expression quotes and splices let us construct ill-typed +-- expressions: +-- +-- >>> fmap ppr $ runQ (unTypeCode [| True == $( [| "foo" |] ) |]) +-- GHC.Types.True GHC.Classes.== "foo" +-- >>> GHC.Types.True GHC.Classes.== "foo" +-- error: +-- • Couldn't match expected type ‘Bool’ with actual type ‘[Char]’ +-- • In the second argument of ‘(==)’, namely ‘"foo"’ +-- In the expression: True == "foo" +-- In an equation for ‘it’: it = True == "foo" +-- +-- With typed expressions, the type error occurs when /constructing/ the +-- Template Haskell expression: +-- +-- >>> fmap ppr $ runQ (unTypeCode [|| True == $$( [|| "foo" ||] ) ||]) +-- error: +-- • Couldn't match type ‘[Char]’ with ‘Bool’ +-- Expected type: Code Q Bool +-- Actual type: Code Q [Char] +-- • In the Template Haskell quotation [|| "foo" ||] +-- In the expression: [|| "foo" ||] +-- In the Template Haskell splice $$([|| "foo" ||]) + -- | Unsafely convert an untyped code representation into a typed code -- representation. unsafeCodeCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m . @@ -957,7 +967,7 @@ -- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@ or -- @[|| ... ||]@) but not at the top level. As an example: -- --- > add1 :: Int -> Q (TExp Int) +-- > add1 :: Int -> Code Q Int -- > add1 x = [|| x + 1 ||] -- -- Template Haskell has no way of knowing what value @x@ will take on at @@ -965,7 +975,7 @@ -- -- A 'Lift' instance must satisfy @$(lift x) ≡ x@ and @$$(liftTyped x) ≡ x@ -- for all @x@, where @$(...)@ and @$$(...)@ are Template Haskell splices. --- It is additionally expected that @'lift' x ≡ 'unTypeQ' ('liftTyped' x)@. +-- It is additionally expected that @'lift' x ≡ 'unTypeCode' ('liftTyped' x)@. -- -- 'Lift' instances can be derived automatically by use of the @-XDeriveLift@ -- GHC language extension: @@ -1056,6 +1066,14 @@ liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (IntegerL (fromIntegral x))) +instance Lift (Fixed.Fixed a) where + liftTyped x = unsafeCodeCoerce (lift x) + lift (Fixed.MkFixed x) = do + ex <- lift x + return (ConE mkFixedName `AppE` ex) + where + mkFixedName = 'Fixed.MkFixed + instance Integral a => Lift (Ratio a) where liftTyped x = unsafeCodeCoerce (lift x) lift x = return (LitE (RationalL (toRational x))) @@ -1125,19 +1143,8 @@ ptr :: ForeignPtr Word8 ptr = ForeignPtr (byteArrayContents# pb) (PlainPtr (unsafeCoerce# pb)) - --- We can't use a TH quote in this module because we're in the template-haskell --- package, so we conconct this quite defensive solution to make the correct name --- which will work if the package name or module name changes in future. addrToByteArrayName :: Name -addrToByteArrayName = helper - where - helper :: HasCallStack => Name - helper = - case getCallStack ?callStack of - [] -> error "addrToByteArrayName: empty call stack" - (_, SrcLoc{..}) : _ -> mkNameG_v srcLocPackage srcLocModule "addrToByteArray" - +addrToByteArrayName = 'addrToByteArray addrToByteArray :: Int -> Addr# -> ByteArray addrToByteArray (I# len) addr = runST $ ST $ @@ -1357,23 +1364,24 @@ trueName, falseName :: Name -trueName = mkNameG DataName "ghc-prim" "GHC.Types" "True" -falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False" +trueName = 'True +falseName = 'False nothingName, justName :: Name -nothingName = mkNameG DataName "base" "GHC.Maybe" "Nothing" -justName = mkNameG DataName "base" "GHC.Maybe" "Just" +nothingName = 'Nothing +justName = 'Just leftName, rightName :: Name -leftName = mkNameG DataName "base" "Data.Either" "Left" -rightName = mkNameG DataName "base" "Data.Either" "Right" +leftName = 'Left +rightName = 'Right nonemptyName :: Name -nonemptyName = mkNameG DataName "base" "GHC.Base" ":|" +nonemptyName = '(:|) oneName, manyName :: Name -oneName = mkNameG DataName "ghc-prim" "GHC.Types" "One" -manyName = mkNameG DataName "ghc-prim" "GHC.Types" "Many" +oneName = 'One +manyName = 'Many + ----------------------------------------------------- -- -- Generic Lift implementations @@ -1488,8 +1496,9 @@ -- See #10796. varOrConE s = case nameSpace s of - Just VarName -> return (VarE s) - Just DataName -> return (ConE s) + Just VarName -> return (VarE s) + Just (FldName {}) -> return (VarE s) + Just DataName -> return (ConE s) _ -> error $ "Can't construct an expression from name " ++ showName s appE x y = do { a <- x; b <- y; return (AppE a b)} @@ -1665,6 +1674,14 @@ | DataName -- ^ Data constructors | TcClsName -- ^ Type constructors and classes; Haskell has them -- in the same name space for now. + | FldName + { fldParent :: !String + -- ^ The textual name of the parent of the field. + -- + -- - For a field of a datatype, this is the name of the first constructor + -- of the datatype (regardless of whether this constructor has this field). + -- - For a field of a pattern synonym, this is the name of the pattern synonym. + } deriving( Eq, Ord, Show, Data, Generic ) -- | @Uniq@ is used by GHC to distinguish names from each other. @@ -1824,6 +1841,13 @@ mkNameG_tc = mkNameG TcClsName mkNameG_d = mkNameG DataName +mkNameG_fld :: String -- ^ package + -> String -- ^ module + -> String -- ^ parent (first constructor of parent type) + -> String -- ^ field name + -> Name +mkNameG_fld pkg modu con occ = mkNameG (FldName con) pkg modu occ + data NameIs = Alone | Applied | Infix showName :: Name -> String @@ -1847,11 +1871,11 @@ -- We may well want to distinguish them in the end. -- Ditto NameU and NameL nms = case nm of - Name occ NameS -> occString occ - Name occ (NameQ m) -> modString m ++ "." ++ occString occ - Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ - Name occ (NameU u) -> occString occ ++ "_" ++ show u - Name occ (NameL u) -> occString occ ++ "_" ++ show u + Name occ NameS -> occString occ + Name occ (NameQ m) -> modString m ++ "." ++ occString occ + Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ + Name occ (NameU u) -> occString occ ++ "_" ++ show u + Name occ (NameL u) -> occString occ ++ "_" ++ show u pnam = classify nms @@ -2359,6 +2383,8 @@ | ImplicitParamVarE String -- ^ @{ ?x }@ ( Implicit parameter ) | GetFieldE Exp String -- ^ @{ exp.field }@ ( Overloaded Record Dot ) | ProjectionE (NonEmpty String) -- ^ @(.x)@ or @(.x.y)@ (Record projections) + | TypedBracketE Exp -- ^ @[|| e ||]@ + | TypedSpliceE Exp -- ^ @$$e@ deriving( Show, Eq, Ord, Data, Generic ) type FieldExp = (Name,Exp) @@ -2392,22 +2418,22 @@ 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 +2450,7 @@ | 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 +2574,7 @@ -- @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 @@ -2658,7 +2684,7 @@ | DecidedUnpack -- ^ Field inferred to be unpacked. deriving (Show, Eq, Ord, Data, Generic) --- | A single data constructor. +-- | A data constructor. -- -- The constructors for 'Con' can roughly be divided up into two categories: -- those for constructors with \"vanilla\" syntax ('NormalC', 'RecC', and @@ -2691,16 +2717,36 @@ -- Multiplicity annotations for data types are currently not supported -- in Template Haskell (i.e. all fields represented by Template Haskell -- will be linear). -data Con = NormalC Name [BangType] -- ^ @C Int a@ - | RecC Name [VarBangType] -- ^ @C { v :: Int, w :: a }@ - | InfixC BangType Name BangType -- ^ @Int :+ a@ - | ForallC [TyVarBndr Specificity] Cxt Con -- ^ @forall a. Eq a => C [a]@ - | GadtC [Name] [BangType] - Type -- See Note [GADT return type] - -- ^ @C :: a -> b -> T b Int@ - | RecGadtC [Name] [VarBangType] - Type -- See Note [GADT return type] - -- ^ @C :: { v :: Int } -> T b Int@ +data Con = + -- | @C Int a@ + NormalC Name [BangType] + + -- | @C { v :: Int, w :: a }@ + | RecC Name [VarBangType] + + -- | @Int :+ a@ + | InfixC BangType Name BangType + + -- | @forall a. Eq a => C [a]@ + | ForallC [TyVarBndr Specificity] Cxt Con + + -- @C :: a -> b -> T b Int@ + | GadtC [Name] + -- ^ The list of constructors, corresponding to the GADT constructor + -- syntax @C1, C2 :: a -> T b@. + -- + -- Invariant: the list must be non-empty. + [BangType] -- ^ The constructor arguments + Type -- ^ See Note [GADT return type] + + -- | @C :: { v :: Int } -> T b Int@ + | RecGadtC [Name] + -- ^ The list of constructors, corresponding to the GADT record + -- constructor syntax @C1, C2 :: { fld :: a } -> T b@. + -- + -- Invariant: the list must be non-empty. + [VarBangType] -- ^ The constructor arguments + Type -- ^ See Note [GADT return type] deriving (Show, Eq, Ord, Data, Generic) -- Note [GADT return type] @@ -2804,10 +2850,20 @@ | 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 | KindSig Kind -- ^ @k@ @@ -2897,3 +2953,15 @@ thenCmp :: Ordering -> Ordering -> Ordering thenCmp EQ o2 = o2 thenCmp o1 _ = o1 + +get_cons_names :: Con -> [Name] +get_cons_names (NormalC n _) = [n] +get_cons_names (RecC n _) = [n] +get_cons_names (InfixC _ n _) = [n] +get_cons_names (ForallC _ _ con) = get_cons_names con +-- GadtC can have multiple names, e.g +-- > data Bar a where +-- > MkBar1, MkBar2 :: a -> Bar a +-- Will have one GadtC with [MkBar1, MkBar2] as names +get_cons_names (GadtC ns _ _) = ns +get_cons_names (RecGadtC ns _ _) = ns diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,26 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) +## 2.21.0.0 + + * Shipped with GHC 9.8.1 + + * Record fields now belong to separate `NameSpace`s, keyed by the parent of + the record field. This is the name of the first constructor of the parent type, + even if this constructor does not have the field in question. + + This change enables TemplateHaskell support for `DuplicateRecordFields`. + + * Add support for generating typed splices and brackets in untyped Template Haskell + Introduces `typedSpliceE :: Quote m => m Exp -> m Exp` and + `typedBracketE :: Quote m => m Exp -> m Exp` + + * Add `BndrVis` to support invisible binders + in type declarations (GHC Proposal #425). + + * The binder flag type in `plainTV` and `kindedTV` is generalized from `()` + to any data type with a `DefaultBndrFlag` instance, including `()`, + `Specificity`, and `BndrVis`. + ## 2.20.0.0 * The `Ppr.pprInfixT` function has gained a `Precedence` argument. @@ -7,6 +28,7 @@ * Add `TypeDataD` constructor to the `Dec` type for `type data` declarations (GHC proposal #106). + * Add `instance Lift (Fixed a)` ## 2.19.0.0 diff --git a/template-haskell.cabal b/template-haskell.cabal --- a/template-haskell.cabal +++ b/template-haskell.cabal @@ -3,7 +3,7 @@ -- template-haskell.cabal. name: template-haskell -version: 2.20.0.0 +version: 2.21.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -55,8 +55,8 @@ Language.Haskell.TH.Lib.Map build-depends: - base >= 4.11 && < 4.19, - ghc-boot-th == 9.6.1, + base >= 4.11 && < 4.20, + ghc-boot-th == 9.8.1, ghc-prim, pretty == 1.1.*