Skip to content

Commit 1308553

Browse files
committed
WIP
1 parent 5c4926f commit 1308553

File tree

2 files changed

+79
-3
lines changed

2 files changed

+79
-3
lines changed

ghcide/src/Development/IDE/Core/Compile.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ module Development.IDE.Core.Compile
2828
, loadInterface
2929
, loadModulesHome
3030
, setupFinderCache
31+
, getDocsNonInteractive
3132
, getDocsBatch
3233
, lookupName
3334
,mergeEnvs) where
@@ -989,8 +990,8 @@ mkDetailsFromIface session iface linkable = do
989990
-- | Non-interactive modification of 'GHC.Runtime.Eval.getDocs'.
990991
-- The interactive paths create problems in ghc-lib builds
991992
--- and lead to fun errors like "Cannot continue after interface file error".
992-
getDocsNonInteractive :: Name -> IOEnv (Env TcGblEnv TcLclEnv) (Name, Either GetDocsFailure (Maybe HsDocString, Maybe (Map.Map Int HsDocString)))
993-
getDocsNonInteractive name = do
993+
getDocsNonInteractive :: Name -> IO (Name, Either GetDocsFailure (Maybe HsDocString, Maybe (Map.Map Int HsDocString)))
994+
getDocsNonInteractive name = undefined $ do
994995
case nameModule_maybe name of
995996
Nothing -> return (name, Left $ NameHasNoModule name)
996997
Just mod -> do

ghcide/src/Development/IDE/Spans/Documentation.hs

Lines changed: 76 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -63,9 +63,84 @@ lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing)
6363
lookupKind env mod =
6464
fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod
6565

66+
newGetDocumentationTryGhc :: HscEnv -> Name -> IO SpanDoc
67+
-- 2021-11-17: FIXME: Code uses batch search for singleton & assumes that search always succeeds.
68+
newGetDocumentationTryGhc env n = fun n
69+
where
70+
fun :: Name -> IO SpanDoc
71+
fun name = do
72+
res <- getDocsNonInteractive name
73+
uncurry unwrap res
74+
where
75+
unwrap :: Name -> Either a (Maybe HsDocString, b) -> IO SpanDoc
76+
unwrap name a = extractDocString a <$> getSpanDocUris name
77+
where
78+
extractDocString :: Either b1 (Maybe HsDocString, b2) -> SpanDocUris -> SpanDoc
79+
-- 2021-11-17: FIXME: ArgDocs get dropped here - instead propagate them.
80+
extractDocString (Right (Just docs, _)) = SpanDocString docs
81+
extractDocString _ = SpanDocText mempty
82+
83+
-- | Get the uris to the documentation and source html pages if they exist
84+
getSpanDocUris :: Name -> IO SpanDocUris
85+
getSpanDocUris name = do
86+
(docFu, srcFu) <-
87+
case nameModule_maybe name of
88+
Just mod -> liftIO $ do
89+
let
90+
toUriFileText :: (HscEnv -> Module -> IO (Maybe FilePath)) -> IO (Maybe T.Text)
91+
toUriFileText f = (fmap . fmap) (getUri . filePathToUri) $ f env mod
92+
doc <- toUriFileText lookupDocHtmlForModule
93+
src <- toUriFileText lookupSrcHtmlForModule
94+
return (doc, src)
95+
Nothing -> pure mempty
96+
let
97+
embelishUri :: Functor f => T.Text -> f T.Text -> f T.Text
98+
embelishUri f = fmap (<> "#" <> f <> showNameWithoutUniques name)
99+
100+
docUri = embelishUri (bool "t:" "v:" $ isValName name) docFu
101+
srcUri = embelishUri mempty srcFu
102+
103+
return $ SpanDocUris docUri srcUri
66104
getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc
67105
-- 2021-11-17: FIXME: Code uses batch search for singleton & assumes that search always succeeds.
68-
getDocumentationTryGhc env mod n = fromJust . M.lookup n <$> getDocumentationsTryGhc env mod [n]
106+
getDocumentationTryGhc env mod n = fromJust . M.lookup n <$> fun [n]
107+
where
108+
fun :: [Name] -> IO (M.Map Name SpanDoc)
109+
fun name = do
110+
res <- getDocsBatch env mod name
111+
case res of
112+
Left _ -> return mempty -- catchSrcErrors (hsc_dflags env) "docs"
113+
Right res -> sequenceA $ M.mapWithKey unwrap res
114+
where
115+
unwrap :: Name -> Either a (Maybe HsDocString, b) -> IO SpanDoc
116+
unwrap name a = extractDocString a <$> getSpanDocUris name
117+
where
118+
extractDocString :: Either b1 (Maybe HsDocString, b2) -> SpanDocUris -> SpanDoc
119+
-- 2021-11-17: FIXME: ArgDocs get dropped here - instead propagate them.
120+
extractDocString (Right (Just docs, _)) = SpanDocString docs
121+
extractDocString _ = SpanDocText mempty
122+
123+
-- | Get the uris to the documentation and source html pages if they exist
124+
getSpanDocUris :: Name -> IO SpanDocUris
125+
getSpanDocUris name = do
126+
(docFu, srcFu) <-
127+
case nameModule_maybe name of
128+
Just mod -> liftIO $ do
129+
let
130+
toUriFileText :: (HscEnv -> Module -> IO (Maybe FilePath)) -> IO (Maybe T.Text)
131+
toUriFileText f = (fmap . fmap) (getUri . filePathToUri) $ f env mod
132+
doc <- toUriFileText lookupDocHtmlForModule
133+
src <- toUriFileText lookupSrcHtmlForModule
134+
return (doc, src)
135+
Nothing -> pure mempty
136+
let
137+
embelishUri :: Functor f => T.Text -> f T.Text -> f T.Text
138+
embelishUri f = fmap (<> "#" <> f <> showNameWithoutUniques name)
139+
140+
docUri = embelishUri (bool "t:" "v:" $ isValName name) docFu
141+
srcUri = embelishUri mempty srcFu
142+
143+
return $ SpanDocUris docUri srcUri
69144

70145
getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO (M.Map Name SpanDoc)
71146
getDocumentationsTryGhc env mod names = do

0 commit comments

Comments
 (0)