diff options
42 files changed, 816 insertions, 91 deletions
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 2f3fead184..b987130802 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -60,6 +60,7 @@ import Coverage import Util import MonadUtils import OrdList +import ExtractDocs import Data.List import Data.IORef @@ -183,6 +184,8 @@ deSugar hsc_env ; foreign_files <- readIORef th_foreign_files_var + ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env + ; let mod_guts = ModGuts { mg_module = mod, mg_hsc_src = hsc_src, @@ -209,7 +212,10 @@ deSugar hsc_env mg_modBreaks = modBreaks, mg_safe_haskell = safe_mode, mg_trust_pkg = imp_trust_own_pkg imports, - mg_complete_sigs = complete_matches + mg_complete_sigs = complete_matches, + mg_doc_hdr = doc_hdr, + mg_decl_docs = decl_docs, + mg_arg_docs = arg_docs } ; return (msgs, Just mod_guts) }}}} diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs new file mode 100644 index 0000000000..fc57f98569 --- /dev/null +++ b/compiler/deSugar/ExtractDocs.hs @@ -0,0 +1,344 @@ +-- | Extract docs from the renamer output so they can be be serialized. +{-# language LambdaCase #-} +{-# language TypeFamilies #-} +module ExtractDocs (extractDocs) where + +import GhcPrelude +import Bag +import HsBinds +import HsDoc +import HsDecls +import HsExtension +import HsTypes +import HsUtils +import Name +import NameSet +import SrcLoc +import TcRnTypes + +import Control.Applicative +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Semigroup + +-- | Extract docs from renamer output. +extractDocs :: TcGblEnv + -> (Maybe HsDocString, DeclDocMap, ArgDocMap) + -- ^ + -- 1. Module header + -- 2. Docs on top level declarations + -- 3. Docs on arguments +extractDocs TcGblEnv { tcg_semantic_mod = mod + , tcg_rn_decls = mb_rn_decls + , tcg_insts = insts + , tcg_fam_insts = fam_insts + , tcg_doc_hdr = mb_doc_hdr + } = + (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map) + where + (doc_map, arg_map) = maybe (M.empty, M.empty) + (mkMaps local_insts) + mb_decls_with_docs + mb_decls_with_docs = topDecls <$> mb_rn_decls + local_insts = filter (nameIsLocalOrFrom mod) + $ map getName insts ++ map getName fam_insts + +-- | Create decl and arg doc-maps by looping through the declarations. +-- 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))) +mkMaps instances decls = + ( f' (map (nubByName fst) decls') + , f (filterMapping (not . M.null) args) + ) + where + (decls', args) = unzip (map mappings decls) + + f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b + f = M.fromListWith (<>) . concat + + f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString + f' = M.fromListWith appendDocs . concat + + filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] + filterMapping p = map (filter (p . snd)) + + mappings :: (LHsDecl GhcRn, [HsDocString]) + -> ( [(Name, HsDocString)] + , [(Name, Map Int (HsDocString))] + ) + mappings (L l decl, docStrs) = + (dm, am) + where + doc = concatDocs docStrs + args = declTypeDocs decl + + subs :: [(Name, [(HsDocString)], Map Int (HsDocString))] + subs = subordinates instanceMap decl + + (subDocs, subArgs) = + unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs) + + ns = names l decl + subNs = [ n | (n, _, _) <- subs ] + dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs] + am = [(n, args) | n <- ns] ++ zip subNs subArgs + + instanceMap :: Map SrcSpan Name + instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances] + + names :: SrcSpan -> HsDecl GhcRn -> [Name] + names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See + -- Note [1]. + where loc = case d of + TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only + -- for TFs + _ -> getInstLoc d + names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1]. + names _ decl = getMainDeclBinder decl + +{- +Note [1]: +--------- +We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried +inside them. That should work for normal user-written instances (from +looking at GHC sources). We can assume that commented instances are +user-written. This lets us relate Names (from ClsInsts) to comments +(associated with InstDecls and DerivDecls). +-} + +getMainDeclBinder :: HsDecl pass -> [IdP pass] +getMainDeclBinder (TyClD _ d) = [tcdName d] +getMainDeclBinder (ValD _ d) = + case collectHsBindBinders d of + [] -> [] + (name:_) -> [name] +getMainDeclBinder (SigD _ d) = sigNameNoLoc d +getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] +getMainDeclBinder _ = [] + +sigNameNoLoc :: Sig pass -> [IdP pass] +sigNameNoLoc (TypeSig _ ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns +sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns +sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] +sigNameNoLoc (InlineSig _ n _) = [unLoc n] +sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns +sigNameNoLoc _ = [] + +-- Extract the source location where an instance is defined. This is used +-- to correlate InstDecls with their Instance/CoAxiom Names, via the +-- instanceMap. +getInstLoc :: InstDecl name -> SrcSpan +getInstLoc = \case + ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty) + DataFamInstD _ (DataFamInstDecl + { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l + TyFamInstD _ (TyFamInstDecl + -- Since CoAxioms' Names refer to the whole line for type family instances + -- in particular, we need to dig a bit deeper to pull out the entire + -- equation. This does not happen for data family instances, for some + -- reason. + { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l + ClsInstD _ (XClsInstDecl _) -> error "getInstLoc" + DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" + TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" + XInstDecl _ -> error "getInstLoc" + DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc" + TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc" + +-- | Get all subordinate declarations inside a declaration, and their docs. +-- A subordinate declaration is something like the associate type or data +-- family of a type class. +subordinates :: Map SrcSpan Name + -> HsDecl GhcRn + -> [(Name, [(HsDocString)], Map Int (HsDocString))] +subordinates instMap decl = case decl of + InstD _ (ClsInstD _ d) -> do + DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_tycon = L l _ + , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d + [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn + + InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d }))) + -> dataSubs (feqn_rhs d) + TyClD _ d | isClassDecl d -> classSubs d + | isDataDecl d -> dataSubs (tcdDataDefn d) + _ -> [] + where + classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd + , name <- getMainDeclBinder d, not (isValD d) + ] + dataSubs :: HsDataDefn GhcRn + -> [(Name, [HsDocString], Map Int (HsDocString))] + dataSubs dd = constrs ++ fields ++ derivs + where + cons = map unLoc $ (dd_cons dd) + constrs = [ ( unLoc cname + , maybeToList $ fmap unLoc $ con_doc c + , conArgDocs c) + | c <- cons, cname <- getConNames c ] + fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) + | RecCon flds <- map getConArgs cons + , L _ (ConDeclField _ ns _ doc) <- (unLoc flds) + , L _ n <- ns ] + derivs = [ (instName, [unLoc doc], M.empty) + | HsIB { hsib_body = L l (HsDocTy _ _ doc) } + <- concatMap (unLoc . deriv_clause_tys . unLoc) $ + unLoc $ dd_derivs dd + , Just instName <- [M.lookup l instMap] ] + +-- | Extract constructor argument docs from inside constructor decls. +conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) +conArgDocs con = case getConArgs con of + PrefixCon args -> go 0 (map unLoc args ++ ret) + InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) + RecCon _ -> go 1 ret + where + go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys + go n (_ : tys) = go (n+1) tys + go _ [] = M.empty + + ret = case con of + ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ] + _ -> [] + +isValD :: HsDecl a -> Bool +isValD (ValD _ _) = True +isValD _ = False + +-- | All the sub declarations of a class (that we handle), ordered by +-- source location, with documentation attached if it exists. +classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls + where + decls = docs ++ defs ++ sigs ++ ats + docs = mkDecls tcdDocs (DocD noExt) class_ + defs = mkDecls (bagToList . tcdMeths) (ValD noExt) class_ + sigs = mkDecls tcdSigs (SigD noExt) class_ + ats = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_ + +-- | Extract function argument docs from inside top-level decls. +declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString) +declTypeDocs = \case + SigD _ (TypeSig _ _ ty) -> typeDocs (unLoc (hsSigWcType ty)) + SigD _ (ClassOpSig _ _ _ ty) -> typeDocs (unLoc (hsSigType ty)) + SigD _ (PatSynSig _ _ ty) -> typeDocs (unLoc (hsSigType ty)) + ForD _ (ForeignImport _ _ ty _) -> typeDocs (unLoc (hsSigType ty)) + TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty) + _ -> M.empty + +nubByName :: (a -> Name) -> [a] -> [a] +nubByName f ns = go emptyNameSet ns + where + go _ [] = [] + go s (x:xs) + | y `elemNameSet` s = go s xs + | otherwise = let s' = extendNameSet s y + in x : go s' xs + where + y = f x + +-- | Extract function argument docs from inside types. +typeDocs :: HsType GhcRn -> Map Int (HsDocString) +typeDocs = go 0 + where + go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) + go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) + go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = + M.insert n x $ go (n+1) ty + go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty) + go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc + go _ _ = M.empty + +-- | The top-level declarations of a module that we care about, +-- ordered by source location, with documentation attached if it exists. +topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup + +-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. +ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] +ungroup group_ = + mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt) group_ ++ + mkDecls hs_derivds (DerivD noExt) group_ ++ + mkDecls hs_defds (DefD noExt) group_ ++ + mkDecls hs_fords (ForD noExt) group_ ++ + mkDecls hs_docs (DocD noExt) group_ ++ + mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt) group_ ++ + mkDecls (typesigs . hs_valds) (SigD noExt) group_ ++ + mkDecls (valbinds . hs_valds) (ValD noExt) group_ + where + typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs + typesigs _ = error "expected ValBindsOut" + + valbinds (XValBindsLR (NValBinds binds _)) = + concatMap bagToList . snd . unzip $ binds + valbinds _ = error "expected ValBindsOut" + +-- | Sort by source location +sortByLoc :: [Located a] -> [Located a] +sortByLoc = sortOn getLoc + +-- | Collect docs and attach them to the right declarations. +-- +-- A declaration may have multiple doc strings attached to it. +collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])] +-- ^ This is an example. +collectDocs = go Nothing [] + where + go Nothing _ [] = [] + go (Just prev) docs [] = finished prev docs [] + go prev docs (L _ (DocD _ (DocCommentNext str)) : ds) + | Nothing <- prev = go Nothing (str:docs) ds + | Just decl <- prev = finished decl docs (go Nothing [str] ds) + go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = + go prev (str:docs) ds + go Nothing docs (d:ds) = go (Just d) docs ds + go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) + + finished decl docs rest = (decl, reverse docs) : rest + +-- | Filter out declarations that we don't handle in Haddock +filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] +filterDecls = filter (isHandled . unLoc . fst) + where + isHandled (ForD _ (ForeignImport {})) = True + isHandled (TyClD {}) = True + isHandled (InstD {}) = True + isHandled (DerivD {}) = True + isHandled (SigD _ d) = isUserSig d + isHandled (ValD {}) = True + -- we keep doc declarations to be able to get at named docs + isHandled (DocD {}) = True + isHandled _ = False + + +-- | Go through all class declarations and filter their sub-declarations +filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] +filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x + | x@(L loc d, doc) <- decls ] + where + filterClass (TyClD x c) = + TyClD x $ c { tcdSigs = + filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) } + filterClass _ = error "expected TyClD" + +-- | Was this signature given by the user? +isUserSig :: Sig name -> Bool +isUserSig TypeSig {} = True +isUserSig ClassOpSig {} = True +isUserSig PatSynSig {} = True +isUserSig _ = False + +isClassD :: HsDecl a -> Bool +isClassD (TyClD _ d) = isClassDecl d +isClassD _ = False + +-- | Take a field of declarations from a data structure and create HsDecls +-- using the given constructor +mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] +mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ] diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index a6e6149f9f..8f21f02123 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -310,6 +310,7 @@ Library DsMonad DsUsage DsUtils + ExtractDocs Match MatchCon MatchLit diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs index cbe1d94bec..ed887636a6 100644 --- a/compiler/hsSyn/HsDoc.hs +++ b/compiler/hsSyn/HsDoc.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module HsDoc ( HsDocString @@ -8,33 +10,59 @@ module HsDoc , unpackHDS , hsDocStringToByteString , ppr_mbDoc + + , appendDocs + , concatDocs + + , DeclDocMap(..) + , emptyDeclDocMap + + , ArgDocMap(..) + , emptyArgDocMap ) where #include "HsVersions.h" import GhcPrelude +import Binary import Encoding import FastFunctions +import Name import Outputable import SrcLoc import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Internal as BS import Data.Data +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe import Foreign -- | Haskell Documentation String -- -- Internally this is a UTF8-Encoded 'ByteString'. newtype HsDocString = HsDocString ByteString + -- There are at least two plausible Semigroup instances for this type: + -- + -- 1. Simple string concatenation. + -- 2. Concatenation as documentation paragraphs with newlines in between. + -- + -- To avoid confusion, we pass on defining an instance at all. deriving (Eq, Show, Data) -- | Located Haskell Documentation String type LHsDocString = Located HsDocString +instance Binary HsDocString where + put_ bh (HsDocString bs) = put_ bh bs + get bh = HsDocString <$> get bh + instance Outputable HsDocString where - ppr = text . unpackHDS + ppr = doubleQuotes . text . unpackHDS mkHsDocString :: String -> HsDocString mkHsDocString s = @@ -59,3 +87,63 @@ hsDocStringToByteString (HsDocString bs) = bs ppr_mbDoc :: Maybe LHsDocString -> SDoc ppr_mbDoc (Just doc) = ppr doc ppr_mbDoc Nothing = empty + +-- | Join two docstrings. +-- +-- Non-empty docstrings are joined with two newlines in between, +-- resulting in separate paragraphs. +appendDocs :: HsDocString -> HsDocString -> HsDocString +appendDocs x y = + fromMaybe + (HsDocString BS.empty) + (concatDocs [x, y]) + +-- | Concat docstrings with two newlines in between. +-- +-- Empty docstrings are skipped. +-- +-- If all inputs are empty, 'Nothing' is returned. +concatDocs :: [HsDocString] -> Maybe HsDocString +concatDocs xs = + if BS.null b + then Nothing + else Just (HsDocString b) + where + b = BS.intercalate (C8.pack "\n\n") + . filter (not . BS.null) + . map hsDocStringToByteString + $ xs + +-- | Docs for declarations: functions, data types, instances, methods etc. +newtype DeclDocMap = DeclDocMap (Map Name HsDocString) + +instance Binary DeclDocMap where + put_ bh (DeclDocMap m) = put_ bh (Map.toAscList m) + get bh = DeclDocMap . Map.fromDistinctAscList <$> get bh + +instance Outputable DeclDocMap where + ppr (DeclDocMap m) = vcat (map pprPair (Map.toAscList m)) + where + pprPair (name, doc) = ppr name Outputable.<> colon $$ nest 2 (ppr doc) + +emptyDeclDocMap :: DeclDocMap +emptyDeclDocMap = DeclDocMap Map.empty + +-- | Docs for arguments. E.g. function arguments, method arguments. +newtype ArgDocMap = ArgDocMap (Map Name (Map Int HsDocString)) + +instance Binary ArgDocMap where + put_ bh (ArgDocMap m) = put_ bh (Map.toAscList (Map.toAscList <$> m)) + get bh = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromDistinctAscList + <$> 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)) + pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc) + +emptyArgDocMap :: ArgDocMap +emptyArgDocMap = ArgDocMap Map.empty diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index cc4a4241d5..20928d6ba5 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -1090,6 +1090,9 @@ pprModIface iface , pprTrustInfo (mi_trust iface) , pprTrustPkg (mi_trust_pkg iface) , vcat (map ppr (mi_complete_sigs iface)) + , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface)) + , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface)) + , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface)) ] where pp_hsc_src HsBootFile = text "[boot]" diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 5c6912dca6..8091587c84 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -108,6 +108,7 @@ import Fingerprint import Exception import UniqSet import Packages +import ExtractDocs import Control.Monad import Data.Function @@ -152,12 +153,17 @@ mkIface hsc_env maybe_old_fingerprint mod_details mg_warns = warns, mg_hpc_info = hpc_info, mg_safe_haskell = safe_mode, - mg_trust_pkg = self_trust + mg_trust_pkg = self_trust, + mg_doc_hdr = doc_hdr, + mg_decl_docs = decl_docs, + mg_arg_docs = arg_docs } = mkIface_ hsc_env maybe_old_fingerprint this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust - safe_mode usages mod_details + safe_mode usages + doc_hdr decl_docs arg_docs + mod_details -- | make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any @@ -198,11 +204,16 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details -- module and does not need to be recorded as a dependency. -- See Note [Identity versus semantic module] usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files merged + + let (doc_hdr', doc_map, arg_map) = extractDocs tc_result + mkIface_ hsc_env maybe_old_fingerprint this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info - (imp_trust_own_pkg imports) safe_mode usages mod_details + (imp_trust_own_pkg imports) safe_mode usages + doc_hdr' doc_map arg_map + mod_details @@ -212,11 +223,15 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource -> Bool -> SafeHaskellMode -> [Usage] + -> Maybe HsDocString + -> DeclDocMap + -> ArgDocMap -> ModDetails -> IO (ModIface, Bool) mkIface_ hsc_env maybe_old_fingerprint this_mod hsc_src used_th deps rdr_env fix_env src_warns hpc_info pkg_trust_req safe_mode usages + doc_hdr decl_docs arg_docs ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, @@ -304,7 +319,10 @@ mkIface_ hsc_env maybe_old_fingerprint -- And build the cached values mi_warn_fn = mkIfaceWarnCache warns, mi_fix_fn = mkIfaceFixCache fixities, - mi_complete_sigs = icomplete_sigs } + mi_complete_sigs = icomplete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs } (new_iface, no_change_at_all) <- {-# SCC "versioninfo" #-} diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 49e6c211eb..2b25646d8d 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -132,6 +132,9 @@ module GHC ( ForeignHValue, compileExprRemote, compileParsedExprRemote, + -- ** Docs + getDocs, GetDocsFailure(..), + -- ** Other runTcInteractive, -- Desired by some clients (Trac #8878) isStmt, hasImport, isImport, isDecl, diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 7cb25dfefb..9823c60f70 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -950,7 +950,16 @@ data ModIface -- itself) but imports some trustworthy modules from its own -- package (which does require its own package be trusted). -- See Note [RnNames . Trust Own Package] - mi_complete_sigs :: [IfaceCompleteMatch] + mi_complete_sigs :: [IfaceCompleteMatch], + + mi_doc_hdr :: Maybe HsDocString, + -- ^ Module header. + + mi_decl_docs :: DeclDocMap, + -- ^ Docs on declarations. + + mi_arg_docs :: ArgDocMap + -- ^ Docs on arguments. } -- | Old-style accessor for whether or not the ModIface came from an hs-boot @@ -1028,7 +1037,10 @@ instance Binary ModIface where mi_hpc = hpc_info, mi_trust = trust, mi_trust_pkg = trust_pkg, - mi_complete_sigs = complete_sigs }) = do + mi_complete_sigs = complete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs }) = do put_ bh mod put_ bh sig_of put_ bh hsc_src @@ -1057,6 +1069,9 @@ instance Binary ModIface where put_ bh trust put_ bh trust_pkg put_ bh complete_sigs + lazyPut bh doc_hdr + lazyPut bh decl_docs + lazyPut bh arg_docs get bh = do mod <- get bh @@ -1087,6 +1102,9 @@ instance Binary ModIface where trust <- get bh trust_pkg <- get bh complete_sigs <- get bh + doc_hdr <- lazyGet bh + decl_docs <- lazyGet bh + arg_docs <- lazyGet bh return (ModIface { mi_module = mod, mi_sig_of = sig_of, @@ -1120,7 +1138,10 @@ instance Binary ModIface where mi_warn_fn = mkIfaceWarnCache warns, mi_fix_fn = mkIfaceFixCache fixities, mi_hash_fn = mkIfaceHashCache decls, - mi_complete_sigs = complete_sigs }) + mi_complete_sigs = complete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs }) -- | The original names declared of a certain module that are exported type IfaceExport = AvailInfo @@ -1159,7 +1180,10 @@ emptyModIface mod mi_hpc = False, mi_trust = noIfaceTrustInfo, mi_trust_pkg = False, - mi_complete_sigs = [] } + mi_complete_sigs = [], + mi_doc_hdr = Nothing, + mi_decl_docs = emptyDeclDocMap, + mi_arg_docs = emptyArgDocMap } -- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' @@ -1284,9 +1308,13 @@ data ModGuts -- one); c.f. 'tcg_fam_inst_env' mg_safe_haskell :: SafeHaskellMode, -- ^ Safe Haskell mode - mg_trust_pkg :: Bool -- ^ Do we need to trust our + mg_trust_pkg :: Bool, -- ^ Do we need to trust our -- own package for Safe Haskell? -- See Note [RnNames . Trust Own Package] + + mg_doc_hdr :: !(Maybe HsDocString), -- ^ Module header. + mg_decl_docs :: !DeclDocMap, -- ^ Docs on declarations. + mg_arg_docs :: !ArgDocMap -- ^ Docs on arguments. } -- The ModGuts takes on several slightly different forms: diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 163bb8de3f..3f2309e7f5 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -30,6 +30,8 @@ module InteractiveEval ( exprType, typeKind, parseName, + getDocs, + GetDocsFailure(..), showModule, moduleIsBootOrNotObjectLinkable, parseExpr, compileParsedExpr, @@ -91,6 +93,8 @@ import Data.Dynamic import Data.Either import qualified Data.IntMap as IntMap import Data.List (find,intercalate) +import Data.Map (Map) +import qualified Data.Map as Map import StringBuffer (stringToStringBuffer) import Control.Monad import GHC.Exts @@ -821,6 +825,70 @@ parseThing parser dflags stmt = do Lexer.unP parser (Lexer.mkPState dflags buf loc) +getDocs :: GhcMonad m + => Name + -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)) + -- TODO: What about docs for constructors etc.? +getDocs name = + withSession $ \hsc_env -> do + case nameModule_maybe name of + Nothing -> pure (Left (NameHasNoModule name)) + Just mod -> do + if isInteractiveModule mod + then pure (Left InteractiveName) + else do + ModIface { mi_doc_hdr = mb_doc_hdr + , mi_decl_docs = DeclDocMap dmap + , mi_arg_docs = ArgDocMap amap + } <- liftIO $ hscGetModuleInterface hsc_env mod + 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)) + where + compiled = + -- TODO: Find a more direct indicator. + case nameSrcLoc name of + RealSrcLoc {} -> False + UnhelpfulLoc {} -> True + +-- | Failure modes for 'getDocs'. + +-- TODO: Find a way to differentiate between modules loaded without '-haddock' +-- and modules that contain no docs. +data GetDocsFailure + + -- | 'nameModule_maybe' returned 'Nothing'. + = NameHasNoModule Name + + -- | This is probably because the module was loaded without @-haddock@, + -- but it's also possible that the entire module contains no documentation. + | NoDocsInIface + Module + Bool -- ^ 'True': The module was compiled. + -- 'False': The module was :loaded. + + -- | The 'Name' was defined interactively. + | InteractiveName + +instance Outputable GetDocsFailure where + ppr (NameHasNoModule name) = + quotes (ppr name) <+> text "has no module where we could look for docs." + ppr (NoDocsInIface mod compiled) = vcat + [ text "Can't find any documentation for" <+> ppr mod <> char '.' + , text "This is probably because the module was" + <+> text (if compiled then "compiled" else "loaded") + <+> text "without '-haddock'," + , text "but it's also possible that the module contains no documentation." + , text "" + , if compiled + then text "Try re-compiling with '-haddock'." + else text "Try running ':set -haddock' and :load the file again." + -- TODO: Figure out why :reload doesn't load the docs and maybe fix it. + ] + ppr InteractiveName = + text "Docs are unavailable for interactive declarations." + -- ----------------------------------------------------------------------------- -- Getting the type of an expression diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index a68d0f504a..26f549b3fc 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -234,6 +234,12 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this maybe_rn_syntax :: forall a. a -> Maybe a ; maybe_rn_syntax empty_val | dopt Opt_D_dump_rn_ast dflags = Just empty_val + + -- We want to serialize the documentation in the .hi-files, + -- and need to extract it from the renamed syntax first. + -- See 'ExtractDocs.extractDocs'. + | gopt Opt_Haddock dflags = Just empty_val + | keep_rn_syntax = Just empty_val | otherwise = Nothing ; diff --git a/docs/users_guide/8.6.1-notes.rst b/docs/users_guide/8.6.1-notes.rst index 2b3fd9b463..fc2b1d2cfd 100644 --- a/docs/users_guide/8.6.1-notes.rst +++ b/docs/users_guide/8.6.1-notes.rst @@ -118,6 +118,12 @@ Compiler :ghc-flag:`-fexternal-dynamic-refs`. If you don't know why you might need this, you don't need it. +GHCi +~~~~ + +- Added an experimental :ghci-cmd:`:doc` command that displays the + documentation for a declaration. + Runtime system ~~~~~~~~~~~~~~ diff --git a/docs/users_guide/ghci.rst b/docs/users_guide/ghci.rst index a5f5764a9e..49a96caa0b 100644 --- a/docs/users_guide/ghci.rst +++ b/docs/users_guide/ghci.rst @@ -2374,6 +2374,14 @@ commonly used commands. see the number of each breakpoint). The ``*`` form deletes all the breakpoints. +.. ghci-cmd:: :doc; ⟨name⟩ + + (Experimental: This command will likely change significantly in GHC 8.8.) + + Displays the documentation for the given name. Currently the command is + restricted to displaying the documentation directly on the declaration + in question, ignoring documentation for arguments, constructors etc. + .. ghci-cmd:: :edit; ⟨file⟩ Opens an editor to edit the file ⟨file⟩, or the most recently loaded diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 67f2cbb147..7c427a03a8 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -48,6 +48,7 @@ import GhcMonad ( modifySession ) import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, + GetDocsFailure(..), getModuleGraph, handleSourceError ) import HsImpExp import HsSyn @@ -99,6 +100,7 @@ import Data.List ( find, group, intercalate, intersperse, isPrefixOf, 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.Time.LocalTime ( getZonedTime ) import Data.Time.Format ( formatTime, defaultTimeLocale ) @@ -179,6 +181,7 @@ ghciCommands = map mkCmd [ ("def", keepGoing (defineMacro False), completeExpression), ("def!", keepGoing (defineMacro True), completeExpression), ("delete", keepGoing deleteCmd, noCompletion), + ("doc", keepGoing' docCmd, completeIdentifier), ("edit", keepGoing' editFile, completeFilename), ("etags", keepGoing createETagsFileCmd, completeFilename), ("force", keepGoing forceCmd, completeExpression), @@ -288,6 +291,7 @@ defFullHelpText = " (!: use regex instead of line number)\n" ++ " :def <cmd> <expr> define command :<cmd> (later defined command has\n" ++ " precedence, ::<cmd> is always a builtin command)\n" ++ + " :doc <name> display docs for the given name (experimental)\n" ++ " :edit <file> edit file\n" ++ " :edit edit last module\n" ++ " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" ++ @@ -1604,6 +1608,38 @@ checkModule m = do return True afterLoad (successIf ok) False +----------------------------------------------------------------------------- +-- :doc + +docCmd :: String -> InputT GHCi () +docCmd "" = + throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'") +docCmd s = do + -- TODO: Maybe also get module headers for module names + names <- GHC.parseName s + e_docss <- mapM GHC.getDocs names + sdocs <- mapM (either handleGetDocsFailure (pure . pprDocs)) e_docss + let sdocs' = vcat (intersperse (text "") sdocs) + unqual <- GHC.getPrintUnqual + dflags <- getDynFlags + (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs' + +-- TODO: also print arg docs. +pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc +pprDocs (mb_decl_docs, _arg_docs) = + maybe + (text "<has no documentation>") + (text . unpackHDS) + mb_decl_docs + +handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc +handleGetDocsFailure no_docs = do + dflags <- getDynFlags + let msg = showPpr dflags no_docs + throwGhcException $ case no_docs of + NameHasNoModule {} -> Sorry msg + NoDocsInIface {} -> InstallationError msg + InteractiveName -> ProgramError msg ----------------------------------------------------------------------------- -- :load, :add, :reload diff --git a/mk/config.mk.in b/mk/config.mk.in index 92830fa1e8..6ff8e0ee7d 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -311,8 +311,11 @@ GhcThreaded = $(if $(findstring thr,$(GhcRTSWays)),YES,NO) # # -O(2) is pretty desirable, otherwise no inlining of prelude # things (incl "+") happens when compiling with this compiler +# +# -haddock is needed so the GHCi :doc command can find the boot +# library docs in the respective .hi-files -GhcLibHcOpts=-O2 +GhcLibHcOpts=-O2 -haddock # Strip local symbols from libraries? This can make the libraries smaller, # but makes debugging somewhat more difficult. Doesn't work with all ld's. diff --git a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr index 8f06390348..d230d58eaa 100644 --- a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr +++ b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr @@ -17,7 +17,7 @@ visible a = a [3 of 3] Compiling Test ( Test.hs, Test.o ) ==================== Parser ==================== - +" Module : Test Copyright : (c) Simon Marlow 2002 License : BSD-style @@ -28,63 +28,65 @@ visible a = a This module illustrates & tests most of the features of Haddock. Testing references from the description: 'T', 'f', 'g', 'Visible.visible'. - +" module Test ( <IEGroup: 1>, <IEGroup: 2>, T(..), T2, T3(..), T4(..), T5(..), T6(..), N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..), <IEGroup: 2>, R(..), R1(..), - test that we can export record selectors on their own:, p, q, u, + " test that we can export record selectors on their own:", p, q, u, <IEGroup: 1>, C(a, b), D(..), E, F(..), - Test that we can export a class method on its own:, a, + " Test that we can export a class method on its own:", a, <IEGroup: 1>, f, g, <IEGroup: 1>, <IEDocNamed: aux1>, <IEDocNamed: aux2>, <IEDocNamed: aux3>, <IEDocNamed: aux4>, <IEDocNamed: aux5>, <IEDocNamed: aux6>, <IEDocNamed: aux7>, <IEDocNamed: aux8>, <IEDocNamed: aux9>, <IEDocNamed: aux10>, <IEDocNamed: aux11>, <IEDocNamed: aux12>, - This is some inline documentation in the export list + " This is some inline documentation in the export list > a code block using bird-tracks > each line must begin with > (which isn't significant unless it - > is at the beginning of the line)., + > is at the beginning of the line).", <IEGroup: 1>, module Hidden, <IEGroup: 1>, module Visible, - nested-style doc comments , <IEGroup: 1>, Ex(..), <IEGroup: 1>, k, - l, m, o, <IEGroup: 1>, <IEGroup: 2>, - + " nested-style doc comments ", <IEGroup: 1>, Ex(..), <IEGroup: 1>, + k, l, m, o, <IEGroup: 1>, <IEGroup: 2>, + " > a literal line $ a non /literal/ line $ -, f' +", f' ) where import Hidden import Visible <document comment> data T a b - = This comment describes the 'A' constructor A Int (Maybe Float) | - This comment describes the 'B' constructor B (T a b, T Int Float) + = " This comment describes the 'A' constructor" + A Int (Maybe Float) | + " This comment describes the 'B' constructor" + B (T a b, T Int Float) <document comment> data T2 a b = T2 a b <document comment> data T3 a b = A1 a | B1 b data T4 a b = A2 a | B2 b -data T5 a b = documents 'A3' A3 a | documents 'B3' B3 b +data T5 a b = " documents 'A3'" A3 a | " documents 'B3'" B3 b <document comment> data T6 - = This is the doc for 'A4' A4 | - This is the doc for 'B4' B4 | - This is the doc for 'C4' C4 + = " This is the doc for 'A4'" A4 | + " This is the doc for 'B4'" B4 | + " This is the doc for 'C4'" C4 <document comment> newtype N1 a = N1 a <document comment> newtype N2 a b = N2 {n :: a b} <document comment> -newtype N3 a b = N3 {n3 :: a b this is the 'n3' field} +newtype N3 a b = N3 {n3 :: a b " this is the 'n3' field"} <document comment> newtype N4 a b = N4 a newtype N5 a b - = N5 {n5 :: a b no docs on the datatype or the constructor} -newtype N6 a b = docs on the constructor only N6 {n6 :: a b} + = N5 {n5 :: a b " no docs on the datatype or the constructor"} +newtype N6 a b = " docs on the constructor only" N6 {n6 :: a b} <document comment> -newtype N7 a b = The 'N7' constructor N7 {n7 :: a b} +newtype N7 a b = " The 'N7' constructor" N7 {n7 :: a b} class (D a) => C a where a :: IO a b :: [a] @@ -107,20 +109,20 @@ class F a where ff :: a <document comment> data R - = This is the 'C1' record constructor, with the following fields: - C1 {p :: Int This comment applies to the 'p' field, - q :: forall a. a -> a This comment applies to the 'q' field, - r, s :: Int This comment applies to both 'r' and 's'} | - This is the 'C2' record constructor, also with some fields: + = " This is the 'C1' record constructor, with the following fields:" + C1 {p :: Int " This comment applies to the 'p' field", + q :: forall a. a -> a " This comment applies to the 'q' field", + r, s :: Int " This comment applies to both 'r' and 's'"} | + " This is the 'C2' record constructor, also with some fields:" C2 {t :: T1 -> (T2 Int Int) -> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (), u, v :: Int} <document comment> data R1 - = This is the 'C3' record constructor - C3 {s1 :: Int The 's1' record selector, - s2 :: Int The 's2' record selector, - s3 :: Int The 's3' record selector} + = " This is the 'C3' record constructor" + C3 {s1 :: Int " The 's1' record selector", + s2 :: Int " The 's2' record selector", + s3 :: Int " The 's3' record selector"} <document comment> <document comment> <document comment> @@ -151,26 +153,27 @@ data Ex a Ex4 (forall a. a -> a) <document comment> k :: - T () () This argument has type 'T' - -> (T2 Int Int) This argument has type 'T2 Int Int' + T () () " This argument has type 'T'" + -> (T2 Int Int) " This argument has type 'T2 Int Int'" -> (T3 Bool Bool - -> T4 Float Float) This argument has type @T3 Bool Bool -> T4 Float Float@ - -> T5 () () This argument has a very long description that should + -> T4 Float Float) " This argument has type @T3 Bool Bool -> T4 Float Float@" + -> T5 () () " This argument has a very long description that should hopefully cause some wrapping to happen when it is finally - rendered by Haddock in the generated HTML page. - -> IO () This is the result type -l :: (Int, Int, Float) takes a triple -> Int returns an 'Int' + rendered by Haddock in the generated HTML page." + -> IO () " This is the result type" +l :: (Int, Int, Float) " takes a triple" -> Int " returns an 'Int'" <document comment> m :: - R -> N1 () one of the arguments -> IO Int and the return value + R + -> N1 () " one of the arguments" -> IO Int " and the return value" <document comment> newn :: - R one of the arguments, an 'R' - -> N1 () one of the arguments -> IO Int + R " one of the arguments, an 'R'" + -> N1 () " one of the arguments" -> IO Int newn = undefined <document comment> foreign import ccall unsafe "header.h" o - :: Float The input float -> IO Float The output float + :: Float " The input float" -> IO Float " The output float" <document comment> newp :: Int newp = undefined diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr index 060dd06ad2..997c2ef24c 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr @@ -3,10 +3,10 @@ module T11768 where data Foo = Foo - deriving Eq Documenting a single type + deriving Eq " Documenting a single type" data Bar = Bar - deriving (Eq Documenting one of multiple types, Ord) + deriving (Eq " Documenting one of multiple types", Ord) <document comment> deriving instance Read Bar diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA014.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA014.stderr index a70f624278..f55f8afab1 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA014.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA014.stderr @@ -1,6 +1,6 @@ ==================== Parser ==================== - a header +" a header" module HeaderTest where <document comment> x = 0 diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA015.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA015.stderr index 3bfc17d811..15adf3e54e 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA015.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA015.stderr @@ -1,6 +1,6 @@ ==================== Parser ==================== - a header +" a header" module HeaderTest where <document comment> x = 0 diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA016.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA016.stderr index 48dd0870c9..e9ccec44a0 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA016.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA016.stderr @@ -1,6 +1,6 @@ ==================== Parser ==================== -Module description +"Module description" module A where diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA018.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA018.stderr index 2aa5245f50..357f7540e2 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA018.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA018.stderr @@ -1,6 +1,6 @@ ==================== Parser ==================== - module header bla bla +" module header bla bla " module A where diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA019.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA019.stderr index ca316bc8b8..c7a34730d9 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA019.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA019.stderr @@ -1,7 +1,7 @@ ==================== Parser ==================== module A ( - bla bla, blabla + " bla bla", " blabla " ) where diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA020.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA020.stderr index 2aaa3eba98..660b28036e 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA020.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA020.stderr @@ -1,7 +1,7 @@ ==================== Parser ==================== module A ( - bla bla, blabla , x, <IEGroup: 2>, qweljqwelkqjwelqjkq + " bla bla", " blabla ", x, <IEGroup: 2>, " qweljqwelkqjwelqjkq" ) where x = True diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA021.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA021.stderr index 162c403b84..befbee45f9 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA021.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA021.stderr @@ -1,8 +1,8 @@ ==================== Parser ==================== module A ( - bla bla, blabla , x, <IEGroup: 2>, qweljqwelkqjwelqjkq, y, - dkashdakj, z, <IEGroup: 1> + " bla bla", " blabla ", x, <IEGroup: 2>, " qweljqwelkqjwelqjkq", y, + " dkashdakj", z, <IEGroup: 1> ) where x = True y = False diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr index fcb953a495..d04558c301 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr @@ -1,7 +1,7 @@ ==================== Parser ==================== module ShouldCompile where -test :: (Eq a) => [a] doc1 -> [a] doc2 -> [a] doc3 +test :: (Eq a) => [a] " doc1" -> [a] " doc2 " -> [a] " doc3" test xs ys = xs diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr index 9f57f5df07..c453e071a3 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr @@ -1,7 +1,7 @@ ==================== Parser ==================== module ShouldCompile where -test2 :: a doc1 -> b doc2 -> a doc 3 +test2 :: a " doc1 " -> b " doc2 " -> a " doc 3 " test2 x y = x diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr index 472ec1a1eb..e0b8a4a7bf 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr @@ -1,7 +1,7 @@ ==================== Parser ==================== module ShouldCompile where -test2 :: a doc1 -> a +test2 :: a " doc1 " -> a test2 x = x diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr index 5f7335b6b9..37135099a0 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr @@ -2,7 +2,7 @@ ==================== Parser ==================== module ShouldCompile where test :: - (Eq a) => [a] doc1 -> forall b. [b] doc2 -> [a] doc3 + (Eq a) => [a] " doc1" -> forall b. [b] " doc2 " -> [a] " doc3" test xs ys = xs diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr index e7707c5ec0..0bbb612119 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr @@ -2,9 +2,9 @@ ==================== Parser ==================== module ShouldCompile where test :: - [a] doc1 + [a] " doc1" -> forall b. - (Ord b) => [b] doc2 -> forall c. (Num c) => [c] doc3 -> [a] + (Ord b) => [b] " doc2 " -> forall c. (Num c) => [c] " doc3" -> [a] test xs ys zs = xs diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr index 47d2468ea5..3c1bbc9565 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr @@ -2,7 +2,7 @@ ==================== Parser ==================== module ShouldCompile where data a <--> b = Mk a b -test :: [a] doc1 -> a <--> b -> [a] blabla +test :: [a] " doc1 " -> a <--> b -> [a] " blabla" test xs ys = xs diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA029.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA029.stderr index 820ffa6708..7271238e3e 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA029.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA029.stderr @@ -2,6 +2,6 @@ ==================== Parser ==================== module ShouldCompile where data A - = A comment that documents the first constructor A | B | C | D + = " A comment that documents the first constructor" A | B | C | D diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr index b0ef139199..e09cfa2187 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr @@ -2,6 +2,9 @@ ==================== Parser ==================== module ShouldCompile where data A - = comment for A A | comment for B B | comment for C C | D + = " comment for A " A | + " comment for B " B | + " comment for C " C | + D diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA031.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA031.stderr index 1d033cd6d7..eb6fcaef1e 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA031.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA031.stderr @@ -3,7 +3,7 @@ module ShouldCompile where data A = A | - comment for B forall a. B a a | - comment for C forall a. Num a => C a + " comment for B " forall a. B a a | + " comment for C " forall a. Num a => C a diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA032.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA032.stderr index 5cf2d9b034..eec30285f5 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA032.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA032.stderr @@ -3,8 +3,8 @@ module ShouldCompile where data R a = R {field1 :: a, - field2 :: a comment for field2, - field3 :: a comment for field3, - field4 :: a comment for field4 } + field2 :: a " comment for field2", + field3 :: a " comment for field3", + field4 :: a " comment for field4 "} diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr index f743393349..64478fed12 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr @@ -2,4 +2,6 @@ ==================== Parser ==================== module Hi where <document comment> -data Hi where This is a GADT constructor. Hi :: () -> Hi +data Hi where " This is a GADT constructor." Hi :: () -> Hi + + diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA035.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA035.stderr index d0e5bbc57d..3f12a0cffd 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA035.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA035.stderr @@ -3,7 +3,9 @@ module Hi where data Hi where - Hi :: () This is a comment on the '()' field of 'Hi' - -> Int - -> String This is a comment on the 'String' field of 'Hi' - -> Hi This is a comment on the return type of 'Hi' + Hi :: () " This is a comment on the '()' field of 'Hi'" + -> Int + -> String " This is a comment on the 'String' field of 'Hi'" + -> Hi " This is a comment on the return type of 'Hi'" + + diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA036.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA036.stderr index 0d884ab0e3..5cd0a59a05 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA036.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA036.stderr @@ -2,11 +2,13 @@ ==================== Parser ==================== module ConstructorFields where data Foo - = doc on `Bar` constructor Bar Int String | - doc on the `Baz` constructor - Baz Int doc on the `Int` field of `Baz` String doc on the `String` field of `Baz` | - doc on the `:+` constructor Int :+ String | - doc on the `:*` constructor - Int doc on the `Int` field of the `:*` constructor :* String doc on the `String` field of the `:*` constructor | - doc on the `Boo` record constructor Boo {x :: ()} | - doc on the `Boa` record constructor Boa {y :: ()} + = " doc on `Bar` constructor" Bar Int String | + " doc on the `Baz` constructor" + Baz Int " doc on the `Int` field of `Baz`" String " doc on the `String` field of `Baz`" | + " doc on the `:+` constructor" Int :+ String | + " doc on the `:*` constructor" + Int " doc on the `Int` field of the `:*` constructor" :* String " doc on the `String` field of the `:*` constructor" | + " doc on the `Boo` record constructor" Boo {x :: ()} | + " doc on the `Boa` record constructor" Boa {y :: ()} + + diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA037.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA037.stderr index 8e90efa691..b9ecfa6303 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA037.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA037.stderr @@ -4,4 +4,6 @@ module UnamedConstructorFields where data A = A data B = B data C = C -data Foo = MkFoo A 'A' has a comment B C 'C' has a comment +data Foo = MkFoo A " 'A' has a comment" B C " 'C' has a comment" + + diff --git a/testsuite/tests/showIface/DocsInHiFile.hs b/testsuite/tests/showIface/DocsInHiFile.hs new file mode 100644 index 0000000000..26156722ac --- /dev/null +++ b/testsuite/tests/showIface/DocsInHiFile.hs @@ -0,0 +1,37 @@ +{-| `elem`, 'print', +`Unknown', +'<>', ':=:', 'Bool' +-} +module DocsInHiFile + ( DocsInHiFile.elem + , D(..) + , add + , P(..) + , Show(..) + ) where + +-- | '()', 'elem'. +elem :: () +elem = () + +-- | A datatype. +data D + = D0 -- ^ A constructor for 'D'. ' + | D1 -- ^ Another constructor + deriving ( Show -- ^ 'Show' instance + ) + +add :: Int -- ^ First summand for 'add' + -> Int -- ^ Second summand + -> Int -- ^ Sum +add a b = a + b + +-- | A class +class P f where + -- | A class method + p :: a -- ^ An argument + -> f a + +-- | Another datatype... +data D' +-- ^ ...with two docstrings. diff --git a/testsuite/tests/showIface/DocsInHiFile0.stdout b/testsuite/tests/showIface/DocsInHiFile0.stdout new file mode 100644 index 0000000000..e1c32d63c8 --- /dev/null +++ b/testsuite/tests/showIface/DocsInHiFile0.stdout @@ -0,0 +1,4 @@ +module header: + Nothing +declaration docs: +arg docs: diff --git a/testsuite/tests/showIface/DocsInHiFile1.stdout b/testsuite/tests/showIface/DocsInHiFile1.stdout new file mode 100644 index 0000000000..fcb5f94f71 --- /dev/null +++ b/testsuite/tests/showIface/DocsInHiFile1.stdout @@ -0,0 +1,36 @@ +module header: + Just " `elem`, 'print', +`Unknown', +'<>', ':=:', 'Bool' +" +declaration docs: + D': + " Another datatype... + + ...with two docstrings." + P: + " A class" + p: + " A class method" + D: + " A datatype." + D0: + " A constructor for 'D'. '" + D1: + " Another constructor" + elem: + " '()', 'elem'." + $fShowD: + " 'Show' instance" +arg docs: + p: + 0: + " An argument" + add: + 0: + " First summand for 'add'" + 1: + " Second summand" + 2: + " Sum" + diff --git a/testsuite/tests/showIface/Makefile b/testsuite/tests/showIface/Makefile index 49b90342b3..7eafdfc9d2 100644 --- a/testsuite/tests/showIface/Makefile +++ b/testsuite/tests/showIface/Makefile @@ -5,3 +5,11 @@ include $(TOP)/mk/test.mk Orphans: '$(TEST_HC)' $(TEST_HC_OPTS) -c Orphans.hs '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface Orphans.hi | grep -E '^(instance |family instance |"myrule)' | grep -v 'family instance modules:' + +DocsInHiFile0: + '$(TEST_HC)' $(TEST_HC_OPTS) -c DocsInHiFile.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFile.hi | grep -A 4 'module header:' + +DocsInHiFile1: + '$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock DocsInHiFile.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFile.hi | grep -A 100 'module header:' diff --git a/testsuite/tests/showIface/all.T b/testsuite/tests/showIface/all.T index 5c89b70b59..df5d5cd9ec 100644 --- a/testsuite/tests/showIface/all.T +++ b/testsuite/tests/showIface/all.T @@ -1 +1,9 @@ test('Orphans', normal, run_command, ['$MAKE -s --no-print-directory Orphans']) +test('DocsInHiFile0', + extra_files(['DocsInHiFile.hs']), + run_command, + ['$MAKE -s --no-print-directory DocsInHiFile0']) +test('DocsInHiFile1', + extra_files(['DocsInHiFile.hs']), + run_command, + ['$MAKE -s --no-print-directory DocsInHiFile1']) |