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

{-# LANGUAGE CPP #-}
#include "ghc-api-version.h"

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

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

import           FastString
import           SrcLoc (RealLocated)
import           GhcMonad
import           Packages
import           Name
import           Language.Haskell.LSP.Types (getUri, filePathToUri)
import           TcRnTypes
import           ExtractDocs
import           NameEnv
import HscTypes (HscEnv(hsc_dflags))

mkDocMap
  :: HscEnv
  -> [ParsedModule]
  -> RefMap
  -> TcGblEnv
  -> IO DocAndKindMap
mkDocMap :: HscEnv -> [ParsedModule] -> RefMap -> TcGblEnv -> IO DocAndKindMap
mkDocMap HscEnv
env [ParsedModule]
sources RefMap
rm TcGblEnv
this_mod =
  do let (Maybe HsDocString
_ , DeclDocMap Map Name HsDocString
this_docs, ArgDocMap
_) = TcGblEnv -> (Maybe HsDocString, DeclDocMap, ArgDocMap)
extractDocs TcGblEnv
this_mod
     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 -> [ParsedModule] -> Name -> IO SpanDoc
getDocumentationTryGhc HscEnv
env Module
mod [ParsedModule]
sources 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 -> Set (Either ModuleName Name)
forall k a. Map k a -> Set k
M.keysSet RefMap
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 (([FileDiagnostic] -> Maybe TyThing)
-> (Maybe TyThing -> Maybe TyThing)
-> Either [FileDiagnostic] (Maybe TyThing)
-> Maybe TyThing
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe TyThing -> [FileDiagnostic] -> Maybe TyThing
forall a b. a -> b -> a
const Maybe TyThing
forall a. Maybe a
Nothing) Maybe TyThing -> Maybe TyThing
forall a. a -> a
id) (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 -> [ParsedModule] -> Name -> IO SpanDoc
getDocumentationTryGhc :: HscEnv -> Module -> [ParsedModule] -> Name -> IO SpanDoc
getDocumentationTryGhc HscEnv
env Module
mod [ParsedModule]
deps 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 -> [ParsedModule] -> [Name] -> IO [SpanDoc]
getDocumentationsTryGhc HscEnv
env Module
mod [ParsedModule]
deps [Name
n]

getDocumentationsTryGhc :: HscEnv -> Module -> [ParsedModule] -> [Name] -> IO [SpanDoc]
-- Interfaces are only generated for GHC >= 8.6.
-- In older versions, interface files do not embed Haddocks anyway
getDocumentationsTryGhc :: HscEnv -> Module -> [ParsedModule] -> [Name] -> IO [SpanDoc]
getDocumentationsTryGhc HscEnv
env Module
mod [ParsedModule]
sources [Name]
names = do
  Either
  [FileDiagnostic]
  [Either String (Maybe HsDocString, Map Int HsDocString)]
res <- DynFlags
-> Text
-> IO [Either String (Maybe HsDocString, Map Int HsDocString)]
-> IO
     (Either
        [FileDiagnostic]
        [Either String (Maybe HsDocString, Map Int 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, Map Int HsDocString)]
 -> IO
      (Either
         [FileDiagnostic]
         [Either String (Maybe HsDocString, Map Int HsDocString)]))
-> IO [Either String (Maybe HsDocString, Map Int HsDocString)]
-> IO
     (Either
        [FileDiagnostic]
        [Either String (Maybe HsDocString, Map Int HsDocString)])
forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> [Name]
-> IO [Either String (Maybe HsDocString, Map Int HsDocString)]
getDocsBatch HscEnv
env Module
mod [Name]
names
  case Either
  [FileDiagnostic]
  [Either String (Maybe HsDocString, Map Int HsDocString)]
res of
      Left [FileDiagnostic]
_ -> (Name -> IO SpanDoc) -> [Name] -> IO [SpanDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> IO SpanDoc
forall (f :: * -> *). MonadIO f => Name -> f SpanDoc
mkSpanDocText [Name]
names
      Right [Either String (Maybe HsDocString, Map Int HsDocString)]
res -> (Either String (Maybe HsDocString, Map Int HsDocString)
 -> Name -> IO SpanDoc)
-> [Either String (Maybe HsDocString, Map Int HsDocString)]
-> [Name]
-> IO [SpanDoc]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Either String (Maybe HsDocString, Map Int HsDocString)
-> Name -> IO SpanDoc
forall (f :: * -> *) a b.
MonadIO f =>
Either a (Maybe HsDocString, b) -> Name -> f SpanDoc
unwrap [Either String (Maybe HsDocString, Map Int 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 =
      (SpanDocUris -> SpanDoc) -> f (SpanDocUris -> SpanDoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> SpanDocUris -> SpanDoc
SpanDocText ([ParsedModule] -> Name -> [Text]
forall name. HasSrcSpan name => [ParsedModule] -> name -> [Text]
getDocumentation [ParsedModule]
sources Name
name)) f (SpanDocUris -> SpanDoc) -> f SpanDocUris -> f SpanDoc
forall (f :: * -> *) a b. Applicative f => 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
      let df :: DynFlags
df = HscEnv -> DynFlags
hsc_dflags HscEnv
env
      (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
$ DynFlags -> Module -> IO (Maybe String)
lookupDocHtmlForModule DynFlags
df 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
$ DynFlags -> Module -> IO (Maybe String)
lookupSrcHtmlForModule DynFlags
df 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
showName 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
showName 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.
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
  -- 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 [Located AnnotationComment]
docs = ParsedModule -> Map SrcSpan [Located 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
$ (Located AnnotationComment
 -> Maybe (RealLocated AnnotationComment))
-> [Located AnnotationComment] -> [RealLocated AnnotationComment]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(L SrcSpan
l AnnotationComment
v) -> RealSrcSpan -> AnnotationComment -> RealLocated AnnotationComment
forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> AnnotationComment -> RealLocated AnnotationComment)
-> Maybe RealSrcSpan
-> Maybe (AnnotationComment -> RealLocated AnnotationComment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> Maybe RealSrcSpan
realSpan SrcSpan
l Maybe (AnnotationComment -> RealLocated AnnotationComment)
-> Maybe AnnotationComment -> Maybe (RealLocated AnnotationComment)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AnnotationComment -> Maybe AnnotationComment
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnnotationComment
v)
      ([Located AnnotationComment] -> [RealLocated AnnotationComment])
-> [Located AnnotationComment] -> [RealLocated AnnotationComment]
forall a b. (a -> b) -> a -> b
$ [[Located AnnotationComment]] -> [Located AnnotationComment]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
      ([[Located AnnotationComment]] -> [Located AnnotationComment])
-> [[Located AnnotationComment]] -> [Located AnnotationComment]
forall a b. (a -> b) -> a -> b
$ Map SrcSpan [Located AnnotationComment]
-> [[Located AnnotationComment]]
forall k a. Map k a -> [a]
M.elems
      Map SrcSpan [Located 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
    ann :: ParsedModule -> Map SrcSpan [Located AnnotationComment]
ann = (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
    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
. Map SrcSpan [Located AnnotationComment] -> [RealSrcSpan]
forall a. Map SrcSpan [Located a] -> [RealSrcSpan]
realSpans (Map SrcSpan [Located AnnotationComment] -> [RealSrcSpan])
-> (ParsedModule -> Map SrcSpan [Located AnnotationComment])
-> ParsedModule
-> [RealSrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> Map SrcSpan [Located AnnotationComment]
ann
    realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan]
    realSpans :: Map SrcSpan [Located a] -> [RealSrcSpan]
realSpans =
        (Located a -> Maybe RealSrcSpan) -> [Located a] -> [RealSrcSpan]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SrcSpan -> Maybe RealSrcSpan
realSpan (SrcSpan -> Maybe RealSrcSpan)
-> (Located a -> SrcSpan) -> Located a -> Maybe RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located a -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc)
      ([Located a] -> [RealSrcSpan])
-> (Map SrcSpan [Located a] -> [Located a])
-> Map SrcSpan [Located a]
-> [RealSrcSpan]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Located a]] -> [Located a]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
      ([[Located a]] -> [Located a])
-> (Map SrcSpan [Located a] -> [[Located a]])
-> Map SrcSpan [Located a]
-> [Located a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map SrcSpan [Located a] -> [[Located a]]
forall k a. Map k a -> [a]
M.elems

-- | 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

-- 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 :: DynFlags -> Module -> IO (Maybe FilePath)
lookupDocHtmlForModule :: DynFlags -> Module -> IO (Maybe String)
lookupDocHtmlForModule =
  (String -> String -> String)
-> DynFlags -> 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 :: DynFlags -> Module -> IO (Maybe FilePath)
lookupSrcHtmlForModule :: DynFlags -> Module -> IO (Maybe String)
lookupSrcHtmlForModule =
  (String -> String -> String)
-> DynFlags -> 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) -> DynFlags -> Module -> IO (Maybe FilePath)
lookupHtmlForModule :: (String -> String -> String)
-> DynFlags -> Module -> IO (Maybe String)
lookupHtmlForModule String -> String -> String
mkDocPath DynFlags
df 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) (DynFlags -> UnitId -> Maybe [String]
lookupHtmls DynFlags
df UnitId
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 :: UnitId
ui = Module -> UnitId
moduleUnitId Module
m
    -- try to locate html file from most to least specific name e.g.
    --  first Language.Haskell.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html
    --  then Language.Haskell.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 :: DynFlags -> UnitId -> Maybe [FilePath]
lookupHtmls :: DynFlags -> UnitId -> Maybe [String]
lookupHtmls DynFlags
df UnitId
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])
-> (InstalledPackageInfo
      ComponentId
      SourcePackageId
      PackageName
      InstalledUnitId
      UnitId
      ModuleName
      Module
    -> [String])
-> InstalledPackageInfo
     ComponentId
     SourcePackageId
     PackageName
     InstalledUnitId
     UnitId
     ModuleName
     Module
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo
  ComponentId
  SourcePackageId
  PackageName
  InstalledUnitId
  UnitId
  ModuleName
  Module
-> [String]
forall compid srcpkgid srcpkgname instunitid unitid modulename mod.
InstalledPackageInfo
  compid srcpkgid srcpkgname instunitid unitid modulename mod
-> [String]
haddockInterfaces (InstalledPackageInfo
   ComponentId
   SourcePackageId
   PackageName
   InstalledUnitId
   UnitId
   ModuleName
   Module
 -> [String])
-> Maybe
     (InstalledPackageInfo
        ComponentId
        SourcePackageId
        PackageName
        InstalledUnitId
        UnitId
        ModuleName
        Module)
-> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags
-> UnitId
-> Maybe
     (InstalledPackageInfo
        ComponentId
        SourcePackageId
        PackageName
        InstalledUnitId
        UnitId
        ModuleName
        Module)
lookupPackage DynFlags
df UnitId
ui