{-# LANGUAGE RankNTypes #-}
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

{-# LANGUAGE CPP        #-}

module Development.IDE.Spans.Documentation (
    getDocumentation
  , getDocumentationTryGhc
  , getDocumentationsTryGhc
  , DocMap
  , mkDocMap
  ) where

import           Control.Monad
import           Control.Monad.Extra             (findM)
import           Control.Monad.IO.Class
import           Data.Either
import           Data.Foldable
import           Data.List.Extra
import qualified Data.Map                        as M
import           Data.Maybe
import qualified Data.Set                        as S
import qualified Data.Text                       as T
import           Development.IDE.Core.Compile
import           Development.IDE.Core.RuleTypes
import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Compat.Util
import           Development.IDE.GHC.Error
import           Development.IDE.GHC.Util        (printOutputable)
import           Development.IDE.Spans.Common
import           System.Directory
import           System.FilePath

import           Language.LSP.Types              (filePathToUri, getUri)

mkDocMap
  :: HscEnv
  -> RefMap a
  -> TcGblEnv
  -> IO DocAndKindMap
mkDocMap :: HscEnv -> RefMap a -> TcGblEnv -> IO DocAndKindMap
mkDocMap HscEnv
env RefMap a
rm TcGblEnv
this_mod =
  do
#if MIN_VERSION_ghc(9,2,0)
     (_ , DeclDocMap this_docs, _) <- extractDocs this_mod
#else
     let (Maybe HsDocString
_ , DeclDocMap Map Name HsDocString
this_docs, ArgDocMap
_) = TcGblEnv -> (Maybe HsDocString, DeclDocMap, ArgDocMap)
extractDocs TcGblEnv
this_mod
#endif
     UniqFM SpanDoc
d <- (Name -> UniqFM SpanDoc -> IO (UniqFM SpanDoc))
-> UniqFM SpanDoc -> [Name] -> IO (UniqFM SpanDoc)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM Name -> UniqFM SpanDoc -> IO (UniqFM SpanDoc)
getDocs ([(Name, SpanDoc)] -> UniqFM SpanDoc
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([(Name, SpanDoc)] -> UniqFM SpanDoc)
-> [(Name, SpanDoc)] -> UniqFM SpanDoc
forall a b. (a -> b) -> a -> b
$ Map Name SpanDoc -> [(Name, SpanDoc)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Name SpanDoc -> [(Name, SpanDoc)])
-> Map Name SpanDoc -> [(Name, SpanDoc)]
forall a b. (a -> b) -> a -> b
$ (HsDocString -> SpanDoc)
-> Map Name HsDocString -> Map Name SpanDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HsDocString -> SpanDocUris -> SpanDoc
`SpanDocString` Maybe Text -> Maybe Text -> SpanDocUris
SpanDocUris Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Map Name HsDocString
this_docs) [Name]
names
     UniqFM TyThing
k <- (Name -> UniqFM TyThing -> IO (UniqFM TyThing))
-> UniqFM TyThing -> [Name] -> IO (UniqFM TyThing)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM Name -> UniqFM TyThing -> IO (UniqFM TyThing)
getType (TcGblEnv -> UniqFM TyThing
tcg_type_env TcGblEnv
this_mod) [Name]
names
     DocAndKindMap -> IO DocAndKindMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DocAndKindMap -> IO DocAndKindMap)
-> DocAndKindMap -> IO DocAndKindMap
forall a b. (a -> b) -> a -> b
$ UniqFM SpanDoc -> UniqFM TyThing -> DocAndKindMap
DKMap UniqFM SpanDoc
d UniqFM TyThing
k
  where
    getDocs :: Name -> UniqFM SpanDoc -> IO (UniqFM SpanDoc)
getDocs Name
n UniqFM SpanDoc
map
      | Bool -> (Module -> Bool) -> Maybe Module -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe Module -> Bool) -> Maybe Module -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Module
nameModule_maybe Name
n = UniqFM SpanDoc -> IO (UniqFM SpanDoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure UniqFM SpanDoc
map -- we already have the docs in this_docs, or they do not exist
      | Bool
otherwise = do
      SpanDoc
doc <- HscEnv -> Module -> Name -> IO SpanDoc
getDocumentationTryGhc HscEnv
env Module
mod Name
n
      UniqFM SpanDoc -> IO (UniqFM SpanDoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UniqFM SpanDoc -> IO (UniqFM SpanDoc))
-> UniqFM SpanDoc -> IO (UniqFM SpanDoc)
forall a b. (a -> b) -> a -> b
$ UniqFM SpanDoc -> Name -> SpanDoc -> UniqFM SpanDoc
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv UniqFM SpanDoc
map Name
n SpanDoc
doc
    getType :: Name -> UniqFM TyThing -> IO (UniqFM TyThing)
getType Name
n UniqFM TyThing
map
      | OccName -> Bool
isTcOcc (OccName -> Bool) -> OccName -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
n = do
        Maybe TyThing
kind <- HscEnv -> Module -> Name -> IO (Maybe TyThing)
lookupKind HscEnv
env Module
mod Name
n
        UniqFM TyThing -> IO (UniqFM TyThing)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UniqFM TyThing -> IO (UniqFM TyThing))
-> UniqFM TyThing -> IO (UniqFM TyThing)
forall a b. (a -> b) -> a -> b
$ UniqFM TyThing
-> (TyThing -> UniqFM TyThing) -> Maybe TyThing -> UniqFM TyThing
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UniqFM TyThing
map (UniqFM TyThing -> Name -> TyThing -> UniqFM TyThing
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv UniqFM TyThing
map Name
n) Maybe TyThing
kind
      | Bool
otherwise = UniqFM TyThing -> IO (UniqFM TyThing)
forall (f :: * -> *) a. Applicative f => a -> f a
pure UniqFM TyThing
map
    names :: [Name]
names = [Either ModuleName Name] -> [Name]
forall a b. [Either a b] -> [b]
rights ([Either ModuleName Name] -> [Name])
-> [Either ModuleName Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Set (Either ModuleName Name) -> [Either ModuleName Name]
forall a. Set a -> [a]
S.toList Set (Either ModuleName Name)
idents
    idents :: Set (Either ModuleName Name)
idents = RefMap a -> Set (Either ModuleName Name)
forall k a. Map k a -> Set k
M.keysSet RefMap a
rm
    mod :: Module
mod = TcGblEnv -> Module
tcg_mod TcGblEnv
this_mod

lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing)
lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing)
lookupKind HscEnv
env Module
mod =
    (Either [FileDiagnostic] (Maybe TyThing) -> Maybe TyThing)
-> IO (Either [FileDiagnostic] (Maybe TyThing))
-> IO (Maybe TyThing)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe TyThing
-> Either [FileDiagnostic] (Maybe TyThing) -> Maybe TyThing
forall b a. b -> Either a b -> b
fromRight Maybe TyThing
forall a. Maybe a
Nothing) (IO (Either [FileDiagnostic] (Maybe TyThing))
 -> IO (Maybe TyThing))
-> (Name -> IO (Either [FileDiagnostic] (Maybe TyThing)))
-> Name
-> IO (Maybe TyThing)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags
-> Text
-> IO (Maybe TyThing)
-> IO (Either [FileDiagnostic] (Maybe TyThing))
forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
env) Text
"span" (IO (Maybe TyThing)
 -> IO (Either [FileDiagnostic] (Maybe TyThing)))
-> (Name -> IO (Maybe TyThing))
-> Name
-> IO (Either [FileDiagnostic] (Maybe TyThing))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Module -> Name -> IO (Maybe TyThing)
lookupName HscEnv
env Module
mod

getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc
getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc
getDocumentationTryGhc HscEnv
env Module
mod Name
n = [SpanDoc] -> SpanDoc
forall a. [a] -> a
head ([SpanDoc] -> SpanDoc) -> IO [SpanDoc] -> IO SpanDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Module -> [Name] -> IO [SpanDoc]
getDocumentationsTryGhc HscEnv
env Module
mod [Name
n]

getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc]
getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc]
getDocumentationsTryGhc HscEnv
env Module
mod [Name]
names = do
  Either
  [FileDiagnostic]
  [Either String (Maybe HsDocString, IntMap HsDocString)]
res <- DynFlags
-> Text
-> IO [Either String (Maybe HsDocString, IntMap HsDocString)]
-> IO
     (Either
        [FileDiagnostic]
        [Either String (Maybe HsDocString, IntMap HsDocString)])
forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
env) Text
"docs" (IO [Either String (Maybe HsDocString, IntMap HsDocString)]
 -> IO
      (Either
         [FileDiagnostic]
         [Either String (Maybe HsDocString, IntMap HsDocString)]))
-> IO [Either String (Maybe HsDocString, IntMap HsDocString)]
-> IO
     (Either
        [FileDiagnostic]
        [Either String (Maybe HsDocString, IntMap HsDocString)])
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> [Name]
-> IO [Either String (Maybe HsDocString, IntMap HsDocString)]
getDocsBatch HscEnv
env Module
mod [Name]
names
  case Either
  [FileDiagnostic]
  [Either String (Maybe HsDocString, IntMap HsDocString)]
res of
      Left [FileDiagnostic]
_    -> [SpanDoc] -> IO [SpanDoc]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Right [Either String (Maybe HsDocString, IntMap HsDocString)]
res -> (Either String (Maybe HsDocString, IntMap HsDocString)
 -> Name -> IO SpanDoc)
-> [Either String (Maybe HsDocString, IntMap HsDocString)]
-> [Name]
-> IO [SpanDoc]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Either String (Maybe HsDocString, IntMap HsDocString)
-> Name -> IO SpanDoc
forall (f :: * -> *) a b.
MonadIO f =>
Either a (Maybe HsDocString, b) -> Name -> f SpanDoc
unwrap [Either String (Maybe HsDocString, IntMap HsDocString)]
res [Name]
names
  where
    unwrap :: Either a (Maybe HsDocString, b) -> Name -> f SpanDoc
unwrap (Right (Just HsDocString
docs, b
_)) Name
n = HsDocString -> SpanDocUris -> SpanDoc
SpanDocString HsDocString
docs (SpanDocUris -> SpanDoc) -> f SpanDocUris -> f SpanDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f SpanDocUris
forall (m :: * -> *). MonadIO m => Name -> m SpanDocUris
getUris Name
n
    unwrap Either a (Maybe HsDocString, b)
_ Name
n                      = Name -> f SpanDoc
forall (f :: * -> *). MonadIO f => Name -> f SpanDoc
mkSpanDocText Name
n

    mkSpanDocText :: Name -> f SpanDoc
mkSpanDocText Name
name =
      [Text] -> SpanDocUris -> SpanDoc
SpanDocText [] (SpanDocUris -> SpanDoc) -> f SpanDocUris -> f SpanDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f SpanDocUris
forall (m :: * -> *). MonadIO m => Name -> m SpanDocUris
getUris Name
name

    -- Get the uris to the documentation and source html pages if they exist
    getUris :: Name -> m SpanDocUris
getUris Name
name = do
      (Maybe Text
docFu, Maybe Text
srcFu) <-
        case Name -> Maybe Module
nameModule_maybe Name
name of
          Just Module
mod -> IO (Maybe Text, Maybe Text) -> m (Maybe Text, Maybe Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Text, Maybe Text) -> m (Maybe Text, Maybe Text))
-> IO (Maybe Text, Maybe Text) -> m (Maybe Text, Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
            Maybe Text
doc <- IO (Maybe String) -> IO (Maybe Text)
toFileUriText (IO (Maybe String) -> IO (Maybe Text))
-> IO (Maybe String) -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Maybe String)
lookupDocHtmlForModule HscEnv
env Module
mod
            Maybe Text
src <- IO (Maybe String) -> IO (Maybe Text)
toFileUriText (IO (Maybe String) -> IO (Maybe Text))
-> IO (Maybe String) -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Maybe String)
lookupSrcHtmlForModule HscEnv
env Module
mod
            (Maybe Text, Maybe Text) -> IO (Maybe Text, Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
doc, Maybe Text
src)
          Maybe Module
Nothing -> (Maybe Text, Maybe Text) -> m (Maybe Text, Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text
forall a. Maybe a
Nothing, Maybe Text
forall a. Maybe a
Nothing)
      let docUri :: Maybe Text
docUri = (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
selector Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
forall a. Outputable a => a -> Text
printOutputable Name
name) (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
docFu
          srcUri :: Maybe Text
srcUri = (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
forall a. Outputable a => a -> Text
printOutputable Name
name) (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
srcFu
          selector :: Text
selector
            | Name -> Bool
isValName Name
name = Text
"v:"
            | Bool
otherwise = Text
"t:"
      SpanDocUris -> m SpanDocUris
forall (m :: * -> *) a. Monad m => a -> m a
return (SpanDocUris -> m SpanDocUris) -> SpanDocUris -> m SpanDocUris
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Maybe Text -> SpanDocUris
SpanDocUris Maybe Text
docUri Maybe Text
srcUri

    toFileUriText :: IO (Maybe String) -> IO (Maybe Text)
toFileUriText = ((Maybe String -> Maybe Text)
-> IO (Maybe String) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe String -> Maybe Text)
 -> IO (Maybe String) -> IO (Maybe Text))
-> ((String -> Text) -> Maybe String -> Maybe Text)
-> (String -> Text)
-> IO (Maybe String)
-> IO (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Uri -> Text
getUri (Uri -> Text) -> (String -> Uri) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Uri
filePathToUri)

getDocumentation
 :: HasSrcSpan name
 => [ParsedModule] -- ^ All of the possible modules it could be defined in.
 ->  name -- ^ The name you want documentation for.
 -> [T.Text]
-- This finds any documentation between the name you want
-- documentation for and the one before it. This is only an
-- approximately correct algorithm and there are easily constructed
-- cases where it will be wrong (if so then usually slightly but there
-- may be edge cases where it is very wrong).
-- TODO : Build a version of GHC exactprint to extract this information
-- more accurately.
-- TODO : Implement this for GHC 9.2 with in-tree annotations
--        (alternatively, just remove it and rely soley on GHC's parsing)
getDocumentation :: [ParsedModule] -> name -> [Text]
getDocumentation [ParsedModule]
sources name
targetName = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ do
#if MIN_VERSION_ghc(9,2,0)
  Nothing
#else
  -- Find the module the target is defined in.
  RealSrcSpan
targetNameSpan <- SrcSpan -> Maybe RealSrcSpan
realSpan (SrcSpan -> Maybe RealSrcSpan) -> SrcSpan -> Maybe RealSrcSpan
forall a b. (a -> b) -> a -> b
$ name -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc name
targetName
  ParsedModule
tc <-
    (ParsedModule -> Bool) -> [ParsedModule] -> Maybe ParsedModule
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Maybe FastString -> Maybe FastString -> Bool
forall a. Eq a => a -> a -> Bool
(==) (FastString -> Maybe FastString
forall a. a -> Maybe a
Just (FastString -> Maybe FastString) -> FastString -> Maybe FastString
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
targetNameSpan) (Maybe FastString -> Bool)
-> (ParsedModule -> Maybe FastString) -> ParsedModule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> Maybe FastString
annotationFileName)
      ([ParsedModule] -> Maybe ParsedModule)
-> [ParsedModule] -> Maybe ParsedModule
forall a b. (a -> b) -> a -> b
$ [ParsedModule] -> [ParsedModule]
forall a. [a] -> [a]
reverse [ParsedModule]
sources -- TODO : Is reversing the list here really neccessary?

  -- Top level names bound by the module
  let bs :: [Located RdrName]
bs = [ Located RdrName
n | let L SrcSpan
_ HsModule{[LHsDecl GhcPs]
hsmodDecls :: forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls} = ParsedModule -> GenLocated SrcSpan (HsModule GhcPs)
pm_parsed_source ParsedModule
tc
           , L SrcSpan
_ (ValD XValD GhcPs
_ HsBind GhcPs
hsbind) <- [LHsDecl GhcPs]
hsmodDecls
           , Just Located RdrName
n <- [HsBind GhcPs -> Maybe (Located RdrName)
name_of_bind HsBind GhcPs
hsbind]
           ]
  -- Sort the names' source spans.
  let sortedSpans :: [RealSrcSpan]
sortedSpans = [Located RdrName] -> [RealSrcSpan]
sortedNameSpans [Located RdrName]
bs
  -- Now go ahead and extract the docs.
  let docs :: Map SrcSpan [RealLocated AnnotationComment]
docs = ParsedModule -> Map SrcSpan [RealLocated AnnotationComment]
ann ParsedModule
tc
  Int
nameInd <- RealSrcSpan -> [RealSrcSpan] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex RealSrcSpan
targetNameSpan [RealSrcSpan]
sortedSpans
  let prevNameSpan :: RealSrcSpan
prevNameSpan =
        if Int
nameInd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
        then [RealSrcSpan]
sortedSpans [RealSrcSpan] -> Int -> RealSrcSpan
forall a. [a] -> Int -> a
!! (Int
nameInd Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
        else FastString -> RealSrcSpan
zeroSpan (FastString -> RealSrcSpan) -> FastString -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
targetNameSpan
  -- Annoyingly "-- |" documentation isn't annotated with a location,
  -- so you have to pull it out from the elements.
  [Text] -> Maybe [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ [RealLocated AnnotationComment] -> [Text]
docHeaders
      ([RealLocated AnnotationComment] -> [Text])
-> [RealLocated AnnotationComment] -> [Text]
forall a b. (a -> b) -> a -> b
$ (RealLocated AnnotationComment -> Bool)
-> [RealLocated AnnotationComment]
-> [RealLocated AnnotationComment]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(L RealSrcSpan
target AnnotationComment
_) -> RealSrcSpan -> RealSrcSpan -> RealSrcSpan -> Bool
forall a. Ord a => a -> a -> a -> Bool
isBetween RealSrcSpan
target RealSrcSpan
prevNameSpan RealSrcSpan
targetNameSpan)
      ([RealLocated AnnotationComment]
 -> [RealLocated AnnotationComment])
-> [RealLocated AnnotationComment]
-> [RealLocated AnnotationComment]
forall a b. (a -> b) -> a -> b
$ Map SrcSpan [RealLocated AnnotationComment]
-> [RealLocated AnnotationComment]
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
      Map SrcSpan [RealLocated AnnotationComment]
docs
  where
    -- Get the name bound by a binding. We only concern ourselves with
    -- @FunBind@ (which covers functions and variables).
    name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)
    name_of_bind :: HsBind GhcPs -> Maybe (Located RdrName)
name_of_bind FunBind {Located (IdP GhcPs)
fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id :: Located (IdP GhcPs)
fun_id} = Located RdrName -> Maybe (Located RdrName)
forall a. a -> Maybe a
Just Located (IdP GhcPs)
Located RdrName
fun_id
    name_of_bind HsBind GhcPs
_                = Maybe (Located RdrName)
forall a. Maybe a
Nothing
    -- Get source spans from names, discard unhelpful spans, remove
    -- duplicates and sort.
    sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]
    sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]
sortedNameSpans [Located RdrName]
ls = [RealSrcSpan] -> [RealSrcSpan]
forall a. Ord a => [a] -> [a]
nubSort ((Located RdrName -> Maybe RealSrcSpan)
-> [Located RdrName] -> [RealSrcSpan]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SrcSpan -> Maybe RealSrcSpan
realSpan (SrcSpan -> Maybe RealSrcSpan)
-> (Located RdrName -> SrcSpan)
-> Located RdrName
-> Maybe RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc) [Located RdrName]
ls)
    isBetween :: a -> a -> a -> Bool
isBetween a
target a
before a
after = a
before a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
target Bool -> Bool -> Bool
&& a
target a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
after
#if MIN_VERSION_ghc(9,0,0)
    ann = apiAnnComments . pm_annotations
#else
    ann :: ParsedModule -> Map SrcSpan [RealLocated AnnotationComment]
ann = ([Located AnnotationComment] -> [RealLocated AnnotationComment])
-> Map SrcSpan [Located AnnotationComment]
-> Map SrcSpan [RealLocated AnnotationComment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Located AnnotationComment] -> [RealLocated AnnotationComment]
forall a. [Located a] -> [RealLocated a]
filterReal (Map SrcSpan [Located AnnotationComment]
 -> Map SrcSpan [RealLocated AnnotationComment])
-> (ParsedModule -> Map SrcSpan [Located AnnotationComment])
-> ParsedModule
-> Map SrcSpan [RealLocated AnnotationComment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ApiAnnKey [SrcSpan], Map SrcSpan [Located AnnotationComment])
-> Map SrcSpan [Located AnnotationComment]
forall a b. (a, b) -> b
snd ((Map ApiAnnKey [SrcSpan], Map SrcSpan [Located AnnotationComment])
 -> Map SrcSpan [Located AnnotationComment])
-> (ParsedModule
    -> (Map ApiAnnKey [SrcSpan],
        Map SrcSpan [Located AnnotationComment]))
-> ParsedModule
-> Map SrcSpan [Located AnnotationComment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule
-> (Map ApiAnnKey [SrcSpan],
    Map SrcSpan [Located AnnotationComment])
pm_annotations
    filterReal :: [Located a] -> [RealLocated a]
    filterReal :: [Located a] -> [RealLocated a]
filterReal = (Located a -> Maybe (RealLocated a))
-> [Located a] -> [RealLocated a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(L SrcSpan
l a
v) -> (RealSrcSpan -> a -> RealLocated a
forall l e. l -> e -> GenLocated l e
`L`a
v) (RealSrcSpan -> RealLocated a)
-> Maybe RealSrcSpan -> Maybe (RealLocated a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> Maybe RealSrcSpan
realSpan SrcSpan
l)
#endif
    annotationFileName :: ParsedModule -> Maybe FastString
    annotationFileName :: ParsedModule -> Maybe FastString
annotationFileName = (RealSrcSpan -> FastString)
-> Maybe RealSrcSpan -> Maybe FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RealSrcSpan -> FastString
srcSpanFile (Maybe RealSrcSpan -> Maybe FastString)
-> (ParsedModule -> Maybe RealSrcSpan)
-> ParsedModule
-> Maybe FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RealSrcSpan] -> Maybe RealSrcSpan
forall a. [a] -> Maybe a
listToMaybe ([RealSrcSpan] -> Maybe RealSrcSpan)
-> (ParsedModule -> [RealSrcSpan])
-> ParsedModule
-> Maybe RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealLocated AnnotationComment -> RealSrcSpan)
-> [RealLocated AnnotationComment] -> [RealSrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map RealLocated AnnotationComment -> RealSrcSpan
forall a. RealLocated a -> RealSrcSpan
getRealSrcSpan ([RealLocated AnnotationComment] -> [RealSrcSpan])
-> (ParsedModule -> [RealLocated AnnotationComment])
-> ParsedModule
-> [RealSrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map SrcSpan [RealLocated AnnotationComment]
-> [RealLocated AnnotationComment]
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map SrcSpan [RealLocated AnnotationComment]
 -> [RealLocated AnnotationComment])
-> (ParsedModule -> Map SrcSpan [RealLocated AnnotationComment])
-> ParsedModule
-> [RealLocated AnnotationComment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> Map SrcSpan [RealLocated AnnotationComment]
ann

-- | Shows this part of the documentation
docHeaders :: [RealLocated AnnotationComment]
           -> [T.Text]
docHeaders :: [RealLocated AnnotationComment] -> [Text]
docHeaders = (RealLocated AnnotationComment -> Maybe Text)
-> [RealLocated AnnotationComment] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(L RealSrcSpan
_ AnnotationComment
x) -> AnnotationComment -> Maybe Text
wrk AnnotationComment
x)
  where
  wrk :: AnnotationComment -> Maybe Text
wrk = \case
    -- When `Opt_Haddock` is enabled.
    AnnDocCommentNext String
s -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
    -- When `Opt_KeepRawTokenStream` enabled.
    AnnLineComment String
s  -> if String
"-- |" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s
                            then Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s
                            else Maybe Text
forall a. Maybe a
Nothing
    AnnotationComment
_ -> Maybe Text
forall a. Maybe a
Nothing
#endif

-- These are taken from haskell-ide-engine's Haddock plugin

-- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page.
-- An example for a cabal installed module:
-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@
lookupDocHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath)
lookupDocHtmlForModule :: HscEnv -> Module -> IO (Maybe String)
lookupDocHtmlForModule =
  (String -> String -> String)
-> HscEnv -> Module -> IO (Maybe String)
lookupHtmlForModule (\String
pkgDocDir String
modDocName -> String
pkgDocDir String -> String -> String
</> String
modDocName String -> String -> String
<.> String
"html")

-- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page.
-- An example for a cabal installed module:
-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@
lookupSrcHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath)
lookupSrcHtmlForModule :: HscEnv -> Module -> IO (Maybe String)
lookupSrcHtmlForModule =
  (String -> String -> String)
-> HscEnv -> Module -> IO (Maybe String)
lookupHtmlForModule (\String
pkgDocDir String
modDocName -> String
pkgDocDir String -> String -> String
</> String
"src" String -> String -> String
</> String
modDocName String -> String -> String
<.> String
"html")

lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> HscEnv -> Module -> IO (Maybe FilePath)
lookupHtmlForModule :: (String -> String -> String)
-> HscEnv -> Module -> IO (Maybe String)
lookupHtmlForModule String -> String -> String
mkDocPath HscEnv
hscEnv Module
m = do
  -- try all directories
  let mfs :: Maybe [String]
mfs = ([String] -> [String]) -> Maybe [String] -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
go) (HscEnv -> Unit -> Maybe [String]
lookupHtmls HscEnv
hscEnv Unit
ui)
  Maybe String
html <- (String -> IO Bool) -> [String] -> IO (Maybe String)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM String -> IO Bool
doesFileExist ([[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String])
-> (Maybe [String] -> [[String]]) -> Maybe [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [String] -> [[String]]
forall a. Maybe a -> [a]
maybeToList (Maybe [String] -> [String]) -> Maybe [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Maybe [String]
mfs)
  -- canonicalize located html to remove /../ indirection which can break some clients
  -- (vscode on Windows at least)
  (String -> IO String) -> Maybe String -> IO (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> IO String
canonicalizePath Maybe String
html
  where
    go :: String -> [String]
go String
pkgDocDir = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
mkDocPath String
pkgDocDir) [String]
mns
    ui :: Unit
ui = Module -> Unit
moduleUnit Module
m
    -- try to locate html file from most to least specific name e.g.
    --  first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html
    --  then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc.
    mns :: [String]
mns = do
      [String]
chunks <- ([[String]] -> [[String]]
forall a. [a] -> [a]
reverse ([[String]] -> [[String]])
-> (String -> [[String]]) -> String -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [[String]]
forall a. [a] -> [a]
drop1 ([[String]] -> [[String]])
-> (String -> [[String]]) -> String -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [[String]]
forall a. [a] -> [[a]]
inits ([String] -> [[String]])
-> (String -> [String]) -> String -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. (Partial, Eq a) => [a] -> [a] -> [[a]]
splitOn String
".") (String -> [[String]]) -> String -> [[String]]
forall a b. (a -> b) -> a -> b
$ (ModuleName -> String
moduleNameString (ModuleName -> String)
-> (Module -> ModuleName) -> Module -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
moduleName) Module
m
      -- The file might use "." or "-" as separator
      (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
`intercalate` [String]
chunks) [String
".", String
"-"]

lookupHtmls :: HscEnv -> Unit -> Maybe [FilePath]
lookupHtmls :: HscEnv -> Unit -> Maybe [String]
lookupHtmls HscEnv
df Unit
ui =
  -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path
  -- and therefore doesn't expand $topdir on Windows
  (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
takeDirectory ([String] -> [String])
-> (UnitInfo -> [String]) -> UnitInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> [String]
unitHaddockInterfaces (UnitInfo -> [String]) -> Maybe UnitInfo -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Unit -> Maybe UnitInfo
lookupUnit HscEnv
df Unit
ui