diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs --- a/Language/Haskell/TH.hs +++ b/Language/Haskell/TH.hs @@ -80,7 +80,8 @@ Bang(..), Strict, Foreign(..), Callconv(..), Safety(..), Pragma(..), Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..), FunDep(..), TySynEqn(..), TypeFamilyHead(..), - Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, + Fixity(..), FixityDirection(..), NamespaceSpecifier(..), defaultFixity, + maxPrecedence, PatSynDir(..), PatSynArgs(..), -- ** Expressions Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..), 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 @@ -33,7 +33,7 @@ -- *** Patterns litP, varP, tupP, unboxedTupP, unboxedSumP, conP, uInfixP, parensP, infixP, tildeP, bangP, asP, wildP, recP, - listP, sigP, viewP, + listP, sigP, viewP, typeP, invisP, fieldPat, -- *** Pattern Guards @@ -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, typedSpliceE, typedBracketE, + fieldExp, getFieldE, projectionE, typedSpliceE, typedBracketE, typeE, -- **** Ranges fromE, fromThenE, fromToE, fromThenToE, 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 @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE Trustworthy #-} @@ -160,11 +161,18 @@ sigP p t = do p' <- p t' <- t pure (SigP p' t') +typeP :: Quote m => m Type -> m Pat +typeP t = do t' <- t + pure (TypeP t') +invisP :: Quote m => m Type -> m Pat +invisP t = do t' <- t + pure (InvisP t') viewP :: Quote m => m Exp -> m Pat -> m Pat viewP e p = do e' <- e p' <- p pure (ViewP e' p') + fieldPat :: Quote m => Name -> m Pat -> m FieldPat fieldPat n p = do p' <- p pure (n, p') @@ -246,11 +254,10 @@ ds' <- sequenceA ds; pure (Clause ps' r' ds') } - --------------------------------------------------------------------------- -- * Exp --- | Dynamically binding a variable (unhygenic) +-- | Dynamically binding a variable (unhygienic) dyn :: Quote m => String -> m Exp dyn s = pure (VarE (mkName s)) @@ -401,6 +408,8 @@ fromThenToE x y z = do { a <- x; b <- y; c <- z; pure (ArithSeqE (FromThenToR a b c)) } +typeE :: Quote m => m Type -> m Exp +typeE = fmap TypeE ------------------------------------------------------------------------------- -- * Dec @@ -490,14 +499,23 @@ pure $ ForeignD (ImportF cc s str n ty') infixLD :: Quote m => Int -> Name -> m Dec -infixLD prec nm = pure (InfixD (Fixity prec InfixL) nm) +infixLD prec = infixLWithSpecD prec NoNamespaceSpecifier infixRD :: Quote m => Int -> Name -> m Dec -infixRD prec nm = pure (InfixD (Fixity prec InfixR) nm) +infixRD prec = infixRWithSpecD prec NoNamespaceSpecifier infixND :: Quote m => Int -> Name -> m Dec -infixND prec nm = pure (InfixD (Fixity prec InfixN) nm) +infixND prec = infixNWithSpecD prec NoNamespaceSpecifier +infixLWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec +infixLWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixL) ns_spec nm) + +infixRWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec +infixRWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixR) ns_spec nm) + +infixNWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec +infixNWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixN) ns_spec nm) + defaultD :: Quote m => [m Type] -> m Dec defaultD tys = DefaultD <$> sequenceA tys @@ -548,6 +566,12 @@ pragCompleteD :: Quote m => [Name] -> Maybe Name -> m Dec pragCompleteD cls mty = pure $ PragmaD $ CompleteP cls mty +pragSCCFunD :: Quote m => Name -> m Dec +pragSCCFunD nm = pure $ PragmaD $ SCCP nm Nothing + +pragSCCFunNamedD :: Quote m => Name -> String -> m Dec +pragSCCFunNamedD nm str = pure $ PragmaD $ SCCP nm (Just str) + dataInstD :: Quote m => m Cxt -> (Maybe [m (TyVarBndr ())]) -> m Type -> Maybe (m Kind) -> [m Con] -> [m DerivClause] -> m Dec dataInstD ctxt mb_bndrs ty ksig cons derivs = @@ -1067,7 +1091,7 @@ doc_loc (SigD n _) = Just $ DeclDoc n doc_loc (ForeignD (ImportF _ _ _ n _)) = Just $ DeclDoc n doc_loc (ForeignD (ExportF _ _ n _)) = Just $ DeclDoc n - doc_loc (InfixD _ n) = Just $ DeclDoc n + doc_loc (InfixD _ _ n) = Just $ DeclDoc n doc_loc (DataFamilyD n _ _) = Just $ DeclDoc n doc_loc (OpenTypeFamilyD (TypeFamilyHead n _ _ _)) = Just $ DeclDoc n doc_loc (ClosedTypeFamilyD (TypeFamilyHead n _ _ _) _) = Just $ DeclDoc n 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 @@ -14,7 +14,7 @@ import Data.Word ( Word8 ) import Data.Char ( toLower, chr) import GHC.Show ( showMultiLineString ) -import GHC.Lexeme( startsVarSym ) +import GHC.Lexeme( isVarSymChar ) import Data.Ratio ( numerator, denominator ) import Data.Foldable ( toList ) import Prelude hiding ((<>)) @@ -77,13 +77,19 @@ ppr_sig :: Name -> Type -> Doc ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty -pprFixity :: Name -> Fixity -> Doc -pprFixity _ f | f == defaultFixity = empty -pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> pprName' Infix v +pprFixity :: Name -> Fixity -> NamespaceSpecifier -> Doc +pprFixity _ f _ | f == defaultFixity = empty +pprFixity v (Fixity i d) ns_spec + = ppr_fix d <+> int i <+> pprNamespaceSpecifier ns_spec <+> pprName' Infix v where ppr_fix InfixR = text "infixr" ppr_fix InfixL = text "infixl" ppr_fix InfixN = text "infix" +pprNamespaceSpecifier :: NamespaceSpecifier -> Doc +pprNamespaceSpecifier NoNamespaceSpecifier = empty +pprNamespaceSpecifier TypeNamespaceSpecifier = text "type" +pprNamespaceSpecifier DataNamespaceSpecifier = text "data" + -- | Pretty prints a pattern synonym type signature pprPatSynSig :: Name -> PatSynType -> Doc pprPatSynSig nm ty @@ -122,8 +128,8 @@ isSymOcc n = case nameBase n of [] -> True -- Empty name; weird - (c:_) -> startsVarSym c - -- c.f. OccName.startsVarSym in GHC itself + (c:_) -> isVarSymChar c + -- c.f. isVarSymChar in GHC itself pprInfixExp :: Exp -> Doc pprInfixExp (VarE v) = pprName' Infix v @@ -234,6 +240,7 @@ pprExp _ (ProjectionE xs) = parens $ hcat $ map ((char '.'<>) . text) $ toList xs pprExp _ (TypedBracketE e) = text "[||" <> ppr e <> text "||]" pprExp _ (TypedSpliceE e) = text "$$" <> pprExp appPrec e +pprExp i (TypeE t) = parensIf (i > noPrec) $ text "type" <+> ppr t pprFields :: [(Name,Exp)] -> Doc pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e) @@ -385,27 +392,32 @@ pprPat _ (ListP ps) = brackets (commaSep ps) pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p +pprPat _ (TypeP t) = parens $ text "type" <+> ppr t +pprPat _ (InvisP t) = parens $ text "@" <+> ppr t ------------------------------ instance Ppr Dec where ppr = ppr_dec True -ppr_dec :: Bool -- declaration on the toplevel? +ppr_dec :: Bool -- ^ declaration on the toplevel? -> Dec -> Doc -ppr_dec _ (FunD f cs) = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs +ppr_dec isTop (FunD f cs) = layout $ map (\c -> pprPrefixOcc f <+> ppr c) cs + where + layout :: [Doc] -> Doc + layout = if isTop then vcat else semiSepWith id ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r $$ where_clause ds ppr_dec _ (TySynD t xs rhs) = ppr_tySyn empty (Just t) (hsep (map ppr xs)) rhs -ppr_dec _ (DataD ctxt t xs ksig cs decs) - = ppr_data empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs -ppr_dec _ (NewtypeD ctxt t xs ksig c decs) - = ppr_newtype empty ctxt (Just t) (sep (map ppr xs)) ksig c decs -ppr_dec _ (TypeDataD t xs ksig cs) - = ppr_type_data empty [] (Just t) (hsep (map ppr xs)) ksig cs [] +ppr_dec isTop (DataD ctxt t xs ksig cs decs) + = ppr_data isTop empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs +ppr_dec isTop (NewtypeD ctxt t xs ksig c decs) + = ppr_newtype isTop empty ctxt (Just t) (sep (map ppr xs)) ksig c decs +ppr_dec isTop (TypeDataD t xs ksig cs) + = ppr_type_data isTop empty [] (Just t) (hsep (map ppr xs)) ksig cs [] ppr_dec _ (ClassD ctxt c xs fds ds) - = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds + = text "class" <+> pprCxt ctxt <+> pprName' Applied c <+> hsep (map ppr xs) <+> ppr fds $$ where_clause ds ppr_dec _ (InstanceD o ctxt i ds) = text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i @@ -413,25 +425,25 @@ ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t ppr_dec _ (KiSigD f k) = text "type" <+> pprPrefixOcc f <+> dcolon <+> ppr k ppr_dec _ (ForeignD f) = ppr f -ppr_dec _ (InfixD fx n) = pprFixity n fx +ppr_dec _ (InfixD fx ns_spec n) = pprFixity n fx ns_spec ppr_dec _ (DefaultD tys) = text "default" <+> parens (sep $ punctuate comma $ map ppr tys) ppr_dec _ (PragmaD p) = ppr p ppr_dec isTop (DataFamilyD tc tvs kind) - = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind + = text "data" <+> maybeFamily <+> pprName' Applied tc <+> hsep (map ppr tvs) <+> maybeKind where maybeFamily | isTop = text "family" | otherwise = empty maybeKind | (Just k') <- kind = dcolon <+> ppr k' | otherwise = empty ppr_dec isTop (DataInstD ctxt bndrs ty ksig cs decs) - = ppr_data (maybeInst <+> ppr_bndrs bndrs) + = ppr_data isTop (maybeInst <+> ppr_bndrs bndrs) ctxt Nothing (ppr ty) ksig cs decs where maybeInst | isTop = text "instance" | otherwise = empty ppr_dec isTop (NewtypeInstD ctxt bndrs ty ksig c decs) - = ppr_newtype (maybeInst <+> ppr_bndrs bndrs) + = ppr_newtype isTop (maybeInst <+> ppr_bndrs bndrs) ctxt Nothing (ppr ty) ksig c decs where maybeInst | isTop = text "instance" @@ -454,7 +466,7 @@ ppr_eqn (TySynEqn mb_bndrs lhs rhs) = ppr_bndrs mb_bndrs <+> ppr lhs <+> text "=" <+> ppr rhs ppr_dec _ (RoleAnnotD name roles) - = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles) + = hsep [ text "type role", pprName' Applied name ] <+> hsep (map ppr roles) ppr_dec _ (StandaloneDerivD ds cxt ty) = hsep [ text "deriving" , maybe empty ppr_deriv_strategy ds @@ -469,7 +481,8 @@ pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> pprName' Infix name <+> ppr a2 | otherwise = pprName' Applied name <+> ppr args pprPatRHS | ExplBidir cls <- dir = hang (ppr pat <+> text "where") - nestDepth (pprName' Applied name <+> ppr cls) + nestDepth + (vcat $ (pprName' Applied name <+>) . ppr <$> cls) | otherwise = ppr pat ppr_dec _ (PatSynSigD name ty) = pprPatSynSig name ty @@ -492,27 +505,31 @@ Overlapping -> "{-# OVERLAPPING #-}" Incoherent -> "{-# INCOHERENT #-}" -ppr_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] +ppr_data :: Bool -- ^ declaration on the toplevel? + -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc ppr_data = ppr_typedef "data" -ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause] +ppr_newtype :: Bool -- ^ declaration on the toplevel? + -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause] -> Doc -ppr_newtype maybeInst ctxt t argsDoc ksig c decs = ppr_typedef "newtype" maybeInst ctxt t argsDoc ksig [c] decs +ppr_newtype isTop maybeInst ctxt t argsDoc ksig c decs + = ppr_typedef "newtype" isTop maybeInst ctxt t argsDoc ksig [c] decs -ppr_type_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] - -> Doc +ppr_type_data :: Bool -- ^ declaration on the toplevel? + -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] + -> Doc ppr_type_data = ppr_typedef "type data" -ppr_typedef :: String -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc -ppr_typedef data_or_newtype maybeInst ctxt t argsDoc ksig cs decs +ppr_typedef :: String -> Bool -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc +ppr_typedef data_or_newtype isTop maybeInst ctxt t argsDoc ksig cs decs = sep [text data_or_newtype <+> maybeInst <+> pprCxt ctxt <+> case t of Just n -> pprName' Applied n <+> argsDoc Nothing -> argsDoc <+> ksigDoc <+> maybeWhere, - nest nestDepth (vcat (pref $ map ppr cs)), + nest nestDepth (layout (pref $ map ppr cs)), if null decs then empty else nest nestDepth @@ -523,6 +540,10 @@ pref [] = [] -- No constructors; can't happen in H98 pref (d:ds) = (char '=' <+> d):map (bar <+>) ds + layout :: [Doc] -> Doc + layout | isGadtDecl && not isTop = braces . semiSepWith id + | otherwise = vcat + maybeWhere :: Doc maybeWhere | isGadtDecl = text "where" | otherwise = empty @@ -542,7 +563,7 @@ ppr_deriv_clause :: DerivClause -> Doc ppr_deriv_clause (DerivClause ds ctxt) = text "deriving" <+> pp_strat_before - <+> ppr_cxt_preds ctxt + <+> ppr_cxt_preds appPrec ctxt <+> pp_strat_after where -- @via@ is unique in that in comes /after/ the class being derived, @@ -647,6 +668,8 @@ ppr (CompleteP cls mty) = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map (pprName' Applied) cls) <+> maybe empty (\ty -> dcolon <+> pprName' Applied ty) mty <+> text "#-}" + ppr (SCCP nm str) + = text "{-# SCC" <+> pprName' Applied nm <+> maybe empty pprString str <+> text "#-}" ------------------------------ instance Ppr Inline where @@ -861,11 +884,11 @@ instance Ppr Type where ppr = pprType noPrec instance Ppr TypeArg where - ppr (TANormal ty) = parensIf (isStarT ty) (ppr ty) + ppr (TANormal ty) = ppr ty ppr (TyArg ki) = char '@' <> parensIf (isStarT ki) (ppr ki) pprParendTypeArg :: TypeArg -> Doc -pprParendTypeArg (TANormal ty) = parensIf (isStarT ty) (pprParendType ty) +pprParendTypeArg (TANormal ty) = pprParendType ty pprParendTypeArg (TyArg ki) = char '@' <> parensIf (isStarT ki) (pprParendType ki) isStarT :: Type -> Bool @@ -970,14 +993,12 @@ ------------------------------ pprCxt :: Cxt -> Doc pprCxt [] = empty -pprCxt ts = ppr_cxt_preds ts <+> text "=>" +pprCxt ts = ppr_cxt_preds funPrec ts <+> text "=>" -ppr_cxt_preds :: Cxt -> Doc -ppr_cxt_preds [] = empty -ppr_cxt_preds [t@ImplicitParamT{}] = parens (ppr t) -ppr_cxt_preds [t@ForallT{}] = parens (ppr t) -ppr_cxt_preds [t] = ppr t -ppr_cxt_preds ts = parens (commaSep ts) +ppr_cxt_preds :: Precedence -> Cxt -> Doc +ppr_cxt_preds _ [] = text "()" +ppr_cxt_preds p [t] = pprType p t +ppr_cxt_preds _ ts = parens (commaSep ts) ------------------------------ instance Ppr Range where 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 @@ -57,7 +57,7 @@ import GHC.CString ( unpackCString# ) import GHC.Generics ( Generic ) import GHC.Types ( Int(..), Word(..), Char(..), Double(..), Float(..), - TYPE, RuntimeRep(..), Multiplicity (..) ) + TYPE, RuntimeRep(..), Levity(..), Multiplicity (..) ) import qualified Data.Kind as Kind (Type) import GHC.Prim ( Int#, Word#, Char#, Double#, Float#, Addr# ) import GHC.Ptr ( Ptr, plusPtr ) @@ -70,11 +70,6 @@ import Foreign.C.String import Foreign.C.Types -#if __GLASGOW_HASKELL__ >= 901 -import GHC.Types ( Levity(..) ) -#endif - -#if __GLASGOW_HASKELL__ >= 903 import Data.Array.Byte (ByteArray(..)) import GHC.Exts ( ByteArray#, unsafeFreezeByteArray#, copyAddrToByteArray#, newByteArray# @@ -82,7 +77,6 @@ , copyByteArray#, newPinnedByteArray#) import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..)) import GHC.ST (ST(..), runST) -#endif ----------------------------------------------------- -- @@ -378,8 +372,12 @@ 4::Int. So you can't coerce a (Code Q Age) to a (Code Q Int). -} -- Code constructor - +#if __GLASGOW_HASKELL__ >= 909 +type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type + -- See Note [Foralls to the right in Code] +#else type Code :: (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type +#endif type role Code representational nominal -- See Note [Role of TExp] newtype Code m a = Code { examineCode :: m (TExp a) -- ^ Underlying monadic value @@ -419,6 +417,23 @@ -- In the Template Haskell splice $$([|| "foo" ||]) +{- Note [Foralls to the right in Code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Code has the following type signature: + type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type + +This allows us to write + data T (f :: forall r . (TYPE r) -> Type) = MkT (f Int) (f Int#) + + tcodeq :: T (Code Q) + tcodeq = MkT [||5||] [||5#||] + +If we used the slightly more straightforward signature + type Code :: foral r. (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type + +then the example above would become ill-typed. (See #23592 for some discussion.) +-} + -- | Unsafely convert an untyped code representation into a typed code -- representation. unsafeCodeCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m . @@ -666,7 +681,7 @@ @B@ themselves implement 'Eq' - @reifyInstances ''Show [ 'VarT' ('mkName' "a") ]@ produces every available - instance of 'Eq' + instance of 'Show' There is one edge case: @reifyInstances ''Typeable tys@ currently always produces an empty list (no matter what @tys@ are given). @@ -768,7 +783,7 @@ -- assumption from splices that they will be executed in the directory where the -- cabal file resides. Projects such as haskell-language-server can't and don't -- change directory when compiling files but instead set the -package-root flag --- appropiately. +-- appropriately. getPackageRoot :: Q FilePath getPackageRoot = Q qGetPackageRoot @@ -908,7 +923,7 @@ putDoc :: DocLoc -> String -> Q () putDoc t s = Q (qPutDoc t s) --- | Retreives the Haddock documentation at the specified location, if one +-- | Retrieves the Haddock documentation at the specified location, if one -- exists. -- It can be used to read documentation on things defined outside of the current -- module, provided that those modules were compiled with the @-haddock@ flag. @@ -993,11 +1008,7 @@ -- | Turn a value into a Template Haskell expression, suitable for use in -- a splice. lift :: Quote m => t -> m Exp -#if __GLASGOW_HASKELL__ >= 901 default lift :: (r ~ ('BoxedRep 'Lifted), Quote m) => t -> m Exp -#else - default lift :: (r ~ 'LiftedRep, Quote m) => t -> m Exp -#endif lift = unTypeCode . liftTyped -- | Turn a value into a Template Haskell typed expression, suitable for use @@ -1120,8 +1131,6 @@ lift x = return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x)))) -#if __GLASGOW_HASKELL__ >= 903 - -- | -- @since 2.19.0.0 instance Lift ByteArray where @@ -1153,8 +1162,6 @@ s'' -> case unsafeFreezeByteArray# mb s'' of (# s''', ret #) -> (# s''', ByteArray ret #) -#endif - instance Lift a => Lift (Maybe a) where liftTyped x = unsafeCodeCoerce (lift x) @@ -1424,7 +1431,7 @@ con@('(':_) -> Name (mkOccName con) (NameG DataName (mkPkgName "ghc-prim") - (mkModName "GHC.Tuple.Prim")) + (mkModName "GHC.Tuple")) -- Tricky case: see Note [Data for non-algebraic types] fun@(x:_) | startsVarSym x || startsVarId x @@ -1916,14 +1923,20 @@ withParens thing | boxed = "(" ++ thing ++ ")" | otherwise = "(#" ++ thing ++ "#)" - tup_occ | n == 1 = if boxed then solo else "Solo#" + tup_occ | n == 0, space == TcClsName = if boxed then "Unit" else "Unit#" + | n == 1 = if boxed then solo else unboxed_solo + | space == TcClsName = "Tuple" ++ show n ++ if boxed then "" else "#" | otherwise = withParens (replicate n_commas ',') n_commas = n - 1 - tup_mod = mkModName "GHC.Tuple.Prim" + tup_mod = mkModName (if boxed then "GHC.Tuple" else "GHC.Types") solo | space == DataName = "MkSolo" | otherwise = "Solo" + unboxed_solo + | space == DataName = "(# #)" + | otherwise = "Solo#" + -- Unboxed sum data and type constructors -- | Unboxed sum data constructor unboxedSumDataName :: SumAlt -> SumArity -> Name @@ -1942,7 +1955,7 @@ | otherwise = Name (mkOccName sum_occ) - (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) + (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Types")) where prefix = "unboxedSumDataName: " @@ -1961,11 +1974,11 @@ | otherwise = Name (mkOccName sum_occ) - (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim")) + (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Types")) where -- Synced with the definition of mkSumTyConOcc in GHC.Builtin.Types - sum_occ = '(' : '#' : replicate (arity - 1) '|' ++ "#)" + sum_occ = "Sum" ++ show arity ++ "#" ----------------------------------------------------- -- Locations @@ -2286,6 +2299,8 @@ | ListP [ Pat ] -- ^ @{ [1,2,3] }@ | SigP Pat Type -- ^ @{ p :: t }@ | ViewP Exp Pat -- ^ @{ e -> p }@ + | TypeP Type -- ^ @{ type p }@ + | InvisP Type -- ^ @{ @p }@ deriving( Show, Eq, Ord, Data, Generic ) type FieldPat = (Name,Pat) @@ -2385,6 +2400,7 @@ | ProjectionE (NonEmpty String) -- ^ @(.x)@ or @(.x.y)@ (Record projections) | TypedBracketE Exp -- ^ @[|| e ||]@ | TypedSpliceE Exp -- ^ @$$e@ + | TypeE Type -- ^ @{ type t }@ deriving( Show, Eq, Ord, Data, Generic ) type FieldExp = (Name,Exp) @@ -2443,7 +2459,8 @@ | ForeignD Foreign -- ^ @{ foreign import ... } --{ foreign export ... }@ - | InfixD Fixity Name -- ^ @{ infix 3 foo }@ + | InfixD Fixity NamespaceSpecifier Name + -- ^ @{ infix 3 data foo }@ | DefaultD [Type] -- ^ @{ default (Integer, Double) }@ -- | pragmas @@ -2500,6 +2517,18 @@ -- and where clauses which consist entirely of implicit bindings. deriving( Show, Eq, Ord, Data, Generic ) +-- | A way to specify a namespace to look in when GHC needs to find +-- a name's source +data NamespaceSpecifier + = NoNamespaceSpecifier -- ^ Name may be everything; If there are two + -- names in different namespaces, then consider both + | TypeNamespaceSpecifier -- ^ Name should be a type-level entity, such as a + -- data type, type alias, type family, type class, + -- or type variable + | DataNamespaceSpecifier -- ^ Name should be a term-level entity, such as a + -- function, data constructor, or pattern synonym + deriving( Show, Eq, Ord, Data, Generic ) + -- | Varieties of allowed instance overlap. data Overlap = Overlappable -- ^ May be overlapped by more specific instances | Overlapping -- ^ May overlap a more general instance @@ -2620,6 +2649,8 @@ | LineP Int String | CompleteP [Name] (Maybe Name) -- ^ @{ {\-\# COMPLETE C_1, ..., C_i [ :: T ] \#-} }@ + | SCCP Name (Maybe String) + -- ^ @{ {\-\# SCC fun "optional_name" \#-} }@ deriving( Show, Eq, Ord, Data, Generic ) data Inline = NoInline diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,12 +1,30 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) -## 2.21.0.0 +## 2.22.0.0 - * Shipped with GHC 9.8.1 + * The kind of `Code` was changed from `forall r. (Type -> Type) -> TYPE r -> Type` + to `(Type -> Type) -> forall r. TYPE r -> Type`. This enables higher-kinded usage. + * Extend `Pat` with `TypeP` and `Exp` with `TypeE`, + introduce functions `typeP` and `typeE` (GHC Proposal #281). + + * Extend `Pragma` with `SCCP`. + + * Extend `Pat` with `InvisP`, introduce function `invisP`. (Ghc Proposal #448). + + * Add a new data type `NamespaceSpecifier` to represent `type`/`data` namespace specifiers, + which can be used in conjunction with the `ExplicitNamespaces` extension: + + * The `InfixD` constructor of the `Dec` data type now stores a `NamespaceSpecifier`. + + * Add `infixLWithSpecD`, `infixRWithSpecD` and `infixNWithSpecD` functions, which + accept a `NamespaceSpecifier` as an argument. + +## 2.21.0.0 + * 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. + even if this constructor does not have the field in question. This change enables TemplateHaskell support for `DuplicateRecordFields`. @@ -23,7 +41,7 @@ ## 2.20.0.0 - * The `Ppr.pprInfixT` function has gained a `Precedence` argument. + * The `Ppr.pprInfixT` function has gained a `Precedence` argument. * The values of named precedence levels like `Ppr.appPrec` have changed. * Add `TypeDataD` constructor to the `Dec` type for `type data` 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.21.0.0 +version: 2.22.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.20, - ghc-boot-th == 9.8.1, + base >= 4.11 && < 4.21, + ghc-boot-th == 9.10.1, ghc-prim, pretty == 1.1.*