-- 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           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
#if MIN_VERSION_ghc(9,3,0)
     (Just Docs{docs_decls :: Docs -> UniqMap Name [HsDoc GhcRn]
docs_decls = UniqMap UniqFM Name (Name, [HsDoc GhcRn])
this_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
#else
     (_ , DeclDocMap this_docs, _) <- extractDocs this_mod
#endif
#if MIN_VERSION_ghc(9,3,0)
     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
#else
     d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names
#endif
     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
     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 -> DocAndTyThingMap
DKMap NameEnv SpanDoc
d NameEnv TyThing
k
  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 <- HscEnv -> Name -> IO 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
    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
getDocumentationTryGhc :: HscEnv -> Name -> IO SpanDoc
getDocumentationTryGhc HscEnv
env Name
n =
  (SpanDoc -> Maybe SpanDoc -> SpanDoc
forall a. a -> Maybe a -> a
fromMaybe SpanDoc
emptySpanDoc (Maybe SpanDoc -> SpanDoc)
-> ([SpanDoc] -> Maybe SpanDoc) -> [SpanDoc] -> SpanDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SpanDoc] -> Maybe SpanDoc
forall a. [a] -> Maybe a
listToMaybe ([SpanDoc] -> SpanDoc) -> IO [SpanDoc] -> IO SpanDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> [Name] -> IO [SpanDoc]
getDocumentationsTryGhc HscEnv
env [Name
n])
    IO SpanDoc -> (IOEnvFailure -> IO SpanDoc) -> IO SpanDoc
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(IOEnvFailure
_ :: IOEnvFailure) -> SpanDoc -> IO SpanDoc
forall a. a -> IO a
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 [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] -> IO [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)
-> [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
-> [Name]
-> IO [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
forall {f :: * -> *} {a} {pass} {b}.
MonadIO f =>
Either a (Maybe [WithHsDocIdentifiers HsDocString pass], b)
-> Name -> f SpanDoc
unwrap [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
res [Name]
names
  where
#if MIN_VERSION_ghc(9,3,0)
    unwrap :: Either a (Maybe [WithHsDocIdentifiers HsDocString pass], b)
-> Name -> f SpanDoc
unwrap (Right (Just [WithHsDocIdentifiers HsDocString pass]
docs, b
_)) Name
n = [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 -> 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
#else
    unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n
#endif
    unwrap Either a (Maybe [WithHsDocIdentifiers HsDocString pass], 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 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