{-# LANGUAGE CPP #-}
#include "ghc-api-version.h"
module Development.IDE.Spans.Documentation (
getDocumentation
, getDocumentationTryGhc
) where
import Control.Monad
import Data.List.Extra
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text as T
import Development.IDE.GHC.Compat
import Development.IDE.GHC.Error
import Development.IDE.Spans.Common
import FastString
import SrcLoc
getDocumentationTryGhc
:: GhcMonad m
=> [ParsedModule]
-> Name
-> m SpanDoc
#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
getDocumentationTryGhc sources name = do
res <- catchSrcErrors "docs" $ getDocs name
case res of
Right (Right (Just docs, _)) -> return $ SpanDocString docs
_ -> return $ SpanDocText $ getDocumentation sources name
#else
getDocumentationTryGhc sources name = do
return $ SpanDocText $ getDocumentation sources name
#endif
getDocumentation
:: [ParsedModule]
-> Name
-> [T.Text]
getDocumentation sources targetName = fromMaybe [] $ do
targetNameSpan <- realSpan $ nameSrcSpan targetName
tc <-
find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
$ reverse sources
let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc
, L _ (ValD hsbind) <- hsmodDecls
, Just n <- [name_of_bind hsbind]
]
let sortedSpans = sortedNameSpans bs
let docs = ann tc
nameInd <- elemIndex targetNameSpan sortedSpans
let prevNameSpan =
if nameInd >= 1
then sortedSpans !! (nameInd - 1)
else zeroSpan $ srcSpanFile targetNameSpan
pure
$ docHeaders
$ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan)
$ mapMaybe (\(L l v) -> L <$> realSpan l <*> pure v)
$ join
$ M.elems
docs
where
name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)
name_of_bind FunBind {fun_id} = Just fun_id
name_of_bind _ = Nothing
sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]
sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)
isBetween target before after = before <= target && target <= after
ann = snd . pm_annotations
annotationFileName :: ParsedModule -> Maybe FastString
annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann
realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]
realSpans =
mapMaybe (realSpan . getLoc)
. join
. M.elems
docHeaders :: [RealLocated AnnotationComment]
-> [T.Text]
docHeaders = mapMaybe (\(L _ x) -> wrk x)
where
wrk = \case
AnnDocCommentNext s -> Just $ T.pack s
AnnLineComment s -> if "-- |" `isPrefixOf` s
then Just $ T.pack s
else Nothing
_ -> Nothing