diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs --- a/Language/Haskell/TH.hs +++ b/Language/Haskell/TH.hs @@ -1,7 +1,7 @@ {- | The public face of Template Haskell For other documentation, refer to: - + -} {-# LANGUAGE Safe #-} 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 @@ -86,7 +86,7 @@ -- *** Top Level Declarations -- **** Data - valD, funD, tySynD, dataD, newtypeD, + valD, funD, tySynD, dataD, newtypeD, typeDataD, derivClause, DerivClause(..), stockStrategy, anyclassStrategy, newtypeStrategy, viaStrategy, DerivStrategy(..), @@ -131,8 +131,8 @@ thisModule, -- ** Documentation - withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc, dataInstD_doc, - newtypeInstD_doc, patSynD_doc + withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc, + typeDataD_doc, dataInstD_doc, newtypeInstD_doc, patSynD_doc ) where @@ -140,6 +140,7 @@ ( tySynD , dataD , newtypeD + , typeDataD , classD , pragRuleD , dataInstD @@ -178,10 +179,10 @@ import qualified Language.Haskell.TH.Lib.Internal as Internal import Language.Haskell.TH.Syntax -import Control.Applicative ( liftA2 ) +import Control.Applicative (Applicative(..)) import Foreign.ForeignPtr import Data.Word -import Prelude +import Prelude hiding (Applicative(..)) -- All definitions below represent the "old" API, since their definitions are -- different in Language.Haskell.TH.Lib.Internal. Please think carefully before @@ -211,6 +212,13 @@ con1 <- con derivs1 <- sequenceA derivs return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) + +typeDataD :: Quote m => Name -> [TyVarBndr ()] -> 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 ctxt cls tvs fds decs = 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 @@ -20,12 +20,12 @@ import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn) import qualified Language.Haskell.TH.Syntax as TH -import Control.Applicative(liftA, liftA2) +import Control.Applicative(liftA, Applicative(..)) import qualified Data.Kind as Kind (Type) import Data.Word( Word8 ) import Data.List.NonEmpty ( NonEmpty(..) ) import GHC.Exts (TYPE) -import Prelude +import Prelude hiding (Applicative(..)) ---------------------------------------------------------- -- * Type synonyms @@ -441,6 +441,15 @@ derivs1 <- sequenceA derivs pure (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1) +typeDataD :: Quote m => Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> [m Con] + -> m Dec +typeDataD tc tvs ksig cons = + do + tvs1 <- sequenceA tvs + ksig1 <- sequenceA ksig + cons1 <- sequenceA cons + pure (TypeDataD tc tvs1 ksig1 cons1) + classD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs = do @@ -1033,6 +1042,7 @@ doc_loc (ValD (VarP n) _ _) = Just $ DeclDoc n doc_loc (DataD _ n _ _ _ _) = Just $ DeclDoc n doc_loc (NewtypeD _ n _ _ _ _) = Just $ DeclDoc n + doc_loc (TypeDataD n _ _ _) = Just $ DeclDoc n doc_loc (TySynD n _ _) = Just $ DeclDoc n doc_loc (ClassD _ n _ _ _) = Just $ DeclDoc n doc_loc (SigD n _) = Just $ DeclDoc n @@ -1106,6 +1116,19 @@ newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do qAddModFinalizer $ docCons con_with_docs let dec = newtypeD ctxt tc tvs ksig con derivs + maybe dec (flip withDecDoc dec) mdoc + +-- | Variant of 'typeDataD' that attaches Haddock documentation. +typeDataD_doc :: Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind) + -> [(Q Con, Maybe String, [Maybe String])] + -- ^ List of constructors, documentation for the constructor, and + -- documentation for the arguments + -> Maybe String + -- ^ Documentation to attach to the data declaration + -> Q Dec +typeDataD_doc tc tvs ksig cons_with_docs mdoc = do + qAddModFinalizer $ mapM_ docCons cons_with_docs + let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) maybe dec (flip withDecDoc dec) mdoc -- | Variant of 'dataInstD' that attaches Haddock documentation. 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 @@ -23,10 +23,12 @@ nestDepth = 4 type Precedence = Int -appPrec, opPrec, unopPrec, sigPrec, noPrec :: Precedence -appPrec = 4 -- Argument of a function application -opPrec = 3 -- Argument of an infix operator -unopPrec = 2 -- Argument of an unresolved infix operator +appPrec, opPrec, unopPrec, funPrec, qualPrec, sigPrec, noPrec :: Precedence +appPrec = 6 -- Argument of a function or type application +opPrec = 5 -- Argument of an infix operator +unopPrec = 4 -- Argument of an unresolved infix operator +funPrec = 3 -- Argument of a function arrow +qualPrec = 2 -- Forall-qualified type or result of a function arrow sigPrec = 1 -- Argument of an explicit type signature noPrec = 0 -- Others @@ -220,7 +222,7 @@ pprExp _ (ArithSeqE d) = ppr d pprExp _ (ListE es) = brackets (commaSep es) pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e - <+> dcolon <+> ppr t + <+> dcolon <+> pprType sigPrec t pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields fs) pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) pprExp i (StaticE e) = parensIf (i >= appPrec) $ @@ -397,6 +399,8 @@ = 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 _ (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds $$ where_clause ds @@ -493,6 +497,10 @@ -> Doc ppr_newtype maybeInst ctxt t argsDoc ksig c decs = ppr_typedef "newtype" maybeInst ctxt t argsDoc ksig [c] decs +ppr_type_data :: 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 = sep [text data_or_newtype <+> maybeInst @@ -792,60 +800,63 @@ pprStrictType = pprBangType ------------------------------ -pprParendType :: Type -> Doc -pprParendType (VarT v) = pprName' Applied v +pprType :: Precedence -> Type -> Doc +pprType _ (VarT v) = pprName' Applied v -- `Applied` is used here instead of `ppr` because of infix names (#13887) -pprParendType (ConT c) = pprName' Applied c -pprParendType (TupleT 0) = text "()" -pprParendType (TupleT 1) = pprParendType (ConT (tupleTypeName 1)) -pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) -pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma -pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar -pprParendType ArrowT = parens (text "->") -pprParendType MulArrowT = text "FUN" -pprParendType ListT = text "[]" -pprParendType (LitT l) = pprTyLit l -pprParendType (PromotedT c) = text "'" <> pprName' Applied c -pprParendType (PromotedTupleT 0) = text "'()" -pprParendType (PromotedTupleT 1) = pprParendType (PromotedT (tupleDataName 1)) -pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma)) -pprParendType PromotedNilT = text "'[]" -pprParendType PromotedConsT = text "'(:)" -pprParendType StarT = char '*' -pprParendType ConstraintT = text "Constraint" -pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) -pprParendType WildCardT = char '_' -pprParendType t@(InfixT {}) = parens (pprInfixT t) -pprParendType t@(UInfixT {}) = parens (pprInfixT t) -pprParendType t@(PromotedInfixT {}) = parens (pprInfixT t) -pprParendType t@(PromotedUInfixT {}) = parens (pprInfixT t) -pprParendType (ParensT t) = ppr t -pprParendType tuple | (TupleT n, args) <- split tuple - , length args == n - = parens (commaSep args) -pprParendType (ImplicitParamT n t) = text ('?':n) <+> text "::" <+> ppr t -pprParendType EqualityT = text "(~)" -pprParendType t@(ForallT {}) = parens (ppr t) -pprParendType t@(ForallVisT {}) = parens (ppr t) -pprParendType t@(AppT {}) = parens (ppr t) -pprParendType t@(AppKindT {}) = parens (ppr t) +pprType _ (ConT c) = pprName' Applied c +pprType _ (TupleT 0) = text "()" +pprType p (TupleT 1) = pprType p (ConT (tupleTypeName 1)) +pprType _ (TupleT n) = parens (hcat (replicate (n-1) comma)) +pprType _ (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma +pprType _ (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar +pprType _ ArrowT = parens (text "->") +pprType _ MulArrowT = text "FUN" +pprType _ ListT = text "[]" +pprType _ (LitT l) = pprTyLit l +pprType _ (PromotedT c) = text "'" <> pprName' Applied c +pprType _ (PromotedTupleT 0) = text "'()" +pprType p (PromotedTupleT 1) = pprType p (PromotedT (tupleDataName 1)) +pprType _ (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma)) +pprType _ PromotedNilT = text "'[]" +pprType _ PromotedConsT = text "'(:)" +pprType _ StarT = char '*' +pprType _ ConstraintT = text "Constraint" +pprType _ (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) +pprType _ WildCardT = char '_' +pprType p t@(InfixT {}) = pprInfixT p t +pprType p t@(UInfixT {}) = pprInfixT p t +pprType p t@(PromotedInfixT {}) = pprInfixT p t +pprType p t@(PromotedUInfixT {}) = pprInfixT p t +pprType _ (ParensT t) = parens (pprType noPrec t) +pprType p (ImplicitParamT n ty) = + parensIf (p >= sigPrec) $ text ('?':n) <+> text "::" <+> pprType sigPrec ty +pprType _ EqualityT = text "(~)" +pprType p (ForallT tvars ctxt ty) = + parensIf (p >= funPrec) $ sep [pprForall tvars ctxt, pprType qualPrec ty] +pprType p (ForallVisT tvars ty) = + parensIf (p >= funPrec) $ sep [pprForallVis tvars [], pprType qualPrec ty] +pprType p t@AppT{} = pprTyApp p (split t) +pprType p t@AppKindT{} = pprTyApp p (split t) -pprInfixT :: Type -> Doc -pprInfixT = \case - (InfixT x n y) -> with x n y "" ppr - (UInfixT x n y) -> with x n y "" pprInfixT - (PromotedInfixT x n y) -> with x n y "'" ppr - (PromotedUInfixT x n y) -> with x n y "'" pprInfixT - t -> ppr t +------------------------------ +pprParendType :: Type -> Doc +pprParendType = pprType appPrec + +pprInfixT :: Precedence -> Type -> Doc +pprInfixT p = \case + InfixT x n y -> with x n y "" opPrec + UInfixT x n y -> with x n y "" unopPrec + PromotedInfixT x n y -> with x n y "'" opPrec + PromotedUInfixT x n y -> with x n y "'" unopPrec + t -> pprParendType t where - with x n y prefix ppr' = ppr' x <+> text prefix <> pprName' Infix n <+> ppr' y + with x n y prefix p' = + parensIf + (p >= p') + (pprType opPrec x <+> text prefix <> pprName' Infix n <+> pprType opPrec y) instance Ppr Type where - ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty] - ppr (ForallVisT tvars ty) = sep [pprForallVis tvars [], ppr ty] - ppr ty = pprTyApp (split ty) - -- Works, in a degenerate way, for SigT, and puts parens round (ty :: kind) - -- See Note [Pretty-printing kind signatures] + ppr = pprType noPrec instance Ppr TypeArg where ppr (TANormal ty) = parensIf (isStarT ty) (ppr ty) ppr (TyArg ki) = char '@' <> parensIf (isStarT ki) (ppr ki) @@ -866,38 +877,40 @@ type instance F Int = (Bool :: *) So we always print a SigT with parens (see #10050). -} -pprTyApp :: (Type, [TypeArg]) -> Doc -pprTyApp (MulArrowT, [TANormal (PromotedT c), TANormal arg1, TANormal arg2]) - | c == oneName = sep [pprFunArgType arg1 <+> text "%1 ->", ppr arg2] - | c == manyName = sep [pprFunArgType arg1 <+> text "->", ppr arg2] -pprTyApp (MulArrowT, [TANormal argm, TANormal arg1, TANormal arg2]) = - sep [pprFunArgType arg1 <+> text "%" <> ppr argm <+> text "->", ppr arg2] -pprTyApp (ArrowT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2] -pprTyApp (EqualityT, [TANormal arg1, TANormal arg2]) = - sep [pprFunArgType arg1 <+> text "~", ppr arg2] -pprTyApp (ListT, [TANormal arg]) = brackets (ppr arg) -pprTyApp (TupleT 1, args) = pprTyApp (ConT (tupleTypeName 1), args) -pprTyApp (PromotedTupleT 1, args) = pprTyApp (PromotedT (tupleDataName 1), args) -pprTyApp (TupleT n, args) +pprTyApp :: Precedence -> (Type, [TypeArg]) -> Doc +pprTyApp p app@(MulArrowT, [TANormal (PromotedT c), TANormal arg1, TANormal arg2]) + | p >= funPrec = parens (pprTyApp noPrec app) + | c == oneName = sep [pprFunArgType arg1 <+> text "%1 ->", pprType qualPrec arg2] + | c == manyName = sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2] +pprTyApp p (MulArrowT, [TANormal argm, TANormal arg1, TANormal arg2]) = + parensIf (p >= funPrec) $ + sep [pprFunArgType arg1 <+> text "%" <> pprType appPrec argm <+> text "->", + pprType qualPrec arg2] +pprTyApp p (ArrowT, [TANormal arg1, TANormal arg2]) = + parensIf (p >= funPrec) $ + sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2] +pprTyApp p (EqualityT, [TANormal arg1, TANormal arg2]) = + parensIf (p >= opPrec) $ + sep [pprType opPrec arg1 <+> text "~", pprType opPrec arg2] +pprTyApp _ (ListT, [TANormal arg]) = brackets (pprType noPrec arg) +pprTyApp p (TupleT 1, args) = pprTyApp p (ConT (tupleTypeName 1), args) +pprTyApp _ (TupleT n, args) | length args == n, Just args' <- traverse fromTANormal args = parens (commaSep args') -pprTyApp (PromotedTupleT n, args) +pprTyApp p (PromotedTupleT 1, args) = pprTyApp p (PromotedT (tupleDataName 1), args) +pprTyApp _ (PromotedTupleT n, args) | length args == n, Just args' <- traverse fromTANormal args = quoteParens (commaSep args') -pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendTypeArg args) +pprTyApp p (fun, args) = + parensIf (p >= appPrec) $ pprParendType fun <+> sep (map pprParendTypeArg args) fromTANormal :: TypeArg -> Maybe Type fromTANormal (TANormal arg) = Just arg fromTANormal (TyArg _) = Nothing -pprFunArgType :: Type -> Doc -- Should really use a precedence argument --- Everything except forall and (->) binds more tightly than (->) -pprFunArgType ty@(ForallT {}) = parens (ppr ty) -pprFunArgType ty@(ForallVisT {}) = parens (ppr ty) -pprFunArgType ty@(((MulArrowT `AppT` _) `AppT` _) `AppT` _) = parens (ppr ty) -pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty) -pprFunArgType ty@(SigT _ _) = parens (ppr ty) -pprFunArgType ty = ppr ty +-- Print the type to the left of @->@. Everything except forall and (->) binds more tightly than (->). +pprFunArgType :: Type -> Doc +pprFunArgType = pprType funPrec data ForallVisFlag = ForallVis -- forall a -> {...} | ForallInvis -- forall a. {...} 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 @@ -2,7 +2,7 @@ DeriveGeneric, FlexibleInstances, DefaultSignatures, RankNTypes, RoleAnnotations, ScopedTypeVariables, MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds, - GADTs, UnboxedTuples, UnboxedSums, TypeInType, TypeOperators, + GADTs, UnboxedTuples, UnboxedSums, TypeOperators, Trustworthy, DeriveFunctor, BangPatterns, RecordWildCards, ImplicitParams #-} {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} @@ -26,6 +26,9 @@ -- * Language extensions , module Language.Haskell.TH.LanguageExtensions , ForeignSrcLang(..) + -- * Notes + -- ** Unresolved Infix + -- $infix ) where import Data.Data hiding (Fixity(..)) @@ -36,7 +39,7 @@ import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Fix (MonadFix (..)) -import Control.Applicative (liftA2) +import Control.Applicative (Applicative(..)) import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO) import Control.Exception.Base (FixIOException (..)) import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar) @@ -57,7 +60,7 @@ import GHC.ForeignSrcLang.Type import Language.Haskell.TH.LanguageExtensions import Numeric.Natural -import Prelude +import Prelude hiding (Applicative(..)) import Foreign.ForeignPtr import Foreign.C.String import Foreign.C.Types @@ -639,7 +642,8 @@ newDeclarationGroup :: Q [Dec] newDeclarationGroup = pure [] -{- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is, +{- | @reifyInstances nm tys@ returns a list of all visible instances (see below for "visible") +of @nm tys@. That is, if @nm@ is the name of a type class, then all instances of this class at the types @tys@ are returned. Alternatively, if @nm@ is the name of a data family or type family, all instances of this family at the types @tys@ are returned. @@ -657,9 +661,21 @@ There is one edge case: @reifyInstances ''Typeable tys@ currently always produces an empty list (no matter what @tys@ are given). -An instance is visible if it is imported or defined in a prior top-level -declaration group. See the documentation for 'newDeclarationGroup' for more details. +In principle, the *visible* instances are +* all instances defined in a prior top-level declaration group + (see docs on @newDeclarationGroup@), or +* all instances defined in any module transitively imported by the + module being compiled +However, actually searching all modules transitively below the one being +compiled is unreasonably expensive, so @reifyInstances@ will report only the +instance for modules that GHC has had some cause to visit during this +compilation. This is a shortcoming: @reifyInstances@ might fail to report +instances for a type that is otherwise unusued, or instances defined in a +different component. You can work around this shortcoming by explicitly importing the modules +whose instances you want to be visible. GHC issue +has some discussion around this. + -} reifyInstances :: Name -> [Type] -> Q [InstanceDec] reifyInstances cls tys = Q (qReifyInstances cls tys) @@ -811,6 +827,7 @@ LangObjc -> "m" LangObjcxx -> "mm" LangAsm -> "s" + LangJs -> "js" RawObject -> "a" path <- addTempFile suffix runIO $ writeFile path src @@ -1117,8 +1134,9 @@ where helper :: HasCallStack => Name helper = - case head (getCallStack ?callStack) of - (_, SrcLoc{..}) -> mkNameG_v srcLocPackage srcLocModule "addrToByteArray" + case getCallStack ?callStack of + [] -> error "addrToByteArrayName: empty call stack" + (_, SrcLoc{..}) : _ -> mkNameG_v srcLocPackage srcLocModule "addrToByteArray" addrToByteArray :: Int -> Addr# -> ByteArray @@ -1398,7 +1416,7 @@ con@('(':_) -> Name (mkOccName con) (NameG DataName (mkPkgName "ghc-prim") - (mkModName "GHC.Tuple")) + (mkModName "GHC.Tuple.Prim")) -- Tricky case: see Note [Data for non-algebraic types] fun@(x:_) | startsVarSym x || startsVarId x @@ -1789,6 +1807,10 @@ mkNameL :: String -> Uniq -> Name mkNameL s u = Name (mkOccName s) (NameL u) +-- | Only used internally +mkNameQ :: String -> String -> Name +mkNameQ mn occ = Name (mkOccName occ) (NameQ (mkModName mn)) + -- | Used for 'x etc, but not available to the programmer mkNameG :: NameSpace -> String -> String -> String -> Name mkNameG ns pkg modu occ @@ -1870,10 +1892,13 @@ withParens thing | boxed = "(" ++ thing ++ ")" | otherwise = "(#" ++ thing ++ "#)" - tup_occ | n == 1 = if boxed then "Solo" else "Solo#" + tup_occ | n == 1 = if boxed then solo else "Solo#" | otherwise = withParens (replicate n_commas ',') n_commas = n - 1 - tup_mod = mkModName "GHC.Tuple" + tup_mod = mkModName "GHC.Tuple.Prim" + solo + | space == DataName = "MkSolo" + | otherwise = "Solo" -- Unboxed sum data and type constructors -- | Unboxed sum data constructor @@ -2070,6 +2095,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~ -} {- $infix #infix# + When implementing antiquotation for quasiquoters, one often wants to parse strings into expressions: @@ -2377,6 +2403,9 @@ Con [DerivClause] -- ^ @{ newtype Cxt x => T x = A (B x) -- deriving (Z,W Q) -- deriving stock Eq }@ + | TypeDataD Name [TyVarBndr ()] + (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 ()] [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@ @@ -2597,24 +2626,36 @@ -- be tuples of other constraints. type Pred = Type +-- | 'SourceUnpackedness' corresponds to unpack annotations found in the source code. +-- +-- This may not agree with the annotations returned by 'reifyConStrictness'. +-- See 'reifyConStrictness' for more information. data SourceUnpackedness = NoSourceUnpackedness -- ^ @C a@ | SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@ | SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@ deriving (Show, Eq, Ord, Data, Generic) +-- | 'SourceStrictness' corresponds to strictness annotations found in the source code. +-- +-- This may not agree with the annotations returned by 'reifyConStrictness'. +-- See 'reifyConStrictness' for more information. data SourceStrictness = NoSourceStrictness -- ^ @C a@ | SourceLazy -- ^ @C {~}a@ | SourceStrict -- ^ @C {!}a@ deriving (Show, Eq, Ord, Data, Generic) -- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness' --- refers to the strictness that the compiler chooses for a data constructor --- field, which may be different from what is written in source code. See --- 'reifyConStrictness' for more information. -data DecidedStrictness = DecidedLazy - | DecidedStrict - | DecidedUnpack +-- refers to the strictness annotations that the compiler chooses for a data constructor +-- field, which may be different from what is written in source code. +-- +-- Note that non-unpacked strict fields are assigned 'DecidedLazy' when a bang would be inappropriate, +-- such as the field of a newtype constructor and fields that have an unlifted type. +-- +-- See 'reifyConStrictness' for more information. +data DecidedStrictness = DecidedLazy -- ^ Field inferred to not have a bang. + | DecidedStrict -- ^ Field inferred to have a bang. + | DecidedUnpack -- ^ Field inferred to be unpacked. deriving (Show, Eq, Ord, Data, Generic) -- | A single data constructor. @@ -2740,21 +2781,21 @@ | ParensT Type -- ^ @(T)@ -- See Note [Representing concrete syntax in types] - | TupleT Int -- ^ @(,), (,,), etc.@ - | UnboxedTupleT Int -- ^ @(\#,\#), (\#,,\#), etc.@ - | UnboxedSumT SumArity -- ^ @(\#|\#), (\#||\#), etc.@ + | TupleT Int -- ^ @(,)@, @(,,)@, etc. + | UnboxedTupleT Int -- ^ @(\#,\#)@, @(\#,,\#)@, etc. + | UnboxedSumT SumArity -- ^ @(\#|\#)@, @(\#||\#)@, etc. | ArrowT -- ^ @->@ | MulArrowT -- ^ @%n ->@ -- -- Generalised arrow type with multiplicity argument | EqualityT -- ^ @~@ | ListT -- ^ @[]@ - | PromotedTupleT Int -- ^ @'(), '(,), '(,,), etc.@ + | PromotedTupleT Int -- ^ @'()@, @'(,)@, @'(,,)@, etc. | PromotedNilT -- ^ @'[]@ - | PromotedConsT -- ^ @(':)@ + | PromotedConsT -- ^ @'(:)@ | StarT -- ^ @*@ | ConstraintT -- ^ @Constraint@ - | LitT TyLit -- ^ @0,1,2, etc.@ + | LitT TyLit -- ^ @0@, @1@, @2@, etc. | WildCardT -- ^ @_@ | ImplicitParamT String Type -- ^ @?x :: t@ deriving( Show, Eq, Ord, Data, Generic ) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,13 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) +## 2.20.0.0 + + * 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` + declarations (GHC proposal #106). + ## 2.19.0.0 * Add `DefaultD` constructor to support Haskell `default` declarations. 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.19.0.0 +version: 2.20.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -27,14 +27,6 @@ location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/template-haskell - --- We give the option to vendor filepath to avoid making filepath non-reinstallable.. --- see #21738 for why we are doing this now and what the plan is for the future. -Flag vendor-filepath - Description: Vendor the dependency on filepath - Default: False - Manual: True - Library default-language: Haskell2010 other-extensions: @@ -63,30 +55,21 @@ Language.Haskell.TH.Lib.Map build-depends: - base >= 4.11 && < 4.18, - ghc-boot-th == 9.4.1, + base >= 4.11 && < 4.19, + ghc-boot-th == 9.6.1, ghc-prim, pretty == 1.1.* - if flag(vendor-filepath) - other-modules: - System.FilePath - System.FilePath.Posix - System.FilePath.Windows - hs-source-dirs: ./vendored-filepath . - default-extensions: - ImplicitPrelude - else - build-depends: filepath - hs-source-dirs: . + other-modules: + System.FilePath + System.FilePath.Posix + System.FilePath.Windows + hs-source-dirs: ./vendored-filepath . + default-extensions: + ImplicitPrelude ghc-options: -Wall -- We need to set the unit ID to template-haskell (without a -- version number) as it's magic. ghc-options: -this-unit-id template-haskell - - -- This should match the default-extensions used in 'ghc.cabal'. This way, - -- GHCi can be used to load it along with the compiler. - Default-Extensions: - NoImplicitPrelude diff --git a/vendored-filepath/System/FilePath/Posix.hs b/vendored-filepath/System/FilePath/Posix.hs --- a/vendored-filepath/System/FilePath/Posix.hs +++ b/vendored-filepath/System/FilePath/Posix.hs @@ -600,7 +600,7 @@ hasLeadingPathSeparator :: FilePath -> Bool hasLeadingPathSeparator "" = False -hasLeadingPathSeparator x = isPathSeparator (head x) +hasLeadingPathSeparator (hd : _) = isPathSeparator hd -- | Add a trailing file path separator if one is not already present. @@ -824,7 +824,7 @@ where (a,b) = break isPathSeparator $ dropWhile isPathSeparator x -- on windows, need to drop '/' which is kind of absolute, but not a drive - dropAbs x | hasLeadingPathSeparator x && not (hasDrive x) = tail x + dropAbs x | hasLeadingPathSeparator x && not (hasDrive x) = drop 1 x dropAbs x = dropDrive x takeAbs x | hasLeadingPathSeparator x && not (hasDrive x) = [pathSeparator] diff --git a/vendored-filepath/System/FilePath/Windows.hs b/vendored-filepath/System/FilePath/Windows.hs --- a/vendored-filepath/System/FilePath/Windows.hs +++ b/vendored-filepath/System/FilePath/Windows.hs @@ -600,7 +600,7 @@ hasLeadingPathSeparator :: FilePath -> Bool hasLeadingPathSeparator "" = False -hasLeadingPathSeparator x = isPathSeparator (head x) +hasLeadingPathSeparator (hd : _) = isPathSeparator hd -- | Add a trailing file path separator if one is not already present. @@ -824,7 +824,7 @@ where (a,b) = break isPathSeparator $ dropWhile isPathSeparator x -- on windows, need to drop '/' which is kind of absolute, but not a drive - dropAbs x | hasLeadingPathSeparator x && not (hasDrive x) = tail x + dropAbs x | hasLeadingPathSeparator x && not (hasDrive x) = drop 1 x dropAbs x = dropDrive x takeAbs x | hasLeadingPathSeparator x && not (hasDrive x) = [pathSeparator]