{-# 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)
#if MIN_VERSION_ghc(9,3,0)
import           GHC.Types.Unique.Map
#endif

mkDocMap
  :: HscEnv
  -> RefMap a
  -> TcGblEnv
  -> IO DocAndKindMap
mkDocMap :: forall a. HscEnv -> RefMap a -> TcGblEnv -> IO DocAndKindMap
mkDocMap HscEnv
env RefMap a
rm TcGblEnv
this_mod =
  do
#if MIN_VERSION_ghc(9,3,0)
     (Just Docs{docs_decls = UniqMap this_docs}) <- extractDocs (hsc_dflags env) this_mod
#elif MIN_VERSION_ghc(9,2,0)
     (Maybe HsDocString
_ , DeclDocMap Map Name HsDocString
this_docs, ArgDocMap
_) <- forall (m :: * -> *).
MonadIO m =>
TcGblEnv -> m (Maybe HsDocString, DeclDocMap, ArgDocMap)
extractDocs TcGblEnv
this_mod
#else
     let (_ , DeclDocMap this_docs, _) = extractDocs this_mod
#endif
#if MIN_VERSION_ghc(9,3,0)
     d <- foldrM getDocs (fmap (\(_, x) -> (map hsDocString x) `SpanDocString` SpanDocUris Nothing Nothing) this_docs) names
#else
     NameEnv SpanDoc
d <- forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM Name -> NameEnv SpanDoc -> IO (NameEnv SpanDoc)
getDocs (forall a. [(Name, a)] -> NameEnv a
mkNameEnv forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HsDocString -> SpanDocUris -> SpanDoc
`SpanDocString` Maybe Text -> Maybe Text -> SpanDocUris
SpanDocUris forall a. Maybe a
Nothing forall a. Maybe a
Nothing) Map Name HsDocString
this_docs) [Name]
names
#endif
     NameEnv TyThing
k <- forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM Name -> NameEnv TyThing -> IO (NameEnv TyThing)
getType (TcGblEnv -> NameEnv TyThing
tcg_type_env TcGblEnv
this_mod) [Name]
names
     forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NameEnv SpanDoc -> NameEnv TyThing -> DocAndKindMap
DKMap NameEnv SpanDoc
d NameEnv TyThing
k
  where
    getDocs :: Name -> NameEnv SpanDoc -> IO (NameEnv SpanDoc)
getDocs Name
n NameEnv SpanDoc
map
      | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Module
mod forall a. Eq a => a -> a -> Bool
==) forall a b. (a -> b) -> a -> b
$ Name -> Maybe Module
nameModule_maybe Name
n = forall (f :: * -> *) a. Applicative f => a -> f a
pure NameEnv SpanDoc
map -- we already have the docs in this_docs, or they do not exist
      | Bool
otherwise = do
      SpanDoc
doc <- HscEnv -> Name -> IO SpanDoc
getDocumentationTryGhc HscEnv
env Name
n
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameEnv SpanDoc
map Name
n SpanDoc
doc
    getType :: Name -> NameEnv TyThing -> IO (NameEnv TyThing)
getType Name
n NameEnv TyThing
map
      | OccName -> Bool
isTcOcc forall a b. (a -> b) -> a -> b
$ forall name. HasOccName name => name -> OccName
occName Name
n
      , Maybe TyThing
Nothing <- forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TyThing
map Name
n
      = do Maybe TyThing
kind <- HscEnv -> Name -> IO (Maybe TyThing)
lookupKind HscEnv
env Name
n
           forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe NameEnv TyThing
map (forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameEnv TyThing
map Name
n) Maybe TyThing
kind
      | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure NameEnv TyThing
map
    names :: [Name]
names = forall a b. [Either a b] -> [b]
rights forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList Set Identifier
idents
    idents :: Set Identifier
idents = 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 -> Name -> IO (Maybe TyThing)
lookupKind :: HscEnv -> Name -> IO (Maybe TyThing)
lookupKind HscEnv
env =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> Either a b -> b
fromRight forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
env) Text
"span" forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> Name -> IO (Maybe TyThing)
lookupName HscEnv
env

getDocumentationTryGhc :: HscEnv -> Name -> IO SpanDoc
getDocumentationTryGhc :: HscEnv -> Name -> IO SpanDoc
getDocumentationTryGhc HscEnv
env Name
n =
  (forall a. a -> Maybe a -> a
fromMaybe SpanDoc
emptySpanDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> [Name] -> IO [SpanDoc]
getDocumentationsTryGhc HscEnv
env [Name
n])
    forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(IOEnvFailure
_ :: IOEnvFailure) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SpanDoc
emptySpanDoc)

getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [SpanDoc]
getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [SpanDoc]
getDocumentationsTryGhc HscEnv
env [Name]
names = do
  Either
  [FileDiagnostic]
  [Either String (Maybe HsDocString, IntMap HsDocString)]
res <- forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
env) Text
"docs" forall a b. (a -> b) -> a -> b
$ HscEnv
-> [Name]
-> IO [Either String (Maybe HsDocString, IntMap HsDocString)]
getDocsBatch HscEnv
env [Name]
names
  case Either
  [FileDiagnostic]
  [Either String (Maybe HsDocString, IntMap HsDocString)]
res of
      Left [FileDiagnostic]
_    -> forall (m :: * -> *) a. Monad m => a -> m a
return []
      Right [Either String (Maybe HsDocString, IntMap HsDocString)]
res -> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM 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
#if MIN_VERSION_ghc(9,3,0)
    unwrap (Right (Just docs, _)) n = SpanDocString (map hsDocString docs) <$> getUris n
#else
    unwrap :: Either a (Maybe HsDocString, b) -> Name -> f SpanDoc
unwrap (Right (Just HsDocString
docs, b
_)) Name
n = HsDocString -> SpanDocUris -> SpanDoc
SpanDocString HsDocString
docs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *}. MonadIO m => Name -> m SpanDocUris
getUris Name
n
#endif
    unwrap Either a (Maybe HsDocString, b)
_ Name
n                      = forall {f :: * -> *}. MonadIO f => Name -> f SpanDoc
mkSpanDocText Name
n

    mkSpanDocText :: Name -> f SpanDoc
mkSpanDocText Name
name =
      [Text] -> SpanDocUris -> SpanDoc
SpanDocText [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            Maybe Text
doc <- IO (Maybe String) -> IO (Maybe Text)
toFileUriText 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 forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Maybe String)
lookupSrcHtmlForModule HscEnv
env Module
mod
            forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
doc, Maybe Text
src)
          Maybe Module
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
      let docUri :: Maybe Text
docUri = (forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
selector forall a. Semigroup a => a -> a -> a
<> forall a. Outputable a => a -> Text
printOutputable Name
name) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
docFu
          srcUri :: Maybe Text
srcUri = (forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> forall a. Outputable a => a -> Text
printOutputable Name
name) 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:"
      forall (m :: * -> *) a. Monad m => a -> m a
return 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 = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Uri -> Text
getUri 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 solely on GHC's parsing)
getDocumentation :: forall name. HasSrcSpan name => [ParsedModule] -> name -> [Text]
getDocumentation [ParsedModule]
sources name
targetName = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ do
#if MIN_VERSION_ghc(9,2,0)
  forall a. Maybe a
Nothing
#else
  -- Find the module the target is defined in.
  targetNameSpan <- realSpan $ getLoc targetName
  tc <-
    find ((==) (Just $ srcSpanFile targetNameSpan) . annotationFileName)
      $ reverse sources -- TODO : Is reversing the list here really necessary?

  -- Top level names bound by the module
  let bs = [ n | let L _ HsModule{hsmodDecls} = pm_parsed_source tc
           , L _ (ValD _ hsbind) <- hsmodDecls
           , Just n <- [name_of_bind hsbind]
           ]
  -- Sort the names' source spans.
  let sortedSpans = sortedNameSpans bs
  -- Now go ahead and extract the docs.
  let docs = ann tc
  nameInd <- elemIndex targetNameSpan sortedSpans
  let prevNameSpan =
        if nameInd >= 1
        then sortedSpans !! (nameInd - 1)
        else zeroSpan $ srcSpanFile targetNameSpan
  -- Annoyingly "-- |" documentation isn't annotated with a location,
  -- so you have to pull it out from the elements.
  pure
      $ docHeaders
      $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan)
      $ fold
      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 FunBind {fun_id} = Just fun_id
    name_of_bind _                = Nothing
    -- Get source spans from names, discard unhelpful spans, remove
    -- duplicates and sort.
    sortedNameSpans :: [Located RdrName] -> [RealSrcSpan]
    sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls)
    isBetween target before after = before <= target && target <= after
#if MIN_VERSION_ghc(9,0,0)
    ann = apiAnnComments . pm_annotations
#else
    ann = fmap filterReal . snd . pm_annotations
    filterReal :: [Located a] -> [RealLocated a]
    filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l)
#endif
    annotationFileName :: ParsedModule -> Maybe FastString
    annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann

-- | Shows this part of the documentation
docHeaders :: [RealLocated AnnotationComment]
           -> [T.Text]
docHeaders = mapMaybe (\(L _ x) -> wrk x)
  where
  wrk = \case
    -- When `Opt_Haddock` is enabled.
    AnnDocCommentNext s -> Just $ T.pack s
    -- When `Opt_KeepRawTokenStream` enabled.
    AnnLineComment s  -> if "-- |" `isPrefixOf` s
                            then Just $ T.pack s
                            else Nothing
    _ -> 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
go) (HscEnv -> GenUnit UnitId -> Maybe [String]
lookupHtmls HscEnv
hscEnv GenUnit UnitId
ui)
  Maybe String
html <- forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM String -> IO Bool
doesFileExist (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> [a]
maybeToList 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)
  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 = forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
mkDocPath String
pkgDocDir) [String]
mns
    ui :: GenUnit UnitId
ui = Module -> GenUnit UnitId
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 <- (forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
drop1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]]
inits forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Partial, Eq a) => [a] -> [a] -> [[a]]
splitOn String
".") forall a b. (a -> b) -> a -> b
$ (ModuleName -> String
moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
moduleName) Module
m
      -- The file might use "." or "-" as separator
      forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [[a]] -> [a]
`intercalate` [String]
chunks) [String
".", String
"-"]

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