diff options
32 files changed, 968 insertions, 52 deletions
diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs index 207b65f2fd..425cc03bf0 100644 --- a/compiler/GHC/Hs/Doc.hs +++ b/compiler/GHC/Hs/Doc.hs @@ -19,6 +19,8 @@ module GHC.Hs.Doc , ArgDocMap(..) , emptyArgDocMap + + , ExtractedTHDocs(..) ) where #include "HsVersions.h" @@ -35,6 +37,8 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 import Data.Data +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe @@ -126,21 +130,34 @@ emptyDeclDocMap :: DeclDocMap emptyDeclDocMap = DeclDocMap Map.empty -- | Docs for arguments. E.g. function arguments, method arguments. -newtype ArgDocMap = ArgDocMap (Map Name (Map Int HsDocString)) +newtype ArgDocMap = ArgDocMap (Map Name (IntMap HsDocString)) instance Binary ArgDocMap where - put_ bh (ArgDocMap m) = put_ bh (Map.toList (Map.toAscList <$> m)) + put_ bh (ArgDocMap m) = put_ bh (Map.toList (IntMap.toAscList <$> m)) -- We can't rely on a deterministic ordering of the `Name`s here. -- See the comments on `Name`'s `Ord` instance for context. - get bh = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromList <$> get bh + get bh = ArgDocMap . fmap IntMap.fromDistinctAscList . Map.fromList <$> get bh instance Outputable ArgDocMap where ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m)) where pprPair (name, int_map) = ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map) - pprIntMap im = vcat (map pprIPair (Map.toAscList im)) + pprIntMap im = vcat (map pprIPair (IntMap.toAscList im)) pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc) emptyArgDocMap :: ArgDocMap emptyArgDocMap = ArgDocMap Map.empty + +-- | Maps of docs that were added via Template Haskell's @putDoc@. +data ExtractedTHDocs = + ExtractedTHDocs + { ethd_mod_header :: Maybe HsDocString + -- ^ The added module header documentation, if it exists. + , ethd_decl_docs :: DeclDocMap + -- ^ The documentation added to declarations. + , ethd_arg_docs :: ArgDocMap + -- ^ The documentation added to function arguments. + , ethd_inst_docs :: DeclDocMap + -- ^ The documentation added to class and family instances. + } diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index bf15fd2e10..fafcdb6533 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -214,7 +214,7 @@ deSugar hsc_env ; foreign_files <- readIORef th_foreign_files_var - ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env + ; (doc_hdr, decl_docs, arg_docs) <- extractDocs tcg_env ; let mod_guts = ModGuts { mg_module = mod, diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index 56f089a756..fa278b7983 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -27,15 +27,22 @@ import GHC.Types.SrcLoc import GHC.Tc.Types import Control.Applicative +import Control.Monad.IO.Class import Data.Bifunctor (first) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM import Data.Map (Map) import qualified Data.Map as M import Data.Maybe import Data.Semigroup +import GHC.IORef (readIORef) -- | Extract docs from renamer output. -extractDocs :: TcGblEnv - -> (Maybe HsDocString, DeclDocMap, ArgDocMap) +-- This is monadic since we need to be able to read documentation added from +-- Template Haskell's @putDoc@, which is stored in 'tcg_th_docs'. +extractDocs :: MonadIO m + => TcGblEnv + -> m (Maybe HsDocString, DeclDocMap, ArgDocMap) -- ^ -- 1. Module header -- 2. Docs on top level declarations @@ -45,8 +52,20 @@ extractDocs TcGblEnv { tcg_semantic_mod = mod , tcg_insts = insts , tcg_fam_insts = fam_insts , tcg_doc_hdr = mb_doc_hdr - } = - (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map) + , tcg_th_docs = th_docs_var + } = do + th_docs <- liftIO $ readIORef th_docs_var + let doc_hdr = th_doc_hdr <|> (unLoc <$> mb_doc_hdr) + ExtractedTHDocs + th_doc_hdr + (DeclDocMap th_doc_map) + (ArgDocMap th_arg_map) + (DeclDocMap th_inst_map) = extractTHDocs th_docs + return + ( doc_hdr + , DeclDocMap (th_doc_map <> th_inst_map <> doc_map) + , ArgDocMap (th_arg_map `unionArgMaps` arg_map) + ) where (doc_map, arg_map) = maybe (M.empty, M.empty) (mkMaps local_insts) @@ -59,10 +78,10 @@ extractDocs TcGblEnv { tcg_semantic_mod = mod -- For each declaration, find its names, its subordinates, and its doc strings. mkMaps :: [Name] -> [(LHsDecl GhcRn, [HsDocString])] - -> (Map Name (HsDocString), Map Name (Map Int (HsDocString))) + -> (Map Name (HsDocString), Map Name (IntMap HsDocString)) mkMaps instances decls = ( f' (map (nubByName fst) decls') - , f (filterMapping (not . M.null) args) + , f (filterMapping (not . IM.null) args) ) where (decls', args) = unzip (map mappings decls) @@ -78,7 +97,7 @@ mkMaps instances decls = mappings :: (LHsDecl GhcRn, [HsDocString]) -> ( [(Name, HsDocString)] - , [(Name, Map Int (HsDocString))] + , [(Name, IntMap HsDocString)] ) mappings (L (RealSrcSpan l _) decl, docStrs) = (dm, am) @@ -86,7 +105,7 @@ mkMaps instances decls = doc = concatDocs docStrs args = declTypeDocs decl - subs :: [(Name, [(HsDocString)], Map Int (HsDocString))] + subs :: [(Name, [HsDocString], IntMap HsDocString)] subs = subordinates instanceMap decl (subDocs, subArgs) = @@ -162,13 +181,13 @@ getInstLoc = \case -- family of a type class. subordinates :: Map RealSrcSpan Name -> HsDecl GhcRn - -> [(Name, [(HsDocString)], Map Int (HsDocString))] + -> [(Name, [HsDocString], IntMap HsDocString)] subordinates instMap decl = case decl of InstD _ (ClsInstD _ d) -> do DataFamInstDecl { dfid_eqn = FamEqn { feqn_tycon = L l _ , feqn_rhs = defn }} <- unLoc <$> cid_datafam_insts d - [ (n, [], M.empty) | Just n <- [lookupSrcSpan l instMap] ] ++ dataSubs defn + [ (n, [], IM.empty) | Just n <- [lookupSrcSpan l instMap] ] ++ dataSubs defn InstD _ (DataFamInstD _ (DataFamInstDecl d)) -> dataSubs (feqn_rhs d) @@ -181,7 +200,7 @@ subordinates instMap decl = case decl of , name <- getMainDeclBinder d, not (isValD d) ] dataSubs :: HsDataDefn GhcRn - -> [(Name, [HsDocString], Map Int (HsDocString))] + -> [(Name, [HsDocString], IntMap HsDocString)] dataSubs dd = constrs ++ fields ++ derivs where cons = map unLoc $ (dd_cons dd) @@ -189,11 +208,11 @@ subordinates instMap decl = case decl of , maybeToList $ fmap unLoc $ con_doc c , conArgDocs c) | c <- cons, cname <- getConNames c ] - fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) + fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, IM.empty) | Just flds <- map getRecConArgs_maybe cons , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) , (L _ n) <- ns ] - derivs = [ (instName, [unLoc doc], M.empty) + derivs = [ (instName, [unLoc doc], IM.empty) | (l, doc) <- concatMap (extract_deriv_clause_tys . deriv_clause_tys . unLoc) $ unLoc $ dd_derivs dd @@ -213,26 +232,26 @@ subordinates instMap decl = case decl of _ -> Nothing -- | Extract constructor argument docs from inside constructor decls. -conArgDocs :: ConDecl GhcRn -> Map Int HsDocString +conArgDocs :: ConDecl GhcRn -> IntMap HsDocString conArgDocs (ConDeclH98{con_args = args}) = h98ConArgDocs args conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) = gadtConArgDocs args (unLoc res_ty) -h98ConArgDocs :: HsConDeclH98Details GhcRn -> Map Int HsDocString +h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap HsDocString h98ConArgDocs con_args = case con_args of PrefixCon _ args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1) , unLoc (hsScaledThing arg2) ] - RecCon _ -> M.empty + RecCon _ -> IM.empty -gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> Map Int HsDocString +gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString gadtConArgDocs con_args res_ty = case con_args of PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty] RecConGADT _ -> con_arg_docs 1 [res_ty] -con_arg_docs :: Int -> [HsType GhcRn] -> Map Int HsDocString -con_arg_docs n = M.fromList . catMaybes . zipWith f [n..] +con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString +con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..] where f n (HsDocTy _ _ lds) = Just (n, unLoc lds) f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds) @@ -254,14 +273,14 @@ classDecls class_ = filterDecls . collectDocs . sortLocated $ decls ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ -- | Extract function argument docs from inside top-level decls. -declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString) +declTypeDocs :: HsDecl GhcRn -> IntMap (HsDocString) declTypeDocs = \case SigD _ (TypeSig _ _ ty) -> sigTypeDocs (unLoc (dropWildCards ty)) SigD _ (ClassOpSig _ _ _ ty) -> sigTypeDocs (unLoc ty) SigD _ (PatSynSig _ _ ty) -> sigTypeDocs (unLoc ty) ForD _ (ForeignImport _ _ ty _) -> sigTypeDocs (unLoc ty) TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty) - _ -> M.empty + _ -> IM.empty nubByName :: (a -> Name) -> [a] -> [a] nubByName f ns = go emptyNameSet ns @@ -275,19 +294,19 @@ nubByName f ns = go emptyNameSet ns y = f x -- | Extract function argument docs from inside types. -typeDocs :: HsType GhcRn -> Map Int (HsDocString) +typeDocs :: HsType GhcRn -> IntMap HsDocString typeDocs = go 0 where go n = \case HsForAllTy { hst_body = ty } -> go n (unLoc ty) HsQualTy { hst_body = ty } -> go n (unLoc ty) - HsFunTy _ _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty) + HsFunTy _ _ (unLoc->HsDocTy _ _ x) ty -> IM.insert n (unLoc x) $ go (n+1) (unLoc ty) HsFunTy _ _ _ ty -> go (n+1) (unLoc ty) - HsDocTy _ _ doc -> M.singleton n (unLoc doc) - _ -> M.empty + HsDocTy _ _ doc -> IM.singleton n (unLoc doc) + _ -> IM.empty -- | Extract function argument docs from inside types. -sigTypeDocs :: HsSigType GhcRn -> Map Int HsDocString +sigTypeDocs :: HsSigType GhcRn -> IntMap HsDocString sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body) -- | The top-level declarations of a module that we care about, @@ -372,3 +391,62 @@ mkDecls :: (struct -> [Located decl]) -> struct -> [Located hsDecl] mkDecls field con = map (mapLoc con) . field + +-- | Extracts out individual maps of documentation added via Template Haskell's +-- @putDoc@. +extractTHDocs :: THDocs + -> ExtractedTHDocs +extractTHDocs docs = + -- Split up docs into separate maps for each 'DocLoc' type + ExtractedTHDocs + docHeader + (DeclDocMap (searchDocs decl)) + (ArgDocMap (searchDocs args)) + (DeclDocMap (searchDocs insts)) + where + docHeader :: Maybe HsDocString + docHeader + | ((_, s):_) <- filter isModDoc (M.toList docs) = Just (mkHsDocString s) + | otherwise = Nothing + + isModDoc (ModuleDoc, _) = True + isModDoc _ = False + + -- Folds over the docs, applying 'f' as the accumulating function. + -- We use different accumulating functions to sift out the specific types of + -- documentation + searchDocs :: Monoid a => (a -> (DocLoc, String) -> a) -> a + searchDocs f = foldl' f mempty $ M.toList docs + + -- Pick out the declaration docs + decl acc ((DeclDoc name), s) = M.insert name (mkHsDocString s) acc + decl acc _ = acc + + -- Pick out the instance docs + insts acc ((InstDoc name), s) = M.insert name (mkHsDocString s) acc + insts acc _ = acc + + -- Pick out the argument docs + args :: Map Name (IntMap HsDocString) + -> (DocLoc, String) + -> Map Name (IntMap HsDocString) + args acc ((ArgDoc name i), s) = + -- Insert the doc for the arg into the argument map for the function. This + -- means we have to search to see if an map already exists for the + -- function, and insert the new argument if it exists, or create a new map + let ds = mkHsDocString s + in M.insertWith (\_ m -> IM.insert i ds m) name (IM.singleton i ds) acc + args acc _ = acc + +-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two +-- maps with values for the same key merge the inner map as well. +-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@. +unionArgMaps :: Map Name (IntMap b) + -> Map Name (IntMap b) + -> Map Name (IntMap b) +unionArgMaps a b = M.foldlWithKey go b a + where + go acc n newArgMap + | Just oldArgMap <- M.lookup n acc = + M.insert n (newArgMap `IM.union` oldArgMap) acc + | otherwise = M.insert n newArgMap acc diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 53f0032f28..323f69f0d3 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -212,7 +212,7 @@ mkIfaceTc hsc_env safe_mode mod_details usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files merged pluginModules - let (doc_hdr', doc_map, arg_map) = extractDocs tc_result + (doc_hdr', doc_map, arg_map) <- extractDocs tc_result let partial_iface = mkIface_ hsc_env this_mod hsc_src diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index c2626ce6b3..fc2f8b8ab3 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -117,9 +117,9 @@ import GHC.Unit.Home.ModInfo import System.Directory import Data.Dynamic import Data.Either +import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (find,intercalate) -import Data.Map (Map) import qualified Data.Map as Map import Control.Monad import Control.Monad.Catch as MC @@ -879,7 +879,7 @@ parseName str = withSession $ \hsc_env -> liftIO $ getDocs :: GhcMonad m => Name - -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)) + -> m (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)) -- TODO: What about docs for constructors etc.? getDocs name = withSession $ \hsc_env -> do @@ -896,7 +896,7 @@ getDocs name = if isNothing mb_doc_hdr && Map.null dmap && Map.null amap then pure (Left (NoDocsInIface mod compiled)) else pure (Right ( Map.lookup name dmap - , Map.findWithDefault Map.empty name amap)) + , Map.findWithDefault mempty name amap)) where compiled = -- TODO: Find a more direct indicator. diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index 109a4416bc..b89f5c8a6c 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -419,7 +419,7 @@ addDocs :: [HoleFit] -> TcM [HoleFit] addDocs fits = do { showDocs <- goptM Opt_ShowDocsOfHoleFits ; if showDocs - then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv + then do { (_, DeclDocMap lclDocs, _) <- getGblEnv >>= extractDocs ; mapM (upd lclDocs) fits } else return fits } where diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 7ae4ccb0f6..89ba997d8a 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -68,6 +68,7 @@ import GHC.Builtin.Names import GHC.Builtin.Types import GHC.ThToHs +import GHC.HsToCore.Docs import GHC.HsToCore.Expr import GHC.HsToCore.Monad import GHC.IfaceToCore @@ -147,6 +148,7 @@ import Data.Maybe import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Dynamic ( fromDynamic, toDyn ) +import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) @@ -1220,6 +1222,148 @@ instance TH.Quasi TcM where qExtsEnabled = EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv + qPutDoc doc_loc s = do + th_doc_var <- tcg_th_docs <$> getGblEnv + resolved_doc_loc <- resolve_loc doc_loc + is_local <- checkLocalName resolved_doc_loc + unless is_local $ failWithTc $ text + "Can't add documentation to" <+> ppr_loc doc_loc <+> + text "as it isn't inside the current module" + updTcRef th_doc_var (Map.insert resolved_doc_loc s) + where + resolve_loc (TH.DeclDoc n) = DeclDoc <$> lookupThName n + resolve_loc (TH.ArgDoc n i) = ArgDoc <$> lookupThName n <*> pure i + resolve_loc (TH.InstDoc t) = InstDoc <$> fmap getName (lookupThInstName t) + resolve_loc TH.ModuleDoc = pure ModuleDoc + + ppr_loc (TH.DeclDoc n) = ppr_th n + ppr_loc (TH.ArgDoc n _) = ppr_th n + ppr_loc (TH.InstDoc t) = ppr_th t + ppr_loc TH.ModuleDoc = text "the module header" + + -- It doesn't make sense to add documentation to something not inside + -- the current module. So check for it! + checkLocalName (DeclDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n + checkLocalName (ArgDoc n _) = nameIsLocalOrFrom <$> getModule <*> pure n + checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n + checkLocalName ModuleDoc = pure True + + + qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc + qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc + qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i + qGetDoc TH.ModuleDoc = do + (moduleDoc, _, _) <- getGblEnv >>= extractDocs + return (fmap unpackHDS moduleDoc) + +-- | Looks up documentation for a declaration in first the current module, +-- otherwise tries to find it in another module via 'hscGetModuleInterface'. +lookupDeclDoc :: Name -> TcM (Maybe String) +lookupDeclDoc nm = do + (_, DeclDocMap declDocs, _) <- getGblEnv >>= extractDocs + fam_insts <- tcg_fam_insts <$> getGblEnv + traceTc "lookupDeclDoc" (ppr nm <+> ppr declDocs <+> ppr fam_insts) + case Map.lookup nm declDocs of + Just doc -> pure $ Just (unpackHDS doc) + Nothing -> do + -- Wasn't in the current module. Try searching other external ones! + mIface <- getExternalModIface nm + case mIface of + Nothing -> pure Nothing + Just ModIface { mi_decl_docs = DeclDocMap dmap } -> + pure $ unpackHDS <$> Map.lookup nm dmap + +-- | Like 'lookupDeclDoc', looks up documentation for a function argument. If +-- it can't find any documentation for a function in this module, it tries to +-- find it in another module. +lookupArgDoc :: Int -> Name -> TcM (Maybe String) +lookupArgDoc i nm = do + (_, _, ArgDocMap argDocs) <- getGblEnv >>= extractDocs + case Map.lookup nm argDocs of + Just m -> pure $ unpackHDS <$> IntMap.lookup i m + Nothing -> do + mIface <- getExternalModIface nm + case mIface of + Nothing -> pure Nothing + Just ModIface { mi_arg_docs = ArgDocMap amap } -> + pure $ unpackHDS <$> (Map.lookup nm amap >>= IntMap.lookup i) + +-- | Returns the module a Name belongs to, if it is isn't local. +getExternalModIface :: Name -> TcM (Maybe ModIface) +getExternalModIface nm = do + isLocal <- nameIsLocalOrFrom <$> getModule <*> pure nm + if isLocal + then pure Nothing + else case nameModule_maybe nm of + Nothing -> pure Nothing + Just modNm -> do + hsc_env <- getTopEnv + iface <- liftIO $ hscGetModuleInterface hsc_env modNm + pure (Just iface) + +-- | Find the GHC name of the first instance that matches the TH type +lookupThInstName :: TH.Type -> TcM Name +lookupThInstName th_type = do + cls_name <- inst_cls_name th_type + insts <- reifyInstances' cls_name (inst_arg_types th_type) + case insts of -- This expands any type synonyms + Left (_, (inst:_)) -> return $ getName inst + Left (_, []) -> noMatches + Right (_, (inst:_)) -> return $ getName inst + Right (_, []) -> noMatches + where + noMatches = failWithTc $ + text "Couldn't find any instances of" + <+> ppr_th th_type + <+> text "to add documentation to" + + -- | Get the name of the class for the instance we are documenting + -- > inst_cls_name (Monad Maybe) == Monad + -- > inst_cls_name C = C + inst_cls_name :: TH.Type -> TcM TH.Name + inst_cls_name (TH.AppT t _) = inst_cls_name t + inst_cls_name (TH.SigT n _) = inst_cls_name n + inst_cls_name (TH.VarT n) = pure n + inst_cls_name (TH.ConT n) = pure n + inst_cls_name (TH.PromotedT n) = pure n + inst_cls_name (TH.InfixT _ n _) = pure n + inst_cls_name (TH.UInfixT _ n _) = pure n + inst_cls_name (TH.ParensT t) = inst_cls_name t + + inst_cls_name (TH.ForallT _ _ _) = inst_cls_name_err + inst_cls_name (TH.ForallVisT _ _) = inst_cls_name_err + inst_cls_name (TH.AppKindT _ _) = inst_cls_name_err + inst_cls_name (TH.TupleT _) = inst_cls_name_err + inst_cls_name (TH.UnboxedTupleT _) = inst_cls_name_err + inst_cls_name (TH.UnboxedSumT _) = inst_cls_name_err + inst_cls_name TH.ArrowT = inst_cls_name_err + inst_cls_name TH.MulArrowT = inst_cls_name_err + inst_cls_name TH.EqualityT = inst_cls_name_err + inst_cls_name TH.ListT = inst_cls_name_err + inst_cls_name (TH.PromotedTupleT _) = inst_cls_name_err + inst_cls_name TH.PromotedNilT = inst_cls_name_err + inst_cls_name TH.PromotedConsT = inst_cls_name_err + inst_cls_name TH.StarT = inst_cls_name_err + inst_cls_name TH.ConstraintT = inst_cls_name_err + inst_cls_name (TH.LitT _) = inst_cls_name_err + inst_cls_name TH.WildCardT = inst_cls_name_err + inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err + + inst_cls_name_err = failWithTc $ + text "Couldn't work out what instance" + <+> ppr_th th_type + <+> text "is supposed to be" + + -- | Basically does the opposite of 'mkThAppTs' + -- > inst_arg_types (Monad Maybe) == [Maybe] + -- > inst_arg_types C == [] + inst_arg_types :: TH.Type -> [TH.Type] + inst_arg_types (TH.AppT _ args) = + let go (TH.AppT t ts) = t:go ts + go t = [t] + in go args + inst_arg_types _ = [] + -- | Adds a mod finalizer reference to the local environment. addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () addModFinalizerRef finRef = do @@ -1411,6 +1555,8 @@ handleTHMessage msg = case msg of AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled + PutDoc l s -> wrapTHResult $ TH.qPutDoc l s + GetDoc l -> wrapTHResult $ TH.qGetDoc l FailIfErrs -> wrapTHResult failIfErrsM _ -> panic ("handleTHMessage: unexpected message " ++ show msg) @@ -1434,6 +1580,19 @@ getAnnotationsByTypeRep th_name tyrep reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] reifyInstances th_nm th_tys + = do { insts <- reifyInstances' th_nm th_tys + ; case insts of + Left (cls, cls_insts) -> + reifyClassInstances cls cls_insts + Right (tc, fam_insts) -> + reifyFamilyInstances tc fam_insts } + +reifyInstances' :: TH.Name + -> [TH.Type] + -> TcM (Either (Class, [ClsInst]) (TyCon, [FamInst])) + -- ^ Returns 'Left' in the case that the instances were found to + -- be class instances, or 'Right' if they are family instances. +reifyInstances' th_nm th_tys = addErrCtxt (text "In the argument of reifyInstances:" <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ do { loc <- getSrcSpanM @@ -1467,19 +1626,19 @@ reifyInstances th_nm th_tys -- In particular, the type might have kind -- variables inside it (#7477) - ; traceTc "reifyInstances" (ppr ty $$ ppr (tcTypeKind ty)) + ; traceTc "reifyInstances'" (ppr ty $$ ppr (tcTypeKind ty)) ; case splitTyConApp_maybe ty of -- This expands any type synonyms Just (tc, tys) -- See #7910 | Just cls <- tyConClass_maybe tc -> do { inst_envs <- tcGetInstEnvs ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys - ; traceTc "reifyInstances1" (ppr matches) - ; reifyClassInstances cls (map fst matches ++ unifies) } + ; traceTc "reifyInstances'1" (ppr matches) + ; return $ Left (cls, map fst matches ++ unifies) } | isOpenFamilyTyCon tc -> do { inst_envs <- tcGetFamInstEnvs ; let matches = lookupFamInstEnv inst_envs tc tys - ; traceTc "reifyInstances2" (ppr matches) - ; reifyFamilyInstances tc (map fim_instance matches) } + ; traceTc "reifyInstances'2" (ppr matches) + ; return $ Right (tc, map fim_instance matches) } _ -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty)) 2 (text "is not a class constraint or type family application")) } where diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 9e9e82bca4..81cf5ea408 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -283,6 +283,14 @@ tcRnModuleTcRnM hsc_env mod_sum tcg_env <- {-# SCC "tcRnImports" #-} tcRnImports hsc_env all_imports + ; -- Don't need to rename the Haddock documentation, + -- it's not parsed by GHC anymore. + -- Make sure to do this before 'tcRnSrcDecls', because we need the + -- module header when we're splicing TH, since it can be accessed via + -- 'getDoc'. + tcg_env <- return (tcg_env + { tcg_doc_hdr = maybe_doc_hdr }) + ; -- If the whole module is warned about or deprecated -- (via mod_deprec) record that in tcg_warns. If we do thereby add -- a WarnAll, it will override any subsequent deprecations added to tcg_warns @@ -320,13 +328,8 @@ tcRnModuleTcRnM hsc_env mod_sum -- because the latter might add new bindings for -- boot_dfuns, which may be mentioned in imported -- unfoldings. - - -- Don't need to rename the Haddock documentation, - -- it's not parsed by GHC anymore. - tcg_env <- return (tcg_env - { tcg_doc_hdr = maybe_doc_hdr }) - ; -- Report unused names - -- Do this /after/ type inference, so that when reporting + -- Report unused names + -- Do this /after/ typeinference, so that when reporting -- a function with no type signature we can give the -- inferred type reportUnusedNames tcg_env hsc_src diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 0003a93169..2c9be13dff 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -55,7 +55,7 @@ module GHC.Tc.Types( ThStage(..), SpliceType(..), PendingStuff(..), topStage, topAnnStage, topSpliceStage, ThLevel, impLevel, outerLevel, thLevel, - ForeignSrcLang(..), + ForeignSrcLang(..), THDocs, DocLoc(..), -- Arrows ArrowCtxt(..), @@ -522,6 +522,9 @@ data TcGblEnv tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))), -- ^ Template Haskell state + tcg_th_docs :: TcRef THDocs, + -- ^ Docs added in Template Haskell via @putDoc@. + tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings -- Things defined in this module, or (in GHCi) @@ -1738,3 +1741,15 @@ lintGblEnv logger dflags tcg_env = liftIO $ lintAxioms logger dflags (text "TcGblEnv axioms") axioms where axioms = typeEnvCoAxioms (tcg_type_env tcg_env) + +-- | This is a mirror of Template Haskell's DocLoc, but the TH names are +-- resolved to GHC names. +data DocLoc = DeclDoc Name + | ArgDoc Name Int + | InstDoc Name + | ModuleDoc + deriving (Eq, Ord) + +-- | The current collection of docs that Template Haskell has built up via +-- putDoc. +type THDocs = Map DocLoc String diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index a3c087c4da..873c9b9fd2 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -257,6 +257,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this th_coreplugins_var <- newIORef [] ; th_state_var <- newIORef Map.empty ; th_remote_state_var <- newIORef Nothing ; + th_docs_var <- newIORef Map.empty ; let { -- bangs to avoid leaking the env (#19356) !dflags = hsc_dflags hsc_env ; @@ -284,6 +285,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_th_coreplugins = th_coreplugins_var, tcg_th_state = th_state_var, tcg_th_remote_state = th_remote_state_var, + tcg_th_docs = th_docs_var, tcg_mod = mod, tcg_semantic_mod = homeModuleInstantiation home_unit mod, diff --git a/docs/users_guide/9.2.1-notes.rst b/docs/users_guide/9.2.1-notes.rst index 3b0022fb8a..131f694f6b 100644 --- a/docs/users_guide/9.2.1-notes.rst +++ b/docs/users_guide/9.2.1-notes.rst @@ -165,6 +165,19 @@ Runtime system is returned is controlled by the :rts-flag:`-Fd ⟨factor⟩`. Memory return is triggered by consecutive idle collections. +Template Haskell +~~~~~~~~~~~~~~~~ + +- There are two new functions ``putDoc`` and ``getDoc``, which allow Haddock + documentation to be attached and read from module headers, declarations, + function arguments, class instances and family instances. + These functions are quite low level, so the ``withDecDoc`` function provides + a more ergonomic interface for this. Similarly ``funD_doc``, ``dataD_doc`` + and friends provide an easy way to document functions and constructors + alongside their arguments simultaneously. :: + + $(withDecsDoc "This does good things" [d| foo x = 42 |]) + ``ghc-prim`` library ~~~~~~~~~~~~~~~~~~~~ diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 2f0dfcde8d..0ac6fe4d9c 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -122,8 +122,8 @@ import Data.List ( elemIndices, find, group, intercalate, intersperse, isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) import qualified Data.Set as S import Data.Maybe -import Data.Map (Map) import qualified Data.Map as M +import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.Time.LocalTime ( getZonedTime ) import Data.Time.Format ( formatTime, defaultTimeLocale ) @@ -1833,7 +1833,7 @@ data DocComponents = DocComponents { docs :: Maybe HsDocString -- ^ subject's haddocks , sigAndLoc :: Maybe SDoc -- ^ type signature + category + location - , argDocs :: Map Int HsDocString -- ^ haddocks for arguments + , argDocs :: IntMap HsDocString -- ^ haddocks for arguments } buildDocComponents :: GHC.GhcMonad m => String -> Name -> m DocComponents diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index d21686a326..1018242210 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -265,6 +265,8 @@ data THMessage a where AddForeignFilePath :: ForeignSrcLang -> FilePath -> THMessage (THResult ()) IsExtEnabled :: Extension -> THMessage (THResult Bool) ExtsEnabled :: THMessage (THResult [Extension]) + PutDoc :: TH.DocLoc -> String -> THMessage (THResult ()) + GetDoc :: TH.DocLoc -> THMessage (THResult (Maybe String)) StartRecover :: THMessage () EndRecover :: Bool -> THMessage () @@ -305,6 +307,8 @@ getTHMessage = do 20 -> THMsg <$> (AddForeignFilePath <$> get <*> get) 21 -> THMsg <$> AddCorePlugin <$> get 22 -> THMsg <$> ReifyType <$> get + 23 -> THMsg <$> (PutDoc <$> get <*> get) + 24 -> THMsg <$> GetDoc <$> get n -> error ("getTHMessage: unknown message " ++ show n) putTHMessage :: THMessage a -> Put @@ -332,6 +336,8 @@ putTHMessage m = case m of AddForeignFilePath lang a -> putWord8 20 >> put lang >> put a AddCorePlugin a -> putWord8 21 >> put a ReifyType a -> putWord8 22 >> put a + PutDoc l s -> putWord8 23 >> put l >> put s + GetDoc l -> putWord8 24 >> put l data EvalOpts = EvalOpts diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs index 56e38c0244..f2325db1e1 100644 --- a/libraries/ghci/GHCi/TH.hs +++ b/libraries/ghci/GHCi/TH.hs @@ -209,6 +209,8 @@ instance TH.Quasi GHCiQ where return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) }) qIsExtEnabled x = ghcCmd (IsExtEnabled x) qExtsEnabled = ghcCmd ExtsEnabled + qPutDoc l s = ghcCmd (PutDoc l s) + qGetDoc l = ghcCmd (GetDoc l) -- | The implementation of the 'StartTH' message: create -- a new IORef QState, and return a RemoteRef to it. diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs index 69326eb9d1..236229a9df 100644 --- a/libraries/ghci/GHCi/TH/Binary.hs +++ b/libraries/ghci/GHCi/TH/Binary.hs @@ -68,6 +68,7 @@ instance Binary TH.FamilyResultSig instance Binary TH.TypeFamilyHead instance Binary TH.PatSynDir instance Binary TH.PatSynArgs +instance Binary TH.DocLoc -- We need Binary TypeRep for serializing annotations diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index 2da2bd61c6..83432c14e3 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -90,6 +90,9 @@ module Language.Haskell.TH( Syntax.Specificity(..), FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, BangType, VarBangType, + -- ** Documentation + putDoc, getDoc, DocLoc(..), + -- * Library functions module Language.Haskell.TH.Lib, diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 3e05081619..de90df2bfd 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -124,7 +124,11 @@ module Language.Haskell.TH.Lib ( implicitParamBindD, -- ** Reify - thisModule + thisModule, + + -- ** Documentation + withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc, dataInstD_doc, + newtypeInstD_doc, patSynD_doc ) where diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index a41d0a47b3..706d4a8c6a 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -981,3 +981,171 @@ thisModule :: Q Module 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/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 3cb5a44ee8..d3c5a5eb45 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -123,6 +123,9 @@ class (MonadIO m, MonadFail m) => Quasi m where qIsExtEnabled :: Extension -> m Bool qExtsEnabled :: m [Extension] + qPutDoc :: DocLoc -> String -> m () + qGetDoc :: DocLoc -> m (Maybe String) + ----------------------------------------------------- -- The IO instance of Quasi -- @@ -161,6 +164,8 @@ instance Quasi IO where qPutQ _ = badIO "putQ" qIsExtEnabled _ = badIO "isExtEnabled" qExtsEnabled = badIO "extsEnabled" + qPutDoc _ _ = badIO "putDoc" + qGetDoc _ = badIO "getDoc" instance Quote IO where newName = newNameIO @@ -745,6 +750,32 @@ isExtEnabled ext = Q (qIsExtEnabled ext) 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 @@ -772,6 +803,8 @@ instance Quasi Q where qPutQ = putQ qIsExtEnabled = isExtEnabled qExtsEnabled = extsEnabled + qPutDoc = putDoc + qGetDoc = getDoc ---------------------------------------------------- @@ -2625,6 +2658,17 @@ constructors): (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/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 6d6e06b8ce..0a570a89ee 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -1,5 +1,13 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) +## 2.18.0.0 + * 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. + ## 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/testsuite/tests/showIface/DocsInHiFileTH.hs b/testsuite/tests/showIface/DocsInHiFileTH.hs new file mode 100644 index 0000000000..73b46c8876 --- /dev/null +++ b/testsuite/tests/showIface/DocsInHiFileTH.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, TypeFamilies, DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses, StandaloneKindSignatures, PolyKinds #-} +{-# LANGUAGE PatternSynonyms #-} + +-- |This is the module header +module DocInHiFilesTH where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import DocsInHiFileTHExternal + +f :: Int +f = 42 + +$(putDoc (DeclDoc 'f) "The meaning of life" >> pure []) + +-- |A data type +data Foo = + -- |A constructor + Foo + +do + Just "A data type" <- getDoc (DeclDoc ''Foo) + Just "A constructor" <- getDoc (DeclDoc 'Foo) + putDoc (DeclDoc ''Foo) "A new data type" + putDoc (DeclDoc 'Foo) "A new constructor" + Just "A new data type" <- getDoc (DeclDoc ''Foo) + Just "A new constructor" <- getDoc (DeclDoc 'Foo) + pure [] + +-- |Some documentation +g :: String +g = "Hello world" + +do + Just "Some documentation" <- getDoc (DeclDoc 'g) + pure [] + +-- Testing module headers + +do + Just "This is the module header" <- getDoc ModuleDoc + putDoc ModuleDoc "This is the new module header" + Just "This is the new module header" <- getDoc ModuleDoc + pure [] + +-- Testing argument documentation + +h :: Int -- ^Your favourite number + -> Bool -- ^Your favourite element in the Boolean algebra + -> String -- ^A return value +h _ _ = "Hello world" + +do + Just "Your favourite number" <- getDoc (ArgDoc 'h 0) + Just "Your favourite element in the Boolean algebra" <- getDoc (ArgDoc 'h 1) + Just "A return value" <- getDoc (ArgDoc 'h 2) + Nothing <- getDoc (ArgDoc 'h 3) + putDoc (ArgDoc 'h 1) "Your least favourite Boolean" + Just "Your least favourite Boolean" <- getDoc (ArgDoc 'h 1) + pure [] + + +-- Testing classes and instances + +-- |A fancy class +class C a where + +-- |A fancy instance +instance C Int where +instance C String where + +class D a where +-- |Another fancy instance +instance D a where + +-- |A type family +type family E a + +-- |A type family instance +type instance E Bool = Int + +i :: E Bool +i = 42 + +do + Just "A fancy class" <- getDoc (DeclDoc ''C) + Just "A fancy instance" <- getDoc . InstDoc =<< [t| C Int |] + Just "Another fancy instance" <- getDoc (InstDoc (AppT (ConT ''D) (VarT (mkName "a")))) + Just "Another fancy instance" <- getDoc (InstDoc (AppT (ConT ''D) (VarT (mkName "b")))) + Nothing <- getDoc . InstDoc =<< [t| C String |] + + putDoc (DeclDoc ''C) "A new class" + putDoc (InstDoc (AppT (ConT ''C) (ConT ''Int))) "A new instance" + putDoc (InstDoc (AppT (ConT ''C) (ConT ''String))) "Another new instance" + putDoc (InstDoc (AppT (ConT ''D) (VarT (mkName "a")))) "Another new instance" + Just "A new class" <- getDoc (DeclDoc ''C) + Just "A new instance" <- getDoc . InstDoc =<< [t| C Int |] + Just "Another new instance" <- getDoc . InstDoc =<< [t| C String |] + Just "Another new instance" <- getDoc (InstDoc (AppT (ConT ''D) (VarT (mkName "a")))) + + Just "A type family" <- getDoc (DeclDoc ''E) + -- Doesn't work just yet. See T18241 + -- https://gitlab.haskell.org/ghc/ghc/issues/18241 + Just "A type family instance" <- getDoc . InstDoc =<< [t| E Bool |] + + pure [] + +-- Testing documentation from external modules +do + Just "This is an external function" <- getDoc (DeclDoc 'externalFunc) + Just "Some integer" <- getDoc (ArgDoc 'externalFunc 0) + + Just "This is an external class" <- getDoc (DeclDoc ''ExternalClass) + Just "This is an external instance" <- + getDoc . InstDoc =<< [t| ExternalClass Int |] + + pure [] + +data family WD11 a +type family WD13 a + +wd8 = () + +class F + +-- Testing combinators + +withDecsDoc "1" [d| wd1 x = () |] +withDecsDoc "2" [d| wd2 = () |] +withDecsDoc "3" [d| data WD3 = WD3 |] +withDecsDoc "4" [d| newtype WD4 = WD4 () |] +withDecsDoc "5" [d| type WD5 = () |] +withDecsDoc "6" [d| class WD6 a where |] +withDecsDoc "7" [d| instance C Foo where |] +do + d <- withDecDoc "8" $ sigD 'wd8 [t| () |] + pure [d] +-- this gives 'Illegal variable name: ‘WD9’' when splicing +-- withDoc "9" [sigD ''WD9 [t| Type -> Type |]] +withDecsDoc "10" [d| data family WD10 a|] +withDecsDoc "11" [d| data instance WD11 Foo = WD11Foo |] +withDecsDoc "12" [d| type family WD12 a |] +withDecsDoc "13" [d| type instance WD13 Foo = Int |] + +-- testing nullary classes here +withDecsDoc "14" [d| instance F |] + +withDecsDoc "15" [d| foreign import ccall "math.h sin" sin :: Double -> Double |] +-- this gives 'Foreign export not (yet) handled by Template Haskell' +-- withDecsDoc "16" [d| foreign export ccall "addInt" (+) :: Int -> Int -> Int |] + +wd17 = 42 + +do + d <- withDecDoc "17" (sigD 'wd17 [t| Int |]) + pure [d] + +do + let nm = mkName "wd18" + d' <- withDecDoc "18" $ sigD nm [t| Int |] + d <- withDecDoc "19" $ valD (varP nm) (normalB [| 42 |]) [] + pure [d, d'] + +-- Doing this to test that wd20 is documented as "20" and not "2020" +withDecsDoc "20" [d| + wd20 :: Int + wd20 = 42 + |] + +do + let defBang = bang noSourceUnpackedness noSourceStrictness + patSynVarName <- newName "a" + sequenceA + [ funD_doc (mkName "qux") [clause [ [p| a |], [p| b |] ] (normalB [e| () |]) []] + (Just "This is qux") [Just "Arg uno", Just "Arg dos"] + + , dataD_doc (cxt []) (mkName "Quux") [] Nothing + [ ( normalC (mkName "Quux1") [bangType defBang (reifyType ''Int)] + , Just "This is Quux1", [Just "I am an integer"]) + , ( normalC (mkName "Quux2") + [ bangType defBang (reifyType ''String) + , bangType defBang (reifyType ''Bool) + ] + , Just "This is Quux2", map Just ["I am a string", "I am a bool"]) + ] [] (Just "This is Quux") + + , dataD_doc (cxt []) (mkName "Quuz") [] Nothing + [ ( recC (mkName "Quuz") [varBangType (mkName "quuz1_a") (bangType defBang (reifyType ''String))] + , Just "This is a record constructor", [Just "This is the record constructor's argument"]) + ] [] (Just "This is a record type") + + , newtypeD_doc (cxt []) (mkName "Corge") [] Nothing + ( recC (mkName ("Corge")) [varBangType (mkName "runCorge") (bangType defBang [t| Int |])] + , Just "This is a newtype record constructor", [Just "This is the newtype record constructor's argument"] + ) [] (Just "This is a record newtype") + + , dataInstD_doc (cxt []) Nothing [t| WD11 Int |] Nothing + [ ( normalC (mkName "WD11Int") [bangType defBang [t| Int |]] + , Just "This is a data instance constructor", [Just "This is a data instance constructor argument"]) + ] [] (Just "This is a data instance") + + , newtypeInstD_doc (cxt []) Nothing [t| WD11 Bool |] Nothing + (normalC (mkName "WD11Bool") [bangType defBang [t| Bool |]] + , Just "This is a newtype instance constructor", [Just "This is a newtype instance constructor argument"]) + [] (Just "This is a newtype instance") + + , patSynD_doc (mkName "Tup2") (prefixPatSyn [patSynVarName]) unidir + [p| ($(varP patSynVarName), $(varP patSynVarName)) |] + (Just "Matches a tuple of (a, a)") [Just "The thing to match twice"] + + , withDecDoc "My cool class" $ do + tyVar <- newName "a" + classD (cxt []) (mkName "Pretty") [plainTV tyVar] [] + [ withDecDoc "Prettily prints the object" $ + sigD (mkName "prettyPrint") [t| $(varT tyVar) -> String |] + ] + ] diff --git a/testsuite/tests/showIface/DocsInHiFileTH.stdout b/testsuite/tests/showIface/DocsInHiFileTH.stdout new file mode 100644 index 0000000000..6951b9a1e5 --- /dev/null +++ b/testsuite/tests/showIface/DocsInHiFileTH.stdout @@ -0,0 +1,118 @@ +module header: + Just "This is the new module header" +declaration docs: + Tup2: + "Matches a tuple of (a, a)" + f: + "The meaning of life" + g: + "Some documentation" + qux: + "This is qux" + sin: + "15" + wd1: + "1" + wd17: + "17" + wd18: + "18" + wd2: + "2" + wd20: + "20" + wd8: + "8" + C: + "A new class" + Corge: + "This is a newtype record constructor" + runCorge: + "This is the newtype record constructor's argument" + E: + "A type family" + Foo: + "A new data type" + Foo: + "A new constructor" + Pretty: + "My cool class" + prettyPrint: + "Prettily prints the object" + Quux: + "This is Quux" + Quux1: + "This is Quux1" + Quux2: + "This is Quux2" + Quuz: + "This is a record constructor" + quuz1_a: + "This is the record constructor's argument" + WD10: + "10" + WD11Bool: + "This is a newtype instance constructor" + WD11Int: + "This is a data instance constructor" + WD12: + "12" + WD3: + "3" + WD4: + "4" + WD5: + "5" + WD6: + "6" + $fCTYPEFoo: + "7" + $fCTYPEInt: + "A new instance" + $fCTYPE[]: + "Another new instance" + $fDka: + "Another new instance" + $fF: + "14" + D:R:EBool: + "A type family instance" + D:R:WD11Bool0: + "This is a newtype instance" + D:R:WD11Foo0: + "11" + D:R:WD11Int0: + "This is a data instance" + D:R:WD13Foo: + "13" +arg docs: + Tup2: + 0: + "The thing to match twice" + h: + 0: + "Your favourite number" + 1: + "Your least favourite Boolean" + 2: + "A return value" + qux: + 0: + "Arg uno" + 1: + "Arg dos" + Quux1: + 0: + "I am an integer" + Quux2: + 0: + "I am a string" + 1: + "I am a bool" + WD11Bool: + 0: + "This is a newtype instance constructor argument" + WD11Int: + 0: + "This is a data instance constructor argument" +extensible fields: diff --git a/testsuite/tests/showIface/DocsInHiFileTHExternal.hs b/testsuite/tests/showIface/DocsInHiFileTHExternal.hs new file mode 100644 index 0000000000..9a1d46b05e --- /dev/null +++ b/testsuite/tests/showIface/DocsInHiFileTHExternal.hs @@ -0,0 +1,12 @@ +module DocsInHiFileTHExternal where + +-- |This is an external function +externalFunc :: Int -- ^Some integer + -> Int -- ^Another integer +externalFunc = const 42 + +-- |This is an external class +class ExternalClass a where + +-- |This is an external instance +instance ExternalClass Int where diff --git a/testsuite/tests/showIface/Makefile b/testsuite/tests/showIface/Makefile index 7eafdfc9d2..c45f38684e 100644 --- a/testsuite/tests/showIface/Makefile +++ b/testsuite/tests/showIface/Makefile @@ -13,3 +13,7 @@ DocsInHiFile0: DocsInHiFile1: '$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock DocsInHiFile.hs '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFile.hi | grep -A 100 'module header:' + +DocsInHiFileTH: + '$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock DocsInHiFileTHExternal.hs DocsInHiFileTH.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFileTH.hi | grep -A 200 'module header:' diff --git a/testsuite/tests/showIface/all.T b/testsuite/tests/showIface/all.T index e2ec264431..a5e5f5f085 100644 --- a/testsuite/tests/showIface/all.T +++ b/testsuite/tests/showIface/all.T @@ -6,3 +6,6 @@ test('DocsInHiFile1', extra_files(['DocsInHiFile.hs']), makefile_test, ['DocsInHiFile1']) test('T17871', [extra_files(['T17871a.hs'])], multimod_compile, ['T17871', '-v0']) +test('DocsInHiFileTH', + extra_files(['DocsInHiFileTHExternal.hs', 'DocsInHiFileTH.hs']), + makefile_test, ['DocsInHiFileTH']) diff --git a/testsuite/tests/showIface/should_fail/THPutDocExternal.hs b/testsuite/tests/showIface/should_fail/THPutDocExternal.hs new file mode 100644 index 0000000000..f9a180af4c --- /dev/null +++ b/testsuite/tests/showIface/should_fail/THPutDocExternal.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module THPutDocExternal where + +import Language.Haskell.TH +import THPutDocExternalA + +putDoc (DeclDoc 'f) "Hello world" >> pure [] diff --git a/testsuite/tests/showIface/should_fail/THPutDocExternal.stderr b/testsuite/tests/showIface/should_fail/THPutDocExternal.stderr new file mode 100644 index 0000000000..3063fe9350 --- /dev/null +++ b/testsuite/tests/showIface/should_fail/THPutDocExternal.stderr @@ -0,0 +1,2 @@ +THPutDocExternal.hs:8:1: + Can't add documentation to THPutDocExternalA.f as it isn't inside the current module diff --git a/testsuite/tests/showIface/should_fail/THPutDocExternalA.hs b/testsuite/tests/showIface/should_fail/THPutDocExternalA.hs new file mode 100644 index 0000000000..694266bbe9 --- /dev/null +++ b/testsuite/tests/showIface/should_fail/THPutDocExternalA.hs @@ -0,0 +1,4 @@ +module THPutDocExternalA where + +f :: Int +f = 42 diff --git a/testsuite/tests/showIface/should_fail/THPutDocNonExistent.hs b/testsuite/tests/showIface/should_fail/THPutDocNonExistent.hs new file mode 100644 index 0000000000..d0b1d7a162 --- /dev/null +++ b/testsuite/tests/showIface/should_fail/THPutDocNonExistent.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + +module THPutDocNonExistent where + +import Language.Haskell.TH + +class A a where +data B + +do + t <- [t| A B |] + putDoc (InstDoc t) "a" + pure [] diff --git a/testsuite/tests/showIface/should_fail/THPutDocNonExistent.stderr b/testsuite/tests/showIface/should_fail/THPutDocNonExistent.stderr new file mode 100644 index 0000000000..ce3a64a1d9 --- /dev/null +++ b/testsuite/tests/showIface/should_fail/THPutDocNonExistent.stderr @@ -0,0 +1,2 @@ +THPutDocNonExistent.hs:10:1: + Couldn't find any instances of THPutDocNonExistent.A THPutDocNonExistent.B to add documentation to diff --git a/testsuite/tests/showIface/should_fail/all.T b/testsuite/tests/showIface/should_fail/all.T new file mode 100644 index 0000000000..0dd8106b81 --- /dev/null +++ b/testsuite/tests/showIface/should_fail/all.T @@ -0,0 +1,9 @@ +test('THPutDocExternal', + normal, + multimod_compile_fail, + ['THPutDocExternal', '-no-hs-main -haddock -c -v0']) + +test('THPutDocNonExistent', + normal, + multimod_compile_fail, + ['THPutDocNonExistent', '-no-hs-main -haddock -c -v0']) diff --git a/utils/haddock b/utils/haddock -Subproject d1bf3e5030ebf0f8f7443b394abb96da2f216eb +Subproject d930bd87cd43d840bf2877e4a51b2a48c2e18f7 |