never executed always true always false
1 -- | Extract docs from the renamer output so they can be serialized.
2 {-# LANGUAGE LambdaCase #-}
3 {-# LANGUAGE RankNTypes #-}
4 {-# LANGUAGE TypeApplications #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# LANGUAGE FlexibleContexts #-}
8 {-# LANGUAGE ViewPatterns #-}
9 {-# LANGUAGE BangPatterns #-}
10
11 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
12
13 module GHC.HsToCore.Docs where
14
15 import GHC.Prelude
16 import GHC.Data.Bag
17 import GHC.Hs.Binds
18 import GHC.Hs.Doc
19 import GHC.Hs.Decls
20 import Language.Haskell.Syntax.Extension
21 import GHC.Hs.Extension
22 import GHC.Hs.Type
23 import GHC.Hs.Utils
24 import GHC.Types.Name
25 import GHC.Types.Name.Set
26 import GHC.Types.SrcLoc
27 import GHC.Tc.Types
28 import GHC.Parser.Annotation
29
30 import Control.Applicative
31 import Control.Monad.IO.Class
32 import Data.Bifunctor (first)
33 import Data.IntMap (IntMap)
34 import qualified Data.IntMap as IM
35 import Data.Map (Map)
36 import qualified Data.Map as M
37 import Data.Maybe
38 import Data.Semigroup
39 import GHC.IORef (readIORef)
40
41 -- | Extract docs from renamer output.
42 -- This is monadic since we need to be able to read documentation added from
43 -- Template Haskell's @putDoc@, which is stored in 'tcg_th_docs'.
44 extractDocs :: MonadIO m
45 => TcGblEnv
46 -> m (Maybe HsDocString, DeclDocMap, ArgDocMap)
47 -- ^
48 -- 1. Module header
49 -- 2. Docs on top level declarations
50 -- 3. Docs on arguments
51 extractDocs TcGblEnv { tcg_semantic_mod = mod
52 , tcg_rn_decls = mb_rn_decls
53 , tcg_insts = insts
54 , tcg_fam_insts = fam_insts
55 , tcg_doc_hdr = mb_doc_hdr
56 , tcg_th_docs = th_docs_var
57 } = do
58 th_docs <- liftIO $ readIORef th_docs_var
59 let doc_hdr = th_doc_hdr <|> (unLoc <$> mb_doc_hdr)
60 ExtractedTHDocs
61 th_doc_hdr
62 (DeclDocMap th_doc_map)
63 (ArgDocMap th_arg_map)
64 (DeclDocMap th_inst_map) = extractTHDocs th_docs
65 return
66 ( doc_hdr
67 , DeclDocMap (th_doc_map <> th_inst_map <> doc_map)
68 , ArgDocMap (th_arg_map `unionArgMaps` arg_map)
69 )
70 where
71 (doc_map, arg_map) = maybe (M.empty, M.empty)
72 (mkMaps local_insts)
73 mb_decls_with_docs
74 mb_decls_with_docs = topDecls <$> mb_rn_decls
75 local_insts = filter (nameIsLocalOrFrom mod)
76 $ map getName insts ++ map getName fam_insts
77
78 -- | Create decl and arg doc-maps by looping through the declarations.
79 -- For each declaration, find its names, its subordinates, and its doc strings.
80 mkMaps :: [Name]
81 -> [(LHsDecl GhcRn, [HsDocString])]
82 -> (Map Name (HsDocString), Map Name (IntMap HsDocString))
83 mkMaps instances decls =
84 ( f' (map (nubByName fst) decls')
85 , f (filterMapping (not . IM.null) args)
86 )
87 where
88 (decls', args) = unzip (map mappings decls)
89
90 f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b
91 f = M.fromListWith (<>) . concat
92
93 f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString
94 f' = M.fromListWith appendDocs . concat
95
96 filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]]
97 filterMapping p = map (filter (p . snd))
98
99 mappings :: (LHsDecl GhcRn, [HsDocString])
100 -> ( [(Name, HsDocString)]
101 , [(Name, IntMap HsDocString)]
102 )
103 mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, docStrs) =
104 (dm, am)
105 where
106 doc = concatDocs docStrs
107 args = declTypeDocs decl
108
109 subs :: [(Name, [HsDocString], IntMap HsDocString)]
110 subs = subordinates instanceMap decl
111
112 (subDocs, subArgs) =
113 unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs)
114
115 ns = names l decl
116 subNs = [ n | (n, _, _) <- subs ]
117 dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]
118 am = [(n, args) | n <- ns] ++ zip subNs subArgs
119 mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], [])
120
121 instanceMap :: Map RealSrcSpan Name
122 instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]
123
124 names :: RealSrcSpan -> HsDecl GhcRn -> [Name]
125 names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap
126 names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].
127 names _ decl = getMainDeclBinder decl
128
129 {-
130 Note [1]:
131 ---------
132 We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
133 inside them. That should work for normal user-written instances (from
134 looking at GHC sources). We can assume that commented instances are
135 user-written. This lets us relate Names (from ClsInsts) to comments
136 (associated with InstDecls and DerivDecls).
137 -}
138 getMainDeclBinder :: (Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p))
139 => HsDecl (GhcPass p) -> [IdP (GhcPass p)]
140 getMainDeclBinder (TyClD _ d) = [tcdName d]
141 getMainDeclBinder (ValD _ d) =
142 case collectHsBindBinders CollNoDictBinders d of
143 [] -> []
144 (name:_) -> [name]
145 getMainDeclBinder (SigD _ d) = sigNameNoLoc d
146 getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
147 getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
148 getMainDeclBinder _ = []
149
150
151 sigNameNoLoc :: forall pass. UnXRec pass => Sig pass -> [IdP pass]
152 sigNameNoLoc (TypeSig _ ns _) = map (unXRec @pass) ns
153 sigNameNoLoc (ClassOpSig _ _ ns _) = map (unXRec @pass) ns
154 sigNameNoLoc (PatSynSig _ ns _) = map (unXRec @pass) ns
155 sigNameNoLoc (SpecSig _ n _ _) = [unXRec @pass n]
156 sigNameNoLoc (InlineSig _ n _) = [unXRec @pass n]
157 sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @pass) ns
158 sigNameNoLoc _ = []
159
160 -- Extract the source location where an instance is defined. This is used
161 -- to correlate InstDecls with their Instance/CoAxiom Names, via the
162 -- instanceMap.
163 getInstLoc :: Anno (IdGhcP p) ~ SrcSpanAnnN => InstDecl (GhcPass p) -> SrcSpan
164 getInstLoc = \case
165 ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLocA ty
166 -- The Names of data and type family instances have their SrcSpan's attached
167 -- to the *type constructor*. For example, the Name "D:R:Foo:Int" would have
168 -- its SrcSpan attached here:
169 -- type family Foo a
170 -- type instance Foo Int = Bool
171 -- ^^^
172 DataFamInstD _ (DataFamInstDecl
173 { dfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l
174 -- Since CoAxioms' Names refer to the whole line for type family instances
175 -- in particular, we need to dig a bit deeper to pull out the entire
176 -- equation. This does not happen for data family instances, for some reason.
177 TyFamInstD _ (TyFamInstDecl
178 { tfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l
179
180 -- | Get all subordinate declarations inside a declaration, and their docs.
181 -- A subordinate declaration is something like the associate type or data
182 -- family of a type class.
183 subordinates :: Map RealSrcSpan Name
184 -> HsDecl GhcRn
185 -> [(Name, [HsDocString], IntMap HsDocString)]
186 subordinates instMap decl = case decl of
187 InstD _ (ClsInstD _ d) -> do
188 DataFamInstDecl { dfid_eqn =
189 FamEqn { feqn_tycon = L l _
190 , feqn_rhs = defn }} <- unLoc <$> cid_datafam_insts d
191 [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn
192
193 InstD _ (DataFamInstD _ (DataFamInstDecl d))
194 -> dataSubs (feqn_rhs d)
195 TyClD _ d | isClassDecl d -> classSubs d
196 | isDataDecl d -> dataSubs (tcdDataDefn d)
197 _ -> []
198 where
199 classSubs dd = [ (name, doc, declTypeDocs d)
200 | (L _ d, doc) <- classDecls dd
201 , name <- getMainDeclBinder d, not (isValD d)
202 ]
203 dataSubs :: HsDataDefn GhcRn
204 -> [(Name, [HsDocString], IntMap HsDocString)]
205 dataSubs dd = constrs ++ fields ++ derivs
206 where
207 cons = map unLoc $ (dd_cons dd)
208 constrs = [ ( unLoc cname
209 , maybeToList $ fmap unLoc $ con_doc c
210 , conArgDocs c)
211 | c <- cons, cname <- getConNames c ]
212 fields = [ (foExt n, maybeToList $ fmap unLoc doc, IM.empty)
213 | Just flds <- map getRecConArgs_maybe cons
214 , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
215 , (L _ n) <- ns ]
216 derivs = [ (instName, [unLoc doc], IM.empty)
217 | (l, doc) <- concatMap (extract_deriv_clause_tys .
218 deriv_clause_tys . unLoc) $
219 -- unLoc $ dd_derivs dd
220 dd_derivs dd
221 , Just instName <- [lookupSrcSpan l instMap] ]
222
223 extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDocString)]
224 extract_deriv_clause_tys (L _ dct) =
225 case dct of
226 DctSingle _ ty -> maybeToList $ extract_deriv_ty ty
227 DctMulti _ tys -> mapMaybe extract_deriv_ty tys
228
229 extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString)
230 extract_deriv_ty (L l (HsSig{sig_body = L _ ty})) =
231 case ty of
232 -- deriving (C a {- ^ Doc comment -})
233 HsDocTy _ _ doc -> Just (locA l, doc)
234 _ -> Nothing
235
236 -- | Extract constructor argument docs from inside constructor decls.
237 conArgDocs :: ConDecl GhcRn -> IntMap HsDocString
238 conArgDocs (ConDeclH98{con_args = args}) =
239 h98ConArgDocs args
240 conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =
241 gadtConArgDocs args (unLoc res_ty)
242
243 h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap HsDocString
244 h98ConArgDocs con_args = case con_args of
245 PrefixCon _ args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args
246 InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)
247 , unLoc (hsScaledThing arg2) ]
248 RecCon _ -> IM.empty
249
250 gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString
251 gadtConArgDocs con_args res_ty = case con_args of
252 PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]
253 RecConGADT _ _ -> con_arg_docs 1 [res_ty]
254
255 con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString
256 con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..]
257 where
258 f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
259 f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)
260 f _ _ = Nothing
261
262 isValD :: HsDecl a -> Bool
263 isValD (ValD _ _) = True
264 isValD _ = False
265
266 -- | All the sub declarations of a class (that we handle), ordered by
267 -- source location, with documentation attached if it exists.
268 classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
269 classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls
270 where
271 decls = docs ++ defs ++ sigs ++ ats
272 docs = mkDecls tcdDocs (DocD noExtField) class_
273 defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_
274 sigs = mkDecls tcdSigs (SigD noExtField) class_
275 ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_
276
277 -- | Extract function argument docs from inside top-level decls.
278 declTypeDocs :: HsDecl GhcRn -> IntMap (HsDocString)
279 declTypeDocs = \case
280 SigD _ (TypeSig _ _ ty) -> sigTypeDocs (unLoc (dropWildCards ty))
281 SigD _ (ClassOpSig _ _ _ ty) -> sigTypeDocs (unLoc ty)
282 SigD _ (PatSynSig _ _ ty) -> sigTypeDocs (unLoc ty)
283 ForD _ (ForeignImport _ _ ty _) -> sigTypeDocs (unLoc ty)
284 TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)
285 _ -> IM.empty
286
287 nubByName :: (a -> Name) -> [a] -> [a]
288 nubByName f ns = go emptyNameSet ns
289 where
290 go _ [] = []
291 go s (x:xs)
292 | y `elemNameSet` s = go s xs
293 | otherwise = let !s' = extendNameSet s y
294 in x : go s' xs
295 where
296 y = f x
297
298 -- | Extract function argument docs from inside types.
299 typeDocs :: HsType GhcRn -> IntMap HsDocString
300 typeDocs = go 0
301 where
302 go n = \case
303 HsForAllTy { hst_body = ty } -> go n (unLoc ty)
304 HsQualTy { hst_body = ty } -> go n (unLoc ty)
305 HsFunTy _ _ (unLoc->HsDocTy _ _ x) ty -> IM.insert n (unLoc x) $ go (n+1) (unLoc ty)
306 HsFunTy _ _ _ ty -> go (n+1) (unLoc ty)
307 HsDocTy _ _ doc -> IM.singleton n (unLoc doc)
308 _ -> IM.empty
309
310 -- | Extract function argument docs from inside types.
311 sigTypeDocs :: HsSigType GhcRn -> IntMap HsDocString
312 sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body)
313
314 -- | The top-level declarations of a module that we care about,
315 -- ordered by source location, with documentation attached if it exists.
316 topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
317 topDecls = filterClasses . filterDecls . collectDocs . sortLocatedA . ungroup
318
319 -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
320 ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
321 ungroup group_ =
322 mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++
323 mkDecls hs_derivds (DerivD noExtField) group_ ++
324 mkDecls hs_defds (DefD noExtField) group_ ++
325 mkDecls hs_fords (ForD noExtField) group_ ++
326 mkDecls hs_docs (DocD noExtField) group_ ++
327 mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++
328 mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++
329 mkDecls (valbinds . hs_valds) (ValD noExtField) group_
330 where
331 typesigs :: HsValBinds GhcRn -> [LSig GhcRn]
332 typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig
333 typesigs ValBinds{} = error "expected XValBindsLR"
334
335 valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn]
336 valbinds (XValBindsLR (NValBinds binds _)) =
337 concatMap bagToList . snd . unzip $ binds
338 valbinds ValBinds{} = error "expected XValBindsLR"
339
340 -- | Collect docs and attach them to the right declarations.
341 --
342 -- A declaration may have multiple doc strings attached to it.
343 collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])]
344 -- ^ This is an example.
345 collectDocs = go [] Nothing
346 where
347 go docs mprev decls = case (decls, mprev) of
348 ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds
349 ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds
350 ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds
351 (d : ds, Nothing) -> go docs (Just d) ds
352 (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds
353 ([] , Nothing) -> []
354 ([] , Just prev) -> finished prev docs []
355
356 finished decl docs rest = (decl, reverse docs) : rest
357
358 -- | Filter out declarations that we don't handle in Haddock
359 filterDecls :: forall p doc. UnXRec p => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]
360 filterDecls = filter (isHandled . unXRec @p . fst)
361 where
362 isHandled (ForD _ (ForeignImport {})) = True
363 isHandled (TyClD {}) = True
364 isHandled (InstD {}) = True
365 isHandled (DerivD {}) = True
366 isHandled (SigD _ d) = isUserSig d
367 isHandled (ValD {}) = True
368 -- we keep doc declarations to be able to get at named docs
369 isHandled (DocD {}) = True
370 isHandled _ = False
371
372
373 -- | Go through all class declarations and filter their sub-declarations
374 filterClasses :: forall p doc. (IsPass p) => [(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)]
375 filterClasses = map (first (mapLoc filterClass))
376 where
377 filterClass (TyClD x c@(ClassDecl {})) =
378 TyClD x $ c { tcdSigs =
379 filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }
380 filterClass d = d
381
382 -- | Was this signature given by the user?
383 isUserSig :: Sig name -> Bool
384 isUserSig TypeSig {} = True
385 isUserSig ClassOpSig {} = True
386 isUserSig PatSynSig {} = True
387 isUserSig _ = False
388
389 -- | Take a field of declarations from a data structure and create HsDecls
390 -- using the given constructor
391 mkDecls :: (struct -> [GenLocated l decl])
392 -> (decl -> hsDecl)
393 -> struct
394 -> [GenLocated l hsDecl]
395 mkDecls field con = map (mapLoc con) . field
396
397 -- | Extracts out individual maps of documentation added via Template Haskell's
398 -- @putDoc@.
399 extractTHDocs :: THDocs
400 -> ExtractedTHDocs
401 extractTHDocs docs =
402 -- Split up docs into separate maps for each 'DocLoc' type
403 ExtractedTHDocs
404 docHeader
405 (DeclDocMap (searchDocs decl))
406 (ArgDocMap (searchDocs args))
407 (DeclDocMap (searchDocs insts))
408 where
409 docHeader :: Maybe HsDocString
410 docHeader
411 | ((_, s):_) <- filter isModDoc (M.toList docs) = Just (mkHsDocString s)
412 | otherwise = Nothing
413
414 isModDoc (ModuleDoc, _) = True
415 isModDoc _ = False
416
417 -- Folds over the docs, applying 'f' as the accumulating function.
418 -- We use different accumulating functions to sift out the specific types of
419 -- documentation
420 searchDocs :: Monoid a => (a -> (DocLoc, String) -> a) -> a
421 searchDocs f = foldl' f mempty $ M.toList docs
422
423 -- Pick out the declaration docs
424 decl acc ((DeclDoc name), s) = M.insert name (mkHsDocString s) acc
425 decl acc _ = acc
426
427 -- Pick out the instance docs
428 insts acc ((InstDoc name), s) = M.insert name (mkHsDocString s) acc
429 insts acc _ = acc
430
431 -- Pick out the argument docs
432 args :: Map Name (IntMap HsDocString)
433 -> (DocLoc, String)
434 -> Map Name (IntMap HsDocString)
435 args acc ((ArgDoc name i), s) =
436 -- Insert the doc for the arg into the argument map for the function. This
437 -- means we have to search to see if an map already exists for the
438 -- function, and insert the new argument if it exists, or create a new map
439 let ds = mkHsDocString s
440 in M.insertWith (\_ m -> IM.insert i ds m) name (IM.singleton i ds) acc
441 args acc _ = acc
442
443 -- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two
444 -- maps with values for the same key merge the inner map as well.
445 -- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.
446 unionArgMaps :: Map Name (IntMap b)
447 -> Map Name (IntMap b)
448 -> Map Name (IntMap b)
449 unionArgMaps a b = M.foldlWithKey go b a
450 where
451 go acc n newArgMap
452 | Just oldArgMap <- M.lookup n acc =
453 M.insert n (newArgMap `IM.union` oldArgMap) acc
454 | otherwise = M.insert n newArgMap acc