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 -}