template-haskell 2.17.0.0 → 2.18.0.0

raw patch · 7 files changed

+323/−44 lines, 7 filesdep ~basedep ~ghc-boot-thPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, ghc-boot-th

API changes (from Hackage documentation)

Files

• Language/Haskell/TH.hs +3/−0
• Language/Haskell/TH/Lib.hs +15/−2
• Language/Haskell/TH/Lib/Internal.hs +189/−12
• Language/Haskell/TH/Ppr.hs +31/−25
• Language/Haskell/TH/Syntax.hs +57/−2
• changelog.md +25/−0
• template-haskell.cabal +3/−3

@@ -90,6 +90,9 @@         Syntax.Specificity(..),         FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, BangType, VarBangType, +    -- ** Documentation+        putDoc, getDoc, DocLoc(..),+     -- * Library functions     module Language.Haskell.TH.Lib, 

@@ -44,6 +44,7 @@         appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR,         lamE, lam1E, lamCaseE, tupE, unboxedTupE, unboxedSumE, condE, multiIfE,         letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp,+        getFieldE, projectionE,     -- **** Ranges     fromE, fromThenE, fromToE, fromThenToE, @@ -61,7 +62,7 @@         sigT, litT, wildCardT, promotedT, promotedTupleT, promotedNilT,         promotedConsT, implicitParamT,     -- **** Type literals-    numTyLit, strTyLit,+    numTyLit, strTyLit, charTyLit,     -- **** Strictness     noSourceUnpackedness, sourceNoUnpack, sourceUnpack,     noSourceStrictness, sourceLazy, sourceStrict,@@ -124,8 +125,12 @@     implicitParamBindD,      -- ** Reify-    thisModule+    thisModule, +    -- ** Documentation+    withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc, dataInstD_doc,+    newtypeInstD_doc, patSynD_doc+    ) where  import Language.Haskell.TH.Lib.Internal hiding@@ -162,6 +167,8 @@   , tupE   , unboxedTupE +  , conP+   , Role   , InjectivityAnn   )@@ -349,3 +356,9 @@  mdoE :: Quote m => [m Stmt] -> m Exp mdoE = Internal.mdoE Nothing++-------------------------------------------------------------------------------+-- * Patterns++conP :: Quote m => Name -> [m Pat] -> m Pat+conP n xs = Internal.conP n [] xs

@@ -1,4 +1,5 @@ {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE Trustworthy #-}  -- |@@ -22,6 +23,7 @@ import Control.Applicative(liftA, liftA2) import qualified Data.Kind as Kind (Type) import Data.Word( Word8 )+import Data.List.NonEmpty ( NonEmpty(..) ) import GHC.Exts (TYPE) import Prelude @@ -29,17 +31,12 @@ -- * Type synonyms ---------------------------------------------------------- --- Since GHC 8.8 is currently the minimum boot compiler version that we must--- support, we must use inline kind signatures to make TExpQ and CodeQ--- levity polymorphic. When we drop support for GHC 8.8, we can instead use--- standalone kind signatures, which are provided as comments.- -- | Levity-polymorphic since /template-haskell-2.17.0.0/.--- type TExpQ :: TYPE r -> Kind.Type-type TExpQ (a :: TYPE r) = Q (TExp a)+type TExpQ :: TYPE r -> Kind.Type+type TExpQ a = Q (TExp a) --- type CodeQ :: TYPE r -> Kind.Type-type CodeQ = Code Q :: (TYPE r -> Kind.Type)+type CodeQ :: TYPE r -> Kind.Type+type CodeQ = Code Q  type InfoQ               = Q Info type PatQ                = Q Pat@@ -125,9 +122,10 @@ unboxedSumP :: Quote m => m Pat -> SumAlt -> SumArity -> m Pat unboxedSumP p alt arity = do { p1 <- p; pure (UnboxedSumP p1 alt arity) } -conP :: Quote m => Name -> [m Pat] -> m Pat-conP n ps = do ps' <- sequenceA ps-               pure (ConP n ps')+conP :: Quote m => Name -> [m Type] -> [m Pat] -> m Pat+conP n ts ps = do ps' <- sequenceA ps+                  ts' <- sequenceA ts+                  pure (ConP n ts' ps') infixP :: Quote m => m Pat -> Name -> m Pat -> m Pat infixP p1 n p2 = do p1' <- p1                     p2' <- p2@@ -369,6 +367,14 @@ implicitParamVarE :: Quote m => String -> m Exp implicitParamVarE n = pure (ImplicitParamVarE n) +getFieldE :: Quote m => m Exp -> String -> m Exp+getFieldE e f = do+  e' <- e+  pure (GetFieldE e' f)++projectionE :: Quote m => NonEmpty String -> m Exp+projectionE xs = pure (ProjectionE xs)+ -- ** 'arithSeqE' Shortcuts fromE :: Quote m => m Exp -> m Exp fromE x = do { a <- x; pure (ArithSeqE (FromR a)) }@@ -831,6 +837,9 @@ strTyLit :: Quote m => String -> m TyLit strTyLit s = pure (StrTyLit s) +charTyLit :: Quote m => Char -> m TyLit+charTyLit c = pure (CharTyLit c)+ ------------------------------------------------------------------------------- -- *   Kind @@ -981,3 +990,171 @@ thisModule = do   loc <- location   pure $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc)++--------------------------------------------------------------+-- * Documentation combinators++-- | Attaches Haddock documentation to the declaration provided. Unlike+-- 'putDoc', the names do not need to be in scope when calling this function so+-- it can be used for quoted declarations and anything else currently being+-- spliced.+-- Not all declarations can have documentation attached to them. For those that+-- can't, 'withDecDoc' will return it unchanged without any side effects.+withDecDoc :: String -> Q Dec -> Q Dec+withDecDoc doc dec = do+  dec' <- dec+  case doc_loc dec' of+    Just loc -> qAddModFinalizer $ qPutDoc loc doc+    Nothing  -> pure ()+  pure dec'+  where+    doc_loc (FunD n _)                                     = Just $ DeclDoc n+    doc_loc (ValD (VarP n) _ _)                            = Just $ DeclDoc n+    doc_loc (DataD _ n _ _ _ _)                            = Just $ DeclDoc n+    doc_loc (NewtypeD _ 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+    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 (DataFamilyD n _ _)                            = Just $ DeclDoc n+    doc_loc (OpenTypeFamilyD (TypeFamilyHead n _ _ _))     = Just $ DeclDoc n+    doc_loc (ClosedTypeFamilyD (TypeFamilyHead n _ _ _) _) = Just $ DeclDoc n+    doc_loc (PatSynD n _ _ _)                              = Just $ DeclDoc n+    doc_loc (PatSynSigD n _)                               = Just $ DeclDoc n++    -- For instances we just pass along the full type+    doc_loc (InstanceD _ _ t _)           = Just $ InstDoc t+    doc_loc (DataInstD _ _ t _ _ _)       = Just $ InstDoc t+    doc_loc (NewtypeInstD _ _ t _ _ _)    = Just $ InstDoc t+    doc_loc (TySynInstD (TySynEqn _ t _)) = Just $ InstDoc t++    -- Declarations that can't have documentation attached to+    -- ValDs that aren't a simple variable pattern+    doc_loc (ValD _ _ _)             = Nothing+    doc_loc (KiSigD _ _)             = Nothing+    doc_loc (PragmaD _)              = Nothing+    doc_loc (RoleAnnotD _ _)         = Nothing+    doc_loc (StandaloneDerivD _ _ _) = Nothing+    doc_loc (DefaultSigD _ _)        = Nothing+    doc_loc (ImplicitParamBindD _ _) = Nothing++-- | Variant of 'withDecDoc' that applies the same documentation to+-- multiple declarations. Useful for documenting quoted declarations.+withDecsDoc :: String -> Q [Dec] -> Q [Dec]+withDecsDoc doc decs = decs >>= mapM (withDecDoc doc . pure)++-- | Variant of 'funD' that attaches Haddock documentation.+funD_doc :: Name -> [Q Clause]+         -> Maybe String -- ^ Documentation to attach to function+         -> [Maybe String] -- ^ Documentation to attach to arguments+         -> Q Dec+funD_doc nm cs mfun_doc arg_docs = do+  qAddModFinalizer $ sequence_+    [putDoc (ArgDoc nm i) s | (i, Just s) <- zip [0..] arg_docs]+  let dec = funD nm cs+  case mfun_doc of+    Just fun_doc -> withDecDoc fun_doc dec+    Nothing -> funD nm cs++-- | Variant of 'dataD' that attaches Haddock documentation.+dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind)+          -> [(Q Con, Maybe String, [Maybe String])]+          -- ^ List of constructors, documentation for the constructor, and+          -- documentation for the arguments+          -> [Q DerivClause]+          -> Maybe String+          -- ^ Documentation to attach to the data declaration+          -> Q Dec+dataD_doc ctxt tc tvs ksig cons_with_docs derivs mdoc = do+  qAddModFinalizer $ mapM_ docCons cons_with_docs+  let dec = dataD ctxt tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) derivs+  maybe dec (flip withDecDoc dec) mdoc++-- | Variant of 'newtypeD' that attaches Haddock documentation.+newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind)+             -> (Q Con, Maybe String, [Maybe String])+             -- ^ The constructor, documentation for the constructor, and+             -- documentation for the arguments+             -> [Q DerivClause]+             -> Maybe String+             -- ^ Documentation to attach to the newtype declaration+             -> Q Dec+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 'dataInstD' that attaches Haddock documentation.+dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind)+              -> [(Q Con, Maybe String, [Maybe String])]+              -- ^ List of constructors, documentation for the constructor, and+              -- documentation for the arguments+              -> [Q DerivClause]+              -> Maybe String+              -- ^ Documentation to attach to the instance declaration+              -> Q Dec+dataInstD_doc ctxt mb_bndrs ty ksig cons_with_docs derivs mdoc = do+  qAddModFinalizer $ mapM_ docCons cons_with_docs+  let dec = dataInstD ctxt mb_bndrs ty ksig (map (\(con, _, _) -> con) cons_with_docs)+              derivs+  maybe dec (flip withDecDoc dec) mdoc++-- | Variant of 'newtypeInstD' that attaches Haddock documentation.+newtypeInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type+                 -> Maybe (Q Kind)+                 -> (Q Con, Maybe String, [Maybe String])+                 -- ^ The constructor, documentation for the constructor, and+                 -- documentation for the arguments+                 -> [Q DerivClause]+                 -> Maybe String+                 -- ^ Documentation to attach to the instance declaration+                 -> Q Dec+newtypeInstD_doc ctxt mb_bndrs ty ksig con_with_docs@(con, _, _) derivs mdoc = do+  qAddModFinalizer $ docCons con_with_docs+  let dec = newtypeInstD ctxt mb_bndrs ty ksig con derivs+  maybe dec (flip withDecDoc dec) mdoc++-- | Variant of 'patSynD' that attaches Haddock documentation.+patSynD_doc :: Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat+            -> Maybe String   -- ^ Documentation to attach to the pattern synonym+            -> [Maybe String] -- ^ Documentation to attach to the pattern arguments+            -> Q Dec+patSynD_doc name args dir pat mdoc arg_docs = do+  qAddModFinalizer $ sequence_+    [putDoc (ArgDoc name i) s | (i, Just s) <- zip [0..] arg_docs]+  let dec = patSynD name args dir pat+  maybe dec (flip withDecDoc dec) mdoc++-- | Document a data/newtype constructor with its arguments.+docCons :: (Q Con, Maybe String, [Maybe String]) -> Q ()+docCons (c, md, arg_docs) = do+  c' <- c+  -- Attach docs to the constructors+  sequence_ [ putDoc (DeclDoc nm) d | Just d <- [md], nm <- get_cons_names c' ]+  -- Attach docs to the arguments+  case c' of+    -- Record selector documentation isn't stored in the argument map,+    -- but in the declaration map instead+    RecC _ var_bang_types ->+      sequence_ [ putDoc (DeclDoc nm) arg_doc+                  | (Just arg_doc, (nm, _, _)) <- zip arg_docs var_bang_types+                ]+    _ ->+      sequence_ [ putDoc (ArgDoc nm i) arg_doc+                    | 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

@@ -15,6 +15,7 @@ import GHC.Show  ( showMultiLineString ) import GHC.Lexeme( startsVarSym ) import Data.Ratio ( numerator, denominator )+import Data.Foldable ( toList ) import Prelude hiding ((<>))  nestDepth :: Int@@ -75,7 +76,7 @@  pprFixity :: Name -> Fixity -> Doc pprFixity _ f | f == defaultFixity = empty-pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v+pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> pprName' Infix v     where ppr_fix InfixR = text "infixr"           ppr_fix InfixL = text "infixl"           ppr_fix InfixN = text "infix"@@ -216,16 +217,18 @@ pprExp _ (ListE es) = brackets (commaSep es) pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e                                           <+> dcolon <+> ppr t-pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)+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) $                          text "static"<+> pprExp appPrec e pprExp _ (UnboundVarE v) = pprName' Applied v pprExp _ (LabelE s) = text "#" <> text s pprExp _ (ImplicitParamVarE n) = text ('?' : n)+pprExp _ (GetFieldE e f) = pprExp appPrec e <> text ('.': f)+pprExp _ (ProjectionE xs) = parens $ hcat $ map ((char '.'<>) . text) $ toList xs  pprFields :: [(Name,Exp)] -> Doc-pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)+pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)  pprMaybeExp :: Precedence -> Maybe Exp -> Doc pprMaybeExp _ Nothing = empty@@ -304,13 +307,15 @@ pprPat _ (VarP v)     = pprName' Applied v pprPat i (TupP ps)   | [_] <- ps-  = pprPat i (ConP (tupleDataName 1) ps)+  = pprPat i (ConP (tupleDataName 1) [] ps)   | otherwise   = parens (commaSep ps) pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps) pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity-pprPat i (ConP s ps)  = parensIf (i >= appPrec) $ pprName' Applied s-                                              <+> sep (map (pprPat appPrec) ps)+pprPat i (ConP s ts ps)  = parensIf (i >= appPrec) $+      pprName' Applied s+  <+> sep (map (\t -> char '@' <> pprParendType t) ts)+  <+> sep (map (pprPat appPrec) ps) pprPat _ (ParensP p)  = parens $ pprPat noPrec p pprPat i (UInfixP p1 n p2)                       = parensIf (i > unopPrec) (pprPat unopPrec p1 <+>@@ -326,9 +331,9 @@                                                       <> pprPat appPrec p pprPat _ WildP        = text "_" pprPat _ (RecP nm fs)- = parens $     ppr nm+ = parens $     pprName' Applied nm             <+> braces (sep $ punctuate comma $-                        map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)+                        map (\(s,p) -> pprName' Applied s <+> equals <+> ppr p) fs) 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@@ -409,10 +414,10 @@ ppr_dec _ (PatSynD name args dir pat)   = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS   where-    pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> ppr name <+> ppr a2-                | otherwise                 = ppr name <+> ppr args+    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 (ppr name <+> ppr cls)+                                           nestDepth (pprName' Applied name <+> ppr cls)                 | otherwise            = ppr pat ppr_dec _ (PatSynSigD name ty)   = pprPatSynSig name ty@@ -506,13 +511,13 @@ ppr_tySyn maybeInst t argsDoc rhs   = text "type" <+> maybeInst     <+> case t of-         Just n -> ppr n <+> argsDoc+         Just n -> pprName' Applied n <+> argsDoc          Nothing -> argsDoc     <+> text "=" <+> ppr rhs  ppr_tf_head :: TypeFamilyHead -> Doc ppr_tf_head (TypeFamilyHead tc tvs res inj)-  = ppr tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj+  = pprName' Applied tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj   where     maybeInj | (Just inj') <- inj = ppr inj'              | otherwise          = empty@@ -545,13 +550,13 @@      <+> showtextl callconv      <+> showtextl safety      <+> text (show impent)-     <+> ppr as+     <+> pprName' Applied as      <+> dcolon <+> ppr typ     ppr (ExportF callconv expent as typ)         = text "foreign export"       <+> showtextl callconv       <+> text (show expent)-      <+> ppr as+      <+> pprName' Applied as       <+> dcolon <+> ppr typ  ------------------------------@@ -561,13 +566,13 @@      <+> ppr inline      <+> ppr rm      <+> ppr phases-     <+> ppr n+     <+> pprName' Applied n      <+> text "#-}"     ppr (SpecialiseP n ty inline phases)        =   text "{-# SPECIALISE"        <+> maybe empty ppr inline        <+> ppr phases-       <+> sep [ ppr n <+> dcolon+       <+> sep [ pprName' Applied n <+> dcolon                , nest 2 $ ppr ty ]        <+> text "#-}"     ppr (SpecialiseInstP inst)@@ -588,13 +593,13 @@     ppr (AnnP tgt expr)        = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"       where target1 ModuleAnnotation    = text "module"-            target1 (TypeAnnotation t)  = text "type" <+> ppr t-            target1 (ValueAnnotation v) = ppr v+            target1 (TypeAnnotation t)  = text "type" <+> pprName' Applied t+            target1 (ValueAnnotation v) = pprName' Applied v     ppr (LineP line file)        = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}"     ppr (CompleteP cls mty)-       = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map ppr cls)-                <+> maybe empty (\ty -> dcolon <+> ppr ty) mty+       = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map (pprName' Applied) cls)+                <+> maybe empty (\ty -> dcolon <+> pprName' Applied ty) mty <+> text "#-}"  ------------------------------ instance Ppr Inline where@@ -625,10 +630,10 @@  ------------------------------ instance Ppr Con where-    ppr (NormalC c sts) = ppr c <+> sep (map pprBangType sts)+    ppr (NormalC c sts) = pprName' Applied c <+> sep (map pprBangType sts)      ppr (RecC c vsts)-        = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))+        = pprName' Applied c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))      ppr (InfixC st1 c st2) = pprBangType st1                          <+> pprName' Infix c@@ -661,7 +666,7 @@ instance Ppr PatSynArgs where   ppr (PrefixPatSyn args) = sep $ map ppr args   ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2-  ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map ppr sels))+  ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map (pprName' Applied) sels))  commaSepApplied :: [Name] -> Doc commaSepApplied = commaSepWith (pprName' Applied)@@ -700,7 +705,7 @@ ------------------------------ pprVarBangType :: VarBangType -> Doc -- Slight infelicity: with print non-atomic type with parens-pprVarBangType (v, bang, t) = ppr v <+> dcolon <+> pprBangType (bang, t)+pprVarBangType (v, bang, t) = pprName' Applied v <+> dcolon <+> pprBangType (bang, t)  ------------------------------ pprBangType :: BangType -> Doc@@ -867,6 +872,7 @@ pprTyLit :: TyLit -> Doc pprTyLit (NumTyLit n) = integer n pprTyLit (StrTyLit s) = text (show s)+pprTyLit (CharTyLit c) = text (show c)  instance Ppr TyLit where   ppr = pprTyLit

@@ -61,6 +61,10 @@ import Foreign.C.String import Foreign.C.Types +#if __GLASGOW_HASKELL__ >= 901+import GHC.Types ( Levity(..) )+#endif+ ----------------------------------------------------- -- --              The Quasi class@@ -119,6 +123,9 @@   qIsExtEnabled :: Extension -> m Bool   qExtsEnabled :: m [Extension] +  qPutDoc :: DocLoc -> String -> m ()+  qGetDoc :: DocLoc -> m (Maybe String)+ ----------------------------------------------------- --      The IO instance of Quasi --@@ -157,6 +164,8 @@   qPutQ _               = badIO "putQ"   qIsExtEnabled _       = badIO "isExtEnabled"   qExtsEnabled          = badIO "extsEnabled"+  qPutDoc _ _           = badIO "putDoc"+  qGetDoc _             = badIO "getDoc"  instance Quote IO where   newName = newNameIO@@ -741,6 +750,32 @@ extsEnabled :: Q [Extension] extsEnabled = Q qExtsEnabled +-- | Add Haddock documentation to the specified location. This will overwrite+-- any documentation at the location if it already exists. This will reify the+-- specified name, so it must be in scope when you call it. If you want to add+-- documentation to something that you are currently splicing, you can use+-- 'addModFinalizer' e.g.+--+-- > do+-- >   let nm = mkName "x"+-- >   addModFinalizer $ putDoc (DeclDoc nm) "Hello"+-- >   [d| $(varP nm) = 42 |]+--+-- The helper functions 'withDecDoc' and 'withDecsDoc' will do this for you, as+-- will the 'funD_doc' and other @_doc@ combinators.+-- You most likely want to have the @-haddock@ flag turned on when using this.+-- Adding documentation to anything outside of the current module will cause an+-- error.+putDoc :: DocLoc -> String -> Q ()+putDoc t s = Q (qPutDoc t s)++-- | Retreives 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.+getDoc :: DocLoc -> Q (Maybe String)+getDoc n = Q (qGetDoc n)+ instance MonadIO Q where   liftIO = runIO @@ -768,6 +803,8 @@   qPutQ               = putQ   qIsExtEnabled       = isExtEnabled   qExtsEnabled        = extsEnabled+  qPutDoc             = putDoc+  qGetDoc             = getDoc   ----------------------------------------------------@@ -816,7 +853,11 @@   -- | 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@@ -1296,7 +1337,7 @@             case nameSpace n of                 Just DataName -> do                     ps' <- sequence ps-                    return (ConP n ps')+                    return (ConP n [] ps')                 _ -> error $ "Can't construct a pattern from name "                           ++ showName n @@ -2018,7 +2059,7 @@   | TupP [Pat]                      -- ^ @{ (p1,p2) }@   | UnboxedTupP [Pat]               -- ^ @{ (\# p1,p2 \#) }@   | UnboxedSumP Pat SumAlt SumArity -- ^ @{ (\#|p|\#) }@-  | ConP Name [Pat]                 -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@+  | ConP Name [Type] [Pat]          -- ^ @data T1 = C1 t1 t2; {C1 \@ty1 p1 p2} = e@   | InfixP Pat Name Pat             -- ^ @foo ({x :+ y}) = e@   | UInfixP Pat Name Pat            -- ^ @foo ({x :+ y}) = e@                                     --@@ -2127,6 +2168,8 @@                                        -- or constructor name.   | LabelE String                      -- ^ @{ #x }@ ( Overloaded label )   | ImplicitParamVarE String           -- ^ @{ ?x }@ ( Implicit parameter )+  | GetFieldE Exp String               -- ^ @{ exp.field }@ ( Overloaded Record Dot )+  | ProjectionE (NonEmpty String)      -- ^ @(.x)@ or @(.x.y)@ (Record projections)   deriving( Show, Eq, Ord, Data, Generic )  type FieldExp = (Name,Exp)@@ -2562,6 +2605,7 @@  data TyLit = NumTyLit Integer             -- ^ @2@            | StrTyLit String              -- ^ @\"Hello\"@+           | CharTyLit Char               -- ^ @\'C\'@, @since 4.16.0.0   deriving ( Show, Eq, Ord, Data, Generic )  -- | Role annotations@@ -2615,6 +2659,17 @@   '[ Maybe, IO ]    PromotedConsT `AppT` Maybe `AppT`                     (PromotedConsT  `AppT` IO `AppT` PromotedNilT) -}++-- | A location at which to attach Haddock documentation.+-- Note that adding documentation to a 'Name' defined oustide of the current+-- module will cause an error.+data DocLoc+  = ModuleDoc         -- ^ At the current module's header.+  | DeclDoc Name      -- ^ At a declaration, not necessarily top level.+  | ArgDoc Name Int   -- ^ At a specific argument of a function, indexed by its+                      -- position.+  | InstDoc Type      -- ^ At a class or family instance.+  deriving ( Show, Eq, Ord, Data, Generic )  ----------------------------------------------------- --              Internal helper functions

@@ -1,5 +1,30 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) +## 2.19.0.0++  * Add `DefaultD` constructor to support Haskell `default` declarations.++## 2.18.0.0+  * The types of `ConP` and `conP` have been changed to allow for an additional list+    of type applications preceding the argument patterns.++  * Add support for the `Char` kind (#11342): we extend the `TyLit` data type with+    the constructor `CharTyLit` that reflects type-level characters.++  * Add `putDoc` and `getDoc` which allow Haddock documentation to be attached+    to module headers, declarations, function arguments and instances, as well+    as queried. These are quite low level operations, so for convenience there+    are several combinators that can be used with `Dec`s directly, including+    `withDecDoc`/`withDecsDoc` as well as `_doc` counterparts to many of the+    `Dec` helper functions.++  * Add `newDeclarationGroup` to document the effect of visibility while+    reifying types and instances.++  * Add support for Overloaded Record Dot. +    Introduces `getFieldE :: Quote m => m Exp -> String -> m Exp` and+    `projectionE :: Quote m => [String] -> m Exp`.+ ## 2.17.0.0   * Typed Quotations now return a value of type `Code m a` (GHC Proposal #195).     The main motiviation is to make writing instances easier and make it easier to

@@ -3,7 +3,7 @@ -- template-haskell.cabal.  name:           template-haskell-version:        2.17.0.0+version:        2.18.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.16,-        ghc-boot-th == 9.0.1,+        base        >= 4.11 && < 4.17,+        ghc-boot-th == 9.2.1,         ghc-prim,         pretty      == 1.1.*