{-# LANGUAGE ApplicativeDo              #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}

{- | This module implements 'addHaddockToModule', which inserts Haddock
    comments accumulated during parsing into the AST (#17544).

We process Haddock comments in two phases:

1. Parse the program (via the Happy parser in `Parser.y`), generating
   an AST, and (quite separately) a list of all the Haddock comments
   found in the file. More precisely, the Haddock comments are
   accumulated in the `hdk_comments` field of the `PState`, the parser
   state (see Lexer.x):

     data PState = PState { ...
                          ,  hdk_comments :: [PsLocated HdkComment] }

   Each of these Haddock comments has a `PsSpan`, which gives the `BufPos` of
   the beginning and end of the Haddock comment.

2. Walk over the AST, attaching the Haddock comments to the correct
   parts of the tree. This step is called `addHaddockToModule`, and is
   implemented in this module.

   See Note [Adding Haddock comments to the syntax tree].

This approach codifies an important principle:

  The presence or absence of a Haddock comment should never change the parsing
  of a program.

Alternative approaches that did not work properly:

1. Using 'RealSrcLoc' instead of 'BufPos'. This led to failures in presence
   of {-# LANGUAGE CPP #-} and other sources of line pragmas. See documentation
   on 'BufPos' (in GHC.Types.SrcLoc) for the details.

2. In earlier versions of GHC, the Haddock comments were incorporated into the
   Parser.y grammar. The parser constructed the AST and attached comments to it in
   a single pass. See Note [Old solution: Haddock in the grammar] for the details.
-}
module GHC.Parser.PostProcess.Haddock (addHaddockToModule) where

import GHC.Prelude hiding (head, init, last, mod, tail)

import GHC.Hs

import GHC.Types.SrcLoc

import Data.Semigroup
import Data.Foldable
import Data.Traversable
import qualified Data.List.NonEmpty as NE
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Reader
import Data.Functor.Identity

import {-# SOURCE #-} GHC.Parser (parseIdentifier)
import GHC.Parser.Lexer
import GHC.Parser.HaddockLex
import GHC.Parser.Errors.Types
import GHC.Utils.Misc (mergeListsBy, filterOut, (<&&>))
import qualified GHC.Data.Strict as Strict

{- Note [Adding Haddock comments to the syntax tree]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'addHaddock' traverses the AST in concrete syntax order, building a computation
(represented by HdkA) that reconstructs the AST but with Haddock comments
inserted in appropriate positions:

  addHaddock :: HasHaddock a => a -> HdkA a

Consider this code example:

  f :: Int  -- ^ comment on argument
    -> Bool -- ^ comment on result

In the AST, the "Int" part of this snippet is represented like this
(pseudo-code):

  L (BufSpan 6 8) (HsTyVar "Int") :: LHsType GhcPs

And the comments are represented like this (pseudo-code):

  L (BufSpan 11 35) (HdkCommentPrev "comment on argument")
  L (BufSpan 46 69) (HdkCommentPrev "comment on result")

So when we are traversing the AST and 'addHaddock' is applied to HsTyVar "Int",
how does it know to associate it with "comment on argument" but not with
"comment on result"?

The trick is to look in the space between syntactic elements. In the example above,
the location range in which we search for HdkCommentPrev is as follows:

  f :: Int████████████████████████
   ████Bool -- ^ comment on result

We search for comments after  HsTyVar "Int"  and until the next syntactic
element, in this case  HsTyVar "Bool".

Ignoring the "->" allows us to accommodate alternative coding styles:

  f :: Int ->   -- ^ comment on argument
       Bool     -- ^ comment on result

Sometimes we also need to take indentation information into account.
Compare the following examples:

    class C a where
      f :: a -> Int
      -- ^ comment on f

    class C a where
      f :: a -> Int
    -- ^ comment on C

Notice how "comment on f" and "comment on C" differ only by indentation level.

Therefore, in order to know the location range in which the comments are applicable
to a syntactic elements, we need three nuggets of information:
  1. lower bound on the BufPos of a comment
  2. upper bound on the BufPos of a comment
  3. minimum indentation level of a comment

This information is represented by the 'LocRange' type.

In order to propagate this information, we have the 'HdkA' applicative.
'HdkA' is defined as follows:

  data HdkA a = HdkA (Maybe BufSpan) (HdkM a)

The first field contains a 'BufSpan', which represents the location
span taken by a syntactic element:

  addHaddock (L bufSpan ...) = HdkA (Just bufSpan) ...

The second field, 'HdkM', is a stateful computation that looks up Haddock
comments in the specified location range:

  HdkM a ≈
       LocRange                  -- The allowed location range
    -> [PsLocated HdkComment]    -- Unallocated comments
    -> (a,                       -- AST with comments inserted into it
        [PsLocated HdkComment])  -- Leftover comments

The 'Applicative' instance for 'HdkA' is defined in such a way that the
location range of every computation is defined by its neighbours:

  addHaddock aaa <*> addHaddock bbb <*> addHaddock ccc

Here, the 'LocRange' passed to the 'HdkM' computation of  addHaddock bbb
is determined by the BufSpan recorded in  addHaddock aaa  and  addHaddock ccc.

This is why it's important to traverse the AST in the order of the concrete
syntax. In the example above we assume that  aaa, bbb, ccc  are ordered by location:

  * getBufSpan (getLoc aaa) < getBufSpan (getLoc bbb)
  * getBufSpan (getLoc bbb) < getBufSpan (getLoc ccc)

Violation of this assumption would lead to bugs, and care must be taken to
traverse the AST correctly. For example, when dealing with class declarations,
we have to use 'flattenBindsAndSigs' to traverse it in the correct order.
-}

-- | Add Haddock documentation accumulated in the parser state
-- to a parsed HsModule.
--
-- Reports badly positioned comments when -Winvalid-haddock is enabled.
addHaddockToModule :: Located (HsModule GhcPs) -> P (Located (HsModule GhcPs))
addHaddockToModule :: Located (HsModule GhcPs) -> P (Located (HsModule GhcPs))
addHaddockToModule Located (HsModule GhcPs)
lmod = do
  PState
pState <- P PState
getPState
  let all_comments :: [PsLocated HdkComment]
all_comments = OrdList (PsLocated HdkComment) -> [PsLocated HdkComment]
forall a. OrdList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (PState -> OrdList (PsLocated HdkComment)
hdk_comments PState
pState)
      initial_hdk_st :: HdkSt
initial_hdk_st = [PsLocated HdkComment] -> [HdkWarn] -> HdkSt
HdkSt [PsLocated HdkComment]
all_comments []
      (Located (HsModule GhcPs)
lmod', HdkSt
final_hdk_st) = HdkA (Located (HsModule GhcPs))
-> HdkSt -> (Located (HsModule GhcPs), HdkSt)
forall a. HdkA a -> HdkSt -> (a, HdkSt)
runHdkA (Located (HsModule GhcPs) -> HdkA (Located (HsModule GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock Located (HsModule GhcPs)
lmod) HdkSt
initial_hdk_st
      hdk_warnings :: [HdkWarn]
hdk_warnings = HdkSt -> [HdkWarn]
collectHdkWarnings HdkSt
final_hdk_st
        -- lmod':        module with Haddock comments inserted into the AST
        -- hdk_warnings: warnings accumulated during AST/comment processing
  (HdkWarn -> P ()) -> [HdkWarn] -> P ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ HdkWarn -> P ()
reportHdkWarning [HdkWarn]
hdk_warnings
  return Located (HsModule GhcPs)
lmod'

reportHdkWarning :: HdkWarn -> P ()
reportHdkWarning :: HdkWarn -> P ()
reportHdkWarning (HdkWarnInvalidComment (L PsSpan
l HdkComment
_)) =
  SrcSpan -> PsMessage -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> PsMessage -> m ()
addPsMessage (PsSpan -> SrcSpan
mkSrcSpanPs PsSpan
l) PsMessage
PsWarnHaddockInvalidPos
reportHdkWarning (HdkWarnExtraComment (L SrcSpan
l HsDocString
_)) =
  SrcSpan -> PsMessage -> P ()
forall (m :: * -> *). MonadP m => SrcSpan -> PsMessage -> m ()
addPsMessage SrcSpan
l PsMessage
PsWarnHaddockIgnoreMulti

collectHdkWarnings :: HdkSt -> [HdkWarn]
collectHdkWarnings :: HdkSt -> [HdkWarn]
collectHdkWarnings HdkSt{ [PsLocated HdkComment]
hdk_st_pending :: [PsLocated HdkComment]
hdk_st_pending :: HdkSt -> [PsLocated HdkComment]
hdk_st_pending, [HdkWarn]
hdk_st_warnings :: [HdkWarn]
hdk_st_warnings :: HdkSt -> [HdkWarn]
hdk_st_warnings } =
  (PsLocated HdkComment -> HdkWarn)
-> [PsLocated HdkComment] -> [HdkWarn]
forall a b. (a -> b) -> [a] -> [b]
map PsLocated HdkComment -> HdkWarn
HdkWarnInvalidComment [PsLocated HdkComment]
hdk_st_pending -- leftover Haddock comments not inserted into the AST
  [HdkWarn] -> [HdkWarn] -> [HdkWarn]
forall a. [a] -> [a] -> [a]
++ [HdkWarn]
hdk_st_warnings

{- *********************************************************************
*                                                                      *
*       addHaddock: a family of functions that processes the AST       *
*    in concrete syntax order, adding documentation comments to it     *
*                                                                      *
********************************************************************* -}

-- HasHaddock is a convenience class for overloading the addHaddock operation.
-- Alternatively, we could define a family of monomorphic functions:
--
--    addHaddockSomeTypeX    :: SomeTypeX    -> HdkA SomeTypeX
--    addHaddockAnotherTypeY :: AnotherTypeY -> HdkA AnotherTypeY
--    addHaddockOneMoreTypeZ :: OneMoreTypeZ -> HdkA OneMoreTypeZ
--
-- But having a single name for all of them is just easier to read, and makes it clear
-- that they all are of the form  t -> HdkA t  for some t.
--
-- If you need to handle a more complicated scenario that doesn't fit this
-- pattern, it's always possible to define separate functions outside of this
-- class, as is done in case of e.g. addHaddockConDeclField.
--
-- See Note [Adding Haddock comments to the syntax tree].
class HasHaddock a where
  addHaddock :: a -> HdkA a

instance HasHaddock a => HasHaddock [a] where
  addHaddock :: [a] -> HdkA [a]
addHaddock = (a -> HdkA a) -> [a] -> HdkA [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse a -> HdkA a
forall a. HasHaddock a => a -> HdkA a
addHaddock

--    -- | Module header comment
--    module M (
--        -- * Export list comment
--        Item1,
--        Item2,
--        -- * Export list comment
--        item3,
--        item4
--      ) where
--
instance HasHaddock (Located (HsModule GhcPs)) where
  addHaddock :: Located (HsModule GhcPs) -> HdkA (Located (HsModule GhcPs))
addHaddock (L SrcSpan
l_mod HsModule GhcPs
mod) = do
    -- Step 1, get the module header documentation comment:
    --
    --    -- | Module header comment
    --    module M where
    --
    -- Only do this when the module header exists.
    Maybe (Maybe (LHsDoc GhcPs))
headerDocs <-
      forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for @Maybe (HsModule GhcPs -> Maybe (XRec GhcPs ModuleName)
forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodName HsModule GhcPs
mod) ((GenLocated SrcSpanAnnA ModuleName -> HdkA (Maybe (LHsDoc GhcPs)))
 -> HdkA (Maybe (Maybe (LHsDoc GhcPs))))
-> (GenLocated SrcSpanAnnA ModuleName
    -> HdkA (Maybe (LHsDoc GhcPs)))
-> HdkA (Maybe (Maybe (LHsDoc GhcPs)))
forall a b. (a -> b) -> a -> b
$ \(L SrcSpanAnnA
l_name ModuleName
_) ->
      SrcSpan
-> HdkA (Maybe (LHsDoc GhcPs)) -> HdkA (Maybe (LHsDoc GhcPs))
forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l_name) (HdkA (Maybe (LHsDoc GhcPs)) -> HdkA (Maybe (LHsDoc GhcPs)))
-> HdkA (Maybe (LHsDoc GhcPs)) -> HdkA (Maybe (LHsDoc GhcPs))
forall a b. (a -> b) -> a -> b
$ HdkM (Maybe (LHsDoc GhcPs)) -> HdkA (Maybe (LHsDoc GhcPs))
forall a. HdkM a -> HdkA a
liftHdkA (HdkM (Maybe (LHsDoc GhcPs)) -> HdkA (Maybe (LHsDoc GhcPs)))
-> HdkM (Maybe (LHsDoc GhcPs)) -> HdkA (Maybe (LHsDoc GhcPs))
forall a b. (a -> b) -> a -> b
$ do
        -- todo: register keyword location of 'module', see Note [Register keyword location]
        [GenLocated SrcSpan HsDocString]
docs <-
          LocRange
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. LocRange -> HdkM a -> HdkM a
inLocRange (Maybe BufPos -> LocRange
locRangeTo (SrcLoc -> Maybe BufPos
getBufPos (SrcSpan -> SrcLoc
srcSpanStart (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l_name)))) (HdkM [GenLocated SrcSpan HsDocString]
 -> HdkM [GenLocated SrcSpan HsDocString])
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a b. (a -> b) -> a -> b
$
          (PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString))
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a]
takeHdkComments PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString)
mkDocNext
        Maybe (GenLocated SrcSpan HsDocString)
dc <- [GenLocated SrcSpan HsDocString]
-> HdkM (Maybe (GenLocated SrcSpan HsDocString))
selectDocString [GenLocated SrcSpan HsDocString]
docs
        pure $ GenLocated SrcSpan HsDocString -> LHsDoc GhcPs
lexLHsDocString (GenLocated SrcSpan HsDocString -> LHsDoc GhcPs)
-> Maybe (GenLocated SrcSpan HsDocString) -> Maybe (LHsDoc GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (GenLocated SrcSpan HsDocString)
dc

    -- Step 2, process documentation comments in the export list:
    --
    --  module M (
    --        -- * Export list comment
    --        Item1,
    --        Item2,
    --        -- * Export list comment
    --        item3,
    --        item4
    --    ) where
    --
    -- Only do this when the export list exists.
    Maybe (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)])
hsmodExports' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse @Maybe GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
-> HdkA
     (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)])
forall a. HasHaddock a => a -> HdkA a
addHaddock (HsModule GhcPs -> Maybe (XRec GhcPs [LIE GhcPs])
forall p. HsModule p -> Maybe (XRec p [LIE p])
hsmodExports HsModule GhcPs
mod)

    -- Step 3, register the import section to reject invalid comments:
    --
    --   import Data.Maybe
    --   -- | rejected comment (cannot appear here)
    --   import Data.Bool
    --
    (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> HdkA ())
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> HdkA ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> HdkA ()
forall a e. GenLocated (EpAnn a) e -> HdkA ()
registerHdkA (HsModule GhcPs -> [LImportDecl GhcPs]
forall p. HsModule p -> [LImportDecl p]
hsmodImports HsModule GhcPs
mod)

    -- Step 4, process declarations:
    --
    --    module M where
    --      -- | Comment on D
    --      data D = MkD  -- ^ Comment on MkD
    --      data C = MkC  -- ^ Comment on MkC
    --      -- ^ Comment on C
    --
    let layout :: EpLayout
layout = XModulePs -> EpLayout
hsmodLayout (HsModule GhcPs -> XCModule GhcPs
forall p. HsModule p -> XCModule p
hsmodExt HsModule GhcPs
mod)
    [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
hsmodDecls' <- EpLayout
-> (PsLocated HdkComment
    -> Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> HdkA [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a.
HasHaddock a =>
EpLayout -> (PsLocated HdkComment -> Maybe a) -> [a] -> HdkA [a]
addHaddockInterleaveItems EpLayout
layout (EpLayout -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs)
mkDocHsDecl EpLayout
layout) (HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
hsmodDecls HsModule GhcPs
mod)

    pure $ SrcSpan -> HsModule GhcPs -> Located (HsModule GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
l_mod (HsModule GhcPs -> Located (HsModule GhcPs))
-> HsModule GhcPs -> Located (HsModule GhcPs)
forall a b. (a -> b) -> a -> b
$
      HsModule GhcPs
mod { hsmodExports = hsmodExports'
          , hsmodDecls = hsmodDecls'
          , hsmodExt = (hsmodExt mod) { hsmodHaddockModHeader = join @Maybe headerDocs } }

lexHsDocString :: HsDocString -> HsDoc GhcPs
lexHsDocString :: HsDocString -> HsDoc GhcPs
lexHsDocString = P (LocatedN RdrName) -> HsDocString -> HsDoc GhcPs
lexHsDoc P (LocatedN RdrName)
parseIdentifier

lexLHsDocString :: Located HsDocString -> LHsDoc GhcPs
lexLHsDocString :: GenLocated SrcSpan HsDocString -> LHsDoc GhcPs
lexLHsDocString = (HsDocString -> HsDoc GhcPs)
-> GenLocated SrcSpan HsDocString -> LHsDoc GhcPs
forall a b.
(a -> b) -> GenLocated SrcSpan a -> GenLocated SrcSpan b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsDocString -> HsDoc GhcPs
lexHsDocString

-- | Only for module exports, not module imports.
--
--    module M (a, b, c) where   -- use on this [LIE GhcPs]
--    import I (a, b, c)         -- do not use here!
--
-- Imports cannot have documentation comments anyway.
instance HasHaddock (LocatedLI [LocatedA (IE GhcPs)]) where
  addHaddock :: GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
-> HdkA
     (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)])
addHaddock (L SrcSpanAnnLI
l_exports [GenLocated SrcSpanAnnA (IE GhcPs)]
exports) =
    SrcSpan
-> HdkA
     (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)])
-> HdkA
     (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)])
forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA (SrcSpanAnnLI -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnLI
l_exports) (HdkA (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)])
 -> HdkA
      (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]))
-> HdkA
     (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)])
-> HdkA
     (GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)])
forall a b. (a -> b) -> a -> b
$ do
      [GenLocated SrcSpanAnnA (IE GhcPs)]
exports' <- EpLayout
-> (PsLocated HdkComment
    -> Maybe (GenLocated SrcSpanAnnA (IE GhcPs)))
-> [GenLocated SrcSpanAnnA (IE GhcPs)]
-> HdkA [GenLocated SrcSpanAnnA (IE GhcPs)]
forall a.
HasHaddock a =>
EpLayout -> (PsLocated HdkComment -> Maybe a) -> [a] -> HdkA [a]
addHaddockInterleaveItems EpLayout
EpNoLayout PsLocated HdkComment -> Maybe (LIE GhcPs)
PsLocated HdkComment -> Maybe (GenLocated SrcSpanAnnA (IE GhcPs))
mkDocIE [GenLocated SrcSpanAnnA (IE GhcPs)]
exports
      SrcSpan -> HdkA ()
registerLocHdkA (SrcLoc -> SrcSpan
srcLocSpan (SrcSpan -> SrcLoc
srcSpanEnd (SrcSpanAnnLI -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnLI
l_exports))) -- Do not consume comments after the closing parenthesis
      pure $ SrcSpanAnnLI
-> [GenLocated SrcSpanAnnA (IE GhcPs)]
-> GenLocated SrcSpanAnnLI [GenLocated SrcSpanAnnA (IE GhcPs)]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnLI
l_exports [GenLocated SrcSpanAnnA (IE GhcPs)]
exports'

-- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'.
instance HasHaddock (LocatedA (IE GhcPs)) where
  addHaddock :: GenLocated SrcSpanAnnA (IE GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (IE GhcPs))
addHaddock (L SrcSpanAnnA
l_export IE GhcPs
ie ) =
    SrcSpan
-> HdkA (GenLocated SrcSpanAnnA (IE GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (IE GhcPs))
forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l_export) (HdkA (GenLocated SrcSpanAnnA (IE GhcPs))
 -> HdkA (GenLocated SrcSpanAnnA (IE GhcPs)))
-> HdkA (GenLocated SrcSpanAnnA (IE GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (IE GhcPs))
forall a b. (a -> b) -> a -> b
$ HdkM (GenLocated SrcSpanAnnA (IE GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (IE GhcPs))
forall a. HdkM a -> HdkA a
liftHdkA (HdkM (GenLocated SrcSpanAnnA (IE GhcPs))
 -> HdkA (GenLocated SrcSpanAnnA (IE GhcPs)))
-> HdkM (GenLocated SrcSpanAnnA (IE GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (IE GhcPs))
forall a b. (a -> b) -> a -> b
$ do
      [GenLocated SrcSpan HsDocString]
docs <- LocRange
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. LocRange -> HdkM a -> HdkM a
inLocRange (Maybe BufPos -> LocRange
locRangeFrom (SrcLoc -> Maybe BufPos
getBufPos (SrcSpan -> SrcLoc
srcSpanEnd (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l_export)))) (HdkM [GenLocated SrcSpan HsDocString]
 -> HdkM [GenLocated SrcSpan HsDocString])
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a b. (a -> b) -> a -> b
$
        (PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString))
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a]
takeHdkComments PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString)
mkDocPrev
      Maybe (GenLocated SrcSpan HsDocString)
mb_doc <- [GenLocated SrcSpan HsDocString]
-> HdkM (Maybe (GenLocated SrcSpan HsDocString))
selectDocString [GenLocated SrcSpan HsDocString]
docs
      let mb_ldoc :: Maybe (LHsDoc GhcPs)
mb_ldoc = GenLocated SrcSpan HsDocString -> LHsDoc GhcPs
lexLHsDocString (GenLocated SrcSpan HsDocString -> LHsDoc GhcPs)
-> Maybe (GenLocated SrcSpan HsDocString) -> Maybe (LHsDoc GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (GenLocated SrcSpan HsDocString)
mb_doc
      let ie' :: IE GhcPs
ie' = case IE GhcPs
ie of
            IEVar XIEVar GhcPs
ext LIEWrappedName GhcPs
nm Maybe (LHsDoc GhcPs)
_                 -> XIEVar GhcPs
-> LIEWrappedName GhcPs -> Maybe (LHsDoc GhcPs) -> IE GhcPs
forall pass.
XIEVar pass
-> LIEWrappedName pass -> Maybe (ExportDoc pass) -> IE pass
IEVar XIEVar GhcPs
ext LIEWrappedName GhcPs
nm Maybe (LHsDoc GhcPs)
mb_ldoc
            IEThingAbs XIEThingAbs GhcPs
ext LIEWrappedName GhcPs
nm Maybe (LHsDoc GhcPs)
_            -> XIEThingAbs GhcPs
-> LIEWrappedName GhcPs -> Maybe (LHsDoc GhcPs) -> IE GhcPs
forall pass.
XIEThingAbs pass
-> LIEWrappedName pass -> Maybe (ExportDoc pass) -> IE pass
IEThingAbs XIEThingAbs GhcPs
ext LIEWrappedName GhcPs
nm Maybe (LHsDoc GhcPs)
mb_ldoc
            IEThingAll XIEThingAll GhcPs
ext LIEWrappedName GhcPs
nm Maybe (LHsDoc GhcPs)
_            -> XIEThingAll GhcPs
-> LIEWrappedName GhcPs -> Maybe (LHsDoc GhcPs) -> IE GhcPs
forall pass.
XIEThingAll pass
-> LIEWrappedName pass -> Maybe (ExportDoc pass) -> IE pass
IEThingAll XIEThingAll GhcPs
ext LIEWrappedName GhcPs
nm Maybe (LHsDoc GhcPs)
mb_ldoc
            IEThingWith XIEThingWith GhcPs
ext LIEWrappedName GhcPs
nm IEWildcard
wild [LIEWrappedName GhcPs]
subs Maybe (LHsDoc GhcPs)
_ -> XIEThingWith GhcPs
-> LIEWrappedName GhcPs
-> IEWildcard
-> [LIEWrappedName GhcPs]
-> Maybe (LHsDoc GhcPs)
-> IE GhcPs
forall pass.
XIEThingWith pass
-> LIEWrappedName pass
-> IEWildcard
-> [LIEWrappedName pass]
-> Maybe (ExportDoc pass)
-> IE pass
IEThingWith XIEThingWith GhcPs
ext LIEWrappedName GhcPs
nm IEWildcard
wild [LIEWrappedName GhcPs]
subs Maybe (LHsDoc GhcPs)
mb_ldoc
            IE GhcPs
x                              -> IE GhcPs
x
      GenLocated SrcSpanAnnA (IE GhcPs)
-> HdkM (GenLocated SrcSpanAnnA (IE GhcPs))
forall a. a -> HdkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (IE GhcPs)
 -> HdkM (GenLocated SrcSpanAnnA (IE GhcPs)))
-> GenLocated SrcSpanAnnA (IE GhcPs)
-> HdkM (GenLocated SrcSpanAnnA (IE GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> IE GhcPs -> GenLocated SrcSpanAnnA (IE GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l_export IE GhcPs
ie'

{- Add Haddock items to a list of non-Haddock items.
Used to process export lists (with mkDocIE) and declarations (with mkDocHsDecl).

For example:

  module M where
    -- | Comment on D
    data D = MkD  -- ^ Comment on MkD
    data C = MkC  -- ^ Comment on MkC
    -- ^ Comment on C

In this case, we should produce four HsDecl items (pseudo-code):

  1. DocD (DocCommentNext "Comment on D")
  2. TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... (Just "Comment on MkD")])
  3. TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... (Just "Comment on MkC")])
  4. DocD (DocCommentPrev "Comment on C")

The inputs to addHaddockInterleaveItems are:

  * layout :: EpLayout

    In the example above, note that the indentation level inside the module is
    2 spaces. It would be represented as layout = EpVirtualBraces 2.

    It is used to delimit the search space for comments when processing
    declarations. Here, we restrict indentation levels to >=(2+1), so that when
    we look up comment on MkC, we get "Comment on MkC" but not "Comment on C".

  * get_doc_item :: PsLocated HdkComment -> Maybe a

    This is the function used to look up documentation comments.
    In the above example, get_doc_item = mkDocHsDecl layout,
    and it will produce the following parts of the output:

      DocD (DocCommentNext "Comment on D")
      DocD (DocCommentPrev "Comment on C")

  * The list of items. These are the declarations that will be annotated with
    documentation comments.

    Before processing:
       TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... Nothing])
       TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... Nothing])

    After processing:
       TyClD (DataDecl "D" ... [ConDeclH98 "MkD" ... (Just "Comment on MkD")])
       TyClD (DataDecl "C" ... [ConDeclH98 "MkC" ... (Just "Comment on MkC")])
-}
addHaddockInterleaveItems
  :: forall a.
     HasHaddock a
  => EpLayout
  -> (PsLocated HdkComment -> Maybe a) -- Get a documentation item
  -> [a]           -- Unprocessed (non-documentation) items
  -> HdkA [a]      -- Documentation items & processed non-documentation items
addHaddockInterleaveItems :: forall a.
HasHaddock a =>
EpLayout -> (PsLocated HdkComment -> Maybe a) -> [a] -> HdkA [a]
addHaddockInterleaveItems EpLayout
layout PsLocated HdkComment -> Maybe a
get_doc_item = [a] -> HdkA [a]
go
  where
    go :: [a] -> HdkA [a]
    go :: [a] -> HdkA [a]
go [] = HdkM [a] -> HdkA [a]
forall a. HdkM a -> HdkA a
liftHdkA ((PsLocated HdkComment -> Maybe a) -> HdkM [a]
forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a]
takeHdkComments PsLocated HdkComment -> Maybe a
get_doc_item)
    go (a
item : [a]
items) = do
      [a]
docItems <- HdkM [a] -> HdkA [a]
forall a. HdkM a -> HdkA a
liftHdkA ((PsLocated HdkComment -> Maybe a) -> HdkM [a]
forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a]
takeHdkComments PsLocated HdkComment -> Maybe a
get_doc_item)
      a
item' <- HdkA a -> HdkA a
with_layout (a -> HdkA a
forall a. HasHaddock a => a -> HdkA a
addHaddock a
item)
      [a]
other_items <- [a] -> HdkA [a]
go [a]
items
      pure $ [a]
docItems [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a
item'a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
other_items

    with_layout :: HdkA a -> HdkA a
    with_layout :: HdkA a -> HdkA a
with_layout = case EpLayout
layout of
      EpLayout
EpNoLayout -> HdkA a -> HdkA a
forall a. a -> a
id
      EpExplicitBraces{} -> HdkA a -> HdkA a
forall a. a -> a
id
      EpVirtualBraces Int
n ->
        let loc_range :: LocRange
loc_range = LocRange
forall a. Monoid a => a
mempty { loc_range_col = ColumnFrom (n+1) }
        in (HdkM a -> HdkM a) -> HdkA a -> HdkA a
forall a b. (HdkM a -> HdkM b) -> HdkA a -> HdkA b
hoistHdkA (LocRange -> HdkM a -> HdkM a
forall a. LocRange -> HdkM a -> HdkM a
inLocRange LocRange
loc_range)

instance HasHaddock (LocatedA (HsDecl GhcPs)) where
  addHaddock :: GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsDecl GhcPs))
addHaddock GenLocated SrcSpanAnnA (HsDecl GhcPs)
ldecl =
    SrcSpan
-> HdkA (GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsDecl GhcPs)
ldecl) (HdkA (GenLocated SrcSpanAnnA (HsDecl GhcPs))
 -> HdkA (GenLocated SrcSpanAnnA (HsDecl GhcPs)))
-> HdkA (GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse @LocatedA HsDecl GhcPs -> HdkA (HsDecl GhcPs)
forall a. HasHaddock a => a -> HdkA a
addHaddock GenLocated SrcSpanAnnA (HsDecl GhcPs)
ldecl

-- Process documentation comments *inside* a declaration, for example:
--
--    data T = MkT -- ^ Comment on MkT (inside DataDecl)
--    f, g
--      :: Int  -- ^ Comment on Int   (inside TypeSig)
--      -> Bool -- ^ Comment on Bool  (inside TypeSig)
--
-- Comments that relate to the entire declaration are processed elsewhere:
--
--    -- | Comment on T (not processed in this instance)
--    data T = MkT
--
--    -- | Comment on f, g (not processed in this instance)
--    f, g :: Int -> Bool
--    f = ...
--    g = ...
--
-- Such comments are inserted into the syntax tree as DocD declarations
-- by addHaddockInterleaveItems, and then associated with other declarations
-- in GHC.HsToCore.Docs (see DeclDocMap).
--
-- In this instance, we only process comments that relate to parts of the
-- declaration, not to the declaration itself.
instance HasHaddock (HsDecl GhcPs) where

  -- Type signatures:
  --
  --    f, g
  --      :: Int  -- ^ Comment on Int
  --      -> Bool -- ^ Comment on Bool
  --
  addHaddock :: HsDecl GhcPs -> HdkA (HsDecl GhcPs)
addHaddock (SigD XSigD GhcPs
_ (TypeSig XTypeSig GhcPs
x [LIdP GhcPs]
names LHsSigWcType GhcPs
t)) = do
      (LocatedN RdrName -> HdkA ()) -> [LocatedN RdrName] -> HdkA ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ LocatedN RdrName -> HdkA ()
forall a e. GenLocated (EpAnn a) e -> HdkA ()
registerHdkA [LIdP GhcPs]
[LocatedN RdrName]
names
      HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
t' <- HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> HdkA
     (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
forall a. HasHaddock a => a -> HdkA a
addHaddock LHsSigWcType GhcPs
HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
t
      pure (XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
SigD XSigD GhcPs
NoExtField
noExtField (XTypeSig GhcPs -> [LIdP GhcPs] -> LHsSigWcType GhcPs -> Sig GhcPs
forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig GhcPs
x [LIdP GhcPs]
names LHsSigWcType GhcPs
HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
t'))

  -- Pattern synonym type signatures:
  --
  --    pattern MyPat
  --      :: Bool       -- ^ Comment on Bool
  --      -> Maybe Bool -- ^ Comment on Maybe Bool
  --
  addHaddock (SigD XSigD GhcPs
_ (PatSynSig XPatSynSig GhcPs
x [LIdP GhcPs]
names LHsSigType GhcPs
t)) = do
    (LocatedN RdrName -> HdkA ()) -> [LocatedN RdrName] -> HdkA ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ LocatedN RdrName -> HdkA ()
forall a e. GenLocated (EpAnn a) e -> HdkA ()
registerHdkA [LIdP GhcPs]
[LocatedN RdrName]
names
    GenLocated SrcSpanAnnA (HsSigType GhcPs)
t' <- GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock LHsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs)
t
    pure (XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
SigD XSigD GhcPs
NoExtField
noExtField (XPatSynSig GhcPs -> [LIdP GhcPs] -> LHsSigType GhcPs -> Sig GhcPs
forall pass.
XPatSynSig pass -> [LIdP pass] -> LHsSigType pass -> Sig pass
PatSynSig XPatSynSig GhcPs
x [LIdP GhcPs]
names LHsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs)
t'))

  -- Class method signatures and default signatures:
  --
  --   class C x where
  --      method_of_c
  --        :: Maybe x -- ^ Comment on Maybe x
  --        -> IO ()   -- ^ Comment on IO ()
  --      default method_of_c
  --        :: Eq x
  --        => Maybe x -- ^ Comment on Maybe x
  --        -> IO ()   -- ^ Comment on IO ()
  --
  addHaddock (SigD XSigD GhcPs
_ (ClassOpSig XClassOpSig GhcPs
x Bool
is_dflt [LIdP GhcPs]
names LHsSigType GhcPs
t)) = do
    (LocatedN RdrName -> HdkA ()) -> [LocatedN RdrName] -> HdkA ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ LocatedN RdrName -> HdkA ()
forall a e. GenLocated (EpAnn a) e -> HdkA ()
registerHdkA [LIdP GhcPs]
[LocatedN RdrName]
names
    GenLocated SrcSpanAnnA (HsSigType GhcPs)
t' <- GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock LHsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs)
t
    pure (XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
SigD XSigD GhcPs
NoExtField
noExtField (XClassOpSig GhcPs
-> Bool -> [LIdP GhcPs] -> LHsSigType GhcPs -> Sig GhcPs
forall pass.
XClassOpSig pass
-> Bool -> [LIdP pass] -> LHsSigType pass -> Sig pass
ClassOpSig XClassOpSig GhcPs
x Bool
is_dflt [LIdP GhcPs]
names LHsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs)
t'))

  -- Data/newtype declarations:
  --
  --   data T = MkT -- ^ Comment on MkT
  --            A   -- ^ Comment on A
  --            B   -- ^ Comment on B
  --
  --   data G where
  --     -- | Comment on MkG
  --     MkG :: A    -- ^ Comment on A
  --         -> B    -- ^ Comment on B
  --         -> G
  --
  --   newtype N = MkN { getN :: Natural }  -- ^ Comment on N
  --     deriving newtype (Eq  {- ^ Comment on Eq  N -})
  --     deriving newtype (Ord {- ^ Comment on Ord N -})
  --
  addHaddock (TyClD XTyClD GhcPs
x TyClDecl GhcPs
decl)
    | DataDecl { XDataDecl GhcPs
tcdDExt :: XDataDecl GhcPs
tcdDExt :: forall pass. TyClDecl pass -> XDataDecl pass
tcdDExt, LIdP GhcPs
tcdLName :: LIdP GhcPs
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName, LHsQTyVars GhcPs
tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars, LexicalFixity
tcdFixity :: LexicalFixity
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdFixity, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcPs
defn } <- TyClDecl GhcPs
decl
    = do
        LocatedN RdrName -> HdkA ()
forall a e. GenLocated (EpAnn a) e -> HdkA ()
registerHdkA LIdP GhcPs
LocatedN RdrName
tcdLName
        HsDataDefn GhcPs
defn' <- HsDataDefn GhcPs -> HdkA (HsDataDefn GhcPs)
forall a. HasHaddock a => a -> HdkA a
addHaddock HsDataDefn GhcPs
defn
        pure $
          XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
x (DataDecl {
            XDataDecl GhcPs
tcdDExt :: XDataDecl GhcPs
tcdDExt :: XDataDecl GhcPs
tcdDExt,
            LIdP GhcPs
tcdLName :: LIdP GhcPs
tcdLName :: LIdP GhcPs
tcdLName, LHsQTyVars GhcPs
tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars, LexicalFixity
tcdFixity :: LexicalFixity
tcdFixity :: LexicalFixity
tcdFixity,
            tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
defn' })

  -- Class declarations:
  --
  --  class C a where
  --      -- | Comment on the first method
  --      first_method :: a -> Bool
  --      second_method :: a -> String
  --      -- ^ Comment on the second method
  --
  addHaddock (TyClD XTyClD GhcPs
_ TyClDecl GhcPs
decl)
    | ClassDecl { tcdCExt :: forall pass. TyClDecl pass -> XClassDecl pass
tcdCExt = (AnnClassDecl
x, EpLayout
layout, AnnSortKey DeclTag
NoAnnSortKey),
                  Maybe (LHsContext GhcPs)
tcdCtxt :: Maybe (LHsContext GhcPs)
tcdCtxt :: forall pass. TyClDecl pass -> Maybe (LHsContext pass)
tcdCtxt, LIdP GhcPs
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName :: LIdP GhcPs
tcdLName, LHsQTyVars GhcPs
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars, LexicalFixity
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdFixity :: LexicalFixity
tcdFixity, [LHsFunDep GhcPs]
tcdFDs :: [LHsFunDep GhcPs]
tcdFDs :: forall pass. TyClDecl pass -> [LHsFunDep pass]
tcdFDs,
                  [LSig GhcPs]
tcdSigs :: [LSig GhcPs]
tcdSigs :: forall pass. TyClDecl pass -> [LSig pass]
tcdSigs, LHsBinds GhcPs
tcdMeths :: LHsBinds GhcPs
tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths, [LFamilyDecl GhcPs]
tcdATs :: [LFamilyDecl GhcPs]
tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs, [LTyFamDefltDecl GhcPs]
tcdATDefs :: [LTyFamDefltDecl GhcPs]
tcdATDefs :: forall pass. TyClDecl pass -> [LTyFamDefltDecl pass]
tcdATDefs } <- TyClDecl GhcPs
decl
    = do
        LocatedN RdrName -> HdkA ()
forall a e. GenLocated (EpAnn a) e -> HdkA ()
registerHdkA LIdP GhcPs
LocatedN RdrName
tcdLName
        -- todo: register keyword location of 'where', see Note [Register keyword location]
        [LHsDecl GhcPs]
where_cls' <-
          EpLayout
-> (PsLocated HdkComment -> Maybe (LHsDecl GhcPs))
-> [LHsDecl GhcPs]
-> HdkA [LHsDecl GhcPs]
forall a.
HasHaddock a =>
EpLayout -> (PsLocated HdkComment -> Maybe a) -> [a] -> HdkA [a]
addHaddockInterleaveItems EpLayout
layout (EpLayout -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs)
mkDocHsDecl EpLayout
layout) ([LHsDecl GhcPs] -> HdkA [LHsDecl GhcPs])
-> [LHsDecl GhcPs] -> HdkA [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$
          (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
 [LTyFamDefltDecl GhcPs], [LDataFamInstDecl GhcPs],
 [LDocDecl GhcPs])
-> [LHsDecl GhcPs]
flattenBindsAndSigs (LHsBinds GhcPs
tcdMeths, [LSig GhcPs]
tcdSigs, [LFamilyDecl GhcPs]
tcdATs, [LTyFamDefltDecl GhcPs]
tcdATDefs, [], [])
        pure $
          let (LHsBinds GhcPs
tcdMeths', [LSig GhcPs]
tcdSigs', [LFamilyDecl GhcPs]
tcdATs', [LTyFamDefltDecl GhcPs]
tcdATDefs', [LDataFamInstDecl GhcPs]
_, [LDocDecl GhcPs]
tcdDocs) = [LHsDecl GhcPs]
-> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
    [LTyFamDefltDecl GhcPs], [LDataFamInstDecl GhcPs],
    [LDocDecl GhcPs])
partitionBindsAndSigs [LHsDecl GhcPs]
where_cls'
              decl' :: TyClDecl GhcPs
decl' = ClassDecl { tcdCExt :: XClassDecl GhcPs
tcdCExt = (AnnClassDecl
x, EpLayout
layout, AnnSortKey DeclTag
forall tag. AnnSortKey tag
NoAnnSortKey)
                                , Maybe (LHsContext GhcPs)
tcdCtxt :: Maybe (LHsContext GhcPs)
tcdCtxt :: Maybe (LHsContext GhcPs)
tcdCtxt, LIdP GhcPs
tcdLName :: LIdP GhcPs
tcdLName :: LIdP GhcPs
tcdLName, LHsQTyVars GhcPs
tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars, LexicalFixity
tcdFixity :: LexicalFixity
tcdFixity :: LexicalFixity
tcdFixity, [LHsFunDep GhcPs]
tcdFDs :: [LHsFunDep GhcPs]
tcdFDs :: [LHsFunDep GhcPs]
tcdFDs
                                , tcdSigs :: [LSig GhcPs]
tcdSigs = [LSig GhcPs]
tcdSigs'
                                , tcdMeths :: LHsBinds GhcPs
tcdMeths = LHsBinds GhcPs
tcdMeths'
                                , tcdATs :: [LFamilyDecl GhcPs]
tcdATs = [LFamilyDecl GhcPs]
tcdATs'
                                , tcdATDefs :: [LTyFamDefltDecl GhcPs]
tcdATDefs = [LTyFamDefltDecl GhcPs]
tcdATDefs'
                                , [LDocDecl GhcPs]
tcdDocs :: [LDocDecl GhcPs]
tcdDocs :: [LDocDecl GhcPs]
tcdDocs }
          in XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
NoExtField
noExtField TyClDecl GhcPs
decl'

  -- Data family instances:
  --
  --    data instance D Bool where ... (same as data/newtype declarations)
  --    data instance D Bool = ...     (same as data/newtype declarations)
  --
  addHaddock (InstD XInstD GhcPs
_ InstDecl GhcPs
decl)
    | DataFamInstD { XDataFamInstD GhcPs
dfid_ext :: XDataFamInstD GhcPs
dfid_ext :: forall pass. InstDecl pass -> XDataFamInstD pass
dfid_ext, DataFamInstDecl GhcPs
dfid_inst :: DataFamInstDecl GhcPs
dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass
dfid_inst } <- InstDecl GhcPs
decl
    , DataFamInstDecl { FamEqn GhcPs (HsDataDefn GhcPs)
dfid_eqn :: FamEqn GhcPs (HsDataDefn GhcPs)
dfid_eqn :: forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn } <- DataFamInstDecl GhcPs
dfid_inst
    = do
      FamEqn GhcPs (HsDataDefn GhcPs)
dfid_eqn' <- case FamEqn GhcPs (HsDataDefn GhcPs)
dfid_eqn of
        FamEqn { XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext :: forall pass rhs. FamEqn pass rhs -> XCFamEqn pass rhs
feqn_ext, LIdP GhcPs
feqn_tycon :: LIdP GhcPs
feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon, HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass
feqn_bndrs, HsFamEqnPats GhcPs
feqn_pats :: HsFamEqnPats GhcPs
feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsFamEqnPats pass
feqn_pats, LexicalFixity
feqn_fixity :: LexicalFixity
feqn_fixity :: forall pass rhs. FamEqn pass rhs -> LexicalFixity
feqn_fixity, HsDataDefn GhcPs
feqn_rhs :: HsDataDefn GhcPs
feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs }
          -> do
            LocatedN RdrName -> HdkA ()
forall a e. GenLocated (EpAnn a) e -> HdkA ()
registerHdkA LIdP GhcPs
LocatedN RdrName
feqn_tycon
            HsDataDefn GhcPs
feqn_rhs' <- HsDataDefn GhcPs -> HdkA (HsDataDefn GhcPs)
forall a. HasHaddock a => a -> HdkA a
addHaddock HsDataDefn GhcPs
feqn_rhs
            pure $ FamEqn {
                XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs)
feqn_ext,
                LIdP GhcPs
feqn_tycon :: LIdP GhcPs
feqn_tycon :: LIdP GhcPs
feqn_tycon, HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs :: HsOuterFamEqnTyVarBndrs GhcPs
feqn_bndrs, HsFamEqnPats GhcPs
feqn_pats :: HsFamEqnPats GhcPs
feqn_pats :: HsFamEqnPats GhcPs
feqn_pats, LexicalFixity
feqn_fixity :: LexicalFixity
feqn_fixity :: LexicalFixity
feqn_fixity,
                feqn_rhs :: HsDataDefn GhcPs
feqn_rhs = HsDataDefn GhcPs
feqn_rhs' }
      pure $ XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD GhcPs
NoExtField
noExtField (DataFamInstD {
        XDataFamInstD GhcPs
dfid_ext :: XDataFamInstD GhcPs
dfid_ext :: XDataFamInstD GhcPs
dfid_ext,
        dfid_inst :: DataFamInstDecl GhcPs
dfid_inst = DataFamInstDecl { dfid_eqn :: FamEqn GhcPs (HsDataDefn GhcPs)
dfid_eqn = FamEqn GhcPs (HsDataDefn GhcPs)
dfid_eqn' } })

  -- Type synonyms:
  --
  --    type T = Int -- ^ Comment on Int
  --
  addHaddock (TyClD XTyClD GhcPs
_ TyClDecl GhcPs
decl)
    | SynDecl { XSynDecl GhcPs
tcdSExt :: XSynDecl GhcPs
tcdSExt :: forall pass. TyClDecl pass -> XSynDecl pass
tcdSExt, LIdP GhcPs
tcdLName :: forall pass. TyClDecl pass -> LIdP pass
tcdLName :: LIdP GhcPs
tcdLName, LHsQTyVars GhcPs
tcdTyVars :: forall pass. TyClDecl pass -> LHsQTyVars pass
tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars, LexicalFixity
tcdFixity :: forall pass. TyClDecl pass -> LexicalFixity
tcdFixity :: LexicalFixity
tcdFixity, LHsType GhcPs
tcdRhs :: LHsType GhcPs
tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdRhs } <- TyClDecl GhcPs
decl
    = do
        LocatedN RdrName -> HdkA ()
forall a e. GenLocated (EpAnn a) e -> HdkA ()
registerHdkA LIdP GhcPs
LocatedN RdrName
tcdLName
        -- todo: register keyword location of '=', see Note [Register keyword location]
        GenLocated SrcSpanAnnA (HsType GhcPs)
tcdRhs' <- GenLocated SrcSpanAnnA (HsType GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
tcdRhs
        pure $
          XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
NoExtField
noExtField (SynDecl {
            XSynDecl GhcPs
tcdSExt :: XSynDecl GhcPs
tcdSExt :: XSynDecl GhcPs
tcdSExt,
            LIdP GhcPs
tcdLName :: LIdP GhcPs
tcdLName :: LIdP GhcPs
tcdLName, LHsQTyVars GhcPs
tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars :: LHsQTyVars GhcPs
tcdTyVars, LexicalFixity
tcdFixity :: LexicalFixity
tcdFixity :: LexicalFixity
tcdFixity,
            tcdRhs :: LHsType GhcPs
tcdRhs = LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
tcdRhs' })

  -- Foreign imports:
  --
  --    foreign import ccall unsafe
  --      o :: Float     -- ^ The input float
  --        -> IO Float  -- ^ The output float
  --
  addHaddock (ForD XForD GhcPs
_ ForeignDecl GhcPs
decl) = do
    LocatedN RdrName -> HdkA ()
forall a e. GenLocated (EpAnn a) e -> HdkA ()
registerHdkA (ForeignDecl GhcPs -> LIdP GhcPs
forall pass. ForeignDecl pass -> LIdP pass
fd_name ForeignDecl GhcPs
decl)
    GenLocated SrcSpanAnnA (HsSigType GhcPs)
fd_sig_ty' <- GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock (ForeignDecl GhcPs -> LHsSigType GhcPs
forall pass. ForeignDecl pass -> LHsSigType pass
fd_sig_ty ForeignDecl GhcPs
decl)
    pure $ XForD GhcPs -> ForeignDecl GhcPs -> HsDecl GhcPs
forall p. XForD p -> ForeignDecl p -> HsDecl p
ForD XForD GhcPs
NoExtField
noExtField (ForeignDecl GhcPs
decl{ fd_sig_ty = fd_sig_ty' })

  -- Other declarations
  addHaddock HsDecl GhcPs
d = HsDecl GhcPs -> HdkA (HsDecl GhcPs)
forall a. a -> HdkA a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HsDecl GhcPs
d

-- The right-hand side of a data/newtype declaration or data family instance.
instance HasHaddock (HsDataDefn GhcPs) where
  addHaddock :: HsDataDefn GhcPs -> HdkA (HsDataDefn GhcPs)
addHaddock defn :: HsDataDefn GhcPs
defn@HsDataDefn{} = do

    -- Register the kind signature:
    --    data D :: Type -> Type        where ...
    --    data instance D Bool :: Type  where ...
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ @Maybe GenLocated SrcSpanAnnA (HsType GhcPs) -> HdkA ()
forall a e. GenLocated (EpAnn a) e -> HdkA ()
registerHdkA (HsDataDefn GhcPs -> Maybe (LHsType GhcPs)
forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig HsDataDefn GhcPs
defn)
    -- todo: register keyword location of '=' or 'where', see Note [Register keyword location]

    -- Process the data constructors:
    --
    --    data T
    --      = MkT1 Int Bool  -- ^ Comment on MkT1
    --      | MkT2 Char Int  -- ^ Comment on MkT2
    --
    DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs))
dd_cons' <- (GenLocated SrcSpanAnnA (ConDecl GhcPs)
 -> HdkA (GenLocated SrcSpanAnnA (ConDecl GhcPs)))
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs))
-> HdkA (DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcPs)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DataDefnCons a -> f (DataDefnCons b)
traverse GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock (HsDataDefn GhcPs -> DataDefnCons (LConDecl GhcPs)
forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons HsDataDefn GhcPs
defn)

    -- Process the deriving clauses:
    --
    --   newtype N = MkN Natural
    --     deriving (Eq  {- ^ Comment on Eq  N -})
    --     deriving (Ord {- ^ Comment on Ord N -})
    --
    [GenLocated EpAnnCO (HsDerivingClause GhcPs)]
dd_derivs' <- [GenLocated EpAnnCO (HsDerivingClause GhcPs)]
-> HdkA [GenLocated EpAnnCO (HsDerivingClause GhcPs)]
forall a. HasHaddock a => a -> HdkA a
addHaddock (HsDataDefn GhcPs -> HsDeriving GhcPs
forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs HsDataDefn GhcPs
defn)

    pure $ HsDataDefn GhcPs
defn { dd_cons = dd_cons',
                  dd_derivs = dd_derivs' }

-- Process the deriving clauses of a data/newtype declaration.
-- Not used for standalone deriving.
instance HasHaddock (Located [LocatedAn NoEpAnns (HsDerivingClause GhcPs)]) where
  addHaddock :: Located [GenLocated EpAnnCO (HsDerivingClause GhcPs)]
-> HdkA (Located [GenLocated EpAnnCO (HsDerivingClause GhcPs)])
addHaddock Located [GenLocated EpAnnCO (HsDerivingClause GhcPs)]
lderivs =
    SrcSpan
-> HdkA (Located [GenLocated EpAnnCO (HsDerivingClause GhcPs)])
-> HdkA (Located [GenLocated EpAnnCO (HsDerivingClause GhcPs)])
forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA (Located [GenLocated EpAnnCO (HsDerivingClause GhcPs)] -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located [GenLocated EpAnnCO (HsDerivingClause GhcPs)]
lderivs) (HdkA (Located [GenLocated EpAnnCO (HsDerivingClause GhcPs)])
 -> HdkA (Located [GenLocated EpAnnCO (HsDerivingClause GhcPs)]))
-> HdkA (Located [GenLocated EpAnnCO (HsDerivingClause GhcPs)])
-> HdkA (Located [GenLocated EpAnnCO (HsDerivingClause GhcPs)])
forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse @Located [GenLocated EpAnnCO (HsDerivingClause GhcPs)]
-> HdkA [GenLocated EpAnnCO (HsDerivingClause GhcPs)]
forall a. HasHaddock a => a -> HdkA a
addHaddock Located [GenLocated EpAnnCO (HsDerivingClause GhcPs)]
lderivs

-- Process a single deriving clause of a data/newtype declaration:
--
--  newtype N = MkN Natural
--    deriving newtype (Eq  {- ^ Comment on Eq  N -})
--    deriving (Ord {- ^ Comment on Ord N -}) via Down N
--
-- Not used for standalone deriving.
instance HasHaddock (LocatedAn NoEpAnns (HsDerivingClause GhcPs)) where
  addHaddock :: GenLocated EpAnnCO (HsDerivingClause GhcPs)
-> HdkA (GenLocated EpAnnCO (HsDerivingClause GhcPs))
addHaddock GenLocated EpAnnCO (HsDerivingClause GhcPs)
lderiv =
    SrcSpan
-> HdkA (GenLocated EpAnnCO (HsDerivingClause GhcPs))
-> HdkA (GenLocated EpAnnCO (HsDerivingClause GhcPs))
forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA (GenLocated EpAnnCO (HsDerivingClause GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated EpAnnCO (HsDerivingClause GhcPs)
lderiv) (HdkA (GenLocated EpAnnCO (HsDerivingClause GhcPs))
 -> HdkA (GenLocated EpAnnCO (HsDerivingClause GhcPs)))
-> HdkA (GenLocated EpAnnCO (HsDerivingClause GhcPs))
-> HdkA (GenLocated EpAnnCO (HsDerivingClause GhcPs))
forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for @(LocatedAn NoEpAnns) GenLocated EpAnnCO (HsDerivingClause GhcPs)
lderiv ((HsDerivingClause GhcPs -> HdkA (HsDerivingClause GhcPs))
 -> HdkA (GenLocated EpAnnCO (HsDerivingClause GhcPs)))
-> (HsDerivingClause GhcPs -> HdkA (HsDerivingClause GhcPs))
-> HdkA (GenLocated EpAnnCO (HsDerivingClause GhcPs))
forall a b. (a -> b) -> a -> b
$ \HsDerivingClause GhcPs
deriv ->
    case HsDerivingClause GhcPs
deriv of
      HsDerivingClause { XCHsDerivingClause GhcPs
deriv_clause_ext :: XCHsDerivingClause GhcPs
deriv_clause_ext :: forall pass. HsDerivingClause pass -> XCHsDerivingClause pass
deriv_clause_ext, Maybe (LDerivStrategy GhcPs)
deriv_clause_strategy :: Maybe (LDerivStrategy GhcPs)
deriv_clause_strategy :: forall pass. HsDerivingClause pass -> Maybe (LDerivStrategy pass)
deriv_clause_strategy, LDerivClauseTys GhcPs
deriv_clause_tys :: LDerivClauseTys GhcPs
deriv_clause_tys :: forall pass. HsDerivingClause pass -> LDerivClauseTys pass
deriv_clause_tys } -> do
        let
          -- 'stock', 'anyclass', and 'newtype' strategies come
          -- before the clause types.
          --
          -- 'via' comes after.
          --
          -- See tests/.../T11768.hs
          (HdkA ()
register_strategy_before, HdkA ()
register_strategy_after) =
            case Maybe (LDerivStrategy GhcPs)
deriv_clause_strategy of
              Maybe (LDerivStrategy GhcPs)
Nothing -> (() -> HdkA ()
forall a. a -> HdkA a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), () -> HdkA ()
forall a. a -> HdkA a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              Just (L EpAnnCO
l (ViaStrategy XViaStrategy GhcPs
_)) -> (() -> HdkA ()
forall a. a -> HdkA a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (), SrcSpan -> HdkA ()
registerLocHdkA (EpAnnCO -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnnCO
l))
              Just (L EpAnnCO
l DerivStrategy GhcPs
_) -> (SrcSpan -> HdkA ()
registerLocHdkA (EpAnnCO -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnnCO
l), () -> HdkA ()
forall a. a -> HdkA a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        HdkA ()
register_strategy_before
        GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)
deriv_clause_tys' <- GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)
-> HdkA (GenLocated SrcSpanAnnC (DerivClauseTys GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock LDerivClauseTys GhcPs
GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)
deriv_clause_tys
        HdkA ()
register_strategy_after
        pure HsDerivingClause
          { XCHsDerivingClause GhcPs
deriv_clause_ext :: XCHsDerivingClause GhcPs
deriv_clause_ext :: XCHsDerivingClause GhcPs
deriv_clause_ext,
            Maybe (LDerivStrategy GhcPs)
deriv_clause_strategy :: Maybe (LDerivStrategy GhcPs)
deriv_clause_strategy :: Maybe (LDerivStrategy GhcPs)
deriv_clause_strategy,
            deriv_clause_tys :: LDerivClauseTys GhcPs
deriv_clause_tys = LDerivClauseTys GhcPs
GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)
deriv_clause_tys' }

-- Process the types in a single deriving clause, which may come in one of the
-- following forms:
--
--    1. A singular type constructor:
--          deriving Eq -- ^ Comment on Eq
--
--    2. A list of comma-separated types surrounded by enclosing parentheses:
--          deriving ( Eq  -- ^ Comment on Eq
--                   , C a -- ^ Comment on C a
--                   )
instance HasHaddock (LocatedC (DerivClauseTys GhcPs)) where
  addHaddock :: GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)
-> HdkA (GenLocated SrcSpanAnnC (DerivClauseTys GhcPs))
addHaddock (L SrcSpanAnnC
l_dct DerivClauseTys GhcPs
dct) =
    SrcSpan
-> HdkA (GenLocated SrcSpanAnnC (DerivClauseTys GhcPs))
-> HdkA (GenLocated SrcSpanAnnC (DerivClauseTys GhcPs))
forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA (SrcSpanAnnC -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnC
l_dct) (HdkA (GenLocated SrcSpanAnnC (DerivClauseTys GhcPs))
 -> HdkA (GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)))
-> HdkA (GenLocated SrcSpanAnnC (DerivClauseTys GhcPs))
-> HdkA (GenLocated SrcSpanAnnC (DerivClauseTys GhcPs))
forall a b. (a -> b) -> a -> b
$
    case DerivClauseTys GhcPs
dct of
      DctSingle XDctSingle GhcPs
x LHsSigType GhcPs
ty -> do
        GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty' <- GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock LHsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty
        pure $ SrcSpanAnnC
-> DerivClauseTys GhcPs
-> GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnC
l_dct (DerivClauseTys GhcPs
 -> GenLocated SrcSpanAnnC (DerivClauseTys GhcPs))
-> DerivClauseTys GhcPs
-> GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)
forall a b. (a -> b) -> a -> b
$ XDctSingle GhcPs -> LHsSigType GhcPs -> DerivClauseTys GhcPs
forall pass.
XDctSingle pass -> LHsSigType pass -> DerivClauseTys pass
DctSingle XDctSingle GhcPs
x LHsSigType GhcPs
GenLocated SrcSpanAnnA (HsSigType GhcPs)
ty'
      DctMulti XDctMulti GhcPs
x [LHsSigType GhcPs]
tys -> do
        [GenLocated SrcSpanAnnA (HsSigType GhcPs)]
tys' <- [GenLocated SrcSpanAnnA (HsSigType GhcPs)]
-> HdkA [GenLocated SrcSpanAnnA (HsSigType GhcPs)]
forall a. HasHaddock a => a -> HdkA a
addHaddock [LHsSigType GhcPs]
[GenLocated SrcSpanAnnA (HsSigType GhcPs)]
tys
        pure $ SrcSpanAnnC
-> DerivClauseTys GhcPs
-> GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnC
l_dct (DerivClauseTys GhcPs
 -> GenLocated SrcSpanAnnC (DerivClauseTys GhcPs))
-> DerivClauseTys GhcPs
-> GenLocated SrcSpanAnnC (DerivClauseTys GhcPs)
forall a b. (a -> b) -> a -> b
$ XDctMulti GhcPs -> [LHsSigType GhcPs] -> DerivClauseTys GhcPs
forall pass.
XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass
DctMulti XDctMulti GhcPs
x [LHsSigType GhcPs]
[GenLocated SrcSpanAnnA (HsSigType GhcPs)]
tys'

-- Process a single data constructor declaration, which may come in one of the
-- following forms:
--
--    1. H98-syntax PrefixCon:
--          data T =
--            MkT    -- ^ Comment on MkT
--              Int  -- ^ Comment on Int
--              Bool -- ^ Comment on Bool
--
--    2. H98-syntax InfixCon:
--          data T =
--            Int   -- ^ Comment on Int
--              :+  -- ^ Comment on (:+)
--            Bool  -- ^ Comment on Bool
--
--    3. H98-syntax RecCon:
--          data T =
--            MkT { int_field :: Int,     -- ^ Comment on int_field
--                  bool_field :: Bool }  -- ^ Comment on bool_field
--
--    4. GADT-syntax PrefixCon:
--          data T where
--            -- | Comment on MkT
--            MkT :: Int  -- ^ Comment on Int
--                -> Bool -- ^ Comment on Bool
--                -> T
--
--    5. GADT-syntax RecCon:
--          data T where
--            -- | Comment on MkT
--            MkT :: { int_field :: Int,     -- ^ Comment on int_field
--                     bool_field :: Bool }  -- ^ Comment on bool_field
--                -> T
--
instance HasHaddock (LocatedA (ConDecl GhcPs)) where
  addHaddock :: GenLocated SrcSpanAnnA (ConDecl GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (ConDecl GhcPs))
addHaddock (L SrcSpanAnnA
l_con_decl ConDecl GhcPs
con_decl) =
    SrcSpan
-> HdkA (GenLocated SrcSpanAnnA (ConDecl GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l_con_decl) (HdkA (GenLocated SrcSpanAnnA (ConDecl GhcPs))
 -> HdkA (GenLocated SrcSpanAnnA (ConDecl GhcPs)))
-> HdkA (GenLocated SrcSpanAnnA (ConDecl GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall a b. (a -> b) -> a -> b
$
    case ConDecl GhcPs
con_decl of
      ConDeclGADT { XConDeclGADT GhcPs
con_g_ext :: XConDeclGADT GhcPs
con_g_ext :: forall pass. ConDecl pass -> XConDeclGADT pass
con_g_ext, NonEmpty (LIdP GhcPs)
con_names :: NonEmpty (LIdP GhcPs)
con_names :: forall pass. ConDecl pass -> NonEmpty (LIdP pass)
con_names, XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_bndrs :: XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_bndrs, Maybe (LHsContext GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt, HsConDeclGADTDetails GhcPs
con_g_args :: HsConDeclGADTDetails GhcPs
con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args, LHsType GhcPs
con_res_ty :: LHsType GhcPs
con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty } -> do
        Maybe (GenLocated SrcSpan HsDocString)
con_doc' <- SrcSpan -> HdkA (Maybe (GenLocated SrcSpan HsDocString))
getConDoc (LocatedN RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA (NonEmpty (LocatedN RdrName) -> LocatedN RdrName
forall a. NonEmpty a -> a
NE.head NonEmpty (LIdP GhcPs)
NonEmpty (LocatedN RdrName)
con_names))
        HsConDeclGADTDetails GhcPs
con_g_args' <-
          case HsConDeclGADTDetails GhcPs
con_g_args of
            PrefixConGADT XPrefixConGADT GhcPs
x [HsScaled GhcPs (LHsType GhcPs)]
ts -> XPrefixConGADT GhcPs
-> [HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclGADTDetails GhcPs
forall pass.
XPrefixConGADT pass
-> [HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
PrefixConGADT XPrefixConGADT GhcPs
x ([HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
 -> HsConDeclGADTDetails GhcPs)
-> HdkA [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> HdkA (HsConDeclGADTDetails GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> HdkA [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a. HasHaddock a => a -> HdkA a
addHaddock [HsScaled GhcPs (LHsType GhcPs)]
[HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
ts
            RecConGADT XRecConGADT GhcPs
arr (L SrcSpanAnnL
l_rec [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
flds) -> do
              [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
flds' <- (GenLocated SrcSpanAnnA (ConDeclField GhcPs)
 -> HdkA (GenLocated SrcSpanAnnA (ConDeclField GhcPs)))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> HdkA [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LConDeclField GhcPs -> HdkA (LConDeclField GhcPs)
GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (ConDeclField GhcPs))
addHaddockConDeclField [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
flds
              pure $ XRecConGADT GhcPs
-> XRec GhcPs [LConDeclField GhcPs] -> HsConDeclGADTDetails GhcPs
forall pass.
XRecConGADT pass
-> XRec pass [LConDeclField pass] -> HsConDeclGADTDetails pass
RecConGADT XRecConGADT GhcPs
arr (SrcSpanAnnL
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> GenLocated
     SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l_rec [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
flds')
        GenLocated SrcSpanAnnA (HsType GhcPs)
con_res_ty' <- GenLocated SrcSpanAnnA (HsType GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
con_res_ty
        pure $ SrcSpanAnnA
-> ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l_con_decl (ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs))
-> ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
          ConDeclGADT { XConDeclGADT GhcPs
con_g_ext :: XConDeclGADT GhcPs
con_g_ext :: XConDeclGADT GhcPs
con_g_ext, NonEmpty (LIdP GhcPs)
con_names :: NonEmpty (LIdP GhcPs)
con_names :: NonEmpty (LIdP GhcPs)
con_names, XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_bndrs :: XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_bndrs :: XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_bndrs, Maybe (LHsContext GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt,
                        con_doc :: Maybe (LHsDoc GhcPs)
con_doc = GenLocated SrcSpan HsDocString -> LHsDoc GhcPs
lexLHsDocString (GenLocated SrcSpan HsDocString -> LHsDoc GhcPs)
-> Maybe (GenLocated SrcSpan HsDocString) -> Maybe (LHsDoc GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (GenLocated SrcSpan HsDocString)
con_doc',
                        con_g_args :: HsConDeclGADTDetails GhcPs
con_g_args = HsConDeclGADTDetails GhcPs
con_g_args',
                        con_res_ty :: LHsType GhcPs
con_res_ty = LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
con_res_ty' }
      ConDeclH98 { XConDeclH98 GhcPs
con_ext :: XConDeclH98 GhcPs
con_ext :: forall pass. ConDecl pass -> XConDeclH98 pass
con_ext, LIdP GhcPs
con_name :: LIdP GhcPs
con_name :: forall pass. ConDecl pass -> LIdP pass
con_name, Bool
con_forall :: Bool
con_forall :: forall pass. ConDecl pass -> Bool
con_forall, [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass]
con_ex_tvs, Maybe (LHsContext GhcPs)
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt, HsConDeclH98Details GhcPs
con_args :: HsConDeclH98Details GhcPs
con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args } ->
        let
          -- See Note [Leading and trailing comments on H98 constructors]
          getTrailingLeading :: HdkM (LocatedA (ConDecl GhcPs))
          getTrailingLeading :: HdkM (GenLocated SrcSpanAnnA (ConDecl GhcPs))
getTrailingLeading = do
            Maybe (GenLocated SrcSpan HsDocString)
con_doc' <- SrcSpan -> HdkM (Maybe (GenLocated SrcSpan HsDocString))
getPrevNextDoc (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l_con_decl)
            return $ SrcSpanAnnA
-> ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l_con_decl (ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs))
-> ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
              ConDeclH98 { XConDeclH98 GhcPs
con_ext :: XConDeclH98 GhcPs
con_ext :: XConDeclH98 GhcPs
con_ext, LIdP GhcPs
con_name :: LIdP GhcPs
con_name :: LIdP GhcPs
con_name, Bool
con_forall :: Bool
con_forall :: Bool
con_forall, [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs, Maybe (LHsContext GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt, HsConDeclH98Details GhcPs
con_args :: HsConDeclH98Details GhcPs
con_args :: HsConDeclH98Details GhcPs
con_args
                         , con_doc :: Maybe (LHsDoc GhcPs)
con_doc = GenLocated SrcSpan HsDocString -> LHsDoc GhcPs
lexLHsDocString (GenLocated SrcSpan HsDocString -> LHsDoc GhcPs)
-> Maybe (GenLocated SrcSpan HsDocString) -> Maybe (LHsDoc GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (GenLocated SrcSpan HsDocString)
con_doc' }

          -- See Note [Leading and trailing comments on H98 constructors]
          getMixed :: HdkA (LocatedA (ConDecl GhcPs))
          getMixed :: HdkA (GenLocated SrcSpanAnnA (ConDecl GhcPs))
getMixed =
            case HsConDeclH98Details GhcPs
con_args of
              PrefixCon [Void]
_ [HsScaled GhcPs (LHsType GhcPs)]
ts -> do
                Maybe (GenLocated SrcSpan HsDocString)
con_doc' <- SrcSpan -> HdkA (Maybe (GenLocated SrcSpan HsDocString))
getConDoc (LocatedN RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LIdP GhcPs
LocatedN RdrName
con_name)
                [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
ts' <- (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
 -> HdkA (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))))
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> HdkA [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse HsScaled GhcPs (LHsType GhcPs)
-> HdkA (HsScaled GhcPs (LHsType GhcPs))
HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HdkA (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
addHaddockConDeclFieldTy [HsScaled GhcPs (LHsType GhcPs)]
[HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
ts
                pure $ SrcSpanAnnA
-> ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l_con_decl (ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs))
-> ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
                  ConDeclH98 { XConDeclH98 GhcPs
con_ext :: XConDeclH98 GhcPs
con_ext :: XConDeclH98 GhcPs
con_ext, LIdP GhcPs
con_name :: LIdP GhcPs
con_name :: LIdP GhcPs
con_name, Bool
con_forall :: Bool
con_forall :: Bool
con_forall, [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs, Maybe (LHsContext GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt,
                               con_doc :: Maybe (LHsDoc GhcPs)
con_doc = GenLocated SrcSpan HsDocString -> LHsDoc GhcPs
lexLHsDocString (GenLocated SrcSpan HsDocString -> LHsDoc GhcPs)
-> Maybe (GenLocated SrcSpan HsDocString) -> Maybe (LHsDoc GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (GenLocated SrcSpan HsDocString)
con_doc',
                               con_args :: HsConDeclH98Details GhcPs
con_args = [Void]
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> HsConDetails
     Void
     (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
     (GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [Void]
noTypeArgs [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
ts' }
              InfixCon HsScaled GhcPs (LHsType GhcPs)
t1 HsScaled GhcPs (LHsType GhcPs)
t2 -> do
                HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
t1' <- HsScaled GhcPs (LHsType GhcPs)
-> HdkA (HsScaled GhcPs (LHsType GhcPs))
addHaddockConDeclFieldTy HsScaled GhcPs (LHsType GhcPs)
t1
                Maybe (GenLocated SrcSpan HsDocString)
con_doc' <- SrcSpan -> HdkA (Maybe (GenLocated SrcSpan HsDocString))
getConDoc (LocatedN RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LIdP GhcPs
LocatedN RdrName
con_name)
                HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
t2' <- HsScaled GhcPs (LHsType GhcPs)
-> HdkA (HsScaled GhcPs (LHsType GhcPs))
addHaddockConDeclFieldTy HsScaled GhcPs (LHsType GhcPs)
t2
                pure $ SrcSpanAnnA
-> ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l_con_decl (ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs))
-> ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
                  ConDeclH98 { XConDeclH98 GhcPs
con_ext :: XConDeclH98 GhcPs
con_ext :: XConDeclH98 GhcPs
con_ext, LIdP GhcPs
con_name :: LIdP GhcPs
con_name :: LIdP GhcPs
con_name, Bool
con_forall :: Bool
con_forall :: Bool
con_forall, [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs, Maybe (LHsContext GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt,
                               con_doc :: Maybe (LHsDoc GhcPs)
con_doc = GenLocated SrcSpan HsDocString -> LHsDoc GhcPs
lexLHsDocString (GenLocated SrcSpan HsDocString -> LHsDoc GhcPs)
-> Maybe (GenLocated SrcSpan HsDocString) -> Maybe (LHsDoc GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (GenLocated SrcSpan HsDocString)
con_doc',
                               con_args :: HsConDeclH98Details GhcPs
con_args = HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsConDetails
     Void
     (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
     (GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
t1' HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
t2' }
              RecCon (L SrcSpanAnnL
l_rec [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
flds) -> do
                Maybe (GenLocated SrcSpan HsDocString)
con_doc' <- SrcSpan -> HdkA (Maybe (GenLocated SrcSpan HsDocString))
getConDoc (LocatedN RdrName -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA LIdP GhcPs
LocatedN RdrName
con_name)
                [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
flds' <- (GenLocated SrcSpanAnnA (ConDeclField GhcPs)
 -> HdkA (GenLocated SrcSpanAnnA (ConDeclField GhcPs)))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> HdkA [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LConDeclField GhcPs -> HdkA (LConDeclField GhcPs)
GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (ConDeclField GhcPs))
addHaddockConDeclField [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
flds
                pure $ SrcSpanAnnA
-> ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l_con_decl (ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs))
-> ConDecl GhcPs -> GenLocated SrcSpanAnnA (ConDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
                  ConDeclH98 { XConDeclH98 GhcPs
con_ext :: XConDeclH98 GhcPs
con_ext :: XConDeclH98 GhcPs
con_ext, LIdP GhcPs
con_name :: LIdP GhcPs
con_name :: LIdP GhcPs
con_name, Bool
con_forall :: Bool
con_forall :: Bool
con_forall, [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs]
con_ex_tvs, Maybe (LHsContext GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_mb_cxt,
                               con_doc :: Maybe (LHsDoc GhcPs)
con_doc = GenLocated SrcSpan HsDocString -> LHsDoc GhcPs
lexLHsDocString (GenLocated SrcSpan HsDocString -> LHsDoc GhcPs)
-> Maybe (GenLocated SrcSpan HsDocString) -> Maybe (LHsDoc GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (GenLocated SrcSpan HsDocString)
con_doc',
                               con_args :: HsConDeclH98Details GhcPs
con_args = GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> HsConDetails
     Void
     (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
     (GenLocated
        SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon (SrcSpanAnnL
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> GenLocated
     SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnL
l_rec [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
flds') }
        in
          (HdkM (GenLocated SrcSpanAnnA (ConDecl GhcPs))
 -> HdkM (GenLocated SrcSpanAnnA (ConDecl GhcPs)))
-> HdkA (GenLocated SrcSpanAnnA (ConDecl GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (ConDecl GhcPs))
forall a b. (HdkM a -> HdkM b) -> HdkA a -> HdkA b
hoistHdkA
            (\HdkM (GenLocated SrcSpanAnnA (ConDecl GhcPs))
m -> do { Bool
a <- SrcSpan -> HdkM Bool
onlyTrailingOrLeading (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l_con_decl)
                      ; if Bool
a then HdkM (GenLocated SrcSpanAnnA (ConDecl GhcPs))
getTrailingLeading else HdkM (GenLocated SrcSpanAnnA (ConDecl GhcPs))
m })
            HdkA (GenLocated SrcSpanAnnA (ConDecl GhcPs))
getMixed

-- See Note [Leading and trailing comments on H98 constructors]
onlyTrailingOrLeading :: SrcSpan -> HdkM Bool
onlyTrailingOrLeading :: SrcSpan -> HdkM Bool
onlyTrailingOrLeading SrcSpan
l = HdkM Bool -> HdkM Bool
forall a. HdkM a -> HdkM a
peekHdkM (HdkM Bool -> HdkM Bool) -> HdkM Bool -> HdkM Bool
forall a b. (a -> b) -> a -> b
$ do
  [GenLocated SrcSpan HsDocString]
leading <-
    LocRange
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. LocRange -> HdkM a -> HdkM a
inLocRange (Maybe BufPos -> LocRange
locRangeTo (SrcLoc -> Maybe BufPos
getBufPos (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
l))) (HdkM [GenLocated SrcSpan HsDocString]
 -> HdkM [GenLocated SrcSpan HsDocString])
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a b. (a -> b) -> a -> b
$
    (PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString))
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a]
takeHdkComments PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString)
mkDocNext
  [GenLocated SrcSpan HsDocString]
inner <-
    LocRange
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. LocRange -> HdkM a -> HdkM a
inLocRange (Maybe BufSpan -> LocRange
locRangeIn (SrcSpan -> Maybe BufSpan
getBufSpan SrcSpan
l)) (HdkM [GenLocated SrcSpan HsDocString]
 -> HdkM [GenLocated SrcSpan HsDocString])
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a b. (a -> b) -> a -> b
$
    (PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString))
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a]
takeHdkComments (\PsLocated HdkComment
x -> PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString)
mkDocNext PsLocated HdkComment
x Maybe (GenLocated SrcSpan HsDocString)
-> Maybe (GenLocated SrcSpan HsDocString)
-> Maybe (GenLocated SrcSpan HsDocString)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString)
mkDocPrev PsLocated HdkComment
x)
  [GenLocated SrcSpan HsDocString]
trailing <-
    LocRange
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. LocRange -> HdkM a -> HdkM a
inLocRange (Maybe BufPos -> LocRange
locRangeFrom (SrcLoc -> Maybe BufPos
getBufPos (SrcSpan -> SrcLoc
srcSpanEnd SrcSpan
l))) (HdkM [GenLocated SrcSpan HsDocString]
 -> HdkM [GenLocated SrcSpan HsDocString])
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a b. (a -> b) -> a -> b
$
    (PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString))
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a]
takeHdkComments PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString)
mkDocPrev
  return $ case ([GenLocated SrcSpan HsDocString]
leading, [GenLocated SrcSpan HsDocString]
inner, [GenLocated SrcSpan HsDocString]
trailing) of
    (GenLocated SrcSpan HsDocString
_:[GenLocated SrcSpan HsDocString]
_, [], []) -> Bool
True  -- leading comment only
    ([], [], GenLocated SrcSpan HsDocString
_:[GenLocated SrcSpan HsDocString]
_) -> Bool
True  -- trailing comment only
    ([GenLocated SrcSpan HsDocString],
 [GenLocated SrcSpan HsDocString], [GenLocated SrcSpan HsDocString])
_             -> Bool
False

-- Get the documentation comment associated with the data constructor in a
-- data/newtype declaration.
getConDoc
  :: SrcSpan  -- Location of the data constructor
  -> HdkA (Maybe (Located HsDocString))
getConDoc :: SrcSpan -> HdkA (Maybe (GenLocated SrcSpan HsDocString))
getConDoc SrcSpan
l = SrcSpan
-> HdkA (Maybe (GenLocated SrcSpan HsDocString))
-> HdkA (Maybe (GenLocated SrcSpan HsDocString))
forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA SrcSpan
l (HdkA (Maybe (GenLocated SrcSpan HsDocString))
 -> HdkA (Maybe (GenLocated SrcSpan HsDocString)))
-> HdkA (Maybe (GenLocated SrcSpan HsDocString))
-> HdkA (Maybe (GenLocated SrcSpan HsDocString))
forall a b. (a -> b) -> a -> b
$ HdkM (Maybe (GenLocated SrcSpan HsDocString))
-> HdkA (Maybe (GenLocated SrcSpan HsDocString))
forall a. HdkM a -> HdkA a
liftHdkA (HdkM (Maybe (GenLocated SrcSpan HsDocString))
 -> HdkA (Maybe (GenLocated SrcSpan HsDocString)))
-> HdkM (Maybe (GenLocated SrcSpan HsDocString))
-> HdkA (Maybe (GenLocated SrcSpan HsDocString))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HdkM (Maybe (GenLocated SrcSpan HsDocString))
getPrevNextDoc SrcSpan
l

-- Add documentation comment to a data constructor field.
-- Used for PrefixCon and InfixCon.
addHaddockConDeclFieldTy
  :: HsScaled GhcPs (LHsType GhcPs)
  -> HdkA (HsScaled GhcPs (LHsType GhcPs))
addHaddockConDeclFieldTy :: HsScaled GhcPs (LHsType GhcPs)
-> HdkA (HsScaled GhcPs (LHsType GhcPs))
addHaddockConDeclFieldTy (HsScaled HsArrow GhcPs
mult (L SrcSpanAnnA
l HsType GhcPs
t)) =
  SrcSpan
-> HdkA (HsScaled GhcPs (LHsType GhcPs))
-> HdkA (HsScaled GhcPs (LHsType GhcPs))
forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (HdkA (HsScaled GhcPs (LHsType GhcPs))
 -> HdkA (HsScaled GhcPs (LHsType GhcPs)))
-> HdkA (HsScaled GhcPs (LHsType GhcPs))
-> HdkA (HsScaled GhcPs (LHsType GhcPs))
forall a b. (a -> b) -> a -> b
$ HdkM (HsScaled GhcPs (LHsType GhcPs))
-> HdkA (HsScaled GhcPs (LHsType GhcPs))
forall a. HdkM a -> HdkA a
liftHdkA (HdkM (HsScaled GhcPs (LHsType GhcPs))
 -> HdkA (HsScaled GhcPs (LHsType GhcPs)))
-> HdkM (HsScaled GhcPs (LHsType GhcPs))
-> HdkA (HsScaled GhcPs (LHsType GhcPs))
forall a b. (a -> b) -> a -> b
$ do
    Maybe (GenLocated SrcSpan HsDocString)
mDoc <- SrcSpan -> HdkM (Maybe (GenLocated SrcSpan HsDocString))
getPrevNextDoc (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
    return (HsArrow GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall pass a. HsArrow pass -> a -> HsScaled pass a
HsScaled HsArrow GhcPs
mult (LHsType GhcPs
-> Maybe (GenLocated SrcSpan HsDocString) -> LHsType GhcPs
mkLHsDocTy (SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsType GhcPs
t) Maybe (GenLocated SrcSpan HsDocString)
mDoc))

-- Add documentation comment to a data constructor field.
-- Used for RecCon.
addHaddockConDeclField
  :: LConDeclField GhcPs
  -> HdkA (LConDeclField GhcPs)
addHaddockConDeclField :: LConDeclField GhcPs -> HdkA (LConDeclField GhcPs)
addHaddockConDeclField (L SrcSpanAnnA
l_fld ConDeclField GhcPs
fld) =
  SrcSpan -> HdkA (LConDeclField GhcPs) -> HdkA (LConDeclField GhcPs)
forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l_fld) (HdkA (LConDeclField GhcPs) -> HdkA (LConDeclField GhcPs))
-> HdkA (LConDeclField GhcPs) -> HdkA (LConDeclField GhcPs)
forall a b. (a -> b) -> a -> b
$ HdkM (LConDeclField GhcPs) -> HdkA (LConDeclField GhcPs)
forall a. HdkM a -> HdkA a
liftHdkA (HdkM (LConDeclField GhcPs) -> HdkA (LConDeclField GhcPs))
-> HdkM (LConDeclField GhcPs) -> HdkA (LConDeclField GhcPs)
forall a b. (a -> b) -> a -> b
$ do
    Maybe (LHsDoc GhcPs)
cd_fld_doc <- (GenLocated SrcSpan HsDocString -> LHsDoc GhcPs)
-> Maybe (GenLocated SrcSpan HsDocString) -> Maybe (LHsDoc GhcPs)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenLocated SrcSpan HsDocString -> LHsDoc GhcPs
lexLHsDocString (Maybe (GenLocated SrcSpan HsDocString) -> Maybe (LHsDoc GhcPs))
-> HdkM (Maybe (GenLocated SrcSpan HsDocString))
-> HdkM (Maybe (LHsDoc GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SrcSpan -> HdkM (Maybe (GenLocated SrcSpan HsDocString))
getPrevNextDoc (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l_fld)
    return (SrcSpanAnnA
-> ConDeclField GhcPs
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l_fld (ConDeclField GhcPs
fld { cd_fld_doc }))

{- Note [Leading and trailing comments on H98 constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The trailing comment after a constructor declaration is associated with the
constructor itself when it is the only comment:

   data T = MkT A B        -- ^ Comment on MkT
   data T = MkT { x :: A } -- ^ Comment on MkT
   data T = A `MkT` B      -- ^ Comment on MkT

When there are other comments, the trailing comment applies to the last field:

   data T = MkT -- ^ Comment on MkT
            A   -- ^ Comment on A
            B   -- ^ Comment on B

   data T =
     MkT { a :: A   -- ^ Comment on a
         , b :: B   -- ^ Comment on b
         , c :: C } -- ^ Comment on c

   data T =
       A      -- ^ Comment on A
      `MkT`   -- ^ Comment on MkT
       B      -- ^ Comment on B

When it comes to the leading comment, there is no such ambiguity in /prefix/
constructor declarations (plain or record syntax):

   data T =
    -- | Comment on MkT
    MkT A B

   data T =
    -- | Comment on MkT
    MkT
      -- | Comment on A
      A
      -- | Comment on B
      B

   data T =
    -- | Comment on MkT
    MkT { x :: A }

   data T =
     -- | Comment on MkT
     MkT {
      -- | Comment on a
      a :: A,
      -- | Comment on b
      b :: B,
      -- | Comment on c
      c :: C
    }

However, in /infix/ constructor declarations the leading comment is associated
with the constructor itself if it is the only comment, and with the first
field if there are other comments:

   data T =
    -- | Comment on MkT
    A `MkT` B

   data T =
    -- | Comment on A
    A
    -- | Comment on MkT
    `MkT`
    -- | Comment on B
    B

This makes the leading and trailing comments context-sensitive. Example:
      data T =
        -- | comment 1
        MkT Int Bool -- ^ comment 2

    Here, "comment 2" applies to the Bool field.
    But if we removed "comment 1", then "comment 2" would be apply to the data
    constructor rather than its field.

All of this applies to H98-style data declarations only.
GADTSyntax data constructors don't have any special treatment for the trailing comment.

We implement this in two steps:

  1. Gather information about available comments using `onlyTrailingOrLeading`.
     It inspects available comments but does not consume them, and returns a
     boolean that tells us what algorithm we should use
        True  <=>  expect a single leading/trailing comment
        False <=>  expect inner comments or more than one comment

  2. Collect the comments using the algorithm determined in the previous step

     a) `getTrailingLeading`:
            a single leading/trailing comment is applied to the entire
            constructor declaration as a whole; see the `con_doc` field
     b) `getMixed`:
            comments apply to individual parts of a constructor declaration,
            including its field types
-}

instance HasHaddock a => HasHaddock (HsScaled GhcPs a) where
  addHaddock :: HsScaled GhcPs a -> HdkA (HsScaled GhcPs a)
addHaddock (HsScaled HsArrow GhcPs
mult a
a) = HsArrow GhcPs -> a -> HsScaled GhcPs a
forall pass a. HsArrow pass -> a -> HsScaled pass a
HsScaled HsArrow GhcPs
mult (a -> HsScaled GhcPs a) -> HdkA a -> HdkA (HsScaled GhcPs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> HdkA a
forall a. HasHaddock a => a -> HdkA a
addHaddock a
a

instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where
  addHaddock :: HsWildCardBndrs GhcPs a -> HdkA (HsWildCardBndrs GhcPs a)
addHaddock (HsWC XHsWC GhcPs a
_ a
t) = XHsWC GhcPs a -> a -> HsWildCardBndrs GhcPs a
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC XHsWC GhcPs a
NoExtField
noExtField (a -> HsWildCardBndrs GhcPs a)
-> HdkA a -> HdkA (HsWildCardBndrs GhcPs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> HdkA a
forall a. HasHaddock a => a -> HdkA a
addHaddock a
t

instance HasHaddock (LocatedA (HsSigType GhcPs)) where
  addHaddock :: GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsSigType GhcPs))
addHaddock (L SrcSpanAnnA
l (HsSig{sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcPs
outer_bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcPs
body})) =
    SrcSpan
-> HdkA (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (HdkA (GenLocated SrcSpanAnnA (HsSigType GhcPs))
 -> HdkA (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
-> HdkA (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall a b. (a -> b) -> a -> b
$ do
      case HsOuterSigTyVarBndrs GhcPs
outer_bndrs of
        HsOuterImplicit{} -> () -> HdkA ()
forall a. a -> HdkA a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        HsOuterExplicit{hso_bndrs :: forall flag pass.
HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]
hso_bndrs = [LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
bndrs} ->
          SrcSpan -> HdkA ()
registerLocHdkA ([LHsTyVarBndr Specificity GhcPs] -> SrcSpan
forall flag. [LHsTyVarBndr flag GhcPs] -> SrcSpan
getLHsTyVarBndrsLoc [LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
[LHsTyVarBndr Specificity GhcPs]
bndrs)
      GenLocated SrcSpanAnnA (HsType GhcPs)
body' <- GenLocated SrcSpanAnnA (HsType GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
body
      pure $ SrcSpanAnnA
-> HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall a b. (a -> b) -> a -> b
$ XHsSig GhcPs
-> HsOuterSigTyVarBndrs GhcPs -> LHsType GhcPs -> HsSigType GhcPs
forall pass.
XHsSig pass
-> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass
HsSig XHsSig GhcPs
NoExtField
noExtField HsOuterSigTyVarBndrs GhcPs
outer_bndrs LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
body'

-- Process a type, adding documentation comments to function arguments
-- and the result. Many formatting styles are supported.
--
--  my_function ::
--      forall a.
--      Eq a =>
--      Maybe a ->  -- ^ Comment on Maybe a  (function argument)
--      Bool ->     -- ^ Comment on Bool     (function argument)
--      String      -- ^ Comment on String   (the result)
--
--  my_function
--      :: forall a. Eq a
--      => Maybe a     -- ^ Comment on Maybe a  (function argument)
--      -> Bool        -- ^ Comment on Bool     (function argument)
--      -> String      -- ^ Comment on String   (the result)
--
--  my_function ::
--      forall a. Eq a =>
--      -- | Comment on Maybe a (function argument)
--      Maybe a ->
--      -- | Comment on Bool (function argument)
--      Bool ->
--      -- | Comment on String (the result)
--      String
--
-- This is achieved by simply ignoring (not registering the location of) the
-- function arrow (->).
instance HasHaddock (LocatedA (HsType GhcPs)) where
  addHaddock :: GenLocated SrcSpanAnnA (HsType GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
addHaddock (L SrcSpanAnnA
l HsType GhcPs
t) =
    SrcSpan
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l) (HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
 -> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a b. (a -> b) -> a -> b
$
    case HsType GhcPs
t of

      -- forall a b c. t
      HsForAllTy XForAllTy GhcPs
x HsForAllTelescope GhcPs
tele LHsType GhcPs
body -> do
        SrcSpan -> HdkA ()
registerLocHdkA (HsForAllTelescope GhcPs -> SrcSpan
getForAllTeleLoc HsForAllTelescope GhcPs
tele)
        GenLocated SrcSpanAnnA (HsType GhcPs)
body' <- GenLocated SrcSpanAnnA (HsType GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
body
        pure $ SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XForAllTy GhcPs
-> HsForAllTelescope GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XForAllTy pass
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy XForAllTy GhcPs
x HsForAllTelescope GhcPs
tele LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
body')

      -- (Eq a, Num a) => t
      HsQualTy XQualTy GhcPs
x LHsContext GhcPs
lhs LHsType GhcPs
rhs -> do
        GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> HdkA ()
forall a e. GenLocated (EpAnn a) e -> HdkA ()
registerHdkA LHsContext GhcPs
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
lhs
        GenLocated SrcSpanAnnA (HsType GhcPs)
rhs' <- GenLocated SrcSpanAnnA (HsType GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
rhs
        pure $ SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XQualTy GhcPs -> LHsContext GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy XQualTy GhcPs
x LHsContext GhcPs
lhs LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
rhs')

      -- arg -> res
      HsFunTy XFunTy GhcPs
u HsArrow GhcPs
mult LHsType GhcPs
lhs LHsType GhcPs
rhs -> do
        GenLocated SrcSpanAnnA (HsType GhcPs)
lhs' <- GenLocated SrcSpanAnnA (HsType GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
lhs
        GenLocated SrcSpanAnnA (HsType GhcPs)
rhs' <- GenLocated SrcSpanAnnA (HsType GhcPs)
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. HasHaddock a => a -> HdkA a
addHaddock LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
rhs
        pure $ SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XFunTy GhcPs
-> HsArrow GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcPs
u HsArrow GhcPs
mult LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
lhs' LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
rhs')

      -- other types
      HsType GhcPs
_ -> HdkM (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a. HdkM a -> HdkA a
liftHdkA (HdkM (GenLocated SrcSpanAnnA (HsType GhcPs))
 -> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> HdkM (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HdkA (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a b. (a -> b) -> a -> b
$ do
        Maybe (GenLocated SrcSpan HsDocString)
mDoc <- SrcSpan -> HdkM (Maybe (GenLocated SrcSpan HsDocString))
getPrevNextDoc (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
l)
        return (LHsType GhcPs
-> Maybe (GenLocated SrcSpan HsDocString) -> LHsType GhcPs
mkLHsDocTy (SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsType GhcPs
t) Maybe (GenLocated SrcSpan HsDocString)
mDoc)

{- *********************************************************************
*                                                                      *
*      HdkA: a layer over HdkM that propagates location information    *
*                                                                      *
********************************************************************* -}

-- See Note [Adding Haddock comments to the syntax tree].
--
-- 'HdkA' provides a way to propagate location information from surrounding
-- computations:
--
--   left_neighbour <*> HdkA inner_span inner_m <*> right_neighbour
--
-- Here, the following holds:
--
-- * the 'left_neighbour' will only see Haddock comments until 'bufSpanStart' of 'inner_span'
-- * the 'right_neighbour' will only see Haddock comments after 'bufSpanEnd' of 'inner_span'
-- * the 'inner_m' will only see Haddock comments between its 'left_neighbour' and its 'right_neighbour'
--
-- In other words, every computation:
--
--  * delimits the surrounding computations
--  * is delimited by the surrounding computations
--
--  Therefore, a 'HdkA' computation must be always considered in the context in
--  which it is used.
data HdkA a =
  HdkA
    !(Strict.Maybe BufSpan)
                     -- Just b  <=> BufSpan occupied by the processed AST element.
                     --             The surrounding computations will not look inside.
                     --
                     -- Nothing <=> No BufSpan (e.g. when the HdkA is constructed by 'pure' or 'liftHdkA').
                     --             The surrounding computations are not delimited.

    !(HdkM a) -- The stateful computation that looks up Haddock comments and
              -- adds them to the resulting AST node.

  deriving ((forall a b. (a -> b) -> HdkA a -> HdkA b)
-> (forall a b. a -> HdkA b -> HdkA a) -> Functor HdkA
forall a b. a -> HdkA b -> HdkA a
forall a b. (a -> b) -> HdkA a -> HdkA b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> HdkA a -> HdkA b
fmap :: forall a b. (a -> b) -> HdkA a -> HdkA b
$c<$ :: forall a b. a -> HdkA b -> HdkA a
<$ :: forall a b. a -> HdkA b -> HdkA a
Functor)

instance Applicative HdkA where
  HdkA Maybe BufSpan
l1 HdkM (a -> b)
m1 <*> :: forall a b. HdkA (a -> b) -> HdkA a -> HdkA b
<*> HdkA Maybe BufSpan
l2 HdkM a
m2 =
    Maybe BufSpan -> HdkM b -> HdkA b
forall a. Maybe BufSpan -> HdkM a -> HdkA a
HdkA
      (Maybe BufSpan
l1 Maybe BufSpan -> Maybe BufSpan -> Maybe BufSpan
forall a. Semigroup a => a -> a -> a
<> Maybe BufSpan
l2)  -- The combined BufSpan that covers both subcomputations.
                  --
                  -- The Semigroup instance for Maybe quite conveniently does the right thing:
                  --    Nothing <> b       = b
                  --    a       <> Nothing = a
                  --    Just a  <> Just b  = Just (a <> b)

      (HdkM (a -> b) -> HdkM (a -> b)
delim1 HdkM (a -> b)
m1 HdkM (a -> b) -> HdkM a -> HdkM b
forall a b. HdkM (a -> b) -> HdkM a -> HdkM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HdkM a -> HdkM a
delim2 HdkM a
m2) -- Stateful computations are run in left-to-right order,
                                -- without any smart reordering strategy. So users of this
                                -- operation must take care to traverse the AST
                                -- in concrete syntax order.
                                -- See Note [Smart reordering in HdkA (or lack thereof)]
                                --
                                -- Each computation is delimited ("sandboxed")
                                -- in a way that it doesn't see any Haddock
                                -- comments past the neighbouring AST node.
                                -- These delim1/delim2 are key to how HdkA operates.
    where
      -- Delimit the LHS by the location information from the RHS
      delim1 :: HdkM (a -> b) -> HdkM (a -> b)
delim1 = LocRange -> HdkM (a -> b) -> HdkM (a -> b)
forall a. LocRange -> HdkM a -> HdkM a
inLocRange (Maybe BufPos -> LocRange
locRangeTo (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap @Strict.Maybe BufSpan -> BufPos
bufSpanStart Maybe BufSpan
l2))
      -- Delimit the RHS by the location information from the LHS
      delim2 :: HdkM a -> HdkM a
delim2 = LocRange -> HdkM a -> HdkM a
forall a. LocRange -> HdkM a -> HdkM a
inLocRange (Maybe BufPos -> LocRange
locRangeFrom (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap @Strict.Maybe BufSpan -> BufPos
bufSpanEnd Maybe BufSpan
l1))

  pure :: forall a. a -> HdkA a
pure a
a =
    -- Return a value without performing any stateful computation, and without
    -- any delimiting effect on the surrounding computations.
    HdkM a -> HdkA a
forall a. HdkM a -> HdkA a
liftHdkA (a -> HdkM a
forall a. a -> HdkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)

{- Note [Smart reordering in HdkA (or lack thereof)]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When traversing the AST, the user must take care to traverse it in concrete
syntax order.

For example, when processing HsFunTy, it's important to get it right and write
it like so:

      HsFunTy _ mult lhs rhs -> do
        lhs' <- addHaddock lhs
        rhs' <- addHaddock rhs
        pure $ L l (HsFunTy noExtField mult lhs' rhs')

Rather than like so:

      HsFunTy _ mult lhs rhs -> do
        rhs' <- addHaddock rhs   -- bad! wrong order
        lhs' <- addHaddock lhs   -- bad! wrong order
        pure $ L l (HsFunTy noExtField mult lhs' rhs')

This is somewhat bug-prone, so we could try to fix this with some Applicative
magic. When we define (<*>) for HdkA, why not reorder the computations as
necessary? In pseudo-code:

  a1 <*> a2 | a1 `before` a2 = ... normal processing ...
            | otherwise      = a1 <**> a2

While this trick could work for any two *adjacent* AST elements out of order
(as in HsFunTy example above), it would fail in more elaborate scenarios (e.g.
processing a list of declarations out of order).

If it's not obvious why this trick doesn't work, ponder this: it's a bit like trying to get
a sorted list by defining a 'smart' concatenation operator in the following manner:

  a ?++ b | a <= b    = a ++ b
          | otherwise = b ++ a

At first glance it seems to work:

  ghci> [1] ?++ [2] ?++ [3]
  [1,2,3]

  ghci> [2] ?++ [1] ?++ [3]
  [1,2,3]                     -- wow, sorted!

But it actually doesn't:

  ghci> [3] ?++ [1] ?++ [2]
  [1,3,2]                     -- not sorted...
-}

-- Run a HdkA computation in an unrestricted LocRange. This is only used at the
-- top level to run the final computation for the entire module.
runHdkA :: HdkA a -> HdkSt -> (a, HdkSt)
runHdkA :: forall a. HdkA a -> HdkSt -> (a, HdkSt)
runHdkA (HdkA Maybe BufSpan
_ HdkM a
m) = HdkM a -> LocRange -> HdkSt -> (a, HdkSt)
forall a. HdkM a -> LocRange -> HdkSt -> (a, HdkSt)
unHdkM HdkM a
m LocRange
forall a. Monoid a => a
mempty

-- Let the neighbours know about an item at this location.
--
-- Consider this example:
--
--  class -- | peculiarly placed comment
--    MyClass a where
--        my_method :: a -> a
--
-- How do we know to reject the "peculiarly placed comment" instead of
-- associating it with my_method? Its indentation level matches.
--
-- But clearly, there's "MyClass a where" separating the comment and my_method.
-- To take it into account, we must register its location using registerLocHdkA
-- or registerHdkA.
--
-- See Note [Register keyword location].
-- See Note [Adding Haddock comments to the syntax tree].
registerLocHdkA :: SrcSpan -> HdkA ()
registerLocHdkA :: SrcSpan -> HdkA ()
registerLocHdkA SrcSpan
l = Maybe BufSpan -> HdkM () -> HdkA ()
forall a. Maybe BufSpan -> HdkM a -> HdkA a
HdkA (SrcSpan -> Maybe BufSpan
getBufSpan SrcSpan
l) (() -> HdkM ()
forall a. a -> HdkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- Let the neighbours know about an item at this location.
-- A small wrapper over registerLocHdkA.
--
-- See Note [Adding Haddock comments to the syntax tree].
registerHdkA :: GenLocated (EpAnn a) e -> HdkA ()
registerHdkA :: forall a e. GenLocated (EpAnn a) e -> HdkA ()
registerHdkA GenLocated (EpAnn a) e
a = SrcSpan -> HdkA ()
registerLocHdkA (GenLocated (EpAnn a) e -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated (EpAnn a) e
a)

-- Modify the action of a HdkA computation.
hoistHdkA :: (HdkM a -> HdkM b) -> HdkA a -> HdkA b
hoistHdkA :: forall a b. (HdkM a -> HdkM b) -> HdkA a -> HdkA b
hoistHdkA HdkM a -> HdkM b
f (HdkA Maybe BufSpan
l HdkM a
m) = Maybe BufSpan -> HdkM b -> HdkA b
forall a. Maybe BufSpan -> HdkM a -> HdkA a
HdkA Maybe BufSpan
l (HdkM a -> HdkM b
f HdkM a
m)

-- Lift a HdkM computation to HdkA.
liftHdkA :: HdkM a -> HdkA a
liftHdkA :: forall a. HdkM a -> HdkA a
liftHdkA = Maybe BufSpan -> HdkM a -> HdkA a
forall a. Maybe BufSpan -> HdkM a -> HdkA a
HdkA Maybe BufSpan
forall a. Monoid a => a
mempty

-- Extend the declared location span of a 'HdkA' computation:
--
--    left_neighbour <*> extendHdkA l x <*> right_neighbour
--
-- The declared location of 'x' now includes 'l', so that the surrounding
-- computations 'left_neighbour' and 'right_neighbour' will not look for
-- Haddock comments inside the 'l' location span.
extendHdkA :: SrcSpan -> HdkA a -> HdkA a
extendHdkA :: forall a. SrcSpan -> HdkA a -> HdkA a
extendHdkA SrcSpan
l' (HdkA Maybe BufSpan
l HdkM a
m) = Maybe BufSpan -> HdkM a -> HdkA a
forall a. Maybe BufSpan -> HdkM a -> HdkA a
HdkA (SrcSpan -> Maybe BufSpan
getBufSpan SrcSpan
l' Maybe BufSpan -> Maybe BufSpan -> Maybe BufSpan
forall a. Semigroup a => a -> a -> a
<> Maybe BufSpan
l) HdkM a
m


{- *********************************************************************
*                                                                      *
*              HdkM: a stateful computation to associate               *
*          accumulated documentation comments with AST nodes           *
*                                                                      *
********************************************************************* -}

-- The state of 'HdkM' contains a list of pending Haddock comments. We go
-- over the AST, looking up these comments using 'takeHdkComments' and removing
-- them from the state. The remaining, un-removed ones are ignored with a
-- warning (-Winvalid-haddock). Also, using a state means we never use the same
-- Haddock twice.
--
-- See Note [Adding Haddock comments to the syntax tree].
newtype HdkM a = HdkM { forall a. HdkM a -> LocRange -> HdkSt -> (a, HdkSt)
unHdkM :: LocRange -> HdkSt -> (a, HdkSt) }
  deriving ((forall a b. (a -> b) -> HdkM a -> HdkM b)
-> (forall a b. a -> HdkM b -> HdkM a) -> Functor HdkM
forall a b. a -> HdkM b -> HdkM a
forall a b. (a -> b) -> HdkM a -> HdkM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> HdkM a -> HdkM b
fmap :: forall a b. (a -> b) -> HdkM a -> HdkM b
$c<$ :: forall a b. a -> HdkM b -> HdkM a
<$ :: forall a b. a -> HdkM b -> HdkM a
Functor, Functor HdkM
Functor HdkM =>
(forall a. a -> HdkM a)
-> (forall a b. HdkM (a -> b) -> HdkM a -> HdkM b)
-> (forall a b c. (a -> b -> c) -> HdkM a -> HdkM b -> HdkM c)
-> (forall a b. HdkM a -> HdkM b -> HdkM b)
-> (forall a b. HdkM a -> HdkM b -> HdkM a)
-> Applicative HdkM
forall a. a -> HdkM a
forall a b. HdkM a -> HdkM b -> HdkM a
forall a b. HdkM a -> HdkM b -> HdkM b
forall a b. HdkM (a -> b) -> HdkM a -> HdkM b
forall a b c. (a -> b -> c) -> HdkM a -> HdkM b -> HdkM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> HdkM a
pure :: forall a. a -> HdkM a
$c<*> :: forall a b. HdkM (a -> b) -> HdkM a -> HdkM b
<*> :: forall a b. HdkM (a -> b) -> HdkM a -> HdkM b
$cliftA2 :: forall a b c. (a -> b -> c) -> HdkM a -> HdkM b -> HdkM c
liftA2 :: forall a b c. (a -> b -> c) -> HdkM a -> HdkM b -> HdkM c
$c*> :: forall a b. HdkM a -> HdkM b -> HdkM b
*> :: forall a b. HdkM a -> HdkM b -> HdkM b
$c<* :: forall a b. HdkM a -> HdkM b -> HdkM a
<* :: forall a b. HdkM a -> HdkM b -> HdkM a
Applicative, Applicative HdkM
Applicative HdkM =>
(forall a b. HdkM a -> (a -> HdkM b) -> HdkM b)
-> (forall a b. HdkM a -> HdkM b -> HdkM b)
-> (forall a. a -> HdkM a)
-> Monad HdkM
forall a. a -> HdkM a
forall a b. HdkM a -> HdkM b -> HdkM b
forall a b. HdkM a -> (a -> HdkM b) -> HdkM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. HdkM a -> (a -> HdkM b) -> HdkM b
>>= :: forall a b. HdkM a -> (a -> HdkM b) -> HdkM b
$c>> :: forall a b. HdkM a -> HdkM b -> HdkM b
>> :: forall a b. HdkM a -> HdkM b -> HdkM b
$creturn :: forall a. a -> HdkM a
return :: forall a. a -> HdkM a
Monad) via (ReaderT LocRange (State HdkSt))

-- | The state of HdkM.
data HdkSt =
  HdkSt
    { HdkSt -> [PsLocated HdkComment]
hdk_st_pending :: [PsLocated HdkComment]
        -- a list of pending (unassociated with an AST node)
        -- Haddock comments, sorted by location: in ascending order of the starting 'BufPos'
    , HdkSt -> [HdkWarn]
hdk_st_warnings :: [HdkWarn]
        -- accumulated warnings (order doesn't matter)
    }

-- | Warnings accumulated in HdkM.
data HdkWarn
  = HdkWarnInvalidComment (PsLocated HdkComment)
  | HdkWarnExtraComment (Located HsDocString)

-- Restrict the range in which a HdkM computation will look up comments:
--
--   inLocRange r1 $
--   inLocRange r2 $
--     takeHdkComments ...  -- Only takes comments in the (r1 <> r2) location range.
--
-- Note that it does not blindly override the range but tightens it using (<>).
-- At many use sites, you will see something along the lines of:
--
--   inLocRange (locRangeTo end_pos) $ ...
--
-- And 'locRangeTo' defines a location range from the start of the file to
-- 'end_pos'. This does not mean that we now search for every comment from the
-- start of the file, as this restriction will be combined with other
-- restrictions. Somewhere up the callstack we might have:
--
--   inLocRange (locRangeFrom start_pos) $ ...
--
-- The net result is that the location range is delimited by 'start_pos' on
-- one side and by 'end_pos' on the other side.
--
-- In 'HdkA', every (<*>) may restrict the location range of its
-- subcomputations.
inLocRange :: LocRange -> HdkM a -> HdkM a
inLocRange :: forall a. LocRange -> HdkM a -> HdkM a
inLocRange LocRange
r (HdkM LocRange -> HdkSt -> (a, HdkSt)
m) = (LocRange -> HdkSt -> (a, HdkSt)) -> HdkM a
forall a. (LocRange -> HdkSt -> (a, HdkSt)) -> HdkM a
HdkM (\LocRange
r' -> LocRange -> HdkSt -> (a, HdkSt)
m (LocRange
r LocRange -> LocRange -> LocRange
forall a. Semigroup a => a -> a -> a
<> LocRange
r'))

-- Take the Haddock comments that satisfy the matching function,
-- leaving the rest pending.
takeHdkComments :: forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a]
takeHdkComments :: forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a]
takeHdkComments PsLocated HdkComment -> Maybe a
f =
  (LocRange -> HdkSt -> ([a], HdkSt)) -> HdkM [a]
forall a. (LocRange -> HdkSt -> (a, HdkSt)) -> HdkM a
HdkM ((LocRange -> HdkSt -> ([a], HdkSt)) -> HdkM [a])
-> (LocRange -> HdkSt -> ([a], HdkSt)) -> HdkM [a]
forall a b. (a -> b) -> a -> b
$
    \(LocRange LowerLocBound
hdk_from UpperLocBound
hdk_to ColumnBound
hdk_col) ->
    \HdkSt
hdk_st ->
      let
        comments :: [PsLocated HdkComment]
comments = HdkSt -> [PsLocated HdkComment]
hdk_st_pending HdkSt
hdk_st
        ([PsLocated HdkComment]
comments_before_range, [PsLocated HdkComment]
comments') = (PsLocated HdkComment -> Bool)
-> [PsLocated HdkComment]
-> ([PsLocated HdkComment], [PsLocated HdkComment])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (LowerLocBound -> PsLocated HdkComment -> Bool
forall {e}. LowerLocBound -> GenLocated PsSpan e -> Bool
is_after LowerLocBound
hdk_from) [PsLocated HdkComment]
comments
        ([PsLocated HdkComment]
comments_in_range, [PsLocated HdkComment]
comments_after_range) = (PsLocated HdkComment -> Bool)
-> [PsLocated HdkComment]
-> ([PsLocated HdkComment], [PsLocated HdkComment])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (UpperLocBound -> PsLocated HdkComment -> Bool
forall {e}. UpperLocBound -> GenLocated PsSpan e -> Bool
is_before UpperLocBound
hdk_to (PsLocated HdkComment -> Bool)
-> (PsLocated HdkComment -> Bool) -> PsLocated HdkComment -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<&&> ColumnBound -> PsLocated HdkComment -> Bool
forall {e}. ColumnBound -> GenLocated PsSpan e -> Bool
is_indented ColumnBound
hdk_col) [PsLocated HdkComment]
comments'
        ([a]
items, [PsLocated HdkComment]
other_comments) = (PsLocated HdkComment
 -> ([a], [PsLocated HdkComment]) -> ([a], [PsLocated HdkComment]))
-> ([a], [PsLocated HdkComment])
-> [PsLocated HdkComment]
-> ([a], [PsLocated HdkComment])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PsLocated HdkComment
-> ([a], [PsLocated HdkComment]) -> ([a], [PsLocated HdkComment])
add_comment ([], []) [PsLocated HdkComment]
comments_in_range
        remaining_comments :: [PsLocated HdkComment]
remaining_comments = [PsLocated HdkComment]
comments_before_range [PsLocated HdkComment]
-> [PsLocated HdkComment] -> [PsLocated HdkComment]
forall a. [a] -> [a] -> [a]
++ [PsLocated HdkComment]
other_comments [PsLocated HdkComment]
-> [PsLocated HdkComment] -> [PsLocated HdkComment]
forall a. [a] -> [a] -> [a]
++ [PsLocated HdkComment]
comments_after_range
        hdk_st' :: HdkSt
hdk_st' = HdkSt
hdk_st{ hdk_st_pending = remaining_comments }
      in ([a]
items, HdkSt
hdk_st')
  where
    is_after :: LowerLocBound -> GenLocated PsSpan e -> Bool
is_after    LowerLocBound
StartOfFile    GenLocated PsSpan e
_               = Bool
True
    is_after    (StartLoc BufPos
l)   (L PsSpan
l_comment e
_) = BufSpan -> BufPos
bufSpanStart (PsSpan -> BufSpan
psBufSpan PsSpan
l_comment) BufPos -> BufPos -> Bool
forall a. Ord a => a -> a -> Bool
>= BufPos
l
    is_before :: UpperLocBound -> GenLocated PsSpan e -> Bool
is_before   UpperLocBound
EndOfFile      GenLocated PsSpan e
_               = Bool
True
    is_before   (EndLoc BufPos
l)     (L PsSpan
l_comment e
_) = BufSpan -> BufPos
bufSpanStart (PsSpan -> BufSpan
psBufSpan PsSpan
l_comment) BufPos -> BufPos -> Bool
forall a. Ord a => a -> a -> Bool
<= BufPos
l
    is_indented :: ColumnBound -> GenLocated PsSpan e -> Bool
is_indented (ColumnFrom Int
n) (L PsSpan
l_comment e
_) = RealSrcSpan -> Int
srcSpanStartCol (PsSpan -> RealSrcSpan
psRealSpan PsSpan
l_comment) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n

    add_comment
      :: PsLocated HdkComment
      -> ([a], [PsLocated HdkComment])
      -> ([a], [PsLocated HdkComment])
    add_comment :: PsLocated HdkComment
-> ([a], [PsLocated HdkComment]) -> ([a], [PsLocated HdkComment])
add_comment PsLocated HdkComment
hdk_comment ([a]
items, [PsLocated HdkComment]
other_hdk_comments) =
      case PsLocated HdkComment -> Maybe a
f PsLocated HdkComment
hdk_comment of
        Just a
item -> (a
item a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
items, [PsLocated HdkComment]
other_hdk_comments)
        Maybe a
Nothing -> ([a]
items, PsLocated HdkComment
hdk_comment PsLocated HdkComment
-> [PsLocated HdkComment] -> [PsLocated HdkComment]
forall a. a -> [a] -> [a]
: [PsLocated HdkComment]
other_hdk_comments)

-- Run a HdkM action and restore the original state.
peekHdkM :: HdkM a -> HdkM a
peekHdkM :: forall a. HdkM a -> HdkM a
peekHdkM HdkM a
m =
  (LocRange -> HdkSt -> (a, HdkSt)) -> HdkM a
forall a. (LocRange -> HdkSt -> (a, HdkSt)) -> HdkM a
HdkM ((LocRange -> HdkSt -> (a, HdkSt)) -> HdkM a)
-> (LocRange -> HdkSt -> (a, HdkSt)) -> HdkM a
forall a b. (a -> b) -> a -> b
$ \LocRange
r HdkSt
s ->
    case HdkM a -> LocRange -> HdkSt -> (a, HdkSt)
forall a. HdkM a -> LocRange -> HdkSt -> (a, HdkSt)
unHdkM HdkM a
m LocRange
r HdkSt
s of
      (a
a, HdkSt
_) -> (a
a, HdkSt
s)

-- Get the docnext or docprev comment for an AST node at the given source span.
getPrevNextDoc :: SrcSpan -> HdkM (Maybe (Located HsDocString))
getPrevNextDoc :: SrcSpan -> HdkM (Maybe (GenLocated SrcSpan HsDocString))
getPrevNextDoc SrcSpan
l = do
  let (SrcLoc
l_start, SrcLoc
l_end) = (SrcSpan -> SrcLoc
srcSpanStart SrcSpan
l, SrcSpan -> SrcLoc
srcSpanEnd SrcSpan
l)
      before_t :: LocRange
before_t = Maybe BufPos -> LocRange
locRangeTo (SrcLoc -> Maybe BufPos
getBufPos SrcLoc
l_start)
      after_t :: LocRange
after_t = Maybe BufPos -> LocRange
locRangeFrom (SrcLoc -> Maybe BufPos
getBufPos SrcLoc
l_end)
  [GenLocated SrcSpan HsDocString]
nextDocs <- LocRange
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. LocRange -> HdkM a -> HdkM a
inLocRange LocRange
before_t (HdkM [GenLocated SrcSpan HsDocString]
 -> HdkM [GenLocated SrcSpan HsDocString])
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a b. (a -> b) -> a -> b
$ (PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString))
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a]
takeHdkComments PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString)
mkDocNext
  [GenLocated SrcSpan HsDocString]
prevDocs <- LocRange
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. LocRange -> HdkM a -> HdkM a
inLocRange LocRange
after_t (HdkM [GenLocated SrcSpan HsDocString]
 -> HdkM [GenLocated SrcSpan HsDocString])
-> HdkM [GenLocated SrcSpan HsDocString]
-> HdkM [GenLocated SrcSpan HsDocString]
forall a b. (a -> b) -> a -> b
$ (PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString))
-> HdkM [GenLocated SrcSpan HsDocString]
forall a. (PsLocated HdkComment -> Maybe a) -> HdkM [a]
takeHdkComments PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString)
mkDocPrev
  [GenLocated SrcSpan HsDocString]
-> HdkM (Maybe (GenLocated SrcSpan HsDocString))
selectDocString ([GenLocated SrcSpan HsDocString]
nextDocs [GenLocated SrcSpan HsDocString]
-> [GenLocated SrcSpan HsDocString]
-> [GenLocated SrcSpan HsDocString]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpan HsDocString]
prevDocs)

appendHdkWarning :: HdkWarn -> HdkM ()
appendHdkWarning :: HdkWarn -> HdkM ()
appendHdkWarning HdkWarn
e = (LocRange -> HdkSt -> ((), HdkSt)) -> HdkM ()
forall a. (LocRange -> HdkSt -> (a, HdkSt)) -> HdkM a
HdkM ((LocRange -> HdkSt -> ((), HdkSt)) -> HdkM ())
-> (LocRange -> HdkSt -> ((), HdkSt)) -> HdkM ()
forall a b. (a -> b) -> a -> b
$ \LocRange
_ HdkSt
hdk_st ->
  let hdk_st' :: HdkSt
hdk_st' = HdkSt
hdk_st { hdk_st_warnings = e : hdk_st_warnings hdk_st }
  in ((), HdkSt
hdk_st')

selectDocString :: [Located HsDocString] -> HdkM (Maybe (Located HsDocString))
selectDocString :: [GenLocated SrcSpan HsDocString]
-> HdkM (Maybe (GenLocated SrcSpan HsDocString))
selectDocString = [GenLocated SrcSpan HsDocString]
-> HdkM (Maybe (GenLocated SrcSpan HsDocString))
select ([GenLocated SrcSpan HsDocString]
 -> HdkM (Maybe (GenLocated SrcSpan HsDocString)))
-> ([GenLocated SrcSpan HsDocString]
    -> [GenLocated SrcSpan HsDocString])
-> [GenLocated SrcSpan HsDocString]
-> HdkM (Maybe (GenLocated SrcSpan HsDocString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpan HsDocString -> Bool)
-> [GenLocated SrcSpan HsDocString]
-> [GenLocated SrcSpan HsDocString]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (HsDocString -> Bool
isEmptyDocString (HsDocString -> Bool)
-> (GenLocated SrcSpan HsDocString -> HsDocString)
-> GenLocated SrcSpan HsDocString
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan HsDocString -> HsDocString
forall l e. GenLocated l e -> e
unLoc)
  where
    select :: [GenLocated SrcSpan HsDocString]
-> HdkM (Maybe (GenLocated SrcSpan HsDocString))
select [] = Maybe (GenLocated SrcSpan HsDocString)
-> HdkM (Maybe (GenLocated SrcSpan HsDocString))
forall a. a -> HdkM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (GenLocated SrcSpan HsDocString)
forall a. Maybe a
Nothing
    select [GenLocated SrcSpan HsDocString
doc] = Maybe (GenLocated SrcSpan HsDocString)
-> HdkM (Maybe (GenLocated SrcSpan HsDocString))
forall a. a -> HdkM a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated SrcSpan HsDocString
-> Maybe (GenLocated SrcSpan HsDocString)
forall a. a -> Maybe a
Just GenLocated SrcSpan HsDocString
doc)
    select (GenLocated SrcSpan HsDocString
doc : [GenLocated SrcSpan HsDocString]
extra_docs) = do
      [GenLocated SrcSpan HsDocString] -> HdkM ()
reportExtraDocs [GenLocated SrcSpan HsDocString]
extra_docs
      return (GenLocated SrcSpan HsDocString
-> Maybe (GenLocated SrcSpan HsDocString)
forall a. a -> Maybe a
Just GenLocated SrcSpan HsDocString
doc)

reportExtraDocs :: [Located HsDocString] -> HdkM ()
reportExtraDocs :: [GenLocated SrcSpan HsDocString] -> HdkM ()
reportExtraDocs =
  (GenLocated SrcSpan HsDocString -> HdkM ())
-> [GenLocated SrcSpan HsDocString] -> HdkM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\GenLocated SrcSpan HsDocString
extra_doc -> HdkWarn -> HdkM ()
appendHdkWarning (GenLocated SrcSpan HsDocString -> HdkWarn
HdkWarnExtraComment GenLocated SrcSpan HsDocString
extra_doc))

{- *********************************************************************
*                                                                      *
*      Matching functions for extracting documentation comments        *
*                                                                      *
********************************************************************* -}

mkDocHsDecl :: EpLayout -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs)
mkDocHsDecl :: EpLayout -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs)
mkDocHsDecl EpLayout
layout PsLocated HdkComment
a = (DocDecl GhcPs -> HsDecl GhcPs)
-> GenLocated SrcSpanAnnA (DocDecl GhcPs)
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (XDocD GhcPs -> DocDecl GhcPs -> HsDecl GhcPs
forall p. XDocD p -> DocDecl p -> HsDecl p
DocD XDocD GhcPs
NoExtField
noExtField) (GenLocated SrcSpanAnnA (DocDecl GhcPs)
 -> GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> Maybe (GenLocated SrcSpanAnnA (DocDecl GhcPs))
-> Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EpLayout -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs)
mkDocDecl EpLayout
layout PsLocated HdkComment
a

mkDocDecl :: EpLayout -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs)
mkDocDecl :: EpLayout -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs)
mkDocDecl EpLayout
layout (L PsSpan
l_comment HdkComment
hdk_comment)
  | Bool
indent_mismatch = Maybe (LDocDecl GhcPs)
Maybe (GenLocated SrcSpanAnnA (DocDecl GhcPs))
forall a. Maybe a
Nothing
  | Bool
otherwise =
    LDocDecl GhcPs -> Maybe (LDocDecl GhcPs)
forall a. a -> Maybe a
Just (LDocDecl GhcPs -> Maybe (LDocDecl GhcPs))
-> LDocDecl GhcPs -> Maybe (LDocDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> DocDecl GhcPs -> GenLocated SrcSpanAnnA (DocDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
span) (DocDecl GhcPs -> GenLocated SrcSpanAnnA (DocDecl GhcPs))
-> DocDecl GhcPs -> GenLocated SrcSpanAnnA (DocDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
      case HdkComment
hdk_comment of
        HdkCommentNext HsDocString
doc -> LHsDoc GhcPs -> DocDecl GhcPs
forall pass. LHsDoc pass -> DocDecl pass
DocCommentNext (SrcSpan -> HsDoc GhcPs -> LHsDoc GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
span (HsDoc GhcPs -> LHsDoc GhcPs) -> HsDoc GhcPs -> LHsDoc GhcPs
forall a b. (a -> b) -> a -> b
$ HsDocString -> HsDoc GhcPs
lexHsDocString HsDocString
doc)
        HdkCommentPrev HsDocString
doc -> LHsDoc GhcPs -> DocDecl GhcPs
forall pass. LHsDoc pass -> DocDecl pass
DocCommentPrev (SrcSpan -> HsDoc GhcPs -> LHsDoc GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
span (HsDoc GhcPs -> LHsDoc GhcPs) -> HsDoc GhcPs -> LHsDoc GhcPs
forall a b. (a -> b) -> a -> b
$ HsDocString -> HsDoc GhcPs
lexHsDocString HsDocString
doc)
        HdkCommentNamed String
s HsDocString
doc -> String -> LHsDoc GhcPs -> DocDecl GhcPs
forall pass. String -> LHsDoc pass -> DocDecl pass
DocCommentNamed String
s (SrcSpan -> HsDoc GhcPs -> LHsDoc GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
span (HsDoc GhcPs -> LHsDoc GhcPs) -> HsDoc GhcPs -> LHsDoc GhcPs
forall a b. (a -> b) -> a -> b
$ HsDocString -> HsDoc GhcPs
lexHsDocString HsDocString
doc)
        HdkCommentSection Int
n HsDocString
doc -> Int -> LHsDoc GhcPs -> DocDecl GhcPs
forall pass. Int -> LHsDoc pass -> DocDecl pass
DocGroup Int
n (SrcSpan -> HsDoc GhcPs -> LHsDoc GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
span (HsDoc GhcPs -> LHsDoc GhcPs) -> HsDoc GhcPs -> LHsDoc GhcPs
forall a b. (a -> b) -> a -> b
$ HsDocString -> HsDoc GhcPs
lexHsDocString HsDocString
doc)
  where
    span :: SrcSpan
span = PsSpan -> SrcSpan
mkSrcSpanPs PsSpan
l_comment
    --  'indent_mismatch' checks if the documentation comment has the exact
    --  indentation level expected by the parent node.
    --
    --  For example, when extracting documentation comments between class
    --  method declarations, there are three cases to consider:
    --
    --  1. Indent matches (indent_mismatch=False):
    --         class C a where
    --           f :: a -> a
    --           -- ^ doc on f
    --
    --  2. Indented too much (indent_mismatch=True):
    --         class C a where
    --           f :: a -> a
    --             -- ^ indent mismatch
    --
    --  3. Indented too little (indent_mismatch=True):
    --         class C a where
    --           f :: a -> a
    --         -- ^ indent mismatch
    indent_mismatch :: Bool
indent_mismatch = case EpLayout
layout of
      EpLayout
EpNoLayout -> Bool
False
      EpExplicitBraces{} -> Bool
False
      EpVirtualBraces Int
n -> Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= RealSrcSpan -> Int
srcSpanStartCol (PsSpan -> RealSrcSpan
psRealSpan PsSpan
l_comment)

mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs)
mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs)
mkDocIE (L PsSpan
l_comment HdkComment
hdk_comment) =
  case HdkComment
hdk_comment of
    HdkCommentSection Int
n HsDocString
doc -> LIE GhcPs -> Maybe (LIE GhcPs)
forall a. a -> Maybe a
Just (LIE GhcPs -> Maybe (LIE GhcPs)) -> LIE GhcPs -> Maybe (LIE GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> IE GhcPs -> GenLocated SrcSpanAnnA (IE GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XIEGroup GhcPs -> Int -> LHsDoc GhcPs -> IE GhcPs
forall pass. XIEGroup pass -> Int -> ExportDoc pass -> IE pass
IEGroup XIEGroup GhcPs
NoExtField
noExtField Int
n (LHsDoc GhcPs -> IE GhcPs) -> LHsDoc GhcPs -> IE GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsDoc GhcPs -> LHsDoc GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
span (HsDoc GhcPs -> LHsDoc GhcPs) -> HsDoc GhcPs -> LHsDoc GhcPs
forall a b. (a -> b) -> a -> b
$ HsDocString -> HsDoc GhcPs
lexHsDocString HsDocString
doc)
    HdkCommentNamed String
s HsDocString
_doc -> LIE GhcPs -> Maybe (LIE GhcPs)
forall a. a -> Maybe a
Just (LIE GhcPs -> Maybe (LIE GhcPs)) -> LIE GhcPs -> Maybe (LIE GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> IE GhcPs -> GenLocated SrcSpanAnnA (IE GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XIEDocNamed GhcPs -> String -> IE GhcPs
forall pass. XIEDocNamed pass -> String -> IE pass
IEDocNamed XIEDocNamed GhcPs
NoExtField
noExtField String
s)
    HdkCommentNext HsDocString
doc -> LIE GhcPs -> Maybe (LIE GhcPs)
forall a. a -> Maybe a
Just (LIE GhcPs -> Maybe (LIE GhcPs)) -> LIE GhcPs -> Maybe (LIE GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> IE GhcPs -> GenLocated SrcSpanAnnA (IE GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XIEDoc GhcPs -> LHsDoc GhcPs -> IE GhcPs
forall pass. XIEDoc pass -> ExportDoc pass -> IE pass
IEDoc XIEDoc GhcPs
NoExtField
noExtField (LHsDoc GhcPs -> IE GhcPs) -> LHsDoc GhcPs -> IE GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsDoc GhcPs -> LHsDoc GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
span (HsDoc GhcPs -> LHsDoc GhcPs) -> HsDoc GhcPs -> LHsDoc GhcPs
forall a b. (a -> b) -> a -> b
$ HsDocString -> HsDoc GhcPs
lexHsDocString HsDocString
doc)
    HdkCommentPrev HsDocString
doc -> LIE GhcPs -> Maybe (LIE GhcPs)
forall a. a -> Maybe a
Just (LIE GhcPs -> Maybe (LIE GhcPs)) -> LIE GhcPs -> Maybe (LIE GhcPs)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA -> IE GhcPs -> GenLocated SrcSpanAnnA (IE GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XIEDoc GhcPs -> LHsDoc GhcPs -> IE GhcPs
forall pass. XIEDoc pass -> ExportDoc pass -> IE pass
IEDoc XIEDoc GhcPs
NoExtField
noExtField (LHsDoc GhcPs -> IE GhcPs) -> LHsDoc GhcPs -> IE GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsDoc GhcPs -> LHsDoc GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
span (HsDoc GhcPs -> LHsDoc GhcPs) -> HsDoc GhcPs -> LHsDoc GhcPs
forall a b. (a -> b) -> a -> b
$ HsDocString -> HsDoc GhcPs
lexHsDocString HsDocString
doc)
  where l :: SrcSpanAnnA
l = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
span
        span :: SrcSpan
span = PsSpan -> SrcSpan
mkSrcSpanPs PsSpan
l_comment

mkDocNext :: PsLocated HdkComment -> Maybe (Located HsDocString)
mkDocNext :: PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString)
mkDocNext (L PsSpan
l (HdkCommentNext HsDocString
doc)) = GenLocated SrcSpan HsDocString
-> Maybe (GenLocated SrcSpan HsDocString)
forall a. a -> Maybe a
Just (SrcSpan -> HsDocString -> GenLocated SrcSpan HsDocString
forall l e. l -> e -> GenLocated l e
L (PsSpan -> SrcSpan
mkSrcSpanPs PsSpan
l) HsDocString
doc)
mkDocNext PsLocated HdkComment
_ = Maybe (GenLocated SrcSpan HsDocString)
forall a. Maybe a
Nothing

mkDocPrev :: PsLocated HdkComment -> Maybe (Located HsDocString)
mkDocPrev :: PsLocated HdkComment -> Maybe (GenLocated SrcSpan HsDocString)
mkDocPrev (L PsSpan
l (HdkCommentPrev HsDocString
doc)) = GenLocated SrcSpan HsDocString
-> Maybe (GenLocated SrcSpan HsDocString)
forall a. a -> Maybe a
Just (SrcSpan -> HsDocString -> GenLocated SrcSpan HsDocString
forall l e. l -> e -> GenLocated l e
L (PsSpan -> SrcSpan
mkSrcSpanPs PsSpan
l) HsDocString
doc)
mkDocPrev PsLocated HdkComment
_ = Maybe (GenLocated SrcSpan HsDocString)
forall a. Maybe a
Nothing


{- *********************************************************************
*                                                                      *
*                   LocRange: a location range                         *
*                                                                      *
********************************************************************* -}

-- A location range for extracting documentation comments.
data LocRange =
  LocRange
    { LocRange -> LowerLocBound
loc_range_from :: !LowerLocBound,
      LocRange -> UpperLocBound
loc_range_to   :: !UpperLocBound,
      LocRange -> ColumnBound
loc_range_col  :: !ColumnBound }

instance Semigroup LocRange where
  LocRange LowerLocBound
from1 UpperLocBound
to1 ColumnBound
col1 <> :: LocRange -> LocRange -> LocRange
<> LocRange LowerLocBound
from2 UpperLocBound
to2 ColumnBound
col2 =
    LowerLocBound -> UpperLocBound -> ColumnBound -> LocRange
LocRange (LowerLocBound
from1 LowerLocBound -> LowerLocBound -> LowerLocBound
forall a. Semigroup a => a -> a -> a
<> LowerLocBound
from2) (UpperLocBound
to1 UpperLocBound -> UpperLocBound -> UpperLocBound
forall a. Semigroup a => a -> a -> a
<> UpperLocBound
to2) (ColumnBound
col1 ColumnBound -> ColumnBound -> ColumnBound
forall a. Semigroup a => a -> a -> a
<> ColumnBound
col2)

instance Monoid LocRange where
  mempty :: LocRange
mempty = LowerLocBound -> UpperLocBound -> ColumnBound -> LocRange
LocRange LowerLocBound
forall a. Monoid a => a
mempty UpperLocBound
forall a. Monoid a => a
mempty ColumnBound
forall a. Monoid a => a
mempty

-- The location range from the specified position to the end of the file.
locRangeFrom :: Strict.Maybe BufPos -> LocRange
locRangeFrom :: Maybe BufPos -> LocRange
locRangeFrom (Strict.Just BufPos
l) = LocRange
forall a. Monoid a => a
mempty { loc_range_from = StartLoc l }
locRangeFrom Maybe BufPos
Strict.Nothing = LocRange
forall a. Monoid a => a
mempty

-- The location range from the start of the file to the specified position.
locRangeTo :: Strict.Maybe BufPos -> LocRange
locRangeTo :: Maybe BufPos -> LocRange
locRangeTo (Strict.Just BufPos
l) = LocRange
forall a. Monoid a => a
mempty { loc_range_to = EndLoc l }
locRangeTo Maybe BufPos
Strict.Nothing = LocRange
forall a. Monoid a => a
mempty

-- The location range within the specified span.
locRangeIn :: Strict.Maybe BufSpan -> LocRange
locRangeIn :: Maybe BufSpan -> LocRange
locRangeIn (Strict.Just BufSpan
l) =
  LocRange
forall a. Monoid a => a
mempty { loc_range_from = StartLoc (bufSpanStart l)
         , loc_range_to   = EndLoc (bufSpanEnd l) }
locRangeIn Maybe BufSpan
Strict.Nothing = LocRange
forall a. Monoid a => a
mempty

-- Represents a predicate on BufPos:
--
--   LowerLocBound |   BufPos -> Bool
--   --------------+-----------------
--   StartOfFile   |   const True
--   StartLoc p    |   (>= p)
--
--  The semigroup instance corresponds to (&&).
--
--  We don't use the  BufPos -> Bool  representation
--  as it would lead to redundant checks.
--
--  That is, instead of
--
--      (pos >= 20) && (pos >= 30) && (pos >= 40)
--
--  We'd rather only do the (>=40) check. So we reify the predicate to make
--  sure we only check for the most restrictive bound.
data LowerLocBound = StartOfFile | StartLoc !BufPos
  deriving Int -> LowerLocBound -> ShowS
[LowerLocBound] -> ShowS
LowerLocBound -> String
(Int -> LowerLocBound -> ShowS)
-> (LowerLocBound -> String)
-> ([LowerLocBound] -> ShowS)
-> Show LowerLocBound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LowerLocBound -> ShowS
showsPrec :: Int -> LowerLocBound -> ShowS
$cshow :: LowerLocBound -> String
show :: LowerLocBound -> String
$cshowList :: [LowerLocBound] -> ShowS
showList :: [LowerLocBound] -> ShowS
Show

instance Semigroup LowerLocBound where
  LowerLocBound
StartOfFile <> :: LowerLocBound -> LowerLocBound -> LowerLocBound
<> LowerLocBound
l = LowerLocBound
l
  LowerLocBound
l <> LowerLocBound
StartOfFile = LowerLocBound
l
  StartLoc BufPos
l1 <> StartLoc BufPos
l2 = BufPos -> LowerLocBound
StartLoc (BufPos -> BufPos -> BufPos
forall a. Ord a => a -> a -> a
max BufPos
l1 BufPos
l2)

instance Monoid LowerLocBound where
  mempty :: LowerLocBound
mempty = LowerLocBound
StartOfFile

-- Represents a predicate on BufPos:
--
--   UpperLocBound |   BufPos -> Bool
--   --------------+-----------------
--   EndOfFile     |   const True
--   EndLoc p      |   (<= p)
--
--  The semigroup instance corresponds to (&&).
--
--  We don't use the  BufPos -> Bool  representation
--  as it would lead to redundant checks.
--
--  That is, instead of
--
--      (pos <= 40) && (pos <= 30) && (pos <= 20)
--
--  We'd rather only do the (<=20) check. So we reify the predicate to make
--  sure we only check for the most restrictive bound.
data UpperLocBound = EndOfFile | EndLoc !BufPos
  deriving Int -> UpperLocBound -> ShowS
[UpperLocBound] -> ShowS
UpperLocBound -> String
(Int -> UpperLocBound -> ShowS)
-> (UpperLocBound -> String)
-> ([UpperLocBound] -> ShowS)
-> Show UpperLocBound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UpperLocBound -> ShowS
showsPrec :: Int -> UpperLocBound -> ShowS
$cshow :: UpperLocBound -> String
show :: UpperLocBound -> String
$cshowList :: [UpperLocBound] -> ShowS
showList :: [UpperLocBound] -> ShowS
Show

instance Semigroup UpperLocBound where
  UpperLocBound
EndOfFile <> :: UpperLocBound -> UpperLocBound -> UpperLocBound
<> UpperLocBound
l = UpperLocBound
l
  UpperLocBound
l <> UpperLocBound
EndOfFile = UpperLocBound
l
  EndLoc BufPos
l1 <> EndLoc BufPos
l2 = BufPos -> UpperLocBound
EndLoc (BufPos -> BufPos -> BufPos
forall a. Ord a => a -> a -> a
min BufPos
l1 BufPos
l2)

instance Monoid UpperLocBound where
  mempty :: UpperLocBound
mempty = UpperLocBound
EndOfFile

-- | Represents a predicate on the column number.
--
--   ColumnBound   |   Int -> Bool
--   --------------+-----------------
--   ColumnFrom n  |   (>=n)
--
--  The semigroup instance corresponds to (&&).
--
newtype ColumnBound = ColumnFrom Int -- n >= GHC.Types.SrcLoc.leftmostColumn
  deriving Int -> ColumnBound -> ShowS
[ColumnBound] -> ShowS
ColumnBound -> String
(Int -> ColumnBound -> ShowS)
-> (ColumnBound -> String)
-> ([ColumnBound] -> ShowS)
-> Show ColumnBound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ColumnBound -> ShowS
showsPrec :: Int -> ColumnBound -> ShowS
$cshow :: ColumnBound -> String
show :: ColumnBound -> String
$cshowList :: [ColumnBound] -> ShowS
showList :: [ColumnBound] -> ShowS
Show

instance Semigroup ColumnBound where
  ColumnFrom Int
n <> :: ColumnBound -> ColumnBound -> ColumnBound
<> ColumnFrom Int
m = Int -> ColumnBound
ColumnFrom (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
n Int
m)

instance Monoid ColumnBound where
  mempty :: ColumnBound
mempty = Int -> ColumnBound
ColumnFrom Int
leftmostColumn


{- *********************************************************************
*                                                                      *
*                   AST manipulation utilities                         *
*                                                                      *
********************************************************************* -}

mkLHsDocTy :: LHsType GhcPs -> Maybe (Located HsDocString) -> LHsType GhcPs
mkLHsDocTy :: LHsType GhcPs
-> Maybe (GenLocated SrcSpan HsDocString) -> LHsType GhcPs
mkLHsDocTy LHsType GhcPs
t Maybe (GenLocated SrcSpan HsDocString)
Nothing = LHsType GhcPs
t
mkLHsDocTy LHsType GhcPs
t (Just GenLocated SrcSpan HsDocString
doc) = SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L (GenLocated SrcSpanAnnA (HsType GhcPs) -> SrcSpanAnnA
forall l e. GenLocated l e -> l
getLoc LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
t) (XDocTy GhcPs -> LHsType GhcPs -> LHsDoc GhcPs -> HsType GhcPs
forall pass.
XDocTy pass -> LHsType pass -> LHsDoc pass -> HsType pass
HsDocTy XDocTy GhcPs
NoExtField
noExtField LHsType GhcPs
t (LHsDoc GhcPs -> HsType GhcPs) -> LHsDoc GhcPs -> HsType GhcPs
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan HsDocString -> LHsDoc GhcPs
lexLHsDocString GenLocated SrcSpan HsDocString
doc)

getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan
getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan
getForAllTeleLoc HsForAllTelescope GhcPs
tele =
  case HsForAllTelescope GhcPs
tele of
    HsForAllVis{ [LHsTyVarBndr () GhcPs]
hsf_vis_bndrs :: [LHsTyVarBndr () GhcPs]
hsf_vis_bndrs :: forall pass. HsForAllTelescope pass -> [LHsTyVarBndr () pass]
hsf_vis_bndrs } -> [LHsTyVarBndr () GhcPs] -> SrcSpan
forall flag. [LHsTyVarBndr flag GhcPs] -> SrcSpan
getLHsTyVarBndrsLoc [LHsTyVarBndr () GhcPs]
hsf_vis_bndrs
    HsForAllInvis { [LHsTyVarBndr Specificity GhcPs]
hsf_invis_bndrs :: [LHsTyVarBndr Specificity GhcPs]
hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs } -> [LHsTyVarBndr Specificity GhcPs] -> SrcSpan
forall flag. [LHsTyVarBndr flag GhcPs] -> SrcSpan
getLHsTyVarBndrsLoc [LHsTyVarBndr Specificity GhcPs]
hsf_invis_bndrs

getLHsTyVarBndrsLoc :: [LHsTyVarBndr flag GhcPs] -> SrcSpan
getLHsTyVarBndrsLoc :: forall flag. [LHsTyVarBndr flag GhcPs] -> SrcSpan
getLHsTyVarBndrsLoc [LHsTyVarBndr flag GhcPs]
bndrs = (SrcSpan -> SrcSpan -> SrcSpan) -> SrcSpan -> [SrcSpan] -> SrcSpan
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
noSrcSpan ([SrcSpan] -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs) -> SrcSpan)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA [LHsTyVarBndr flag GhcPs]
[GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcPs)]
bndrs

-- | The inverse of 'partitionBindsAndSigs' that merges partitioned items back
-- into a flat list. Elements are put back into the order in which they
-- appeared in the original program before partitioning, using BufPos to order
-- them.
--
-- Precondition (unchecked): the input lists are already sorted.
flattenBindsAndSigs
  :: (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])
  -> [LHsDecl GhcPs]
flattenBindsAndSigs :: (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],
 [LTyFamDefltDecl GhcPs], [LDataFamInstDecl GhcPs],
 [LDocDecl GhcPs])
-> [LHsDecl GhcPs]
flattenBindsAndSigs (LHsBinds GhcPs
all_bs, [LSig GhcPs]
all_ss, [LFamilyDecl GhcPs]
all_ts, [LTyFamDefltDecl GhcPs]
all_tfis, [LDataFamInstDecl GhcPs]
all_dfis, [LDocDecl GhcPs]
all_docs) =
  -- 'cmpBufSpan' is safe here with the following assumptions:
  --
  -- - 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan'
  -- - 'partitionBindsAndSigs' does not discard this 'BufSpan'
  (GenLocated SrcSpanAnnA (HsDecl GhcPs)
 -> GenLocated SrcSpanAnnA (HsDecl GhcPs) -> Ordering)
-> [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. (a -> a -> Ordering) -> [[a]] -> [a]
mergeListsBy GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> GenLocated SrcSpanAnnA (HsDecl GhcPs) -> Ordering
forall a1 a2 a3.
GenLocated (EpAnn a1) a2 -> GenLocated (EpAnn a3) a2 -> Ordering
cmpBufSpanA [
    (HsBind GhcPs -> HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (HsBind GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b l. (a -> b) -> [GenLocated l a] -> [GenLocated l b]
mapLL (\HsBind GhcPs
b -> XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD XValD GhcPs
NoExtField
noExtField HsBind GhcPs
b) LHsBinds GhcPs
[GenLocated SrcSpanAnnA (HsBind GhcPs)]
all_bs,
    (Sig GhcPs -> HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (Sig GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b l. (a -> b) -> [GenLocated l a] -> [GenLocated l b]
mapLL (\Sig GhcPs
s -> XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
SigD XSigD GhcPs
NoExtField
noExtField Sig GhcPs
s) [LSig GhcPs]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
all_ss,
    (FamilyDecl GhcPs -> HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b l. (a -> b) -> [GenLocated l a] -> [GenLocated l b]
mapLL (\FamilyDecl GhcPs
t -> XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
NoExtField
noExtField (XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs
forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl XFamDecl GhcPs
NoExtField
noExtField FamilyDecl GhcPs
t)) [LFamilyDecl GhcPs]
[GenLocated SrcSpanAnnA (FamilyDecl GhcPs)]
all_ts,
    (TyFamInstDecl GhcPs -> HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b l. (a -> b) -> [GenLocated l a] -> [GenLocated l b]
mapLL (\TyFamInstDecl GhcPs
tfi -> XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD GhcPs
NoExtField
noExtField (XTyFamInstD GhcPs -> TyFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass
TyFamInstD XTyFamInstD GhcPs
NoExtField
noExtField TyFamInstDecl GhcPs
tfi)) [LTyFamDefltDecl GhcPs]
[GenLocated SrcSpanAnnA (TyFamInstDecl GhcPs)]
all_tfis,
    (DataFamInstDecl GhcPs -> HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b l. (a -> b) -> [GenLocated l a] -> [GenLocated l b]
mapLL (\DataFamInstDecl GhcPs
dfi -> XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs
forall p. XInstD p -> InstDecl p -> HsDecl p
InstD XInstD GhcPs
NoExtField
noExtField (XDataFamInstD GhcPs -> DataFamInstDecl GhcPs -> InstDecl GhcPs
forall pass.
XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass
DataFamInstD XDataFamInstD GhcPs
NoExtField
noExtField DataFamInstDecl GhcPs
dfi)) [LDataFamInstDecl GhcPs]
[GenLocated SrcSpanAnnA (DataFamInstDecl GhcPs)]
all_dfis,
    (DocDecl GhcPs -> HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (DocDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b l. (a -> b) -> [GenLocated l a] -> [GenLocated l b]
mapLL (\DocDecl GhcPs
d -> XDocD GhcPs -> DocDecl GhcPs -> HsDecl GhcPs
forall p. XDocD p -> DocDecl p -> HsDecl p
DocD XDocD GhcPs
NoExtField
noExtField DocDecl GhcPs
d) [LDocDecl GhcPs]
[GenLocated SrcSpanAnnA (DocDecl GhcPs)]
all_docs
  ]

cmpBufSpanA :: GenLocated (EpAnn a1) a2 -> GenLocated (EpAnn a3) a2 -> Ordering
cmpBufSpanA :: forall a1 a2 a3.
GenLocated (EpAnn a1) a2 -> GenLocated (EpAnn a3) a2 -> Ordering
cmpBufSpanA (L EpAnn a1
la a2
a) (L EpAnn a3
lb a2
b) = Located a2 -> Located a2 -> Ordering
forall a. HasDebugCallStack => Located a -> Located a -> Ordering
cmpBufSpan (SrcSpan -> a2 -> Located a2
forall l e. l -> e -> GenLocated l e
L (EpAnn a1 -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnn a1
la) a2
a) (SrcSpan -> a2 -> Located a2
forall l e. l -> e -> GenLocated l e
L (EpAnn a3 -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnn a3
lb) a2
b)

{- *********************************************************************
*                                                                      *
*                   General purpose utilities                          *
*                                                                      *
********************************************************************* -}

-- Map a function over a list of located items.
mapLL :: (a -> b) -> [GenLocated l a] -> [GenLocated l b]
mapLL :: forall a b l. (a -> b) -> [GenLocated l a] -> [GenLocated l b]
mapLL a -> b
f = (GenLocated l a -> GenLocated l b)
-> [GenLocated l a] -> [GenLocated l b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> GenLocated l a -> GenLocated l b
forall a b. (a -> b) -> GenLocated l a -> GenLocated l b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)

{- Note [Old solution: Haddock in the grammar]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the past, Haddock comments were incorporated into the grammar (Parser.y).
This led to excessive complexity and duplication.

For example, here's the grammar production for types without documentation:

  type : btype
       | btype '->' ctype

To support Haddock, we had to also maintain an additional grammar production
for types with documentation on function arguments and function result:

  typedoc : btype
          | btype docprev
          | docnext btype
          | btype '->'     ctypedoc
          | btype docprev '->' ctypedoc
          | docnext btype '->' ctypedoc

Sometimes handling documentation comments during parsing led to bugs (#17561),
and sometimes it simply made it hard to modify and extend the grammar.

Another issue was that sometimes Haddock would fail to parse code
that GHC could parse successfully:

  class BadIndent where
    f :: a -> Int
  -- ^ comment
    g :: a -> Int

This declaration was accepted by ghc but rejected by ghc -haddock.
-}

{- Note [Register keyword location]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
At the moment, 'addHaddock' erroneously associates some comments with
constructs that are separated by a keyword. For example:

    data Foo -- | Comment for MkFoo
      where MkFoo :: Foo

We could use EPA (exactprint annotations) to fix this, but not without
modification. For example, EpaLocation contains RealSrcSpan but not BufSpan.
Also, the fix would be more straightforward after #19623.

For examples, see tests/haddock/should_compile_flag_haddock/T17544_kw.hs
-}