diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs --- a/Language/Haskell/TH.hs +++ b/Language/Haskell/TH.hs @@ -90,6 +90,9 @@ Syntax.Specificity(..), FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, BangType, VarBangType, + -- ** Documentation + putDoc, getDoc, DocLoc(..), + -- * Library functions module Language.Haskell.TH.Lib, 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 @@ -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 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,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 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 @@ -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 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 @@ -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 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.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.*