Small refactorings in ExtractDocs
[ghc.git] / compiler / deSugar / ExtractDocs.hs
1 -- | Extract docs from the renamer output so they can be be serialized.
2 {-# LANGUAGE LambdaCase #-}
3 {-# LANGUAGE TypeFamilies #-}
4 {-# LANGUAGE FlexibleContexts #-}
5 {-# LANGUAGE ViewPatterns #-}
6
7 module ExtractDocs (extractDocs) where
8
9 import GhcPrelude
10 import Bag
11 import HsBinds
12 import HsDoc
13 import HsDecls
14 import HsExtension
15 import HsTypes
16 import HsUtils
17 import Name
18 import NameSet
19 import SrcLoc
20 import TcRnTypes
21
22 import Control.Applicative
23 import Data.Bifunctor (first)
24 import Data.List
25 import Data.Map (Map)
26 import qualified Data.Map as M
27 import Data.Maybe
28 import Data.Semigroup
29
30 -- | Extract docs from renamer output.
31 extractDocs :: TcGblEnv
32 -> (Maybe HsDocString, DeclDocMap, ArgDocMap)
33 -- ^
34 -- 1. Module header
35 -- 2. Docs on top level declarations
36 -- 3. Docs on arguments
37 extractDocs TcGblEnv { tcg_semantic_mod = mod
38 , tcg_rn_decls = mb_rn_decls
39 , tcg_insts = insts
40 , tcg_fam_insts = fam_insts
41 , tcg_doc_hdr = mb_doc_hdr
42 } =
43 (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map)
44 where
45 (doc_map, arg_map) = maybe (M.empty, M.empty)
46 (mkMaps local_insts)
47 mb_decls_with_docs
48 mb_decls_with_docs = topDecls <$> mb_rn_decls
49 local_insts = filter (nameIsLocalOrFrom mod)
50 $ map getName insts ++ map getName fam_insts
51
52 -- | Create decl and arg doc-maps by looping through the declarations.
53 -- For each declaration, find its names, its subordinates, and its doc strings.
54 mkMaps :: [Name]
55 -> [(LHsDecl GhcRn, [HsDocString])]
56 -> (Map Name (HsDocString), Map Name (Map Int (HsDocString)))
57 mkMaps instances decls =
58 ( f' (map (nubByName fst) decls')
59 , f (filterMapping (not . M.null) args)
60 )
61 where
62 (decls', args) = unzip (map mappings decls)
63
64 f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b
65 f = M.fromListWith (<>) . concat
66
67 f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString
68 f' = M.fromListWith appendDocs . concat
69
70 filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]]
71 filterMapping p = map (filter (p . snd))
72
73 mappings :: (LHsDecl GhcRn, [HsDocString])
74 -> ( [(Name, HsDocString)]
75 , [(Name, Map Int (HsDocString))]
76 )
77 mappings (L l decl, docStrs) =
78 (dm, am)
79 where
80 doc = concatDocs docStrs
81 args = declTypeDocs decl
82
83 subs :: [(Name, [(HsDocString)], Map Int (HsDocString))]
84 subs = subordinates instanceMap decl
85
86 (subDocs, subArgs) =
87 unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs)
88
89 ns = names l decl
90 subNs = [ n | (n, _, _) <- subs ]
91 dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]
92 am = [(n, args) | n <- ns] ++ zip subNs subArgs
93
94 instanceMap :: Map SrcSpan Name
95 instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances]
96
97 names :: SrcSpan -> HsDecl GhcRn -> [Name]
98 names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See
99 -- Note [1].
100 where loc = case d of
101 TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only
102 -- for TFs
103 _ -> getInstLoc d
104 names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].
105 names _ decl = getMainDeclBinder decl
106
107 {-
108 Note [1]:
109 ---------
110 We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
111 inside them. That should work for normal user-written instances (from
112 looking at GHC sources). We can assume that commented instances are
113 user-written. This lets us relate Names (from ClsInsts) to comments
114 (associated with InstDecls and DerivDecls).
115 -}
116
117 getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
118 getMainDeclBinder (TyClD _ d) = [tcdName d]
119 getMainDeclBinder (ValD _ d) =
120 case collectHsBindBinders d of
121 [] -> []
122 (name:_) -> [name]
123 getMainDeclBinder (SigD _ d) = sigNameNoLoc d
124 getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
125 getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
126 getMainDeclBinder _ = []
127
128 sigNameNoLoc :: Sig pass -> [IdP pass]
129 sigNameNoLoc (TypeSig _ ns _) = map unLoc ns
130 sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns
131 sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns
132 sigNameNoLoc (SpecSig _ n _ _) = [unLoc n]
133 sigNameNoLoc (InlineSig _ n _) = [unLoc n]
134 sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
135 sigNameNoLoc _ = []
136
137 -- Extract the source location where an instance is defined. This is used
138 -- to correlate InstDecls with their Instance/CoAxiom Names, via the
139 -- instanceMap.
140 getInstLoc :: InstDecl name -> SrcSpan
141 getInstLoc = \case
142 ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)
143 DataFamInstD _ (DataFamInstDecl
144 { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->L l _) }}}) -> l
145 TyFamInstD _ (TyFamInstDecl
146 -- Since CoAxioms' Names refer to the whole line for type family instances
147 -- in particular, we need to dig a bit deeper to pull out the entire
148 -- equation. This does not happen for data family instances, for some
149 -- reason.
150 { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = (dL->L l _) }}}) -> l
151 ClsInstD _ (XClsInstDecl _) -> error "getInstLoc"
152 DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
153 TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
154 XInstDecl _ -> error "getInstLoc"
155 DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
156 TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
157
158 -- | Get all subordinate declarations inside a declaration, and their docs.
159 -- A subordinate declaration is something like the associate type or data
160 -- family of a type class.
161 subordinates :: Map SrcSpan Name
162 -> HsDecl GhcRn
163 -> [(Name, [(HsDocString)], Map Int (HsDocString))]
164 subordinates instMap decl = case decl of
165 InstD _ (ClsInstD _ d) -> do
166 DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
167 FamEqn { feqn_tycon = (dL->L l _)
168 , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d
169 [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
170
171 InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
172 -> dataSubs (feqn_rhs d)
173 TyClD _ d | isClassDecl d -> classSubs d
174 | isDataDecl d -> dataSubs (tcdDataDefn d)
175 _ -> []
176 where
177 classSubs dd = [ (name, doc, declTypeDocs d)
178 | (dL->L _ d, doc) <- classDecls dd
179 , name <- getMainDeclBinder d, not (isValD d)
180 ]
181 dataSubs :: HsDataDefn GhcRn
182 -> [(Name, [HsDocString], Map Int (HsDocString))]
183 dataSubs dd = constrs ++ fields ++ derivs
184 where
185 cons = map unLoc $ (dd_cons dd)
186 constrs = [ ( unLoc cname
187 , maybeToList $ fmap unLoc $ con_doc c
188 , conArgDocs c)
189 | c <- cons, cname <- getConNames c ]
190 fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
191 | RecCon flds <- map getConArgs cons
192 , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
193 , (dL->L _ n) <- ns ]
194 derivs = [ (instName, [unLoc doc], M.empty)
195 | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
196 concatMap (unLoc . deriv_clause_tys . unLoc) $
197 unLoc $ dd_derivs dd
198 , Just instName <- [M.lookup l instMap] ]
199
200 extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
201 extract_deriv_ty ty =
202 case dL ty of
203 -- deriving (forall a. C a {- ^ Doc comment -})
204 L l (HsForAllTy{ hst_fvf = ForallInvis
205 , hst_body = dL->L _ (HsDocTy _ _ doc) })
206 -> Just (l, doc)
207 -- deriving (C a {- ^ Doc comment -})
208 L l (HsDocTy _ _ doc) -> Just (l, doc)
209 _ -> Nothing
210
211 -- | Extract constructor argument docs from inside constructor decls.
212 conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
213 conArgDocs con = case getConArgs con of
214 PrefixCon args -> go 0 (map unLoc args ++ ret)
215 InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)
216 RecCon _ -> go 1 ret
217 where
218 go n = M.fromList . catMaybes . zipWith f [n..]
219 where
220 f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
221 f _ _ = Nothing
222
223 ret = case con of
224 ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
225 _ -> []
226
227 isValD :: HsDecl a -> Bool
228 isValD (ValD _ _) = True
229 isValD _ = False
230
231 -- | All the sub declarations of a class (that we handle), ordered by
232 -- source location, with documentation attached if it exists.
233 classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
234 classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
235 where
236 decls = docs ++ defs ++ sigs ++ ats
237 docs = mkDecls tcdDocs (DocD noExt) class_
238 defs = mkDecls (bagToList . tcdMeths) (ValD noExt) class_
239 sigs = mkDecls tcdSigs (SigD noExt) class_
240 ats = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_
241
242 -- | Extract function argument docs from inside top-level decls.
243 declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)
244 declTypeDocs = \case
245 SigD _ (TypeSig _ _ ty) -> typeDocs (unLoc (hsSigWcType ty))
246 SigD _ (ClassOpSig _ _ _ ty) -> typeDocs (unLoc (hsSigType ty))
247 SigD _ (PatSynSig _ _ ty) -> typeDocs (unLoc (hsSigType ty))
248 ForD _ (ForeignImport _ _ ty _) -> typeDocs (unLoc (hsSigType ty))
249 TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)
250 _ -> M.empty
251
252 nubByName :: (a -> Name) -> [a] -> [a]
253 nubByName f ns = go emptyNameSet ns
254 where
255 go _ [] = []
256 go s (x:xs)
257 | y `elemNameSet` s = go s xs
258 | otherwise = let s' = extendNameSet s y
259 in x : go s' xs
260 where
261 y = f x
262
263 -- | Extract function argument docs from inside types.
264 typeDocs :: HsType GhcRn -> Map Int (HsDocString)
265 typeDocs = go 0
266 where
267 go n = \case
268 HsForAllTy { hst_body = ty } -> go n (unLoc ty)
269 HsQualTy { hst_body = ty } -> go n (unLoc ty)
270 HsFunTy _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty)
271 HsFunTy _ _ ty -> go (n+1) (unLoc ty)
272 HsDocTy _ _ doc -> M.singleton n (unLoc doc)
273 _ -> M.empty
274
275 -- | The top-level declarations of a module that we care about,
276 -- ordered by source location, with documentation attached if it exists.
277 topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
278 topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
279
280 -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
281 ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
282 ungroup group_ =
283 mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt) group_ ++
284 mkDecls hs_derivds (DerivD noExt) group_ ++
285 mkDecls hs_defds (DefD noExt) group_ ++
286 mkDecls hs_fords (ForD noExt) group_ ++
287 mkDecls hs_docs (DocD noExt) group_ ++
288 mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt) group_ ++
289 mkDecls (typesigs . hs_valds) (SigD noExt) group_ ++
290 mkDecls (valbinds . hs_valds) (ValD noExt) group_
291 where
292 typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs
293 typesigs ValBinds{} = error "expected XValBindsLR"
294
295 valbinds (XValBindsLR (NValBinds binds _)) =
296 concatMap bagToList . snd . unzip $ binds
297 valbinds ValBinds{} = error "expected XValBindsLR"
298
299 -- | Sort by source location
300 sortByLoc :: [Located a] -> [Located a]
301 sortByLoc = sortOn getLoc
302
303 -- | Collect docs and attach them to the right declarations.
304 --
305 -- A declaration may have multiple doc strings attached to it.
306 collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])]
307 -- ^ This is an example.
308 collectDocs = go [] Nothing
309 where
310 go docs mprev decls = case (decls, mprev) of
311 ((unLoc->DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds
312 ((unLoc->DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds
313 ((unLoc->DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds
314 (d : ds, Nothing) -> go docs (Just d) ds
315 (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds
316 ([] , Nothing) -> []
317 ([] , Just prev) -> finished prev docs []
318
319 finished decl docs rest = (decl, reverse docs) : rest
320
321 -- | Filter out declarations that we don't handle in Haddock
322 filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
323 filterDecls = filter (isHandled . unLoc . fst)
324 where
325 isHandled (ForD _ (ForeignImport {})) = True
326 isHandled (TyClD {}) = True
327 isHandled (InstD {}) = True
328 isHandled (DerivD {}) = True
329 isHandled (SigD _ d) = isUserSig d
330 isHandled (ValD {}) = True
331 -- we keep doc declarations to be able to get at named docs
332 isHandled (DocD {}) = True
333 isHandled _ = False
334
335
336 -- | Go through all class declarations and filter their sub-declarations
337 filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
338 filterClasses = map (first (mapLoc filterClass))
339 where
340 filterClass (TyClD x c@(ClassDecl {})) =
341 TyClD x $ c { tcdSigs =
342 filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }
343 filterClass d = d
344
345 -- | Was this signature given by the user?
346 isUserSig :: Sig name -> Bool
347 isUserSig TypeSig {} = True
348 isUserSig ClassOpSig {} = True
349 isUserSig PatSynSig {} = True
350 isUserSig _ = False
351
352 -- | Take a field of declarations from a data structure and create HsDecls
353 -- using the given constructor
354 mkDecls :: (struct -> [Located decl])
355 -> (decl -> hsDecl)
356 -> struct
357 -> [Located hsDecl]
358 mkDecls field con = map (mapLoc con) . field