-- 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.IntMap                     (IntMap)
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           GHC.Iface.Ext.Utils             (RefMap)
import           Language.LSP.Protocol.Types     (filePathToUri, getUri)
import           Prelude                         hiding (mod)
import           System.Directory
import           System.FilePath


mkDocMap
  :: HscEnv
  -> RefMap a
  -> TcGblEnv
  -> IO DocAndTyThingMap
mkDocMap :: forall a. HscEnv -> RefMap a -> TcGblEnv -> IO DocAndTyThingMap
mkDocMap HscEnv
env RefMap a
rm TcGblEnv
this_mod =
  do
     (Just Docs{docs_decls :: Docs -> UniqMap Name [HsDoc GhcRn]
docs_decls = UniqMap UniqFM Name (Name, [HsDoc GhcRn])
this_docs, docs_args :: Docs -> UniqMap Name (IntMap (HsDoc GhcRn))
docs_args = UniqMap UniqFM Name (Name, IntMap (HsDoc GhcRn))
this_arg_docs}) <- DynFlags -> TcGblEnv -> IO (Maybe Docs)
forall (m :: * -> *).
MonadIO m =>
DynFlags -> TcGblEnv -> m (Maybe Docs)
extractDocs (HscEnv -> DynFlags
hsc_dflags HscEnv
env) TcGblEnv
this_mod
     NameEnv SpanDoc
d <- (Name -> NameEnv SpanDoc -> IO (NameEnv SpanDoc))
-> NameEnv SpanDoc -> [Name] -> IO (NameEnv SpanDoc)
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 (((Name, [HsDoc GhcRn]) -> SpanDoc)
-> UniqFM Name (Name, [HsDoc GhcRn]) -> NameEnv SpanDoc
forall a b. (a -> b) -> UniqFM Name a -> UniqFM Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Name
_, [HsDoc GhcRn]
x) -> ((HsDoc GhcRn -> HsDocString) -> [HsDoc GhcRn] -> [HsDocString]
forall a b. (a -> b) -> [a] -> [b]
map HsDoc GhcRn -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString [HsDoc GhcRn]
x) [HsDocString] -> SpanDocUris -> SpanDoc
`SpanDocString` Maybe Text -> Maybe Text -> SpanDocUris
SpanDocUris Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) UniqFM Name (Name, [HsDoc GhcRn])
this_docs) [Name]
names
     NameEnv TyThing
k <- (Name -> NameEnv TyThing -> IO (NameEnv TyThing))
-> NameEnv TyThing -> [Name] -> IO (NameEnv TyThing)
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
     NameEnv (IntMap SpanDoc)
a <- (Name -> NameEnv (IntMap SpanDoc) -> IO (NameEnv (IntMap SpanDoc)))
-> NameEnv (IntMap SpanDoc)
-> [Name]
-> IO (NameEnv (IntMap SpanDoc))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM Name -> NameEnv (IntMap SpanDoc) -> IO (NameEnv (IntMap SpanDoc))
getArgDocs (((Name, IntMap (HsDoc GhcRn)) -> IntMap SpanDoc)
-> UniqFM Name (Name, IntMap (HsDoc GhcRn))
-> NameEnv (IntMap SpanDoc)
forall a b. (a -> b) -> UniqFM Name a -> UniqFM Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Name
_, IntMap (HsDoc GhcRn)
m) -> (HsDoc GhcRn -> SpanDoc) -> IntMap (HsDoc GhcRn) -> IntMap SpanDoc
forall a b. (a -> b) -> IntMap a -> IntMap b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HsDoc GhcRn
x -> [HsDoc GhcRn -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString HsDoc GhcRn
x] [HsDocString] -> SpanDocUris -> SpanDoc
`SpanDocString` Maybe Text -> Maybe Text -> SpanDocUris
SpanDocUris Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) IntMap (HsDoc GhcRn)
m) UniqFM Name (Name, IntMap (HsDoc GhcRn))
this_arg_docs) [Name]
names
     DocAndTyThingMap -> IO DocAndTyThingMap
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DocAndTyThingMap -> IO DocAndTyThingMap)
-> DocAndTyThingMap -> IO DocAndTyThingMap
forall a b. (a -> b) -> a -> b
$ NameEnv SpanDoc
-> NameEnv TyThing -> NameEnv (IntMap SpanDoc) -> DocAndTyThingMap
DKMap NameEnv SpanDoc
d NameEnv TyThing
k NameEnv (IntMap SpanDoc)
a
  where
    getDocs :: Name -> NameEnv SpanDoc -> IO (NameEnv SpanDoc)
getDocs Name
n NameEnv SpanDoc
nameMap
      | Bool -> (Module -> Bool) -> Maybe Module -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Module
mod ==) (Maybe Module -> Bool) -> Maybe Module -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Module
nameModule_maybe Name
n = NameEnv SpanDoc -> IO (NameEnv SpanDoc)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameEnv SpanDoc
nameMap -- we already have the docs in this_docs, or they do not exist
      | Bool
otherwise = do
      (SpanDoc
doc, IntMap SpanDoc
_argDoc) <- HscEnv -> Name -> IO (SpanDoc, IntMap SpanDoc)
getDocumentationTryGhc HscEnv
env Name
n
      NameEnv SpanDoc -> IO (NameEnv SpanDoc)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NameEnv SpanDoc -> IO (NameEnv SpanDoc))
-> NameEnv SpanDoc -> IO (NameEnv SpanDoc)
forall a b. (a -> b) -> a -> b
$ NameEnv SpanDoc -> Name -> SpanDoc -> NameEnv SpanDoc
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameEnv SpanDoc
nameMap Name
n SpanDoc
doc
    getType :: Name -> NameEnv TyThing -> IO (NameEnv TyThing)
getType Name
n NameEnv TyThing
nameMap
      | Maybe TyThing
Nothing <- NameEnv TyThing -> Name -> Maybe TyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TyThing
nameMap Name
n
      = do Maybe TyThing
kind <- HscEnv -> Name -> IO (Maybe TyThing)
lookupKind HscEnv
env Name
n
           NameEnv TyThing -> IO (NameEnv TyThing)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NameEnv TyThing -> IO (NameEnv TyThing))
-> NameEnv TyThing -> IO (NameEnv TyThing)
forall a b. (a -> b) -> a -> b
$ NameEnv TyThing
-> (TyThing -> NameEnv TyThing) -> Maybe TyThing -> NameEnv TyThing
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NameEnv TyThing
nameMap (NameEnv TyThing -> Name -> TyThing -> NameEnv TyThing
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameEnv TyThing
nameMap Name
n) Maybe TyThing
kind
      | Bool
otherwise = NameEnv TyThing -> IO (NameEnv TyThing)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameEnv TyThing
nameMap
    getArgDocs :: Name -> NameEnv (IntMap SpanDoc) -> IO (NameEnv (IntMap SpanDoc))
getArgDocs Name
n NameEnv (IntMap SpanDoc)
nameMap
      | Bool -> (Module -> Bool) -> Maybe Module -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Module
mod ==) (Maybe Module -> Bool) -> Maybe Module -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Module
nameModule_maybe Name
n = NameEnv (IntMap SpanDoc) -> IO (NameEnv (IntMap SpanDoc))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameEnv (IntMap SpanDoc)
nameMap
      | Bool
otherwise = do
      (SpanDoc
_doc, IntMap SpanDoc
argDoc) <- HscEnv -> Name -> IO (SpanDoc, IntMap SpanDoc)
getDocumentationTryGhc HscEnv
env Name
n
      NameEnv (IntMap SpanDoc) -> IO (NameEnv (IntMap SpanDoc))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NameEnv (IntMap SpanDoc) -> IO (NameEnv (IntMap SpanDoc)))
-> NameEnv (IntMap SpanDoc) -> IO (NameEnv (IntMap SpanDoc))
forall a b. (a -> b) -> a -> b
$ NameEnv (IntMap SpanDoc)
-> Name -> IntMap SpanDoc -> NameEnv (IntMap SpanDoc)
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv NameEnv (IntMap SpanDoc)
nameMap Name
n IntMap SpanDoc
argDoc
    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 -> Name -> IO (Maybe TyThing)
lookupKind :: HscEnv -> Name -> IO (Maybe TyThing)
lookupKind HscEnv
env =
    (Either [FileDiagnostic] (Maybe TyThing) -> Maybe TyThing)
-> IO (Either [FileDiagnostic] (Maybe TyThing))
-> IO (Maybe TyThing)
forall a b. (a -> b) -> IO a -> IO b
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 -> Name -> IO (Maybe TyThing)
lookupName HscEnv
env

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

getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)]
getDocumentationsTryGhc :: HscEnv -> [Name] -> IO [(SpanDoc, IntMap SpanDoc)]
getDocumentationsTryGhc HscEnv
env [Name]
names = do
  Either
  [FileDiagnostic]
  [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
resOr <- DynFlags
-> Text
-> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
-> IO
     (Either
        [FileDiagnostic]
        [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))])
forall a.
DynFlags -> Text -> IO a -> IO (Either [FileDiagnostic] a)
catchSrcErrors (HscEnv -> DynFlags
hsc_dflags HscEnv
env) Text
"docs" (IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
 -> IO
      (Either
         [FileDiagnostic]
         [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]))
-> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
-> IO
     (Either
        [FileDiagnostic]
        [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))])
forall a b. (a -> b) -> a -> b
$ HscEnv
-> [Name]
-> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
getDocsBatch HscEnv
env [Name]
names
  case Either
  [FileDiagnostic]
  [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
resOr of
      Left [FileDiagnostic]
_    -> [(SpanDoc, IntMap SpanDoc)] -> IO [(SpanDoc, IntMap SpanDoc)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Right [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
res -> (Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
 -> Name -> IO (SpanDoc, IntMap SpanDoc))
-> [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
-> [Name]
-> IO [(SpanDoc, IntMap SpanDoc)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))
-> Name -> IO (SpanDoc, IntMap SpanDoc)
forall {f :: * -> *} {f :: * -> *} {a} {pass} {pass}.
(Functor f, MonadIO f, Monoid (f SpanDoc)) =>
Either
  a
  (Maybe [WithHsDocIdentifiers HsDocString pass],
   f (WithHsDocIdentifiers HsDocString pass))
-> Name -> f (SpanDoc, f SpanDoc)
unwrap [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
res [Name]
names
  where
    unwrap :: Either
  a
  (Maybe [WithHsDocIdentifiers HsDocString pass],
   f (WithHsDocIdentifiers HsDocString pass))
-> Name -> f (SpanDoc, f SpanDoc)
unwrap (Right (Just [WithHsDocIdentifiers HsDocString pass]
docs, f (WithHsDocIdentifiers HsDocString pass)
argDocs)) Name
n = (\SpanDocUris
uris -> ([HsDocString] -> SpanDocUris -> SpanDoc
SpanDocString ((WithHsDocIdentifiers HsDocString pass -> HsDocString)
-> [WithHsDocIdentifiers HsDocString pass] -> [HsDocString]
forall a b. (a -> b) -> [a] -> [b]
map WithHsDocIdentifiers HsDocString pass -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString [WithHsDocIdentifiers HsDocString pass]
docs) SpanDocUris
uris, (WithHsDocIdentifiers HsDocString pass -> SpanDoc)
-> f (WithHsDocIdentifiers HsDocString pass) -> f SpanDoc
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\WithHsDocIdentifiers HsDocString pass
x -> [HsDocString] -> SpanDocUris -> SpanDoc
SpanDocString [WithHsDocIdentifiers HsDocString pass -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString WithHsDocIdentifiers HsDocString pass
x] SpanDocUris
uris) f (WithHsDocIdentifiers HsDocString pass)
argDocs)) (SpanDocUris -> (SpanDoc, f SpanDoc))
-> f SpanDocUris -> f (SpanDoc, 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 [WithHsDocIdentifiers HsDocString pass],
   f (WithHsDocIdentifiers HsDocString pass))
_ Name
n                      = Name -> f (SpanDoc, f SpanDoc)
forall {f :: * -> *} {b}.
(Monoid b, MonadIO f) =>
Name -> f (SpanDoc, b)
mkSpanDocText Name
n

    mkSpanDocText :: Name -> f (SpanDoc, b)
mkSpanDocText Name
name =
      (\SpanDocUris
uris -> ([Text] -> SpanDocUris -> SpanDoc
SpanDocText [] SpanDocUris
uris, b
forall a. Monoid a => a
mempty)) (SpanDocUris -> (SpanDoc, b)) -> f SpanDocUris -> f (SpanDoc, b)
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 a. IO a -> m a
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 a. a -> IO a
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 a. a -> m a
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 a. a -> m a
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 a b. (a -> b) -> IO a -> IO b
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 a b. (a -> b) -> Maybe a -> Maybe b
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]
getDocumentation :: forall name. HasSrcSpan name => [ParsedModule] -> name -> [Text]
getDocumentation [ParsedModule]
_sources name
_targetName = []

-- 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 a b. (a -> b) -> Maybe a -> Maybe b
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 -> GenUnit UnitId -> Maybe [String]
lookupHtmls HscEnv
hscEnv GenUnit 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe 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 :: GenUnit UnitId
ui = Module -> GenUnit UnitId
forall unit. GenModule unit -> 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. (HasCallStack, 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
forall unit. GenModule unit -> 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 -> 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
  (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 -> GenUnit UnitId -> Maybe UnitInfo
lookupUnit HscEnv
df GenUnit UnitId
ui