module GHC.HsToCore.Docs where
import GHC.Prelude
import GHC.Data.Bag
import GHC.Hs.Binds
import GHC.Hs.Doc
import GHC.Hs.Decls
import Language.Haskell.Syntax.Extension
import GHC.Hs.Extension
import GHC.Hs.Type
import GHC.Hs.Utils
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Tc.Types
import GHC.Parser.Annotation
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.Strict (Map)
import qualified Data.Map as M
import qualified Data.Set as Set
import Data.Maybe
import Data.Semigroup
import GHC.IORef (readIORef)
import GHC.Unit.Types
import GHC.Hs
import GHC.Types.Avail
import GHC.Unit.Module
import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty ((:|)))
import GHC.Unit.Module.Imported
import GHC.Driver.Session
import GHC.Types.TypeEnv
import GHC.Types.Id
import GHC.Types.Unique.Map
extractDocs :: MonadIO m
=> DynFlags -> TcGblEnv
-> m (Maybe Docs)
extractDocs dflags
TcGblEnv { tcg_semantic_mod = semantic_mdl
, tcg_mod = mdl
, tcg_rn_decls = Just rn_decls
, tcg_rn_exports = mb_rn_exports
, tcg_exports = all_exports
, tcg_imports = import_avails
, tcg_insts = insts
, tcg_fam_insts = fam_insts
, tcg_doc_hdr = mb_doc_hdr
, tcg_th_docs = th_docs_var
, tcg_type_env = ty_env
} = do
th_docs <- liftIO $ readIORef th_docs_var
let doc_hdr = (unLoc <$> mb_doc_hdr)
ExtractedTHDocs th_hdr th_decl_docs th_arg_docs th_inst_docs = extractTHDocs th_docs
mod_docs
= Docs
{ docs_mod_hdr = th_hdr <|> doc_hdr
, docs_decls = plusUniqMap_C (\a _ -> a)
((:[]) <$> th_decl_docs `plusUniqMap` th_inst_docs)
doc_map
, docs_args = th_arg_docs `unionArgMaps` arg_map
, docs_structure = doc_structure
, docs_named_chunks = named_chunks
, docs_haddock_opts = haddockOptions dflags
, docs_language = language_
, docs_extensions = exts
}
pure (Just mod_docs)
where
exts = extensionFlags dflags
language_ = language dflags
def_meths_env = mkOccEnv [(occ, nm)
| id <- typeEnvIds ty_env
, let nm = idName id
occ = nameOccName nm
, isDefaultMethodOcc occ
]
(doc_map, arg_map) = mkMaps def_meths_env local_insts decls_with_docs
decls_with_docs = topDecls rn_decls
local_insts = filter (nameIsLocalOrFrom semantic_mdl)
$ map getName insts ++ map getName fam_insts
doc_structure = mkDocStructure mdl import_avails mb_rn_exports rn_decls
all_exports def_meths_env
named_chunks = getNamedChunks (isJust mb_rn_exports) rn_decls
extractDocs _ _ = pure Nothing
mkDocStructure :: Module
-> ImportAvails
-> Maybe [(LIE GhcRn, Avails)]
-> HsGroup GhcRn
-> [AvailInfo]
-> OccEnv Name
-> DocStructure
mkDocStructure mdl import_avails (Just export_list) _ _ _ =
mkDocStructureFromExportList mdl import_avails export_list
mkDocStructure _ _ Nothing rn_decls all_exports def_meths_env =
mkDocStructureFromDecls def_meths_env all_exports rn_decls
mkDocStructureFromExportList
:: Module
-> ImportAvails
-> [(LIE GhcRn, Avails)]
-> DocStructure
mkDocStructureFromExportList mdl import_avails export_list =
toDocStructure . first unLoc <$> export_list
where
toDocStructure :: (IE GhcRn, Avails) -> DocStructureItem
toDocStructure = \case
(IEModuleContents _ lmn, avails) -> moduleExport (unLoc lmn) avails
(IEGroup _ level doc, _) -> DsiSectionHeading level (unLoc doc)
(IEDoc _ doc, _) -> DsiDocChunk (unLoc doc)
(IEDocNamed _ name, _) -> DsiNamedChunkRef name
(_, avails) -> DsiExports (nubAvails avails)
moduleExport :: ModuleName
-> Avails
-> DocStructureItem
moduleExport alias avails =
DsiModExport (nubSortNE orig_names) (nubAvails avails)
where
orig_names = M.findWithDefault aliasErr alias aliasMap
aliasErr = error $ "mkDocStructureFromExportList: "
++ (moduleNameString . moduleName) mdl
++ ": Can't find alias " ++ moduleNameString alias
nubSortNE = NonEmpty.fromList .
Set.toList .
Set.fromList .
NonEmpty.toList
aliasMap :: Map ModuleName (NonEmpty ModuleName)
aliasMap =
M.fromListWith (<>) $
(this_mdl_name, this_mdl_name :| [])
: (flip concatMap (moduleEnvToList imported) $ \(mdl, imvs) ->
[(imv_name imv, moduleName mdl :| []) | imv <- imvs])
where
this_mdl_name = moduleName mdl
imported :: ModuleEnv [ImportedModsVal]
imported = mapModuleEnv importedByUser (imp_mods import_avails)
mkDocStructureFromDecls :: OccEnv Name
-> [AvailInfo]
-> HsGroup GhcRn
-> DocStructure
mkDocStructureFromDecls env all_exports decls =
map unLoc (sortLocated (docs ++ avails))
where
avails :: [Located DocStructureItem]
avails = flip fmap all_exports $ \avail ->
case M.lookup (availName avail) name_locs of
Just loc -> L loc (DsiExports [avail])
Nothing -> noLoc (DsiExports [avail])
docs = mapMaybe structuralDoc (hs_docs decls)
structuralDoc :: LDocDecl GhcRn
-> Maybe (Located DocStructureItem)
structuralDoc = \case
L loc (DocCommentNamed _name doc) ->
Just (L (locA loc) (DsiDocChunk (unLoc doc)))
L loc (DocGroup level doc) ->
Just (L (locA loc) (DsiSectionHeading level (unLoc doc)))
_ -> Nothing
name_locs = M.fromList (concatMap ldeclNames (ungroup decls))
ldeclNames (L loc d) = zip (getMainDeclBinder env d) (repeat (locA loc))
getNamedChunks :: Bool
-> HsGroup (GhcPass pass)
-> Map String (HsDoc (GhcPass pass))
getNamedChunks True decls =
M.fromList $ flip mapMaybe (unLoc <$> hs_docs decls) $ \case
DocCommentNamed name doc -> Just (name, unLoc doc)
_ -> Nothing
getNamedChunks False _ = M.empty
mkMaps :: OccEnv Name
-> [Name]
-> [(LHsDecl GhcRn, [HsDoc GhcRn])]
-> (UniqMap Name [HsDoc GhcRn], UniqMap Name (IntMap (HsDoc GhcRn)))
mkMaps env instances decls =
( listsToMapWith (++) (map (nubByName fst) decls')
, listsToMapWith (<>) (filterMapping (not . IM.null) args)
)
where
(decls', args) = unzip (map mappings decls)
listsToMapWith f = listToUniqMap_C f . concat
filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]]
filterMapping p = map (filter (p . snd))
mappings :: (LHsDecl GhcRn, [HsDoc GhcRn])
-> ( [(Name, [HsDoc GhcRn])]
, [(Name, IntMap (HsDoc GhcRn))]
)
mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, doc) =
(dm, am)
where
args = declTypeDocs decl
subs :: [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
subs = subordinates env instanceMap decl
(subNs, subDocs, subArgs) =
unzip3 subs
ns = names l decl
dm = [(n, d) | (n, d) <- zip ns (repeat doc) ++ zip subNs subDocs, not $ all (isEmptyDocString . hsDocString) d]
am = [(n, args) | n <- ns] ++ zip subNs subArgs
mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], [])
instanceMap :: Map RealSrcSpan Name
instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]
names :: RealSrcSpan -> HsDecl GhcRn -> [Name]
names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap
names l (DerivD {}) = maybeToList (M.lookup l instanceMap)
names _ decl = getMainDeclBinder env decl
getMainDeclBinder
:: OccEnv Name
-> HsDecl GhcRn -> [Name]
getMainDeclBinder _ (TyClD _ d) = [tcdName d]
getMainDeclBinder _ (ValD _ d) =
case collectHsBindBinders CollNoDictBinders d of
[] -> []
(name:_) -> [name]
getMainDeclBinder env (SigD _ d) = sigNameNoLoc env d
getMainDeclBinder _ (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
getMainDeclBinder _ (ForD _ (ForeignExport _ _ _ _)) = []
getMainDeclBinder _ _ = []
sigNameNoLoc :: forall a . (UnXRec a, HasOccName (IdP a)) => OccEnv (IdP a) -> Sig a -> [IdP a]
sigNameNoLoc _ (TypeSig _ ns _) = map (unXRec @a) ns
sigNameNoLoc _ (ClassOpSig _ False ns _) = map (unXRec @a) ns
sigNameNoLoc env (ClassOpSig _ True ns _) = mapMaybe (lookupOccEnv env . mkDefaultMethodOcc . occName) $ map (unXRec @a) ns
sigNameNoLoc _ (PatSynSig _ ns _) = map (unXRec @a) ns
sigNameNoLoc _ (SpecSig _ n _ _) = [unXRec @a n]
sigNameNoLoc _ (InlineSig _ n _) = [unXRec @a n]
sigNameNoLoc _ (FixSig _ (FixitySig _ ns _)) = map (unXRec @a) ns
sigNameNoLoc _ _ = []
getInstLoc :: Anno (IdGhcP p) ~ SrcSpanAnnN => InstDecl (GhcPass p) -> SrcSpan
getInstLoc = \case
ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLocA ty
DataFamInstD _ (DataFamInstDecl
{ dfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l
TyFamInstD _ (TyFamInstDecl
{ tfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l
subordinates :: OccEnv Name
-> Map RealSrcSpan Name
-> HsDecl GhcRn
-> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
subordinates env instMap decl = case decl of
InstD _ (ClsInstD _ d) -> let
data_fams = do
DataFamInstDecl { dfid_eqn =
FamEqn { feqn_tycon = L l _
, feqn_rhs = defn }} <- unLoc <$> cid_datafam_insts d
[ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn
ty_fams = do
TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = L l _ } } <- unLoc <$> cid_tyfam_insts d
[ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ]
in data_fams ++ ty_fams
InstD _ (DataFamInstD _ (DataFamInstDecl 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 env d, not (isValD d)
]
dataSubs :: HsDataDefn GhcRn
-> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
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 = [ (foExt 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], IM.empty)
| (l, doc) <- concatMap (extract_deriv_clause_tys .
deriv_clause_tys . unLoc) $
dd_derivs dd
, Just instName <- [lookupSrcSpan l instMap] ]
extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDoc GhcRn)]
extract_deriv_clause_tys (L _ dct) =
case dct of
DctSingle _ ty -> maybeToList $ extract_deriv_ty ty
DctMulti _ tys -> mapMaybe extract_deriv_ty tys
extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDoc GhcRn)
extract_deriv_ty (L l (HsSig{sig_body = L _ ty})) =
case ty of
HsDocTy _ _ doc -> Just (locA l, doc)
_ -> Nothing
conArgDocs :: ConDecl GhcRn -> IntMap (HsDoc GhcRn)
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 -> IntMap (HsDoc GhcRn)
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 _ -> IM.empty
gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap (HsDoc GhcRn)
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] -> IntMap (HsDoc GhcRn)
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)
f _ _ = Nothing
isValD :: HsDecl a -> Bool
isValD (ValD _ _) = True
isValD _ = False
classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])]
classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls
where
decls = docs ++ defs ++ sigs ++ ats
docs = mkDecls tcdDocs (DocD noExtField) class_
defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_
sigs = mkDecls tcdSigs (SigD noExtField) class_
ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_
declTypeDocs :: HsDecl GhcRn -> IntMap (HsDoc GhcRn)
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)
_ -> IM.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
typeDocs :: HsType GhcRn -> IntMap (HsDoc GhcRn)
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 -> IM.insert n (unLoc x) $ go (n+1) (unLoc ty)
HsFunTy _ _ _ ty -> go (n+1) (unLoc ty)
HsDocTy _ _ doc -> IM.singleton n (unLoc doc)
_ -> IM.empty
sigTypeDocs :: HsSigType GhcRn -> IntMap (HsDoc GhcRn)
sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body)
topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])]
topDecls = filterClasses . filterDecls . collectDocs . sortLocatedA . ungroup
ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
ungroup group_ =
mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++
mkDecls hs_derivds (DerivD noExtField) group_ ++
mkDecls hs_defds (DefD noExtField) group_ ++
mkDecls hs_fords (ForD noExtField) group_ ++
mkDecls hs_docs (DocD noExtField) group_ ++
mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++
mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++
mkDecls (valbinds . hs_valds) (ValD noExtField) group_
where
typesigs :: HsValBinds GhcRn -> [LSig GhcRn]
typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig
typesigs ValBinds{} = error "expected XValBindsLR"
valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn]
valbinds (XValBindsLR (NValBinds binds _)) =
concatMap bagToList . snd . unzip $ binds
valbinds ValBinds{} = error "expected XValBindsLR"
collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDoc p])]
collectDocs = go [] Nothing
where
go docs mprev decls = case (decls, mprev) of
((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing) -> go (unLoc s:docs) Nothing ds
((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [unLoc s] Nothing ds
((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev) -> go (unLoc s:docs) mprev ds
(d : ds, Nothing) -> go docs (Just d) ds
(d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds
([] , Nothing) -> []
([] , Just prev) -> finished prev docs []
finished decl docs rest = (decl, reverse docs) : rest
filterDecls :: forall p doc. UnXRec p => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]
filterDecls = filter (isHandled . unXRec @p . fst)
where
isHandled (ForD _ (ForeignImport {})) = True
isHandled (TyClD {}) = True
isHandled (InstD {}) = True
isHandled (DerivD {}) = True
isHandled (SigD _ d) = isUserSig d
isHandled (ValD {}) = True
isHandled (DocD {}) = True
isHandled _ = False
filterClasses :: forall p doc. (IsPass p) => [(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)]
filterClasses = map (first (mapLoc filterClass))
where
filterClass (TyClD x c@(ClassDecl {})) =
TyClD x $ c { tcdSigs =
filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }
filterClass d = d
isUserSig :: Sig name -> Bool
isUserSig TypeSig {} = True
isUserSig ClassOpSig {} = True
isUserSig PatSynSig {} = True
isUserSig _ = False
mkDecls :: (struct -> [GenLocated l decl])
-> (decl -> hsDecl)
-> struct
-> [GenLocated l hsDecl]
mkDecls field con = map (mapLoc con) . field
extractTHDocs :: THDocs
-> ExtractedTHDocs
extractTHDocs docs =
ExtractedTHDocs
{ ethd_mod_header = docHeader
, ethd_decl_docs = searchDocs decl
, ethd_arg_docs = searchDocs args
, ethd_inst_docs = searchDocs insts
}
where
docHeader :: Maybe (HsDoc GhcRn)
docHeader
| ((_, s):_) <- filter isModDoc (M.toList docs) = Just s
| otherwise = Nothing
isModDoc (ModuleDoc, _) = True
isModDoc _ = False
searchDocs :: (UniqMap Name a -> (DocLoc, HsDoc GhcRn) -> UniqMap Name a) -> UniqMap Name a
searchDocs f = foldl' f emptyUniqMap $ M.toList docs
decl acc ((DeclDoc name), s) = addToUniqMap acc name s
decl acc _ = acc
insts acc ((InstDoc name), s) = addToUniqMap acc name s
insts acc _ = acc
args :: UniqMap Name (IntMap (HsDoc GhcRn))
-> (DocLoc, HsDoc GhcRn)
-> UniqMap Name (IntMap (HsDoc GhcRn))
args acc ((ArgDoc name i), s) =
addToUniqMap_C (\_ m -> IM.insert i s m) acc name (IM.singleton i s)
args acc _ = acc
unionArgMaps :: forall b . UniqMap Name (IntMap b)
-> UniqMap Name (IntMap b)
-> UniqMap Name (IntMap b)
unionArgMaps a b = nonDetFoldUniqMap go b a
where
go :: (Name, IntMap b)
-> UniqMap Name (IntMap b) -> UniqMap Name (IntMap b)
go (n, newArgMap) acc
| Just oldArgMap <- lookupUniqMap acc n =
addToUniqMap acc n (newArgMap `IM.union` oldArgMap)
| otherwise = addToUniqMap acc n newArgMap