never executed always true always false
1 {-# LANGUAGE ApplicativeDo #-}
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE DerivingVia #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
6 {-# LANGUAGE NamedFieldPuns #-}
7 {-# LANGUAGE RankNTypes #-}
8 {-# LANGUAGE ScopedTypeVariables #-}
9 {-# LANGUAGE TypeApplications #-}
10 {-# LANGUAGE TypeFamilies #-}
11
12 {- | This module implements 'addHaddockToModule', which inserts Haddock
13 comments accumulated during parsing into the AST (#17544).
14
15 We process Haddock comments in two phases:
16
17 1. Parse the program (via the Happy parser in `Parser.y`), generating
18 an AST, and (quite separately) a list of all the Haddock comments
19 found in the file. More precisely, the Haddock comments are
20 accumulated in the `hdk_comments` field of the `PState`, the parser
21 state (see Lexer.x):
22
23 data PState = PState { ...
24 , hdk_comments :: [PsLocated HdkComment] }
25
26 Each of these Haddock comments has a `PsSpan`, which gives the `BufPos` of
27 the beginning and end of the Haddock comment.
28
29 2. Walk over the AST, attaching the Haddock comments to the correct
30 parts of the tree. This step is called `addHaddockToModule`, and is
31 implemented in this module.
32
33 See Note [Adding Haddock comments to the syntax tree].
34
35 This approach codifies an important principle:
36
37 The presence or absence of a Haddock comment should never change the parsing
38 of a program.
39
40 Alternative approaches that did not work properly:
41
42 1. Using 'RealSrcLoc' instead of 'BufPos'. This led to failures in presence
43 of {-# LANGUAGE CPP #-} and other sources of line pragmas. See documentation
44 on 'BufPos' (in GHC.Types.SrcLoc) for the details.
45
46 2. In earlier versions of GHC, the Haddock comments were incorporated into the
47 Parser.y grammar. The parser constructed the AST and attached comments to it in
48 a single pass. See Note [Old solution: Haddock in the grammar] for the details.
49 -}
50 module GHC.Parser.PostProcess.Haddock (addHaddockToModule) where
51
52 import GHC.Prelude hiding (mod)
53
54 import GHC.Hs
55
56 import GHC.Types.SrcLoc
57 import GHC.Utils.Panic
58 import GHC.Data.Bag
59
60 import Data.Semigroup
61 import Data.Foldable
62 import Data.Traversable
63 import Data.Maybe
64 import Control.Monad
65 import Control.Monad.Trans.State.Strict
66 import Control.Monad.Trans.Reader
67 import Control.Monad.Trans.Writer
68 import Data.Functor.Identity
69 import Data.Coerce
70 import qualified Data.Monoid
71
72 import GHC.Parser.Lexer
73 import GHC.Parser.Errors.Types
74 import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>))
75 import qualified GHC.Data.Strict as Strict
76
77 {- Note [Adding Haddock comments to the syntax tree]
78 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
79 'addHaddock' traverses the AST in concrete syntax order, building a computation
80 (represented by HdkA) that reconstructs the AST but with Haddock comments
81 inserted in appropriate positions:
82
83 addHaddock :: HasHaddock a => a -> HdkA a
84
85 Consider this code example:
86
87 f :: Int -- ^ comment on argument
88 -> Bool -- ^ comment on result
89
90 In the AST, the "Int" part of this snippet is represented like this
91 (pseudo-code):
92
93 L (BufSpan 6 8) (HsTyVar "Int") :: LHsType GhcPs
94
95 And the comments are represented like this (pseudo-code):
96
97 L (BufSpan 11 35) (HdkCommentPrev "comment on argument")
98 L (BufSpan 46 69) (HdkCommentPrev "comment on result")
99
100 So when we are traversing the AST and 'addHaddock' is applied to HsTyVar "Int",
101 how does it know to associate it with "comment on argument" but not with
102 "comment on result"?
103
104 The trick is to look in the space between syntactic elements. In the example above,
105 the location range in which we search for HdkCommentPrev is as follows:
106
107 f :: Int████████████████████████
108 ████Bool -- ^ comment on result
109
110 We search for comments after HsTyVar "Int" and until the next syntactic
111 element, in this case HsTyVar "Bool".
112
113 Ignoring the "->" allows us to accommodate alternative coding styles:
114
115 f :: Int -> -- ^ comment on argument
116 Bool -- ^ comment on result
117
118 Sometimes we also need to take indentation information into account.
119 Compare the following examples:
120
121 class C a where
122 f :: a -> Int
123 -- ^ comment on f
124
125 class C a where
126 f :: a -> Int
127 -- ^ comment on C
128
129 Notice how "comment on f" and "comment on C" differ only by indentation level.
130
131 Therefore, in order to know the location range in which the comments are applicable
132 to a syntactic elements, we need three nuggets of information:
133 1. lower bound on the BufPos of a comment
134 2. upper bound on the BufPos of a comment
135 3. minimum indentation level of a comment
136
137 This information is represented by the 'LocRange' type.
138
139 In order to propagate this information, we have the 'HdkA' applicative.
140 'HdkA' is defined as follows:
141
142 data HdkA a = HdkA (Maybe BufSpan) (HdkM a)
143
144 The first field contains a 'BufSpan', which represents the location
145 span taken by a syntactic element:
146
147 addHaddock (L bufSpan ...) = HdkA (Just bufSpan) ...
148
149 The second field, 'HdkM', is a stateful computation that looks up Haddock
150 comments in the specified location range:
151
152 HdkM a ≈
153 LocRange -- The allowed location range
154 -> [PsLocated HdkComment] -- Unallocated comments
155 -> (a, -- AST with comments inserted into it
156 [PsLocated HdkComment]) -- Leftover comments
157
158 The 'Applicative' instance for 'HdkA' is defined in such a way that the
159 location range of every computation is defined by its neighbours:
160
161 addHaddock aaa <*> addHaddock bbb <*> addHaddock ccc
162
163 Here, the 'LocRange' passed to the 'HdkM' computation of addHaddock bbb
164 is determined by the BufSpan recorded in addHaddock aaa and addHaddock ccc.
165
166 This is why it's important to traverse the AST in the order of the concrete
167 syntax. In the example above we assume that aaa, bbb, ccc are ordered by location:
168
169 * getBufSpan (getLoc aaa) < getBufSpan (getLoc bbb)
170 * getBufSpan (getLoc bbb) < getBufSpan (getLoc ccc)
171
172 Violation of this assumption would lead to bugs, and care must be taken to
173 traverse the AST correctly. For example, when dealing with class declarations,
174 we have to use 'flattenBindsAndSigs' to traverse it in the correct order.
175 -}
176
177 -- | Add Haddock documentation accumulated in the parser state
178 -- to a parsed HsModule.
179 --
180 -- Reports badly positioned comments when -Winvalid-haddock is enabled.
181 addHaddockToModule :: Located HsModule -> P (Located HsModule)
182 addHaddockToModule lmod = do
183 pState <- getPState
184 let all_comments = toList (hdk_comments pState)
185 initial_hdk_st = HdkSt all_comments []
186 (lmod', final_hdk_st) = runHdkA (addHaddock lmod) initial_hdk_st
187 hdk_warnings = collectHdkWarnings final_hdk_st
188 -- lmod': module with Haddock comments inserted into the AST
189 -- hdk_warnings: warnings accumulated during AST/comment processing
190 mapM_ reportHdkWarning hdk_warnings
191 return lmod'
192
193 reportHdkWarning :: HdkWarn -> P ()
194 reportHdkWarning (HdkWarnInvalidComment (L l _)) =
195 addPsMessage (mkSrcSpanPs l) PsWarnHaddockInvalidPos
196 reportHdkWarning (HdkWarnExtraComment (L l _)) =
197 addPsMessage l PsWarnHaddockIgnoreMulti
198
199 collectHdkWarnings :: HdkSt -> [HdkWarn]
200 collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } =
201 map HdkWarnInvalidComment hdk_st_pending -- leftover Haddock comments not inserted into the AST
202 ++ hdk_st_warnings
203
204 {- *********************************************************************
205 * *
206 * addHaddock: a family of functions that processes the AST *
207 * in concrete syntax order, adding documentation comments to it *
208 * *
209 ********************************************************************* -}
210
211 -- HasHaddock is a convenience class for overloading the addHaddock operation.
212 -- Alternatively, we could define a family of monomorphic functions:
213 --
214 -- addHaddockSomeTypeX :: SomeTypeX -> HdkA SomeTypeX
215 -- addHaddockAnotherTypeY :: AnotherTypeY -> HdkA AnotherTypeY
216 -- addHaddockOneMoreTypeZ :: OneMoreTypeZ -> HdkA OneMoreTypeZ
217 --
218 -- But having a single name for all of them is just easier to read, and makes it clear
219 -- that they all are of the form t -> HdkA t for some t.
220 --
221 -- If you need to handle a more complicated scenario that doesn't fit this
222 -- pattern, it's always possible to define separate functions outside of this
223 -- class, as is done in case of e.g. addHaddockConDeclField.
224 --
225 -- See Note [Adding Haddock comments to the syntax tree].
226 class HasHaddock a where
227 addHaddock :: a -> HdkA a
228
229 instance HasHaddock a => HasHaddock [a] where
230 addHaddock = traverse addHaddock
231
232 -- -- | Module header comment
233 -- module M (
234 -- -- * Export list comment
235 -- Item1,
236 -- Item2,
237 -- -- * Export list comment
238 -- item3,
239 -- item4
240 -- ) where
241 --
242 instance HasHaddock (Located HsModule) where
243 addHaddock (L l_mod mod) = do
244 -- Step 1, get the module header documentation comment:
245 --
246 -- -- | Module header comment
247 -- module M where
248 --
249 -- Only do this when the module header exists.
250 headerDocs <-
251 for @Maybe (hsmodName mod) $ \(L l_name _) ->
252 extendHdkA (locA l_name) $ liftHdkA $ do
253 -- todo: register keyword location of 'module', see Note [Register keyword location]
254 docs <-
255 inLocRange (locRangeTo (getBufPos (srcSpanStart (locA l_name)))) $
256 takeHdkComments mkDocNext
257 selectDocString docs
258
259 -- Step 2, process documentation comments in the export list:
260 --
261 -- module M (
262 -- -- * Export list comment
263 -- Item1,
264 -- Item2,
265 -- -- * Export list comment
266 -- item3,
267 -- item4
268 -- ) where
269 --
270 -- Only do this when the export list exists.
271 hsmodExports' <- traverse @Maybe addHaddock (hsmodExports mod)
272
273 -- Step 3, register the import section to reject invalid comments:
274 --
275 -- import Data.Maybe
276 -- -- | rejected comment (cannot appear here)
277 -- import Data.Bool
278 --
279 traverse_ registerHdkA (hsmodImports mod)
280
281 -- Step 4, process declarations:
282 --
283 -- module M where
284 -- -- | Comment on D
285 -- data D = MkD -- ^ Comment on MkD
286 -- data C = MkC -- ^ Comment on MkC
287 -- -- ^ Comment on C
288 --
289 let layout_info = hsmodLayout mod
290 hsmodDecls' <- addHaddockInterleaveItems layout_info (mkDocHsDecl layout_info) (hsmodDecls mod)
291
292 pure $ L l_mod $
293 mod { hsmodExports = hsmodExports'
294 , hsmodDecls = hsmodDecls'
295 , hsmodHaddockModHeader = join @Maybe headerDocs }
296
297 -- Only for module exports, not module imports.
298 --
299 -- module M (a, b, c) where -- use on this [LIE GhcPs]
300 -- import I (a, b, c) -- do not use here!
301 --
302 -- Imports cannot have documentation comments anyway.
303 instance HasHaddock (LocatedL [LocatedA (IE GhcPs)]) where
304 addHaddock (L l_exports exports) =
305 extendHdkA (locA l_exports) $ do
306 exports' <- addHaddockInterleaveItems NoLayoutInfo mkDocIE exports
307 registerLocHdkA (srcLocSpan (srcSpanEnd (locA l_exports))) -- Do not consume comments after the closing parenthesis
308 pure $ L l_exports exports'
309
310 -- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'.
311 instance HasHaddock (LocatedA (IE GhcPs)) where
312 addHaddock a = a <$ registerHdkA a
313
314 {- Add Haddock items to a list of non-Haddock items.
315 Used to process export lists (with mkDocIE) and declarations (with mkDocHsDecl).
316
317 For example:
318
319 module M where
320 -- | Comment on D
321 data D = MkD -- ^ Comment on MkD
322 data C = MkC -- ^ Comment on MkC
323 -- ^ Comment on C
324
325 In this case, we should produce four HsDecl items (pseudo-code):
326
327 1. DocD (DocCommentNext "Comment on D")
328 2. TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... (Just "Comment on MkD")])
329 3. TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... (Just "Comment on MkC")])
330 4. DocD (DocCommentPrev "Comment on C")
331
332 The inputs to addHaddockInterleaveItems are:
333
334 * layout_info :: LayoutInfo
335
336 In the example above, note that the indentation level inside the module is
337 2 spaces. It would be represented as layout_info = VirtualBraces 2.
338
339 It is used to delimit the search space for comments when processing
340 declarations. Here, we restrict indentation levels to >=(2+1), so that when
341 we look up comment on MkC, we get "Comment on MkC" but not "Comment on C".
342
343 * get_doc_item :: PsLocated HdkComment -> Maybe a
344
345 This is the function used to look up documentation comments.
346 In the above example, get_doc_item = mkDocHsDecl layout_info,
347 and it will produce the following parts of the output:
348
349 DocD (DocCommentNext "Comment on D")
350 DocD (DocCommentPrev "Comment on C")
351
352 * The list of items. These are the declarations that will be annotated with
353 documentation comments.
354
355 Before processing:
356 TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... Nothing])
357 TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... Nothing])
358
359 After processing:
360 TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... (Just "Comment on MkD")])
361 TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... (Just "Comment on MkC")])
362 -}
363 addHaddockInterleaveItems
364 :: forall a.
365 HasHaddock a
366 => LayoutInfo
367 -> (PsLocated HdkComment -> Maybe a) -- Get a documentation item
368 -> [a] -- Unprocessed (non-documentation) items
369 -> HdkA [a] -- Documentation items & processed non-documentation items
370 addHaddockInterleaveItems layout_info get_doc_item = go
371 where
372 go :: [a] -> HdkA [a]
373 go [] = liftHdkA (takeHdkComments get_doc_item)
374 go (item : items) = do
375 docItems <- liftHdkA (takeHdkComments get_doc_item)
376 item' <- with_layout_info (addHaddock item)
377 other_items <- go items
378 pure $ docItems ++ item':other_items
379
380 with_layout_info :: HdkA a -> HdkA a
381 with_layout_info = case layout_info of
382 NoLayoutInfo -> id
383 ExplicitBraces -> id
384 VirtualBraces n ->
385 let loc_range = mempty { loc_range_col = ColumnFrom (n+1) }
386 in hoistHdkA (inLocRange loc_range)
387
388 instance HasHaddock (LocatedA (HsDecl GhcPs)) where
389 addHaddock ldecl =
390 extendHdkA (getLocA ldecl) $
391 traverse @LocatedA addHaddock ldecl
392
393 -- Process documentation comments *inside* a declaration, for example:
394 --
395 -- data T = MkT -- ^ Comment on MkT (inside DataDecl)
396 -- f, g
397 -- :: Int -- ^ Comment on Int (inside TypeSig)
398 -- -> Bool -- ^ Comment on Bool (inside TypeSig)
399 --
400 -- Comments that relate to the entire declaration are processed elsewhere:
401 --
402 -- -- | Comment on T (not processed in this instance)
403 -- data T = MkT
404 --
405 -- -- | Comment on f, g (not processed in this instance)
406 -- f, g :: Int -> Bool
407 -- f = ...
408 -- g = ...
409 --
410 -- Such comments are inserted into the syntax tree as DocD declarations
411 -- by addHaddockInterleaveItems, and then associated with other declarations
412 -- in GHC.HsToCore.Docs (see DeclDocMap).
413 --
414 -- In this instance, we only process comments that relate to parts of the
415 -- declaration, not to the declaration itself.
416 instance HasHaddock (HsDecl GhcPs) where
417
418 -- Type signatures:
419 --
420 -- f, g
421 -- :: Int -- ^ Comment on Int
422 -- -> Bool -- ^ Comment on Bool
423 --
424 addHaddock (SigD _ (TypeSig x names t)) = do
425 traverse_ registerHdkA names
426 t' <- addHaddock t
427 pure (SigD noExtField (TypeSig x names t'))
428
429 -- Pattern synonym type signatures:
430 --
431 -- pattern MyPat
432 -- :: Bool -- ^ Comment on Bool
433 -- -> Maybe Bool -- ^ Comment on Maybe Bool
434 --
435 addHaddock (SigD _ (PatSynSig x names t)) = do
436 traverse_ registerHdkA names
437 t' <- addHaddock t
438 pure (SigD noExtField (PatSynSig x names t'))
439
440 -- Class method signatures and default signatures:
441 --
442 -- class C x where
443 -- method_of_c
444 -- :: Maybe x -- ^ Comment on Maybe x
445 -- -> IO () -- ^ Comment on IO ()
446 -- default method_of_c
447 -- :: Eq x
448 -- => Maybe x -- ^ Comment on Maybe x
449 -- -> IO () -- ^ Comment on IO ()
450 --
451 addHaddock (SigD _ (ClassOpSig x is_dflt names t)) = do
452 traverse_ registerHdkA names
453 t' <- addHaddock t
454 pure (SigD noExtField (ClassOpSig x is_dflt names t'))
455
456 -- Data/newtype declarations:
457 --
458 -- data T = MkT -- ^ Comment on MkT
459 -- A -- ^ Comment on A
460 -- B -- ^ Comment on B
461 --
462 -- data G where
463 -- -- | Comment on MkG
464 -- MkG :: A -- ^ Comment on A
465 -- -> B -- ^ Comment on B
466 -- -> G
467 --
468 -- newtype N = MkN { getN :: Natural } -- ^ Comment on N
469 -- deriving newtype (Eq {- ^ Comment on Eq N -})
470 -- deriving newtype (Ord {- ^ Comment on Ord N -})
471 --
472 addHaddock (TyClD x decl)
473 | DataDecl { tcdDExt, tcdLName, tcdTyVars, tcdFixity, tcdDataDefn = defn } <- decl
474 = do
475 registerHdkA tcdLName
476 defn' <- addHaddock defn
477 pure $
478 TyClD x (DataDecl {
479 tcdDExt,
480 tcdLName, tcdTyVars, tcdFixity,
481 tcdDataDefn = defn' })
482
483 -- Class declarations:
484 --
485 -- class C a where
486 -- -- | Comment on the first method
487 -- first_method :: a -> Bool
488 -- second_method :: a -> String
489 -- -- ^ Comment on the second method
490 --
491 addHaddock (TyClD _ decl)
492 | ClassDecl { tcdCExt = (x, NoAnnSortKey, tcdLayout),
493 tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs,
494 tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl
495 = do
496 registerHdkA tcdLName
497 -- todo: register keyword location of 'where', see Note [Register keyword location]
498 where_cls' <-
499 addHaddockInterleaveItems tcdLayout (mkDocHsDecl tcdLayout) $
500 flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], [])
501 pure $
502 let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs where_cls'
503 decl' = ClassDecl { tcdCExt = (x, NoAnnSortKey, tcdLayout)
504 , tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs
505 , tcdSigs = tcdSigs'
506 , tcdMeths = tcdMeths'
507 , tcdATs = tcdATs'
508 , tcdATDefs = tcdATDefs'
509 , tcdDocs }
510 in TyClD noExtField decl'
511
512 -- Data family instances:
513 --
514 -- data instance D Bool where ... (same as data/newtype declarations)
515 -- data instance D Bool = ... (same as data/newtype declarations)
516 --
517 addHaddock (InstD _ decl)
518 | DataFamInstD { dfid_ext, dfid_inst } <- decl
519 , DataFamInstDecl { dfid_eqn } <- dfid_inst
520 = do
521 dfid_eqn' <- case dfid_eqn of
522 FamEqn { feqn_ext, feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs }
523 -> do
524 registerHdkA feqn_tycon
525 feqn_rhs' <- addHaddock feqn_rhs
526 pure $ FamEqn {
527 feqn_ext,
528 feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity,
529 feqn_rhs = feqn_rhs' }
530 pure $ InstD noExtField (DataFamInstD {
531 dfid_ext,
532 dfid_inst = DataFamInstDecl { dfid_eqn = dfid_eqn' } })
533
534 -- Type synonyms:
535 --
536 -- type T = Int -- ^ Comment on Int
537 --
538 addHaddock (TyClD _ decl)
539 | SynDecl { tcdSExt, tcdLName, tcdTyVars, tcdFixity, tcdRhs } <- decl
540 = do
541 registerHdkA tcdLName
542 -- todo: register keyword location of '=', see Note [Register keyword location]
543 tcdRhs' <- addHaddock tcdRhs
544 pure $
545 TyClD noExtField (SynDecl {
546 tcdSExt,
547 tcdLName, tcdTyVars, tcdFixity,
548 tcdRhs = tcdRhs' })
549
550 -- Foreign imports:
551 --
552 -- foreign import ccall unsafe
553 -- o :: Float -- ^ The input float
554 -- -> IO Float -- ^ The output float
555 --
556 addHaddock (ForD _ decl) = do
557 registerHdkA (fd_name decl)
558 fd_sig_ty' <- addHaddock (fd_sig_ty decl)
559 pure $ ForD noExtField (decl{ fd_sig_ty = fd_sig_ty' })
560
561 -- Other declarations
562 addHaddock d = pure d
563
564 -- The right-hand side of a data/newtype declaration or data family instance.
565 instance HasHaddock (HsDataDefn GhcPs) where
566 addHaddock defn@HsDataDefn{} = do
567
568 -- Register the kind signature:
569 -- data D :: Type -> Type where ...
570 -- data instance D Bool :: Type where ...
571 traverse_ @Maybe registerHdkA (dd_kindSig defn)
572 -- todo: register keyword location of '=' or 'where', see Note [Register keyword location]
573
574 -- Process the data constructors:
575 --
576 -- data T
577 -- = MkT1 Int Bool -- ^ Comment on MkT1
578 -- | MkT2 Char Int -- ^ Comment on MkT2
579 --
580 dd_cons' <- addHaddock (dd_cons defn)
581
582 -- Process the deriving clauses:
583 --
584 -- newtype N = MkN Natural
585 -- deriving (Eq {- ^ Comment on Eq N -})
586 -- deriving (Ord {- ^ Comment on Ord N -})
587 --
588 dd_derivs' <- addHaddock (dd_derivs defn)
589
590 pure $ defn { dd_cons = dd_cons',
591 dd_derivs = dd_derivs' }
592
593 -- Process the deriving clauses of a data/newtype declaration.
594 -- Not used for standalone deriving.
595 instance HasHaddock (Located [LocatedAn NoEpAnns (HsDerivingClause GhcPs)]) where
596 addHaddock lderivs =
597 extendHdkA (getLoc lderivs) $
598 traverse @Located addHaddock lderivs
599
600 -- Process a single deriving clause of a data/newtype declaration:
601 --
602 -- newtype N = MkN Natural
603 -- deriving newtype (Eq {- ^ Comment on Eq N -})
604 -- deriving (Ord {- ^ Comment on Ord N -}) via Down N
605 --
606 -- Not used for standalone deriving.
607 instance HasHaddock (LocatedAn NoEpAnns (HsDerivingClause GhcPs)) where
608 addHaddock lderiv =
609 extendHdkA (getLocA lderiv) $
610 for @(LocatedAn NoEpAnns) lderiv $ \deriv ->
611 case deriv of
612 HsDerivingClause { deriv_clause_ext, deriv_clause_strategy, deriv_clause_tys } -> do
613 let
614 -- 'stock', 'anyclass', and 'newtype' strategies come
615 -- before the clause types.
616 --
617 -- 'via' comes after.
618 --
619 -- See tests/.../T11768.hs
620 (register_strategy_before, register_strategy_after) =
621 case deriv_clause_strategy of
622 Nothing -> (pure (), pure ())
623 Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA (locA l))
624 Just (L l _) -> (registerLocHdkA (locA l), pure ())
625 register_strategy_before
626 deriv_clause_tys' <- addHaddock deriv_clause_tys
627 register_strategy_after
628 pure HsDerivingClause
629 { deriv_clause_ext,
630 deriv_clause_strategy,
631 deriv_clause_tys = deriv_clause_tys' }
632
633 -- Process the types in a single deriving clause, which may come in one of the
634 -- following forms:
635 --
636 -- 1. A singular type constructor:
637 -- deriving Eq -- ^ Comment on Eq
638 --
639 -- 2. A list of comma-separated types surrounded by enclosing parentheses:
640 -- deriving ( Eq -- ^ Comment on Eq
641 -- , C a -- ^ Comment on C a
642 -- )
643 instance HasHaddock (LocatedC (DerivClauseTys GhcPs)) where
644 addHaddock (L l_dct dct) =
645 extendHdkA (locA l_dct) $
646 case dct of
647 DctSingle x ty -> do
648 ty' <- addHaddock ty
649 pure $ L l_dct $ DctSingle x ty'
650 DctMulti x tys -> do
651 tys' <- addHaddock tys
652 pure $ L l_dct $ DctMulti x tys'
653
654 -- Process a single data constructor declaration, which may come in one of the
655 -- following forms:
656 --
657 -- 1. H98-syntax PrefixCon:
658 -- data T =
659 -- MkT -- ^ Comment on MkT
660 -- Int -- ^ Comment on Int
661 -- Bool -- ^ Comment on Bool
662 --
663 -- 2. H98-syntax InfixCon:
664 -- data T =
665 -- Int -- ^ Comment on Int
666 -- :+ -- ^ Comment on (:+)
667 -- Bool -- ^ Comment on Bool
668 --
669 -- 3. H98-syntax RecCon:
670 -- data T =
671 -- MkT { int_field :: Int, -- ^ Comment on int_field
672 -- bool_field :: Bool } -- ^ Comment on bool_field
673 --
674 -- 4. GADT-syntax PrefixCon:
675 -- data T where
676 -- -- | Comment on MkT
677 -- MkT :: Int -- ^ Comment on Int
678 -- -> Bool -- ^ Comment on Bool
679 -- -> T
680 --
681 -- 5. GADT-syntax RecCon:
682 -- data T where
683 -- -- | Comment on MkT
684 -- MkT :: { int_field :: Int, -- ^ Comment on int_field
685 -- bool_field :: Bool } -- ^ Comment on bool_field
686 -- -> T
687 --
688 instance HasHaddock (LocatedA (ConDecl GhcPs)) where
689 addHaddock (L l_con_decl con_decl) =
690 extendHdkA (locA l_con_decl) $
691 case con_decl of
692 ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do
693 -- discardHasInnerDocs is ok because we don't need this info for GADTs.
694 con_doc' <- discardHasInnerDocs $ getConDoc (getLocA (head con_names))
695 con_g_args' <-
696 case con_g_args of
697 PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts
698 RecConGADT (L l_rec flds) arr -> do
699 -- discardHasInnerDocs is ok because we don't need this info for GADTs.
700 flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds
701 pure $ RecConGADT (L l_rec flds') arr
702 con_res_ty' <- addHaddock con_res_ty
703 pure $ L l_con_decl $
704 ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt,
705 con_doc = con_doc',
706 con_g_args = con_g_args',
707 con_res_ty = con_res_ty' }
708 ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } ->
709 addConTrailingDoc (srcSpanEnd $ locA l_con_decl) $
710 case con_args of
711 PrefixCon _ ts -> do
712 con_doc' <- getConDoc (getLocA con_name)
713 ts' <- traverse addHaddockConDeclFieldTy ts
714 pure $ L l_con_decl $
715 ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
716 con_doc = con_doc',
717 con_args = PrefixCon noTypeArgs ts' }
718 InfixCon t1 t2 -> do
719 t1' <- addHaddockConDeclFieldTy t1
720 con_doc' <- getConDoc (getLocA con_name)
721 t2' <- addHaddockConDeclFieldTy t2
722 pure $ L l_con_decl $
723 ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
724 con_doc = con_doc',
725 con_args = InfixCon t1' t2' }
726 RecCon (L l_rec flds) -> do
727 con_doc' <- getConDoc (getLocA con_name)
728 flds' <- traverse addHaddockConDeclField flds
729 pure $ L l_con_decl $
730 ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
731 con_doc = con_doc',
732 con_args = RecCon (L l_rec flds') }
733
734 -- Keep track of documentation comments on the data constructor or any of its
735 -- fields.
736 --
737 -- See Note [Trailing comment on constructor declaration]
738 type ConHdkA = WriterT HasInnerDocs HdkA
739
740 -- Does the data constructor declaration have any inner (non-trailing)
741 -- documentation comments?
742 --
743 -- Example when HasInnerDocs is True:
744 --
745 -- data X =
746 -- MkX -- ^ inner comment
747 -- Field1 -- ^ inner comment
748 -- Field2 -- ^ inner comment
749 -- Field3 -- ^ trailing comment
750 --
751 -- Example when HasInnerDocs is False:
752 --
753 -- data Y = MkY Field1 Field2 Field3 -- ^ trailing comment
754 --
755 -- See Note [Trailing comment on constructor declaration]
756 newtype HasInnerDocs = HasInnerDocs Bool
757 deriving (Semigroup, Monoid) via Data.Monoid.Any
758
759 -- Run ConHdkA by discarding the HasInnerDocs info when we have no use for it.
760 --
761 -- We only do this when processing data declarations that use GADT syntax,
762 -- because only the H98 syntax declarations have special treatment for the
763 -- trailing documentation comment.
764 --
765 -- See Note [Trailing comment on constructor declaration]
766 discardHasInnerDocs :: ConHdkA a -> HdkA a
767 discardHasInnerDocs = fmap fst . runWriterT
768
769 -- Get the documentation comment associated with the data constructor in a
770 -- data/newtype declaration.
771 getConDoc
772 :: SrcSpan -- Location of the data constructor
773 -> ConHdkA (Maybe LHsDocString)
774 getConDoc l =
775 WriterT $ extendHdkA l $ liftHdkA $ do
776 mDoc <- getPrevNextDoc l
777 return (mDoc, HasInnerDocs (isJust mDoc))
778
779 -- Add documentation comment to a data constructor field.
780 -- Used for PrefixCon and InfixCon.
781 addHaddockConDeclFieldTy
782 :: HsScaled GhcPs (LHsType GhcPs)
783 -> ConHdkA (HsScaled GhcPs (LHsType GhcPs))
784 addHaddockConDeclFieldTy (HsScaled mult (L l t)) =
785 WriterT $ extendHdkA (locA l) $ liftHdkA $ do
786 mDoc <- getPrevNextDoc (locA l)
787 return (HsScaled mult (mkLHsDocTy (L l t) mDoc),
788 HasInnerDocs (isJust mDoc))
789
790 -- Add documentation comment to a data constructor field.
791 -- Used for RecCon.
792 addHaddockConDeclField
793 :: LConDeclField GhcPs
794 -> ConHdkA (LConDeclField GhcPs)
795 addHaddockConDeclField (L l_fld fld) =
796 WriterT $ extendHdkA (locA l_fld) $ liftHdkA $ do
797 cd_fld_doc <- getPrevNextDoc (locA l_fld)
798 return (L l_fld (fld { cd_fld_doc }),
799 HasInnerDocs (isJust cd_fld_doc))
800
801 -- 1. Process a H98-syntax data constructor declaration in a context with no
802 -- access to the trailing documentation comment (by running the provided
803 -- ConHdkA computation).
804 --
805 -- 2. Then grab the trailing comment (if it exists) and attach it where
806 -- appropriate: either to the data constructor itself or to its last field,
807 -- depending on HasInnerDocs.
808 --
809 -- See Note [Trailing comment on constructor declaration]
810 addConTrailingDoc
811 :: SrcLoc -- The end of a data constructor declaration.
812 -- Any docprev comment past this point is considered trailing.
813 -> ConHdkA (LConDecl GhcPs)
814 -> HdkA (LConDecl GhcPs)
815 addConTrailingDoc l_sep =
816 hoistHdkA add_trailing_doc . runWriterT
817 where
818 add_trailing_doc
819 :: HdkM (LConDecl GhcPs, HasInnerDocs)
820 -> HdkM (LConDecl GhcPs)
821 add_trailing_doc m = do
822 (L l con_decl, HasInnerDocs has_inner_docs) <-
823 inLocRange (locRangeTo (getBufPos l_sep)) m
824 -- inLocRange delimits the context so that the inner computation
825 -- will not consume the trailing documentation comment.
826 case con_decl of
827 ConDeclH98{} -> do
828 trailingDocs <-
829 inLocRange (locRangeFrom (getBufPos l_sep)) $
830 takeHdkComments mkDocPrev
831 if null trailingDocs
832 then return (L l con_decl)
833 else do
834 if has_inner_docs then do
835 let mk_doc_ty :: HsScaled GhcPs (LHsType GhcPs)
836 -> HdkM (HsScaled GhcPs (LHsType GhcPs))
837 mk_doc_ty x@(HsScaled _ (L _ HsDocTy{})) =
838 -- Happens in the following case:
839 --
840 -- data T =
841 -- MkT
842 -- -- | Comment on SomeField
843 -- SomeField
844 -- -- ^ Another comment on SomeField? (rejected)
845 --
846 -- See tests/.../haddockExtraDocs.hs
847 x <$ reportExtraDocs trailingDocs
848 mk_doc_ty (HsScaled mult (L l' t)) = do
849 doc <- selectDocString trailingDocs
850 return $ HsScaled mult (mkLHsDocTy (L l' t) doc)
851 let mk_doc_fld :: LConDeclField GhcPs
852 -> HdkM (LConDeclField GhcPs)
853 mk_doc_fld x@(L _ (ConDeclField { cd_fld_doc = Just _ })) =
854 -- Happens in the following case:
855 --
856 -- data T =
857 -- MkT {
858 -- -- | Comment on SomeField
859 -- someField :: SomeField
860 -- } -- ^ Another comment on SomeField? (rejected)
861 --
862 -- See tests/.../haddockExtraDocs.hs
863 x <$ reportExtraDocs trailingDocs
864 mk_doc_fld (L l' con_fld) = do
865 doc <- selectDocString trailingDocs
866 return $ L l' (con_fld { cd_fld_doc = doc })
867 con_args' <- case con_args con_decl of
868 x@(PrefixCon _ []) -> x <$ reportExtraDocs trailingDocs
869 x@(RecCon (L _ [])) -> x <$ reportExtraDocs trailingDocs
870 PrefixCon _ ts -> PrefixCon noTypeArgs <$> mapLastM mk_doc_ty ts
871 InfixCon t1 t2 -> InfixCon t1 <$> mk_doc_ty t2
872 RecCon (L l_rec flds) -> do
873 flds' <- mapLastM mk_doc_fld flds
874 return (RecCon (L l_rec flds'))
875 return $ L l (con_decl{ con_args = con_args' })
876 else do
877 con_doc' <- selectDocString (con_doc con_decl `mcons` trailingDocs)
878 return $ L l (con_decl{ con_doc = con_doc' })
879 _ -> panic "addConTrailingDoc: non-H98 ConDecl"
880
881 {- Note [Trailing comment on constructor declaration]
882 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
883 The trailing comment after a constructor declaration is associated with the
884 constructor itself when there are no other comments inside the declaration:
885
886 data T = MkT A B -- ^ Comment on MkT
887 data T = MkT { x :: A } -- ^ Comment on MkT
888
889 When there are other comments, the trailing comment applies to the last field:
890
891 data T = MkT -- ^ Comment on MkT
892 A -- ^ Comment on A
893 B -- ^ Comment on B
894
895 data T =
896 MkT { a :: A -- ^ Comment on a
897 , b :: B -- ^ Comment on b
898 , c :: C } -- ^ Comment on c
899
900 This makes the trailing comment context-sensitive. Example:
901 data T =
902 -- | comment 1
903 MkT Int Bool -- ^ comment 2
904
905 Here, "comment 2" applies to the Bool field.
906 But if we removed "comment 1", then "comment 2" would be apply to the data
907 constructor rather than its field.
908
909 All of this applies to H98-style data declarations only.
910 GADTSyntax data constructors don't have any special treatment for the trailing comment.
911
912 We implement this in two steps:
913
914 1. Process the data constructor declaration in a delimited context where the
915 trailing documentation comment is not visible. Delimiting the context is done
916 in addConTrailingDoc.
917
918 When processing the declaration, track whether the constructor or any of
919 its fields have a documentation comment associated with them.
920 This is done using WriterT HasInnerDocs, see ConHdkA.
921
922 2. Depending on whether HasInnerDocs is True or False, attach the
923 trailing documentation comment to the data constructor itself
924 or to its last field.
925 -}
926
927 instance HasHaddock a => HasHaddock (HsScaled GhcPs a) where
928 addHaddock (HsScaled mult a) = HsScaled mult <$> addHaddock a
929
930 instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where
931 addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t
932
933 instance HasHaddock (LocatedA (HsSigType GhcPs)) where
934 addHaddock (L l (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =
935 extendHdkA (locA l) $ do
936 case outer_bndrs of
937 HsOuterImplicit{} -> pure ()
938 HsOuterExplicit{hso_bndrs = bndrs} ->
939 registerLocHdkA (getLHsTyVarBndrsLoc bndrs)
940 body' <- addHaddock body
941 pure $ L l $ HsSig noExtField outer_bndrs body'
942
943 -- Process a type, adding documentation comments to function arguments
944 -- and the result. Many formatting styles are supported.
945 --
946 -- my_function ::
947 -- forall a.
948 -- Eq a =>
949 -- Maybe a -> -- ^ Comment on Maybe a (function argument)
950 -- Bool -> -- ^ Comment on Bool (function argument)
951 -- String -- ^ Comment on String (the result)
952 --
953 -- my_function
954 -- :: forall a. Eq a
955 -- => Maybe a -- ^ Comment on Maybe a (function argument)
956 -- -> Bool -- ^ Comment on Bool (function argument)
957 -- -> String -- ^ Comment on String (the result)
958 --
959 -- my_function ::
960 -- forall a. Eq a =>
961 -- -- | Comment on Maybe a (function argument)
962 -- Maybe a ->
963 -- -- | Comment on Bool (function argument)
964 -- Bool ->
965 -- -- | Comment on String (the result)
966 -- String
967 --
968 -- This is achieved by simply ignoring (not registering the location of) the
969 -- function arrow (->).
970 instance HasHaddock (LocatedA (HsType GhcPs)) where
971 addHaddock (L l t) =
972 extendHdkA (locA l) $
973 case t of
974
975 -- forall a b c. t
976 HsForAllTy x tele body -> do
977 registerLocHdkA (getForAllTeleLoc tele)
978 body' <- addHaddock body
979 pure $ L l (HsForAllTy x tele body')
980
981 -- (Eq a, Num a) => t
982 HsQualTy x lhs rhs -> do
983 registerHdkA lhs
984 rhs' <- addHaddock rhs
985 pure $ L l (HsQualTy x lhs rhs')
986
987 -- arg -> res
988 HsFunTy u mult lhs rhs -> do
989 lhs' <- addHaddock lhs
990 rhs' <- addHaddock rhs
991 pure $ L l (HsFunTy u mult lhs' rhs')
992
993 -- other types
994 _ -> liftHdkA $ do
995 mDoc <- getPrevNextDoc (locA l)
996 return (mkLHsDocTy (L l t) mDoc)
997
998 {- *********************************************************************
999 * *
1000 * HdkA: a layer over HdkM that propagates location information *
1001 * *
1002 ********************************************************************* -}
1003
1004 -- See Note [Adding Haddock comments to the syntax tree].
1005 --
1006 -- 'HdkA' provides a way to propagate location information from surrounding
1007 -- computations:
1008 --
1009 -- left_neighbour <*> HdkA inner_span inner_m <*> right_neighbour
1010 --
1011 -- Here, the following holds:
1012 --
1013 -- * the 'left_neighbour' will only see Haddock comments until 'bufSpanStart' of 'inner_span'
1014 -- * the 'right_neighbour' will only see Haddock comments after 'bufSpanEnd' of 'inner_span'
1015 -- * the 'inner_m' will only see Haddock comments between its 'left_neighbour' and its 'right_neighbour'
1016 --
1017 -- In other words, every computation:
1018 --
1019 -- * delimits the surrounding computations
1020 -- * is delimited by the surrounding computations
1021 --
1022 -- Therefore, a 'HdkA' computation must be always considered in the context in
1023 -- which it is used.
1024 data HdkA a =
1025 HdkA
1026 !(Strict.Maybe BufSpan)
1027 -- Just b <=> BufSpan occupied by the processed AST element.
1028 -- The surrounding computations will not look inside.
1029 --
1030 -- Nothing <=> No BufSpan (e.g. when the HdkA is constructed by 'pure' or 'liftHdkA').
1031 -- The surrounding computations are not delimited.
1032
1033 !(HdkM a) -- The stateful computation that looks up Haddock comments and
1034 -- adds them to the resulting AST node.
1035
1036 deriving (Functor)
1037
1038 instance Applicative HdkA where
1039 HdkA l1 m1 <*> HdkA l2 m2 =
1040 HdkA
1041 (l1 <> l2) -- The combined BufSpan that covers both subcomputations.
1042 --
1043 -- The Semigroup instance for Maybe quite conveniently does the right thing:
1044 -- Nothing <> b = b
1045 -- a <> Nothing = a
1046 -- Just a <> Just b = Just (a <> b)
1047
1048 (delim1 m1 <*> delim2 m2) -- Stateful computations are run in left-to-right order,
1049 -- without any smart reordering strategy. So users of this
1050 -- operation must take care to traverse the AST
1051 -- in concrete syntax order.
1052 -- See Note [Smart reordering in HdkA (or lack of thereof)]
1053 --
1054 -- Each computation is delimited ("sandboxed")
1055 -- in a way that it doesn't see any Haddock
1056 -- comments past the neighbouring AST node.
1057 -- These delim1/delim2 are key to how HdkA operates.
1058 where
1059 -- Delimit the LHS by the location information from the RHS
1060 delim1 = inLocRange (locRangeTo (fmap @Strict.Maybe bufSpanStart l2))
1061 -- Delimit the RHS by the location information from the LHS
1062 delim2 = inLocRange (locRangeFrom (fmap @Strict.Maybe bufSpanEnd l1))
1063
1064 pure a =
1065 -- Return a value without performing any stateful computation, and without
1066 -- any delimiting effect on the surrounding computations.
1067 liftHdkA (pure a)
1068
1069 {- Note [Smart reordering in HdkA (or lack of thereof)]
1070 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1071 When traversing the AST, the user must take care to traverse it in concrete
1072 syntax order.
1073
1074 For example, when processing HsFunTy, it's important to get it right and write
1075 it like so:
1076
1077 HsFunTy _ mult lhs rhs -> do
1078 lhs' <- addHaddock lhs
1079 rhs' <- addHaddock rhs
1080 pure $ L l (HsFunTy noExtField mult lhs' rhs')
1081
1082 Rather than like so:
1083
1084 HsFunTy _ mult lhs rhs -> do
1085 rhs' <- addHaddock rhs -- bad! wrong order
1086 lhs' <- addHaddock lhs -- bad! wrong order
1087 pure $ L l (HsFunTy noExtField mult lhs' rhs')
1088
1089 This is somewhat bug-prone, so we could try to fix this with some Applicative
1090 magic. When we define (<*>) for HdkA, why not reorder the computations as
1091 necessary? In pseudo-code:
1092
1093 a1 <*> a2 | a1 `before` a2 = ... normal processing ...
1094 | otherwise = a1 <**> a2
1095
1096 While this trick could work for any two *adjacent* AST elements out of order
1097 (as in HsFunTy example above), it would fail in more elaborate scenarios (e.g.
1098 processing a list of declarations out of order).
1099
1100 If it's not obvious why this trick doesn't work, ponder this: it's a bit like trying to get
1101 a sorted list by defining a 'smart' concatenation operator in the following manner:
1102
1103 a ?++ b | a <= b = a ++ b
1104 | otherwise = b ++ a
1105
1106 At first glance it seems to work:
1107
1108 ghci> [1] ?++ [2] ?++ [3]
1109 [1,2,3]
1110
1111 ghci> [2] ?++ [1] ?++ [3]
1112 [1,2,3] -- wow, sorted!
1113
1114 But it actually doesn't:
1115
1116 ghci> [3] ?++ [1] ?++ [2]
1117 [1,3,2] -- not sorted...
1118 -}
1119
1120 -- Run a HdkA computation in an unrestricted LocRange. This is only used at the
1121 -- top level to run the final computation for the entire module.
1122 runHdkA :: HdkA a -> HdkSt -> (a, HdkSt)
1123 runHdkA (HdkA _ m) = unHdkM m mempty
1124
1125 -- Let the neighbours know about an item at this location.
1126 --
1127 -- Consider this example:
1128 --
1129 -- class -- | peculiarly placed comment
1130 -- MyClass a where
1131 -- my_method :: a -> a
1132 --
1133 -- How do we know to reject the "peculiarly placed comment" instead of
1134 -- associating it with my_method? Its indentation level matches.
1135 --
1136 -- But clearly, there's "MyClass a where" separating the comment and my_method.
1137 -- To take it into account, we must register its location using registerLocHdkA
1138 -- or registerHdkA.
1139 --
1140 -- See Note [Register keyword location].
1141 -- See Note [Adding Haddock comments to the syntax tree].
1142 registerLocHdkA :: SrcSpan -> HdkA ()
1143 registerLocHdkA l = HdkA (getBufSpan l) (pure ())
1144
1145 -- Let the neighbours know about an item at this location.
1146 -- A small wrapper over registerLocHdkA.
1147 --
1148 -- See Note [Adding Haddock comments to the syntax tree].
1149 registerHdkA :: GenLocated (SrcSpanAnn' a) e -> HdkA ()
1150 registerHdkA a = registerLocHdkA (getLocA a)
1151
1152 -- Modify the action of a HdkA computation.
1153 hoistHdkA :: (HdkM a -> HdkM b) -> HdkA a -> HdkA b
1154 hoistHdkA f (HdkA l m) = HdkA l (f m)
1155
1156 -- Lift a HdkM computation to HdkA.
1157 liftHdkA :: HdkM a -> HdkA a
1158 liftHdkA = HdkA mempty
1159
1160 -- Extend the declared location span of a 'HdkA' computation:
1161 --
1162 -- left_neighbour <*> extendHdkA l x <*> right_neighbour
1163 --
1164 -- The declared location of 'x' now includes 'l', so that the surrounding
1165 -- computations 'left_neighbour' and 'right_neighbour' will not look for
1166 -- Haddock comments inside the 'l' location span.
1167 extendHdkA :: SrcSpan -> HdkA a -> HdkA a
1168 extendHdkA l' (HdkA l m) = HdkA (getBufSpan l' <> l) m
1169
1170
1171 {- *********************************************************************
1172 * *
1173 * HdkM: a stateful computation to associate *
1174 * accumulated documentation comments with AST nodes *
1175 * *
1176 ********************************************************************* -}
1177
1178 -- The state of 'HdkM' contains a list of pending Haddock comments. We go
1179 -- over the AST, looking up these comments using 'takeHdkComments' and removing
1180 -- them from the state. The remaining, un-removed ones are ignored with a
1181 -- warning (-Winvalid-haddock). Also, using a state means we never use the same
1182 -- Haddock twice.
1183 --
1184 -- See Note [Adding Haddock comments to the syntax tree].
1185 newtype HdkM a = HdkM (ReaderT LocRange (State HdkSt) a)
1186 deriving (Functor, Applicative, Monad)
1187
1188 -- | The state of HdkM.
1189 data HdkSt =
1190 HdkSt
1191 { hdk_st_pending :: [PsLocated HdkComment]
1192 -- a list of pending (unassociated with an AST node)
1193 -- Haddock comments, sorted by location: in ascending order of the starting 'BufPos'
1194 , hdk_st_warnings :: [HdkWarn]
1195 -- accumulated warnings (order doesn't matter)
1196 }
1197
1198 -- | Warnings accumulated in HdkM.
1199 data HdkWarn
1200 = HdkWarnInvalidComment (PsLocated HdkComment)
1201 | HdkWarnExtraComment LHsDocString
1202
1203 -- 'HdkM' without newtype wrapping/unwrapping.
1204 type InlineHdkM a = LocRange -> HdkSt -> (a, HdkSt)
1205
1206 mkHdkM :: InlineHdkM a -> HdkM a
1207 unHdkM :: HdkM a -> InlineHdkM a
1208 mkHdkM = coerce
1209 unHdkM = coerce
1210
1211 -- Restrict the range in which a HdkM computation will look up comments:
1212 --
1213 -- inLocRange r1 $
1214 -- inLocRange r2 $
1215 -- takeHdkComments ... -- Only takes comments in the (r1 <> r2) location range.
1216 --
1217 -- Note that it does not blindly override the range but tightens it using (<>).
1218 -- At many use sites, you will see something along the lines of:
1219 --
1220 -- inLocRange (locRangeTo end_pos) $ ...
1221 --
1222 -- And 'locRangeTo' defines a location range from the start of the file to
1223 -- 'end_pos'. This does not mean that we now search for every comment from the
1224 -- start of the file, as this restriction will be combined with other
1225 -- restrictions. Somewhere up the callstack we might have:
1226 --
1227 -- inLocRange (locRangeFrom start_pos) $ ...
1228 --
1229 -- The net result is that the location range is delimited by 'start_pos' on
1230 -- one side and by 'end_pos' on the other side.
1231 --
1232 -- In 'HdkA', every (<*>) may restrict the location range of its
1233 -- subcomputations.
1234 inLocRange :: LocRange -> HdkM a -> HdkM a
1235 inLocRange r (HdkM m) = HdkM (local (mappend r) m)
1236
1237 -- Take the Haddock comments that satisfy the matching function,
1238 -- leaving the rest pending.
1239 takeHdkComments :: forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a]
1240 takeHdkComments f =
1241 mkHdkM $
1242 \(LocRange hdk_from hdk_to hdk_col) ->
1243 \hdk_st ->
1244 let
1245 comments = hdk_st_pending hdk_st
1246 (comments_before_range, comments') = break (is_after hdk_from) comments
1247 (comments_in_range, comments_after_range) = span (is_before hdk_to <&&> is_indented hdk_col) comments'
1248 (items, other_comments) = foldr add_comment ([], []) comments_in_range
1249 remaining_comments = comments_before_range ++ other_comments ++ comments_after_range
1250 hdk_st' = hdk_st{ hdk_st_pending = remaining_comments }
1251 in
1252 (items, hdk_st')
1253 where
1254 is_after StartOfFile _ = True
1255 is_after (StartLoc l) (L l_comment _) = bufSpanStart (psBufSpan l_comment) >= l
1256 is_before EndOfFile _ = True
1257 is_before (EndLoc l) (L l_comment _) = bufSpanStart (psBufSpan l_comment) <= l
1258 is_indented (ColumnFrom n) (L l_comment _) = srcSpanStartCol (psRealSpan l_comment) >= n
1259
1260 add_comment
1261 :: PsLocated HdkComment
1262 -> ([a], [PsLocated HdkComment])
1263 -> ([a], [PsLocated HdkComment])
1264 add_comment hdk_comment (items, other_hdk_comments) =
1265 case f hdk_comment of
1266 Just item -> (item : items, other_hdk_comments)
1267 Nothing -> (items, hdk_comment : other_hdk_comments)
1268
1269 -- Get the docnext or docprev comment for an AST node at the given source span.
1270 getPrevNextDoc :: SrcSpan -> HdkM (Maybe LHsDocString)
1271 getPrevNextDoc l = do
1272 let (l_start, l_end) = (srcSpanStart l, srcSpanEnd l)
1273 before_t = locRangeTo (getBufPos l_start)
1274 after_t = locRangeFrom (getBufPos l_end)
1275 nextDocs <- inLocRange before_t $ takeHdkComments mkDocNext
1276 prevDocs <- inLocRange after_t $ takeHdkComments mkDocPrev
1277 selectDocString (nextDocs ++ prevDocs)
1278
1279 appendHdkWarning :: HdkWarn -> HdkM ()
1280 appendHdkWarning e = HdkM (ReaderT (\_ -> modify append_warn))
1281 where
1282 append_warn hdk_st = hdk_st { hdk_st_warnings = e : hdk_st_warnings hdk_st }
1283
1284 selectDocString :: [LHsDocString] -> HdkM (Maybe LHsDocString)
1285 selectDocString = select . filterOut (isEmptyDocString . unLoc)
1286 where
1287 select [] = return Nothing
1288 select [doc] = return (Just doc)
1289 select (doc : extra_docs) = do
1290 reportExtraDocs extra_docs
1291 return (Just doc)
1292
1293 reportExtraDocs :: [LHsDocString] -> HdkM ()
1294 reportExtraDocs =
1295 traverse_ (\extra_doc -> appendHdkWarning (HdkWarnExtraComment extra_doc))
1296
1297 {- *********************************************************************
1298 * *
1299 * Matching functions for extracting documentation comments *
1300 * *
1301 ********************************************************************* -}
1302
1303 mkDocHsDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs)
1304 mkDocHsDecl layout_info a = mapLoc (DocD noExtField) <$> mkDocDecl layout_info a
1305
1306 mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs)
1307 mkDocDecl layout_info (L l_comment hdk_comment)
1308 | indent_mismatch = Nothing
1309 | otherwise =
1310 Just $ L (noAnnSrcSpan $ mkSrcSpanPs l_comment) $
1311 case hdk_comment of
1312 HdkCommentNext doc -> DocCommentNext doc
1313 HdkCommentPrev doc -> DocCommentPrev doc
1314 HdkCommentNamed s doc -> DocCommentNamed s doc
1315 HdkCommentSection n doc -> DocGroup n doc
1316 where
1317 -- 'indent_mismatch' checks if the documentation comment has the exact
1318 -- indentation level expected by the parent node.
1319 --
1320 -- For example, when extracting documentation comments between class
1321 -- method declarations, there are three cases to consider:
1322 --
1323 -- 1. Indent matches (indent_mismatch=False):
1324 -- class C a where
1325 -- f :: a -> a
1326 -- -- ^ doc on f
1327 --
1328 -- 2. Indented too much (indent_mismatch=True):
1329 -- class C a where
1330 -- f :: a -> a
1331 -- -- ^ indent mismatch
1332 --
1333 -- 3. Indented too little (indent_mismatch=True):
1334 -- class C a where
1335 -- f :: a -> a
1336 -- -- ^ indent mismatch
1337 indent_mismatch = case layout_info of
1338 NoLayoutInfo -> False
1339 ExplicitBraces -> False
1340 VirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment)
1341
1342 mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs)
1343 mkDocIE (L l_comment hdk_comment) =
1344 case hdk_comment of
1345 HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n doc)
1346 HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s)
1347 HdkCommentNext doc -> Just $ L l (IEDoc noExtField doc)
1348 _ -> Nothing
1349 where l = noAnnSrcSpan $ mkSrcSpanPs l_comment
1350
1351 mkDocNext :: PsLocated HdkComment -> Maybe LHsDocString
1352 mkDocNext (L l (HdkCommentNext doc)) = Just $ L (mkSrcSpanPs l) doc
1353 mkDocNext _ = Nothing
1354
1355 mkDocPrev :: PsLocated HdkComment -> Maybe LHsDocString
1356 mkDocPrev (L l (HdkCommentPrev doc)) = Just $ L (mkSrcSpanPs l) doc
1357 mkDocPrev _ = Nothing
1358
1359
1360 {- *********************************************************************
1361 * *
1362 * LocRange: a location range *
1363 * *
1364 ********************************************************************* -}
1365
1366 -- A location range for extracting documentation comments.
1367 data LocRange =
1368 LocRange
1369 { loc_range_from :: !LowerLocBound,
1370 loc_range_to :: !UpperLocBound,
1371 loc_range_col :: !ColumnBound }
1372
1373 instance Semigroup LocRange where
1374 LocRange from1 to1 col1 <> LocRange from2 to2 col2 =
1375 LocRange (from1 <> from2) (to1 <> to2) (col1 <> col2)
1376
1377 instance Monoid LocRange where
1378 mempty = LocRange mempty mempty mempty
1379
1380 -- The location range from the specified position to the end of the file.
1381 locRangeFrom :: Strict.Maybe BufPos -> LocRange
1382 locRangeFrom (Strict.Just l) = mempty { loc_range_from = StartLoc l }
1383 locRangeFrom Strict.Nothing = mempty
1384
1385 -- The location range from the start of the file to the specified position.
1386 locRangeTo :: Strict.Maybe BufPos -> LocRange
1387 locRangeTo (Strict.Just l) = mempty { loc_range_to = EndLoc l }
1388 locRangeTo Strict.Nothing = mempty
1389
1390 -- Represents a predicate on BufPos:
1391 --
1392 -- LowerLocBound | BufPos -> Bool
1393 -- --------------+-----------------
1394 -- StartOfFile | const True
1395 -- StartLoc p | (>= p)
1396 --
1397 -- The semigroup instance corresponds to (&&).
1398 --
1399 -- We don't use the BufPos -> Bool representation
1400 -- as it would lead to redundant checks.
1401 --
1402 -- That is, instead of
1403 --
1404 -- (pos >= 20) && (pos >= 30) && (pos >= 40)
1405 --
1406 -- We'd rather only do the (>=40) check. So we reify the predicate to make
1407 -- sure we only check for the most restrictive bound.
1408 data LowerLocBound = StartOfFile | StartLoc !BufPos
1409
1410 instance Semigroup LowerLocBound where
1411 StartOfFile <> l = l
1412 l <> StartOfFile = l
1413 StartLoc l1 <> StartLoc l2 = StartLoc (max l1 l2)
1414
1415 instance Monoid LowerLocBound where
1416 mempty = StartOfFile
1417
1418 -- Represents a predicate on BufPos:
1419 --
1420 -- UpperLocBound | BufPos -> Bool
1421 -- --------------+-----------------
1422 -- EndOfFile | const True
1423 -- EndLoc p | (<= p)
1424 --
1425 -- The semigroup instance corresponds to (&&).
1426 --
1427 -- We don't use the BufPos -> Bool representation
1428 -- as it would lead to redundant checks.
1429 --
1430 -- That is, instead of
1431 --
1432 -- (pos <= 40) && (pos <= 30) && (pos <= 20)
1433 --
1434 -- We'd rather only do the (<=20) check. So we reify the predicate to make
1435 -- sure we only check for the most restrictive bound.
1436 data UpperLocBound = EndOfFile | EndLoc !BufPos
1437
1438 instance Semigroup UpperLocBound where
1439 EndOfFile <> l = l
1440 l <> EndOfFile = l
1441 EndLoc l1 <> EndLoc l2 = EndLoc (min l1 l2)
1442
1443 instance Monoid UpperLocBound where
1444 mempty = EndOfFile
1445
1446 -- | Represents a predicate on the column number.
1447 --
1448 -- ColumnBound | Int -> Bool
1449 -- --------------+-----------------
1450 -- ColumnFrom n | (>=n)
1451 --
1452 -- The semigroup instance corresponds to (&&).
1453 --
1454 newtype ColumnBound = ColumnFrom Int -- n >= GHC.Types.SrcLoc.leftmostColumn
1455
1456 instance Semigroup ColumnBound where
1457 ColumnFrom n <> ColumnFrom m = ColumnFrom (max n m)
1458
1459 instance Monoid ColumnBound where
1460 mempty = ColumnFrom leftmostColumn
1461
1462
1463 {- *********************************************************************
1464 * *
1465 * AST manipulation utilities *
1466 * *
1467 ********************************************************************* -}
1468
1469 mkLHsDocTy :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs
1470 mkLHsDocTy t Nothing = t
1471 mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t doc)
1472
1473 getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan
1474 getForAllTeleLoc tele =
1475 case tele of
1476 HsForAllVis{ hsf_vis_bndrs } -> getLHsTyVarBndrsLoc hsf_vis_bndrs
1477 HsForAllInvis { hsf_invis_bndrs } -> getLHsTyVarBndrsLoc hsf_invis_bndrs
1478
1479 getLHsTyVarBndrsLoc :: [LHsTyVarBndr flag GhcPs] -> SrcSpan
1480 getLHsTyVarBndrsLoc bndrs = foldr combineSrcSpans noSrcSpan $ map getLocA bndrs
1481
1482 -- | The inverse of 'partitionBindsAndSigs' that merges partitioned items back
1483 -- into a flat list. Elements are put back into the order in which they
1484 -- appeared in the original program before partitioning, using BufPos to order
1485 -- them.
1486 --
1487 -- Precondition (unchecked): the input lists are already sorted.
1488 flattenBindsAndSigs
1489 :: (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
1490 [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
1491 -> [LHsDecl GhcPs]
1492 flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) =
1493 -- 'cmpBufSpan' is safe here with the following assumptions:
1494 --
1495 -- - 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan'
1496 -- - 'partitionBindsAndSigs' does not discard this 'BufSpan'
1497 mergeListsBy cmpBufSpanA [
1498 mapLL (\b -> ValD noExtField b) (bagToList all_bs),
1499 mapLL (\s -> SigD noExtField s) all_ss,
1500 mapLL (\t -> TyClD noExtField (FamDecl noExtField t)) all_ts,
1501 mapLL (\tfi -> InstD noExtField (TyFamInstD noExtField tfi)) all_tfis,
1502 mapLL (\dfi -> InstD noExtField (DataFamInstD noAnn dfi)) all_dfis,
1503 mapLL (\d -> DocD noExtField d) all_docs
1504 ]
1505
1506 cmpBufSpanA :: GenLocated (SrcSpanAnn' a1) a2 -> GenLocated (SrcSpanAnn' a3) a2 -> Ordering
1507 cmpBufSpanA (L la a) (L lb b) = cmpBufSpan (L (locA la) a) (L (locA lb) b)
1508
1509 {- *********************************************************************
1510 * *
1511 * General purpose utilities *
1512 * *
1513 ********************************************************************* -}
1514
1515 -- Cons an element to a list, if exists.
1516 mcons :: Maybe a -> [a] -> [a]
1517 mcons = maybe id (:)
1518
1519 -- Map a function over a list of located items.
1520 mapLL :: (a -> b) -> [GenLocated l a] -> [GenLocated l b]
1521 mapLL f = map (mapLoc f)
1522
1523 {- Note [Old solution: Haddock in the grammar]
1524 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1525 In the past, Haddock comments were incorporated into the grammar (Parser.y).
1526 This led to excessive complexity and duplication.
1527
1528 For example, here's the grammar production for types without documentation:
1529
1530 type : btype
1531 | btype '->' ctype
1532
1533 To support Haddock, we had to also maintain an additional grammar production
1534 for types with documentation on function arguments and function result:
1535
1536 typedoc : btype
1537 | btype docprev
1538 | docnext btype
1539 | btype '->' ctypedoc
1540 | btype docprev '->' ctypedoc
1541 | docnext btype '->' ctypedoc
1542
1543 Sometimes handling documentation comments during parsing led to bugs (#17561),
1544 and sometimes it simply made it hard to modify and extend the grammar.
1545
1546 Another issue was that sometimes Haddock would fail to parse code
1547 that GHC could parse successfully:
1548
1549 class BadIndent where
1550 f :: a -> Int
1551 -- ^ comment
1552 g :: a -> Int
1553
1554 This declaration was accepted by ghc but rejected by ghc -haddock.
1555 -}
1556
1557 {- Note [Register keyword location]
1558 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1559 At the moment, 'addHaddock' erroneously associates some comments with
1560 constructs that are separated by a keyword. For example:
1561
1562 data Foo -- | Comment for MkFoo
1563 where MkFoo :: Foo
1564
1565 The issue stems from the lack of location information for keywords. We could
1566 utilize API Annotations for this purpose, but not without modification. For
1567 example, API Annotations operate on RealSrcSpan, whereas we need BufSpan.
1568
1569 Also, there's work towards making API Annotations available in-tree (not in
1570 a separate Map), see #17638. This change should make the fix very easy (it
1571 is not as easy with the current design).
1572
1573 See also testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs
1574 -}