@@ -63,9 +63,84 @@ lookupKind :: HscEnv -> Module -> Name -> IO (Maybe TyThing)
63
63
lookupKind env mod =
64
64
fmap (fromRight Nothing ) . catchSrcErrors (hsc_dflags env) " span" . lookupName env mod
65
65
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
66
104
getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc
67
105
-- 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
69
144
70
145
getDocumentationsTryGhc :: HscEnv -> Module -> [Name ] -> IO (M. Map Name SpanDoc )
71
146
getDocumentationsTryGhc env mod names = do
0 commit comments