{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DerivingVia #-} {- | 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 (mod) import GHC.Hs import GHC.Types.SrcLoc import GHC.Driver.Session ( WarningFlag(..) ) import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Data.Bag import Data.Semigroup import Data.Foldable import Data.Traversable import Data.Maybe import Control.Monad import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer import Data.Functor.Identity import Data.Coerce import qualified Data.Monoid import GHC.Parser.Lexer import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>)) {- 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 accomodate 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 -> P (Located HsModule) addHaddockToModule :: Located HsModule -> P (Located HsModule) addHaddockToModule Located HsModule lmod = do PState pState <- P PState getPState let all_comments :: [PsLocated HdkComment] all_comments = OrdList (PsLocated HdkComment) -> [PsLocated HdkComment] 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 lmod', HdkSt final_hdk_st) = HdkA (Located HsModule) -> HdkSt -> (Located HsModule, HdkSt) forall a. HdkA a -> HdkSt -> (a, HdkSt) runHdkA (Located HsModule -> HdkA (Located HsModule) forall a. HasHaddock a => a -> HdkA a addHaddock Located HsModule 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 lmod' reportHdkWarning :: HdkWarn -> P () reportHdkWarning :: HdkWarn -> P () reportHdkWarning (HdkWarnInvalidComment (L PsSpan l HdkComment _)) = WarningFlag -> SrcSpan -> SDoc -> P () forall (m :: * -> *). MonadP m => WarningFlag -> SrcSpan -> SDoc -> m () addWarning WarningFlag Opt_WarnInvalidHaddock (PsSpan -> SrcSpan mkSrcSpanPs PsSpan l) (SDoc -> P ()) -> SDoc -> P () forall a b. (a -> b) -> a -> b $ String -> SDoc text String "A Haddock comment cannot appear in this position and will be ignored." reportHdkWarning (HdkWarnExtraComment (L SrcSpan l HsDocString _)) = WarningFlag -> SrcSpan -> SDoc -> P () forall (m :: * -> *). MonadP m => WarningFlag -> SrcSpan -> SDoc -> m () addWarning WarningFlag Opt_WarnInvalidHaddock SrcSpan l (SDoc -> P ()) -> SDoc -> P () forall a b. (a -> b) -> a -> b $ String -> SDoc text String "Multiple Haddock comments for a single entity are not allowed." SDoc -> SDoc -> SDoc $$ String -> SDoc text String "The extraneous comment will be ignored." collectHdkWarnings :: HdkSt -> [HdkWarn] collectHdkWarnings :: HdkSt -> [HdkWarn] collectHdkWarnings HdkSt{ [PsLocated HdkComment] hdk_st_pending :: HdkSt -> [PsLocated HdkComment] hdk_st_pending :: [PsLocated HdkComment] hdk_st_pending, [HdkWarn] hdk_st_warnings :: HdkSt -> [HdkWarn] hdk_st_warnings :: [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) 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) where addHaddock :: Located HsModule -> HdkA (Located HsModule) addHaddock (L SrcSpan l_mod HsModule 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 (GenLocated SrcSpan HsDocString)) headerDocs <- forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b) for @Maybe (HsModule -> Maybe (Located ModuleName) hsmodName HsModule mod) ((Located ModuleName -> HdkA (Maybe (GenLocated SrcSpan HsDocString))) -> HdkA (Maybe (Maybe (GenLocated SrcSpan HsDocString)))) -> (Located ModuleName -> HdkA (Maybe (GenLocated SrcSpan HsDocString))) -> HdkA (Maybe (Maybe (GenLocated SrcSpan HsDocString))) forall a b. (a -> b) -> a -> b $ \(L SrcSpan l_name ModuleName _) -> SrcSpan -> HdkA (Maybe (GenLocated SrcSpan HsDocString)) -> HdkA (Maybe (GenLocated SrcSpan HsDocString)) forall a. SrcSpan -> HdkA a -> HdkA a extendHdkA SrcSpan l_name (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 $ 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 SrcSpan 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 [GenLocated SrcSpan HsDocString] -> HdkM (Maybe (GenLocated SrcSpan HsDocString)) selectDocString [GenLocated SrcSpan HsDocString] docs -- 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 (Located [LIE GhcPs]) hsmodExports' <- forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse @Maybe Located [LIE GhcPs] -> HdkA (Located [LIE GhcPs]) forall a. HasHaddock a => a -> HdkA a addHaddock (HsModule -> Maybe (Located [LIE GhcPs]) hsmodExports HsModule mod) -- Step 3, register the import section to reject invalid comments: -- -- import Data.Maybe -- -- | rejected comment (cannot appear here) -- import Data.Bool -- (Located (ImportDecl GhcPs) -> HdkA ()) -> [Located (ImportDecl GhcPs)] -> HdkA () forall (t :: * -> *) (f :: * -> *) a b. (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ Located (ImportDecl GhcPs) -> HdkA () forall a. Located a -> HdkA () registerHdkA (HsModule -> [Located (ImportDecl GhcPs)] hsmodImports HsModule 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_info :: LayoutInfo layout_info = HsModule -> LayoutInfo hsmodLayout HsModule mod [LHsDecl GhcPs] hsmodDecls' <- LayoutInfo -> (PsLocated HdkComment -> Maybe (LHsDecl GhcPs)) -> [LHsDecl GhcPs] -> HdkA [LHsDecl GhcPs] forall a. HasHaddock a => LayoutInfo -> (PsLocated HdkComment -> Maybe a) -> [a] -> HdkA [a] addHaddockInterleaveItems LayoutInfo layout_info (LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) mkDocHsDecl LayoutInfo layout_info) (HsModule -> [LHsDecl GhcPs] hsmodDecls HsModule mod) pure $ SrcSpan -> HsModule -> Located HsModule forall l e. l -> e -> GenLocated l e L SrcSpan l_mod (HsModule -> Located HsModule) -> HsModule -> Located HsModule forall a b. (a -> b) -> a -> b $ HsModule mod { hsmodExports :: Maybe (Located [LIE GhcPs]) hsmodExports = Maybe (Located [LIE GhcPs]) hsmodExports' , hsmodDecls :: [LHsDecl GhcPs] hsmodDecls = [LHsDecl GhcPs] hsmodDecls' , hsmodHaddockModHeader :: Maybe (GenLocated SrcSpan HsDocString) hsmodHaddockModHeader = forall (m :: * -> *) a. Monad m => m (m a) -> m a join @Maybe Maybe (Maybe (GenLocated SrcSpan HsDocString)) headerDocs } -- 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 (Located [LIE GhcPs]) where addHaddock :: Located [LIE GhcPs] -> HdkA (Located [LIE GhcPs]) addHaddock (L SrcSpan l_exports [LIE GhcPs] exports) = SrcSpan -> HdkA (Located [LIE GhcPs]) -> HdkA (Located [LIE GhcPs]) forall a. SrcSpan -> HdkA a -> HdkA a extendHdkA SrcSpan l_exports (HdkA (Located [LIE GhcPs]) -> HdkA (Located [LIE GhcPs])) -> HdkA (Located [LIE GhcPs]) -> HdkA (Located [LIE GhcPs]) forall a b. (a -> b) -> a -> b $ do [LIE GhcPs] exports' <- LayoutInfo -> (PsLocated HdkComment -> Maybe (LIE GhcPs)) -> [LIE GhcPs] -> HdkA [LIE GhcPs] forall a. HasHaddock a => LayoutInfo -> (PsLocated HdkComment -> Maybe a) -> [a] -> HdkA [a] addHaddockInterleaveItems LayoutInfo NoLayoutInfo PsLocated HdkComment -> Maybe (LIE GhcPs) mkDocIE [LIE GhcPs] exports SrcSpan -> HdkA () registerLocHdkA (SrcLoc -> SrcSpan srcLocSpan (SrcSpan -> SrcLoc srcSpanEnd SrcSpan l_exports)) -- Do not consume comments after the closing parenthesis pure $ SrcSpan -> [LIE GhcPs] -> Located [LIE GhcPs] forall l e. l -> e -> GenLocated l e L SrcSpan l_exports [LIE GhcPs] exports' -- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'. instance HasHaddock (LIE GhcPs) where addHaddock :: LIE GhcPs -> HdkA (LIE GhcPs) addHaddock LIE GhcPs a = LIE GhcPs a LIE GhcPs -> HdkA () -> HdkA (LIE GhcPs) forall (f :: * -> *) a b. Functor f => a -> f b -> f a <$ LIE GhcPs -> HdkA () forall a. Located a -> HdkA () registerHdkA LIE GhcPs a {- 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_info :: LayoutInfo In the example above, note that the indentation level inside the module is 2 spaces. It would be represented as layout_info = VirtualBraces 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_info, 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 => LayoutInfo -> (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 => LayoutInfo -> (PsLocated HdkComment -> Maybe a) -> [a] -> HdkA [a] addHaddockInterleaveItems LayoutInfo layout_info 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_info (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_info :: HdkA a -> HdkA a with_layout_info :: HdkA a -> HdkA a with_layout_info = case LayoutInfo layout_info of LayoutInfo NoLayoutInfo -> HdkA a -> HdkA a forall a. a -> a id LayoutInfo ExplicitBraces -> HdkA a -> HdkA a forall a. a -> a id VirtualBraces Int n -> let loc_range :: LocRange loc_range = LocRange forall a. Monoid a => a mempty { loc_range_col :: ColumnBound loc_range_col = Int -> ColumnBound ColumnFrom (Int nInt -> Int -> Int forall a. Num a => a -> a -> a +Int 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 (LHsDecl GhcPs) where addHaddock :: LHsDecl GhcPs -> HdkA (LHsDecl GhcPs) addHaddock LHsDecl GhcPs ldecl = SrcSpan -> HdkA (LHsDecl GhcPs) -> HdkA (LHsDecl GhcPs) forall a. SrcSpan -> HdkA a -> HdkA a extendHdkA (LHsDecl GhcPs -> SrcSpan forall l e. GenLocated l e -> l getLoc LHsDecl GhcPs ldecl) (HdkA (LHsDecl GhcPs) -> HdkA (LHsDecl GhcPs)) -> HdkA (LHsDecl GhcPs) -> HdkA (LHsDecl 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 HsDecl GhcPs -> HdkA (HsDecl GhcPs) forall a. HasHaddock a => a -> HdkA a addHaddock LHsDecl 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 _ [Located (IdP GhcPs)] names LHsSigWcType GhcPs t)) = do (Located RdrName -> HdkA ()) -> [Located RdrName] -> HdkA () forall (t :: * -> *) (f :: * -> *) a b. (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ Located RdrName -> HdkA () forall a. Located a -> HdkA () registerHdkA [Located RdrName] [Located (IdP GhcPs)] names LHsSigWcType GhcPs t' <- LHsSigWcType GhcPs -> HdkA (LHsSigWcType GhcPs) forall a. HasHaddock a => a -> HdkA a addHaddock LHsSigWcType GhcPs t pure (XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs forall p. XSigD p -> Sig p -> HsDecl p SigD NoExtField XSigD GhcPs noExtField (XTypeSig GhcPs -> [Located (IdP GhcPs)] -> LHsSigWcType GhcPs -> Sig GhcPs forall pass. XTypeSig pass -> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass TypeSig NoExtField XTypeSig GhcPs noExtField [Located (IdP GhcPs)] names LHsSigWcType 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 _ [Located (IdP GhcPs)] names LHsSigType GhcPs t)) = do (Located RdrName -> HdkA ()) -> [Located RdrName] -> HdkA () forall (t :: * -> *) (f :: * -> *) a b. (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ Located RdrName -> HdkA () forall a. Located a -> HdkA () registerHdkA [Located RdrName] [Located (IdP GhcPs)] names LHsSigType GhcPs t' <- LHsSigType GhcPs -> HdkA (LHsSigType GhcPs) forall a. HasHaddock a => a -> HdkA a addHaddock LHsSigType GhcPs t pure (XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs forall p. XSigD p -> Sig p -> HsDecl p SigD NoExtField XSigD GhcPs noExtField (XPatSynSig GhcPs -> [Located (IdP GhcPs)] -> LHsSigType GhcPs -> Sig GhcPs forall pass. XPatSynSig pass -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass PatSynSig NoExtField XPatSynSig GhcPs noExtField [Located (IdP GhcPs)] names LHsSigType 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 _ Bool is_dflt [Located (IdP GhcPs)] names LHsSigType GhcPs t)) = do (Located RdrName -> HdkA ()) -> [Located RdrName] -> HdkA () forall (t :: * -> *) (f :: * -> *) a b. (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ Located RdrName -> HdkA () forall a. Located a -> HdkA () registerHdkA [Located RdrName] [Located (IdP GhcPs)] names LHsSigType GhcPs t' <- LHsSigType GhcPs -> HdkA (LHsSigType GhcPs) forall a. HasHaddock a => a -> HdkA a addHaddock LHsSigType GhcPs t pure (XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs forall p. XSigD p -> Sig p -> HsDecl p SigD NoExtField XSigD GhcPs noExtField (XClassOpSig GhcPs -> Bool -> [Located (IdP GhcPs)] -> LHsSigType GhcPs -> Sig GhcPs forall pass. XClassOpSig pass -> Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass ClassOpSig NoExtField XClassOpSig GhcPs noExtField Bool is_dflt [Located (IdP GhcPs)] names LHsSigType 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 _ TyClDecl GhcPs decl) | DataDecl { Located (IdP GhcPs) tcdLName :: forall pass. TyClDecl pass -> Located (IdP pass) tcdLName :: Located (IdP 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, tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass tcdDataDefn = HsDataDefn GhcPs defn } <- TyClDecl GhcPs decl = do Located RdrName -> HdkA () forall a. Located a -> HdkA () registerHdkA Located RdrName Located (IdP GhcPs) 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 NoExtField XTyClD GhcPs noExtField (DataDecl :: forall pass. XDataDecl pass -> Located (IdP pass) -> LHsQTyVars pass -> LexicalFixity -> HsDataDefn pass -> TyClDecl pass DataDecl { tcdDExt :: XDataDecl GhcPs tcdDExt = NoExtField XDataDecl GhcPs noExtField, Located (IdP GhcPs) tcdLName :: Located (IdP GhcPs) tcdLName :: Located (IdP 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 = XClassDecl GhcPs tcdLayout, LHsContext GhcPs tcdCtxt :: forall pass. TyClDecl pass -> LHsContext pass tcdCtxt :: LHsContext GhcPs tcdCtxt, Located (IdP GhcPs) tcdLName :: Located (IdP GhcPs) tcdLName :: forall pass. TyClDecl pass -> Located (IdP 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, [LHsFunDep GhcPs] tcdFDs :: forall pass. TyClDecl pass -> [LHsFunDep pass] tcdFDs :: [LHsFunDep GhcPs] tcdFDs, [LSig GhcPs] tcdSigs :: forall pass. TyClDecl pass -> [LSig pass] tcdSigs :: [LSig GhcPs] tcdSigs, LHsBinds GhcPs tcdMeths :: forall pass. TyClDecl pass -> LHsBinds pass tcdMeths :: LHsBinds GhcPs tcdMeths, [LFamilyDecl GhcPs] tcdATs :: forall pass. TyClDecl pass -> [LFamilyDecl pass] tcdATs :: [LFamilyDecl GhcPs] tcdATs, [LTyFamDefltDecl GhcPs] tcdATDefs :: forall pass. TyClDecl pass -> [LTyFamDefltDecl pass] tcdATDefs :: [LTyFamDefltDecl GhcPs] tcdATDefs } <- TyClDecl GhcPs decl = do Located RdrName -> HdkA () forall a. Located a -> HdkA () registerHdkA Located RdrName Located (IdP GhcPs) tcdLName -- todo: register keyword location of 'where', see Note [Register keyword location] [LHsDecl GhcPs] where_cls' <- LayoutInfo -> (PsLocated HdkComment -> Maybe (LHsDecl GhcPs)) -> [LHsDecl GhcPs] -> HdkA [LHsDecl GhcPs] forall a. HasHaddock a => LayoutInfo -> (PsLocated HdkComment -> Maybe a) -> [a] -> HdkA [a] addHaddockInterleaveItems LayoutInfo XClassDecl GhcPs tcdLayout (LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) mkDocHsDecl LayoutInfo XClassDecl GhcPs tcdLayout) ([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]) -> [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] tcdDocs) = [LHsDecl GhcPs] -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamDefltDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) partitionBindsAndSigs [LHsDecl GhcPs] where_cls' decl' :: TyClDecl GhcPs decl' = ClassDecl :: forall pass. XClassDecl pass -> LHsContext pass -> Located (IdP pass) -> LHsQTyVars pass -> LexicalFixity -> [LHsFunDep pass] -> [LSig pass] -> LHsBinds pass -> [LFamilyDecl pass] -> [LTyFamDefltDecl pass] -> [LDocDecl] -> TyClDecl pass ClassDecl { tcdCExt :: XClassDecl GhcPs tcdCExt = XClassDecl GhcPs tcdLayout , LHsContext GhcPs tcdCtxt :: LHsContext GhcPs tcdCtxt :: LHsContext GhcPs tcdCtxt, Located (IdP GhcPs) tcdLName :: Located (IdP GhcPs) tcdLName :: Located (IdP 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] tcdDocs :: [LDocDecl] tcdDocs :: [LDocDecl] tcdDocs } in XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs forall p. XTyClD p -> TyClDecl p -> HsDecl p TyClD NoExtField XTyClD GhcPs 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 { DataFamInstDecl GhcPs dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass dfid_inst :: DataFamInstDecl GhcPs dfid_inst } <- InstDecl GhcPs decl , DataFamInstDecl { FamInstEqn GhcPs (HsDataDefn GhcPs) dfid_eqn :: forall pass. DataFamInstDecl pass -> FamInstEqn pass (HsDataDefn pass) dfid_eqn :: FamInstEqn GhcPs (HsDataDefn GhcPs) dfid_eqn } <- DataFamInstDecl GhcPs dfid_inst = do FamInstEqn GhcPs (HsDataDefn GhcPs) dfid_eqn' <- case FamInstEqn GhcPs (HsDataDefn GhcPs) dfid_eqn of HsIB XHsIB GhcPs (FamEqn GhcPs (HsDataDefn GhcPs)) _ (FamEqn { Located (IdP GhcPs) feqn_tycon :: forall pass rhs. FamEqn pass rhs -> Located (IdP pass) feqn_tycon :: Located (IdP GhcPs) feqn_tycon, Maybe [LHsTyVarBndr () GhcPs] feqn_bndrs :: forall pass rhs. FamEqn pass rhs -> Maybe [LHsTyVarBndr () pass] feqn_bndrs :: Maybe [LHsTyVarBndr () GhcPs] feqn_bndrs, HsTyPats GhcPs feqn_pats :: forall pass rhs. FamEqn pass rhs -> HsTyPats pass feqn_pats :: HsTyPats GhcPs feqn_pats, LexicalFixity feqn_fixity :: forall pass rhs. FamEqn pass rhs -> LexicalFixity feqn_fixity :: LexicalFixity feqn_fixity, HsDataDefn GhcPs feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs feqn_rhs :: HsDataDefn GhcPs feqn_rhs }) -> do Located RdrName -> HdkA () forall a. Located a -> HdkA () registerHdkA Located RdrName Located (IdP GhcPs) feqn_tycon HsDataDefn GhcPs feqn_rhs' <- HsDataDefn GhcPs -> HdkA (HsDataDefn GhcPs) forall a. HasHaddock a => a -> HdkA a addHaddock HsDataDefn GhcPs feqn_rhs pure $ XHsIB GhcPs (FamEqn GhcPs (HsDataDefn GhcPs)) -> FamEqn GhcPs (HsDataDefn GhcPs) -> FamInstEqn GhcPs (HsDataDefn GhcPs) forall pass thing. XHsIB pass thing -> thing -> HsImplicitBndrs pass thing HsIB NoExtField XHsIB GhcPs (FamEqn GhcPs (HsDataDefn GhcPs)) noExtField (FamEqn :: forall pass rhs. XCFamEqn pass rhs -> Located (IdP pass) -> Maybe [LHsTyVarBndr () pass] -> HsTyPats pass -> LexicalFixity -> rhs -> FamEqn pass rhs FamEqn { feqn_ext :: XCFamEqn GhcPs (HsDataDefn GhcPs) feqn_ext = NoExtField XCFamEqn GhcPs (HsDataDefn GhcPs) noExtField, Located (IdP GhcPs) feqn_tycon :: Located (IdP GhcPs) feqn_tycon :: Located (IdP GhcPs) feqn_tycon, Maybe [LHsTyVarBndr () GhcPs] feqn_bndrs :: Maybe [LHsTyVarBndr () GhcPs] feqn_bndrs :: Maybe [LHsTyVarBndr () GhcPs] feqn_bndrs, HsTyPats GhcPs feqn_pats :: HsTyPats GhcPs feqn_pats :: HsTyPats 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 NoExtField XInstD GhcPs noExtField (DataFamInstD :: forall pass. XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass DataFamInstD { dfid_ext :: XDataFamInstD GhcPs dfid_ext = NoExtField XDataFamInstD GhcPs noExtField, dfid_inst :: DataFamInstDecl GhcPs dfid_inst = DataFamInstDecl :: forall pass. FamInstEqn pass (HsDataDefn pass) -> DataFamInstDecl pass DataFamInstDecl { dfid_eqn :: FamInstEqn GhcPs (HsDataDefn GhcPs) dfid_eqn = FamInstEqn GhcPs (HsDataDefn GhcPs) dfid_eqn' } }) -- Type synonyms: -- -- type T = Int -- ^ Comment on Int -- addHaddock (TyClD XTyClD GhcPs _ TyClDecl GhcPs decl) | SynDecl { Located (IdP GhcPs) tcdLName :: Located (IdP GhcPs) tcdLName :: forall pass. TyClDecl pass -> Located (IdP 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, LHsType GhcPs tcdRhs :: forall pass. TyClDecl pass -> LHsType pass tcdRhs :: LHsType GhcPs tcdRhs } <- TyClDecl GhcPs decl = do Located RdrName -> HdkA () forall a. Located a -> HdkA () registerHdkA Located RdrName Located (IdP GhcPs) tcdLName -- todo: register keyword location of '=', see Note [Register keyword location] LHsType GhcPs tcdRhs' <- LHsType GhcPs -> HdkA (LHsType GhcPs) forall a. HasHaddock a => a -> HdkA a addHaddock LHsType GhcPs tcdRhs pure $ XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs forall p. XTyClD p -> TyClDecl p -> HsDecl p TyClD NoExtField XTyClD GhcPs noExtField (SynDecl :: forall pass. XSynDecl pass -> Located (IdP pass) -> LHsQTyVars pass -> LexicalFixity -> LHsType pass -> TyClDecl pass SynDecl { tcdSExt :: XSynDecl GhcPs tcdSExt = NoExtField XSynDecl GhcPs noExtField, Located (IdP GhcPs) tcdLName :: Located (IdP GhcPs) tcdLName :: Located (IdP GhcPs) tcdLName, LHsQTyVars GhcPs tcdTyVars :: LHsQTyVars GhcPs tcdTyVars :: LHsQTyVars GhcPs tcdTyVars, LexicalFixity tcdFixity :: LexicalFixity tcdFixity :: LexicalFixity tcdFixity, tcdRhs :: LHsType GhcPs tcdRhs = LHsType 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 Located RdrName -> HdkA () forall a. Located a -> HdkA () registerHdkA (ForeignDecl GhcPs -> Located (IdP GhcPs) forall pass. ForeignDecl pass -> Located (IdP pass) fd_name ForeignDecl GhcPs decl) LHsSigType GhcPs fd_sig_ty' <- LHsSigType GhcPs -> HdkA (LHsSigType 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 NoExtField XForD GhcPs noExtField (ForeignDecl GhcPs decl{ fd_sig_ty :: LHsSigType GhcPs fd_sig_ty = LHsSigType GhcPs fd_sig_ty' }) -- Other declarations addHaddock HsDecl GhcPs d = HsDecl GhcPs -> HdkA (HsDecl GhcPs) 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 LHsType GhcPs -> HdkA () forall a. Located a -> 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 -- [LConDecl GhcPs] dd_cons' <- [LConDecl GhcPs] -> HdkA [LConDecl GhcPs] forall a. HasHaddock a => a -> HdkA a addHaddock (HsDataDefn GhcPs -> [LConDecl GhcPs] forall pass. HsDataDefn pass -> [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 -}) -- HsDeriving GhcPs dd_derivs' <- HsDeriving GhcPs -> HdkA (HsDeriving 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 :: [LConDecl GhcPs] dd_cons = [LConDecl GhcPs] dd_cons', dd_derivs :: HsDeriving GhcPs dd_derivs = HsDeriving GhcPs dd_derivs' } -- Process the deriving clauses of a data/newtype declaration. -- Not used for standalone deriving. instance HasHaddock (HsDeriving GhcPs) where addHaddock :: HsDeriving GhcPs -> HdkA (HsDeriving GhcPs) addHaddock HsDeriving GhcPs lderivs = SrcSpan -> HdkA (HsDeriving GhcPs) -> HdkA (HsDeriving GhcPs) forall a. SrcSpan -> HdkA a -> HdkA a extendHdkA (HsDeriving GhcPs -> SrcSpan forall l e. GenLocated l e -> l getLoc HsDeriving GhcPs lderivs) (HdkA (HsDeriving GhcPs) -> HdkA (HsDeriving GhcPs)) -> HdkA (HsDeriving GhcPs) -> HdkA (HsDeriving 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 [LHsDerivingClause GhcPs] -> HdkA [LHsDerivingClause GhcPs] forall a. HasHaddock a => a -> HdkA a addHaddock HsDeriving 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 (LHsDerivingClause GhcPs) where addHaddock :: LHsDerivingClause GhcPs -> HdkA (LHsDerivingClause GhcPs) addHaddock LHsDerivingClause GhcPs lderiv = SrcSpan -> HdkA (LHsDerivingClause GhcPs) -> HdkA (LHsDerivingClause GhcPs) forall a. SrcSpan -> HdkA a -> HdkA a extendHdkA (LHsDerivingClause GhcPs -> SrcSpan forall l e. GenLocated l e -> l getLoc LHsDerivingClause GhcPs lderiv) (HdkA (LHsDerivingClause GhcPs) -> HdkA (LHsDerivingClause GhcPs)) -> HdkA (LHsDerivingClause GhcPs) -> HdkA (LHsDerivingClause 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 @Located LHsDerivingClause GhcPs lderiv ((HsDerivingClause GhcPs -> HdkA (HsDerivingClause GhcPs)) -> HdkA (LHsDerivingClause GhcPs)) -> (HsDerivingClause GhcPs -> HdkA (HsDerivingClause GhcPs)) -> HdkA (LHsDerivingClause GhcPs) forall a b. (a -> b) -> a -> b $ \HsDerivingClause GhcPs deriv -> case HsDerivingClause GhcPs deriv of HsDerivingClause { Maybe (LDerivStrategy GhcPs) deriv_clause_strategy :: forall pass. HsDerivingClause pass -> Maybe (LDerivStrategy pass) deriv_clause_strategy :: Maybe (LDerivStrategy GhcPs) deriv_clause_strategy, Located [LHsSigType GhcPs] deriv_clause_tys :: forall pass. HsDerivingClause pass -> Located [LHsSigType pass] deriv_clause_tys :: Located [LHsSigType GhcPs] 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 (f :: * -> *) a. Applicative f => a -> f a pure (), () -> HdkA () forall (f :: * -> *) a. Applicative f => a -> f a pure ()) Just (L SrcSpan l (ViaStrategy XViaStrategy GhcPs _)) -> (() -> HdkA () forall (f :: * -> *) a. Applicative f => a -> f a pure (), SrcSpan -> HdkA () registerLocHdkA SrcSpan l) Just (L SrcSpan l DerivStrategy GhcPs _) -> (SrcSpan -> HdkA () registerLocHdkA SrcSpan l, () -> HdkA () forall (f :: * -> *) a. Applicative f => a -> f a pure ()) HdkA () register_strategy_before Located [LHsSigType GhcPs] deriv_clause_tys' <- SrcSpan -> HdkA (Located [LHsSigType GhcPs]) -> HdkA (Located [LHsSigType GhcPs]) forall a. SrcSpan -> HdkA a -> HdkA a extendHdkA (Located [LHsSigType GhcPs] -> SrcSpan forall l e. GenLocated l e -> l getLoc Located [LHsSigType GhcPs] deriv_clause_tys) (HdkA (Located [LHsSigType GhcPs]) -> HdkA (Located [LHsSigType GhcPs])) -> HdkA (Located [LHsSigType GhcPs]) -> HdkA (Located [LHsSigType 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 [LHsSigType GhcPs] -> HdkA [LHsSigType GhcPs] forall a. HasHaddock a => a -> HdkA a addHaddock Located [LHsSigType GhcPs] deriv_clause_tys HdkA () register_strategy_after pure HsDerivingClause :: forall pass. XCHsDerivingClause pass -> Maybe (LDerivStrategy pass) -> Located [LHsSigType pass] -> HsDerivingClause pass HsDerivingClause { deriv_clause_ext :: XCHsDerivingClause GhcPs deriv_clause_ext = NoExtField XCHsDerivingClause GhcPs noExtField, Maybe (LDerivStrategy GhcPs) deriv_clause_strategy :: Maybe (LDerivStrategy GhcPs) deriv_clause_strategy :: Maybe (LDerivStrategy GhcPs) deriv_clause_strategy, deriv_clause_tys :: Located [LHsSigType GhcPs] deriv_clause_tys = Located [LHsSigType GhcPs] deriv_clause_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 (LConDecl GhcPs) where addHaddock :: LConDecl GhcPs -> HdkA (LConDecl GhcPs) addHaddock (L SrcSpan l_con_decl ConDecl GhcPs con_decl) = SrcSpan -> HdkA (LConDecl GhcPs) -> HdkA (LConDecl GhcPs) forall a. SrcSpan -> HdkA a -> HdkA a extendHdkA SrcSpan l_con_decl (HdkA (LConDecl GhcPs) -> HdkA (LConDecl GhcPs)) -> HdkA (LConDecl GhcPs) -> HdkA (LConDecl GhcPs) forall a b. (a -> b) -> a -> b $ case ConDecl GhcPs con_decl of ConDeclGADT { XConDeclGADT GhcPs con_g_ext :: forall pass. ConDecl pass -> XConDeclGADT pass con_g_ext :: XConDeclGADT GhcPs con_g_ext, [Located (IdP GhcPs)] con_names :: forall pass. ConDecl pass -> [Located (IdP pass)] con_names :: [Located (IdP GhcPs)] con_names, Located Bool con_forall :: forall pass. ConDecl pass -> Located Bool con_forall :: Located Bool con_forall, [LHsTyVarBndr Specificity GhcPs] con_qvars :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass] con_qvars :: [LHsTyVarBndr Specificity GhcPs] con_qvars, Maybe (LHsContext GhcPs) con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass) con_mb_cxt :: Maybe (LHsContext GhcPs) con_mb_cxt, HsConDeclDetails GhcPs con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass con_args :: HsConDeclDetails GhcPs con_args, LHsType GhcPs con_res_ty :: forall pass. ConDecl pass -> LHsType pass con_res_ty :: LHsType GhcPs con_res_ty } -> do -- discardHasInnerDocs is ok because we don't need this info for GADTs. Maybe (GenLocated SrcSpan HsDocString) con_doc' <- ConHdkA (Maybe (GenLocated SrcSpan HsDocString)) -> HdkA (Maybe (GenLocated SrcSpan HsDocString)) forall a. ConHdkA a -> HdkA a discardHasInnerDocs (ConHdkA (Maybe (GenLocated SrcSpan HsDocString)) -> HdkA (Maybe (GenLocated SrcSpan HsDocString))) -> ConHdkA (Maybe (GenLocated SrcSpan HsDocString)) -> HdkA (Maybe (GenLocated SrcSpan HsDocString)) forall a b. (a -> b) -> a -> b $ SrcSpan -> ConHdkA (Maybe (GenLocated SrcSpan HsDocString)) getConDoc (Located RdrName -> SrcSpan forall l e. GenLocated l e -> l getLoc ([Located RdrName] -> Located RdrName forall a. [a] -> a head [Located RdrName] [Located (IdP GhcPs)] con_names)) HsConDeclDetails GhcPs con_args' <- case HsConDeclDetails GhcPs con_args of PrefixCon [HsScaled GhcPs (LHsType GhcPs)] ts -> [HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclDetails GhcPs forall arg rec. [arg] -> HsConDetails arg rec PrefixCon ([HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclDetails GhcPs) -> HdkA [HsScaled GhcPs (LHsType GhcPs)] -> HdkA (HsConDeclDetails GhcPs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [HsScaled GhcPs (LHsType GhcPs)] -> HdkA [HsScaled GhcPs (LHsType GhcPs)] forall a. HasHaddock a => a -> HdkA a addHaddock [HsScaled GhcPs (LHsType GhcPs)] ts RecCon (L SrcSpan l_rec [LConDeclField GhcPs] flds) -> do -- discardHasInnerDocs is ok because we don't need this info for GADTs. [LConDeclField GhcPs] flds' <- (LConDeclField GhcPs -> HdkA (LConDeclField GhcPs)) -> [LConDeclField GhcPs] -> HdkA [LConDeclField GhcPs] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (ConHdkA (LConDeclField GhcPs) -> HdkA (LConDeclField GhcPs) forall a. ConHdkA a -> HdkA a discardHasInnerDocs (ConHdkA (LConDeclField GhcPs) -> HdkA (LConDeclField GhcPs)) -> (LConDeclField GhcPs -> ConHdkA (LConDeclField GhcPs)) -> LConDeclField GhcPs -> HdkA (LConDeclField GhcPs) forall b c a. (b -> c) -> (a -> b) -> a -> c . LConDeclField GhcPs -> ConHdkA (LConDeclField GhcPs) addHaddockConDeclField) [LConDeclField GhcPs] flds pure $ GenLocated SrcSpan [LConDeclField GhcPs] -> HsConDeclDetails GhcPs forall arg rec. rec -> HsConDetails arg rec RecCon (SrcSpan -> [LConDeclField GhcPs] -> GenLocated SrcSpan [LConDeclField GhcPs] forall l e. l -> e -> GenLocated l e L SrcSpan l_rec [LConDeclField GhcPs] flds') InfixCon HsScaled GhcPs (LHsType GhcPs) _ HsScaled GhcPs (LHsType GhcPs) _ -> String -> HdkA (HsConDeclDetails GhcPs) forall a. String -> a panic String "ConDeclGADT InfixCon" LHsType GhcPs con_res_ty' <- LHsType GhcPs -> HdkA (LHsType GhcPs) forall a. HasHaddock a => a -> HdkA a addHaddock LHsType GhcPs con_res_ty pure $ SrcSpan -> ConDecl GhcPs -> LConDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l_con_decl (ConDecl GhcPs -> LConDecl GhcPs) -> ConDecl GhcPs -> LConDecl GhcPs forall a b. (a -> b) -> a -> b $ ConDeclGADT :: forall pass. XConDeclGADT pass -> [Located (IdP pass)] -> Located Bool -> [LHsTyVarBndr Specificity pass] -> Maybe (LHsContext pass) -> HsConDeclDetails pass -> LHsType pass -> Maybe (GenLocated SrcSpan HsDocString) -> ConDecl pass ConDeclGADT { XConDeclGADT GhcPs con_g_ext :: XConDeclGADT GhcPs con_g_ext :: XConDeclGADT GhcPs con_g_ext, [Located (IdP GhcPs)] con_names :: [Located (IdP GhcPs)] con_names :: [Located (IdP GhcPs)] con_names, Located Bool con_forall :: Located Bool con_forall :: Located Bool con_forall, [LHsTyVarBndr Specificity GhcPs] con_qvars :: [LHsTyVarBndr Specificity GhcPs] con_qvars :: [LHsTyVarBndr Specificity GhcPs] con_qvars, Maybe (LHsContext GhcPs) con_mb_cxt :: Maybe (LHsContext GhcPs) con_mb_cxt :: Maybe (LHsContext GhcPs) con_mb_cxt, con_doc :: Maybe (GenLocated SrcSpan HsDocString) con_doc = Maybe (GenLocated SrcSpan HsDocString) con_doc', con_args :: HsConDeclDetails GhcPs con_args = HsConDeclDetails GhcPs con_args', con_res_ty :: LHsType GhcPs con_res_ty = LHsType GhcPs con_res_ty' } ConDeclH98 { XConDeclH98 GhcPs con_ext :: forall pass. ConDecl pass -> XConDeclH98 pass con_ext :: XConDeclH98 GhcPs con_ext, Located (IdP GhcPs) con_name :: forall pass. ConDecl pass -> Located (IdP pass) con_name :: Located (IdP GhcPs) con_name, Located Bool con_forall :: Located Bool con_forall :: forall pass. ConDecl pass -> Located Bool con_forall, [LHsTyVarBndr Specificity GhcPs] con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr Specificity pass] con_ex_tvs :: [LHsTyVarBndr Specificity GhcPs] con_ex_tvs, Maybe (LHsContext GhcPs) con_mb_cxt :: Maybe (LHsContext GhcPs) con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass) con_mb_cxt, HsConDeclDetails GhcPs con_args :: HsConDeclDetails GhcPs con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass con_args } -> SrcLoc -> ConHdkA (LConDecl GhcPs) -> HdkA (LConDecl GhcPs) addConTrailingDoc (SrcSpan -> SrcLoc srcSpanEnd SrcSpan l_con_decl) (ConHdkA (LConDecl GhcPs) -> HdkA (LConDecl GhcPs)) -> ConHdkA (LConDecl GhcPs) -> HdkA (LConDecl GhcPs) forall a b. (a -> b) -> a -> b $ case HsConDeclDetails GhcPs con_args of PrefixCon [HsScaled GhcPs (LHsType GhcPs)] ts -> do Maybe (GenLocated SrcSpan HsDocString) con_doc' <- SrcSpan -> ConHdkA (Maybe (GenLocated SrcSpan HsDocString)) getConDoc (Located RdrName -> SrcSpan forall l e. GenLocated l e -> l getLoc Located RdrName Located (IdP GhcPs) con_name) [HsScaled GhcPs (LHsType GhcPs)] ts' <- (HsScaled GhcPs (LHsType GhcPs) -> WriterT HasInnerDocs HdkA (HsScaled GhcPs (LHsType GhcPs))) -> [HsScaled GhcPs (LHsType GhcPs)] -> WriterT HasInnerDocs HdkA [HsScaled GhcPs (LHsType GhcPs)] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse HsScaled GhcPs (LHsType GhcPs) -> WriterT HasInnerDocs HdkA (HsScaled GhcPs (LHsType GhcPs)) addHaddockConDeclFieldTy [HsScaled GhcPs (LHsType GhcPs)] ts pure $ SrcSpan -> ConDecl GhcPs -> LConDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l_con_decl (ConDecl GhcPs -> LConDecl GhcPs) -> ConDecl GhcPs -> LConDecl GhcPs forall a b. (a -> b) -> a -> b $ ConDeclH98 :: forall pass. XConDeclH98 pass -> Located (IdP pass) -> Located Bool -> [LHsTyVarBndr Specificity pass] -> Maybe (LHsContext pass) -> HsConDeclDetails pass -> Maybe (GenLocated SrcSpan HsDocString) -> ConDecl pass ConDeclH98 { XConDeclH98 GhcPs con_ext :: XConDeclH98 GhcPs con_ext :: XConDeclH98 GhcPs con_ext, Located (IdP GhcPs) con_name :: Located (IdP GhcPs) con_name :: Located (IdP GhcPs) con_name, Located Bool con_forall :: Located Bool con_forall :: Located 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 (GenLocated SrcSpan HsDocString) con_doc = Maybe (GenLocated SrcSpan HsDocString) con_doc', con_args :: HsConDeclDetails GhcPs con_args = [HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclDetails GhcPs forall arg rec. [arg] -> HsConDetails arg rec PrefixCon [HsScaled GhcPs (LHsType GhcPs)] ts' } InfixCon HsScaled GhcPs (LHsType GhcPs) t1 HsScaled GhcPs (LHsType GhcPs) t2 -> do HsScaled GhcPs (LHsType GhcPs) t1' <- HsScaled GhcPs (LHsType GhcPs) -> WriterT HasInnerDocs HdkA (HsScaled GhcPs (LHsType GhcPs)) addHaddockConDeclFieldTy HsScaled GhcPs (LHsType GhcPs) t1 Maybe (GenLocated SrcSpan HsDocString) con_doc' <- SrcSpan -> ConHdkA (Maybe (GenLocated SrcSpan HsDocString)) getConDoc (Located RdrName -> SrcSpan forall l e. GenLocated l e -> l getLoc Located RdrName Located (IdP GhcPs) con_name) HsScaled GhcPs (LHsType GhcPs) t2' <- HsScaled GhcPs (LHsType GhcPs) -> WriterT HasInnerDocs HdkA (HsScaled GhcPs (LHsType GhcPs)) addHaddockConDeclFieldTy HsScaled GhcPs (LHsType GhcPs) t2 pure $ SrcSpan -> ConDecl GhcPs -> LConDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l_con_decl (ConDecl GhcPs -> LConDecl GhcPs) -> ConDecl GhcPs -> LConDecl GhcPs forall a b. (a -> b) -> a -> b $ ConDeclH98 :: forall pass. XConDeclH98 pass -> Located (IdP pass) -> Located Bool -> [LHsTyVarBndr Specificity pass] -> Maybe (LHsContext pass) -> HsConDeclDetails pass -> Maybe (GenLocated SrcSpan HsDocString) -> ConDecl pass ConDeclH98 { XConDeclH98 GhcPs con_ext :: XConDeclH98 GhcPs con_ext :: XConDeclH98 GhcPs con_ext, Located (IdP GhcPs) con_name :: Located (IdP GhcPs) con_name :: Located (IdP GhcPs) con_name, Located Bool con_forall :: Located Bool con_forall :: Located 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 (GenLocated SrcSpan HsDocString) con_doc = Maybe (GenLocated SrcSpan HsDocString) con_doc', con_args :: HsConDeclDetails GhcPs con_args = HsScaled GhcPs (LHsType GhcPs) -> HsScaled GhcPs (LHsType GhcPs) -> HsConDeclDetails GhcPs forall arg rec. arg -> arg -> HsConDetails arg rec InfixCon HsScaled GhcPs (LHsType GhcPs) t1' HsScaled GhcPs (LHsType GhcPs) t2' } RecCon (L SrcSpan l_rec [LConDeclField GhcPs] flds) -> do Maybe (GenLocated SrcSpan HsDocString) con_doc' <- SrcSpan -> ConHdkA (Maybe (GenLocated SrcSpan HsDocString)) getConDoc (Located RdrName -> SrcSpan forall l e. GenLocated l e -> l getLoc Located RdrName Located (IdP GhcPs) con_name) [LConDeclField GhcPs] flds' <- (LConDeclField GhcPs -> ConHdkA (LConDeclField GhcPs)) -> [LConDeclField GhcPs] -> WriterT HasInnerDocs HdkA [LConDeclField GhcPs] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse LConDeclField GhcPs -> ConHdkA (LConDeclField GhcPs) addHaddockConDeclField [LConDeclField GhcPs] flds pure $ SrcSpan -> ConDecl GhcPs -> LConDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l_con_decl (ConDecl GhcPs -> LConDecl GhcPs) -> ConDecl GhcPs -> LConDecl GhcPs forall a b. (a -> b) -> a -> b $ ConDeclH98 :: forall pass. XConDeclH98 pass -> Located (IdP pass) -> Located Bool -> [LHsTyVarBndr Specificity pass] -> Maybe (LHsContext pass) -> HsConDeclDetails pass -> Maybe (GenLocated SrcSpan HsDocString) -> ConDecl pass ConDeclH98 { XConDeclH98 GhcPs con_ext :: XConDeclH98 GhcPs con_ext :: XConDeclH98 GhcPs con_ext, Located (IdP GhcPs) con_name :: Located (IdP GhcPs) con_name :: Located (IdP GhcPs) con_name, Located Bool con_forall :: Located Bool con_forall :: Located 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 (GenLocated SrcSpan HsDocString) con_doc = Maybe (GenLocated SrcSpan HsDocString) con_doc', con_args :: HsConDeclDetails GhcPs con_args = GenLocated SrcSpan [LConDeclField GhcPs] -> HsConDeclDetails GhcPs forall arg rec. rec -> HsConDetails arg rec RecCon (SrcSpan -> [LConDeclField GhcPs] -> GenLocated SrcSpan [LConDeclField GhcPs] forall l e. l -> e -> GenLocated l e L SrcSpan l_rec [LConDeclField GhcPs] flds') } -- Keep track of documentation comments on the data constructor or any of its -- fields. -- -- See Note [Trailing comment on constructor declaration] type ConHdkA = WriterT HasInnerDocs HdkA -- Does the data constructor declaration have any inner (non-trailing) -- documentation comments? -- -- Example when HasInnerDocs is True: -- -- data X = -- MkX -- ^ inner comment -- Field1 -- ^ inner comment -- Field2 -- ^ inner comment -- Field3 -- ^ trailing comment -- -- Example when HasInnerDocs is False: -- -- data Y = MkY Field1 Field2 Field3 -- ^ trailing comment -- -- See Note [Trailing comment on constructor declaration] newtype HasInnerDocs = HasInnerDocs Bool deriving (NonEmpty HasInnerDocs -> HasInnerDocs HasInnerDocs -> HasInnerDocs -> HasInnerDocs (HasInnerDocs -> HasInnerDocs -> HasInnerDocs) -> (NonEmpty HasInnerDocs -> HasInnerDocs) -> (forall b. Integral b => b -> HasInnerDocs -> HasInnerDocs) -> Semigroup HasInnerDocs forall b. Integral b => b -> HasInnerDocs -> HasInnerDocs forall a. (a -> a -> a) -> (NonEmpty a -> a) -> (forall b. Integral b => b -> a -> a) -> Semigroup a stimes :: forall b. Integral b => b -> HasInnerDocs -> HasInnerDocs $cstimes :: forall b. Integral b => b -> HasInnerDocs -> HasInnerDocs sconcat :: NonEmpty HasInnerDocs -> HasInnerDocs $csconcat :: NonEmpty HasInnerDocs -> HasInnerDocs <> :: HasInnerDocs -> HasInnerDocs -> HasInnerDocs $c<> :: HasInnerDocs -> HasInnerDocs -> HasInnerDocs Semigroup, Semigroup HasInnerDocs HasInnerDocs Semigroup HasInnerDocs -> HasInnerDocs -> (HasInnerDocs -> HasInnerDocs -> HasInnerDocs) -> ([HasInnerDocs] -> HasInnerDocs) -> Monoid HasInnerDocs [HasInnerDocs] -> HasInnerDocs HasInnerDocs -> HasInnerDocs -> HasInnerDocs forall a. Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a mconcat :: [HasInnerDocs] -> HasInnerDocs $cmconcat :: [HasInnerDocs] -> HasInnerDocs mappend :: HasInnerDocs -> HasInnerDocs -> HasInnerDocs $cmappend :: HasInnerDocs -> HasInnerDocs -> HasInnerDocs mempty :: HasInnerDocs $cmempty :: HasInnerDocs Monoid) via Data.Monoid.Any -- Run ConHdkA by discarding the HasInnerDocs info when we have no use for it. -- -- We only do this when processing data declarations that use GADT syntax, -- because only the H98 syntax declarations have special treatment for the -- trailing documentation comment. -- -- See Note [Trailing comment on constructor declaration] discardHasInnerDocs :: ConHdkA a -> HdkA a discardHasInnerDocs :: forall a. ConHdkA a -> HdkA a discardHasInnerDocs = ((a, HasInnerDocs) -> a) -> HdkA (a, HasInnerDocs) -> HdkA a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (a, HasInnerDocs) -> a forall a b. (a, b) -> a fst (HdkA (a, HasInnerDocs) -> HdkA a) -> (WriterT HasInnerDocs HdkA a -> HdkA (a, HasInnerDocs)) -> WriterT HasInnerDocs HdkA a -> HdkA a forall b c a. (b -> c) -> (a -> b) -> a -> c . WriterT HasInnerDocs HdkA a -> HdkA (a, HasInnerDocs) forall w (m :: * -> *) a. WriterT w m a -> m (a, w) runWriterT -- Get the documentation comment associated with the data constructor in a -- data/newtype declaration. getConDoc :: SrcSpan -- Location of the data constructor -> ConHdkA (Maybe LHsDocString) getConDoc :: SrcSpan -> ConHdkA (Maybe (GenLocated SrcSpan HsDocString)) getConDoc SrcSpan l = HdkA (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs) -> ConHdkA (Maybe (GenLocated SrcSpan HsDocString)) forall w (m :: * -> *) a. m (a, w) -> WriterT w m a WriterT (HdkA (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs) -> ConHdkA (Maybe (GenLocated SrcSpan HsDocString))) -> HdkA (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs) -> ConHdkA (Maybe (GenLocated SrcSpan HsDocString)) forall a b. (a -> b) -> a -> b $ SrcSpan -> HdkA (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs) -> HdkA (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs) forall a. SrcSpan -> HdkA a -> HdkA a extendHdkA SrcSpan l (HdkA (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs) -> HdkA (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs)) -> HdkA (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs) -> HdkA (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs) forall a b. (a -> b) -> a -> b $ HdkM (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs) -> HdkA (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs) forall a. HdkM a -> HdkA a liftHdkA (HdkM (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs) -> HdkA (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs)) -> HdkM (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs) -> HdkA (Maybe (GenLocated SrcSpan HsDocString), HasInnerDocs) forall a b. (a -> b) -> a -> b $ do Maybe (GenLocated SrcSpan HsDocString) mDoc <- SrcSpan -> HdkM (Maybe (GenLocated SrcSpan HsDocString)) getPrevNextDoc SrcSpan l return (Maybe (GenLocated SrcSpan HsDocString) mDoc, Bool -> HasInnerDocs HasInnerDocs (Maybe (GenLocated SrcSpan HsDocString) -> Bool forall a. Maybe a -> Bool isJust Maybe (GenLocated SrcSpan HsDocString) mDoc)) -- Add documentation comment to a data constructor field. -- Used for PrefixCon and InfixCon. addHaddockConDeclFieldTy :: HsScaled GhcPs (LHsType GhcPs) -> ConHdkA (HsScaled GhcPs (LHsType GhcPs)) addHaddockConDeclFieldTy :: HsScaled GhcPs (LHsType GhcPs) -> WriterT HasInnerDocs HdkA (HsScaled GhcPs (LHsType GhcPs)) addHaddockConDeclFieldTy (HsScaled HsArrow GhcPs mult (L SrcSpan l HsType GhcPs t)) = HdkA (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs) -> WriterT HasInnerDocs HdkA (HsScaled GhcPs (LHsType GhcPs)) forall w (m :: * -> *) a. m (a, w) -> WriterT w m a WriterT (HdkA (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs) -> WriterT HasInnerDocs HdkA (HsScaled GhcPs (LHsType GhcPs))) -> HdkA (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs) -> WriterT HasInnerDocs HdkA (HsScaled GhcPs (LHsType GhcPs)) forall a b. (a -> b) -> a -> b $ SrcSpan -> HdkA (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs) -> HdkA (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs) forall a. SrcSpan -> HdkA a -> HdkA a extendHdkA SrcSpan l (HdkA (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs) -> HdkA (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs)) -> HdkA (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs) -> HdkA (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs) forall a b. (a -> b) -> a -> b $ HdkM (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs) -> HdkA (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs) forall a. HdkM a -> HdkA a liftHdkA (HdkM (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs) -> HdkA (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs)) -> HdkM (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs) -> HdkA (HsScaled GhcPs (LHsType GhcPs), HasInnerDocs) forall a b. (a -> b) -> a -> b $ do Maybe (GenLocated SrcSpan HsDocString) mDoc <- SrcSpan -> HdkM (Maybe (GenLocated SrcSpan HsDocString)) getPrevNextDoc SrcSpan l return (HsArrow GhcPs -> LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs) forall pass a. HsArrow pass -> a -> HsScaled pass a HsScaled HsArrow GhcPs mult (LHsType GhcPs -> Maybe (GenLocated SrcSpan HsDocString) -> LHsType GhcPs mkLHsDocTy (SrcSpan -> HsType GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l HsType GhcPs t) Maybe (GenLocated SrcSpan HsDocString) mDoc), Bool -> HasInnerDocs HasInnerDocs (Maybe (GenLocated SrcSpan HsDocString) -> Bool forall a. Maybe a -> Bool isJust Maybe (GenLocated SrcSpan HsDocString) mDoc)) -- Add documentation comment to a data constructor field. -- Used for RecCon. addHaddockConDeclField :: LConDeclField GhcPs -> ConHdkA (LConDeclField GhcPs) addHaddockConDeclField :: LConDeclField GhcPs -> ConHdkA (LConDeclField GhcPs) addHaddockConDeclField (L SrcSpan l_fld ConDeclField GhcPs fld) = HdkA (LConDeclField GhcPs, HasInnerDocs) -> ConHdkA (LConDeclField GhcPs) forall w (m :: * -> *) a. m (a, w) -> WriterT w m a WriterT (HdkA (LConDeclField GhcPs, HasInnerDocs) -> ConHdkA (LConDeclField GhcPs)) -> HdkA (LConDeclField GhcPs, HasInnerDocs) -> ConHdkA (LConDeclField GhcPs) forall a b. (a -> b) -> a -> b $ SrcSpan -> HdkA (LConDeclField GhcPs, HasInnerDocs) -> HdkA (LConDeclField GhcPs, HasInnerDocs) forall a. SrcSpan -> HdkA a -> HdkA a extendHdkA SrcSpan l_fld (HdkA (LConDeclField GhcPs, HasInnerDocs) -> HdkA (LConDeclField GhcPs, HasInnerDocs)) -> HdkA (LConDeclField GhcPs, HasInnerDocs) -> HdkA (LConDeclField GhcPs, HasInnerDocs) forall a b. (a -> b) -> a -> b $ HdkM (LConDeclField GhcPs, HasInnerDocs) -> HdkA (LConDeclField GhcPs, HasInnerDocs) forall a. HdkM a -> HdkA a liftHdkA (HdkM (LConDeclField GhcPs, HasInnerDocs) -> HdkA (LConDeclField GhcPs, HasInnerDocs)) -> HdkM (LConDeclField GhcPs, HasInnerDocs) -> HdkA (LConDeclField GhcPs, HasInnerDocs) forall a b. (a -> b) -> a -> b $ do Maybe (GenLocated SrcSpan HsDocString) cd_fld_doc <- SrcSpan -> HdkM (Maybe (GenLocated SrcSpan HsDocString)) getPrevNextDoc SrcSpan l_fld return (SrcSpan -> ConDeclField GhcPs -> LConDeclField GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l_fld (ConDeclField GhcPs fld { Maybe (GenLocated SrcSpan HsDocString) cd_fld_doc :: Maybe (GenLocated SrcSpan HsDocString) cd_fld_doc :: Maybe (GenLocated SrcSpan HsDocString) cd_fld_doc }), Bool -> HasInnerDocs HasInnerDocs (Maybe (GenLocated SrcSpan HsDocString) -> Bool forall a. Maybe a -> Bool isJust Maybe (GenLocated SrcSpan HsDocString) cd_fld_doc)) -- 1. Process a H98-syntax data constructor declaration in a context with no -- access to the trailing documentation comment (by running the provided -- ConHdkA computation). -- -- 2. Then grab the trailing comment (if it exists) and attach it where -- appropriate: either to the data constructor itself or to its last field, -- depending on HasInnerDocs. -- -- See Note [Trailing comment on constructor declaration] addConTrailingDoc :: SrcLoc -- The end of a data constructor declaration. -- Any docprev comment past this point is considered trailing. -> ConHdkA (LConDecl GhcPs) -> HdkA (LConDecl GhcPs) addConTrailingDoc :: SrcLoc -> ConHdkA (LConDecl GhcPs) -> HdkA (LConDecl GhcPs) addConTrailingDoc SrcLoc l_sep = (HdkM (LConDecl GhcPs, HasInnerDocs) -> HdkM (LConDecl GhcPs)) -> HdkA (LConDecl GhcPs, HasInnerDocs) -> HdkA (LConDecl GhcPs) forall a b. (HdkM a -> HdkM b) -> HdkA a -> HdkA b hoistHdkA HdkM (LConDecl GhcPs, HasInnerDocs) -> HdkM (LConDecl GhcPs) add_trailing_doc (HdkA (LConDecl GhcPs, HasInnerDocs) -> HdkA (LConDecl GhcPs)) -> (ConHdkA (LConDecl GhcPs) -> HdkA (LConDecl GhcPs, HasInnerDocs)) -> ConHdkA (LConDecl GhcPs) -> HdkA (LConDecl GhcPs) forall b c a. (b -> c) -> (a -> b) -> a -> c . ConHdkA (LConDecl GhcPs) -> HdkA (LConDecl GhcPs, HasInnerDocs) forall w (m :: * -> *) a. WriterT w m a -> m (a, w) runWriterT where add_trailing_doc :: HdkM (LConDecl GhcPs, HasInnerDocs) -> HdkM (LConDecl GhcPs) add_trailing_doc :: HdkM (LConDecl GhcPs, HasInnerDocs) -> HdkM (LConDecl GhcPs) add_trailing_doc HdkM (LConDecl GhcPs, HasInnerDocs) m = do (L SrcSpan l ConDecl GhcPs con_decl, HasInnerDocs Bool has_inner_docs) <- LocRange -> HdkM (LConDecl GhcPs, HasInnerDocs) -> HdkM (LConDecl GhcPs, HasInnerDocs) forall a. LocRange -> HdkM a -> HdkM a inLocRange (Maybe BufPos -> LocRange locRangeTo (SrcLoc -> Maybe BufPos getBufPos SrcLoc l_sep)) HdkM (LConDecl GhcPs, HasInnerDocs) m -- inLocRange delimits the context so that the inner computation -- will not consume the trailing documentation comment. case ConDecl GhcPs con_decl of ConDeclH98{} -> do [GenLocated SrcSpan HsDocString] trailingDocs <- 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 SrcLoc l_sep)) (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 if [GenLocated SrcSpan HsDocString] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [GenLocated SrcSpan HsDocString] trailingDocs then LConDecl GhcPs -> HdkM (LConDecl GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return (SrcSpan -> ConDecl GhcPs -> LConDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l ConDecl GhcPs con_decl) else do if Bool has_inner_docs then do let mk_doc_ty :: HsScaled GhcPs (LHsType GhcPs) -> HdkM (HsScaled GhcPs (LHsType GhcPs)) mk_doc_ty :: HsScaled GhcPs (LHsType GhcPs) -> HdkM (HsScaled GhcPs (LHsType GhcPs)) mk_doc_ty x :: HsScaled GhcPs (LHsType GhcPs) x@(HsScaled HsArrow GhcPs _ (L SrcSpan _ HsDocTy{})) = -- Happens in the following case: -- -- data T = -- MkT -- -- | Comment on SomeField -- SomeField -- -- ^ Another comment on SomeField? (rejected) -- -- See tests/.../haddockExtraDocs.hs HsScaled GhcPs (LHsType GhcPs) x HsScaled GhcPs (LHsType GhcPs) -> HdkM () -> HdkM (HsScaled GhcPs (LHsType GhcPs)) forall (f :: * -> *) a b. Functor f => a -> f b -> f a <$ [GenLocated SrcSpan HsDocString] -> HdkM () reportExtraDocs [GenLocated SrcSpan HsDocString] trailingDocs mk_doc_ty (HsScaled HsArrow GhcPs mult (L SrcSpan l' HsType GhcPs t)) = do Maybe (GenLocated SrcSpan HsDocString) doc <- [GenLocated SrcSpan HsDocString] -> HdkM (Maybe (GenLocated SrcSpan HsDocString)) selectDocString [GenLocated SrcSpan HsDocString] trailingDocs return $ HsArrow GhcPs -> LHsType GhcPs -> HsScaled GhcPs (LHsType GhcPs) forall pass a. HsArrow pass -> a -> HsScaled pass a HsScaled HsArrow GhcPs mult (LHsType GhcPs -> Maybe (GenLocated SrcSpan HsDocString) -> LHsType GhcPs mkLHsDocTy (SrcSpan -> HsType GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l' HsType GhcPs t) Maybe (GenLocated SrcSpan HsDocString) doc) let mk_doc_fld :: LConDeclField GhcPs -> HdkM (LConDeclField GhcPs) mk_doc_fld :: LConDeclField GhcPs -> HdkM (LConDeclField GhcPs) mk_doc_fld x :: LConDeclField GhcPs x@(L SrcSpan _ (ConDeclField { cd_fld_doc :: forall pass. ConDeclField pass -> Maybe (GenLocated SrcSpan HsDocString) cd_fld_doc = Just GenLocated SrcSpan HsDocString _ })) = -- Happens in the following case: -- -- data T = -- MkT { -- -- | Comment on SomeField -- someField :: SomeField -- } -- ^ Another comment on SomeField? (rejected) -- -- See tests/.../haddockExtraDocs.hs LConDeclField GhcPs x LConDeclField GhcPs -> HdkM () -> HdkM (LConDeclField GhcPs) forall (f :: * -> *) a b. Functor f => a -> f b -> f a <$ [GenLocated SrcSpan HsDocString] -> HdkM () reportExtraDocs [GenLocated SrcSpan HsDocString] trailingDocs mk_doc_fld (L SrcSpan l' ConDeclField GhcPs con_fld) = do Maybe (GenLocated SrcSpan HsDocString) doc <- [GenLocated SrcSpan HsDocString] -> HdkM (Maybe (GenLocated SrcSpan HsDocString)) selectDocString [GenLocated SrcSpan HsDocString] trailingDocs return $ SrcSpan -> ConDeclField GhcPs -> LConDeclField GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l' (ConDeclField GhcPs con_fld { cd_fld_doc :: Maybe (GenLocated SrcSpan HsDocString) cd_fld_doc = Maybe (GenLocated SrcSpan HsDocString) doc }) HsConDeclDetails GhcPs con_args' <- case ConDecl GhcPs -> HsConDeclDetails GhcPs forall pass. ConDecl pass -> HsConDeclDetails pass con_args ConDecl GhcPs con_decl of x :: HsConDeclDetails GhcPs x@(PrefixCon []) -> HsConDeclDetails GhcPs x HsConDeclDetails GhcPs -> HdkM () -> HdkM (HsConDeclDetails GhcPs) forall (f :: * -> *) a b. Functor f => a -> f b -> f a <$ [GenLocated SrcSpan HsDocString] -> HdkM () reportExtraDocs [GenLocated SrcSpan HsDocString] trailingDocs x :: HsConDeclDetails GhcPs x@(RecCon (L SrcSpan _ [])) -> HsConDeclDetails GhcPs x HsConDeclDetails GhcPs -> HdkM () -> HdkM (HsConDeclDetails GhcPs) forall (f :: * -> *) a b. Functor f => a -> f b -> f a <$ [GenLocated SrcSpan HsDocString] -> HdkM () reportExtraDocs [GenLocated SrcSpan HsDocString] trailingDocs PrefixCon [HsScaled GhcPs (LHsType GhcPs)] ts -> [HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclDetails GhcPs forall arg rec. [arg] -> HsConDetails arg rec PrefixCon ([HsScaled GhcPs (LHsType GhcPs)] -> HsConDeclDetails GhcPs) -> HdkM [HsScaled GhcPs (LHsType GhcPs)] -> HdkM (HsConDeclDetails GhcPs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (HsScaled GhcPs (LHsType GhcPs) -> HdkM (HsScaled GhcPs (LHsType GhcPs))) -> [HsScaled GhcPs (LHsType GhcPs)] -> HdkM [HsScaled GhcPs (LHsType GhcPs)] forall (f :: * -> *) a. Functor f => (a -> f a) -> [a] -> f [a] mapLastM HsScaled GhcPs (LHsType GhcPs) -> HdkM (HsScaled GhcPs (LHsType GhcPs)) mk_doc_ty [HsScaled GhcPs (LHsType GhcPs)] ts InfixCon HsScaled GhcPs (LHsType GhcPs) t1 HsScaled GhcPs (LHsType GhcPs) t2 -> HsScaled GhcPs (LHsType GhcPs) -> HsScaled GhcPs (LHsType GhcPs) -> HsConDeclDetails GhcPs forall arg rec. arg -> arg -> HsConDetails arg rec InfixCon HsScaled GhcPs (LHsType GhcPs) t1 (HsScaled GhcPs (LHsType GhcPs) -> HsConDeclDetails GhcPs) -> HdkM (HsScaled GhcPs (LHsType GhcPs)) -> HdkM (HsConDeclDetails GhcPs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> HsScaled GhcPs (LHsType GhcPs) -> HdkM (HsScaled GhcPs (LHsType GhcPs)) mk_doc_ty HsScaled GhcPs (LHsType GhcPs) t2 RecCon (L SrcSpan l_rec [LConDeclField GhcPs] flds) -> do [LConDeclField GhcPs] flds' <- (LConDeclField GhcPs -> HdkM (LConDeclField GhcPs)) -> [LConDeclField GhcPs] -> HdkM [LConDeclField GhcPs] forall (f :: * -> *) a. Functor f => (a -> f a) -> [a] -> f [a] mapLastM LConDeclField GhcPs -> HdkM (LConDeclField GhcPs) mk_doc_fld [LConDeclField GhcPs] flds return (GenLocated SrcSpan [LConDeclField GhcPs] -> HsConDeclDetails GhcPs forall arg rec. rec -> HsConDetails arg rec RecCon (SrcSpan -> [LConDeclField GhcPs] -> GenLocated SrcSpan [LConDeclField GhcPs] forall l e. l -> e -> GenLocated l e L SrcSpan l_rec [LConDeclField GhcPs] flds')) return $ SrcSpan -> ConDecl GhcPs -> LConDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l (ConDecl GhcPs con_decl{ con_args :: HsConDeclDetails GhcPs con_args = HsConDeclDetails GhcPs con_args' }) else do Maybe (GenLocated SrcSpan HsDocString) con_doc' <- [GenLocated SrcSpan HsDocString] -> HdkM (Maybe (GenLocated SrcSpan HsDocString)) selectDocString (ConDecl GhcPs -> Maybe (GenLocated SrcSpan HsDocString) forall pass. ConDecl pass -> Maybe (GenLocated SrcSpan HsDocString) con_doc ConDecl GhcPs con_decl Maybe (GenLocated SrcSpan HsDocString) -> [GenLocated SrcSpan HsDocString] -> [GenLocated SrcSpan HsDocString] forall a. Maybe a -> [a] -> [a] `mcons` [GenLocated SrcSpan HsDocString] trailingDocs) return $ SrcSpan -> ConDecl GhcPs -> LConDecl GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l (ConDecl GhcPs con_decl{ con_doc :: Maybe (GenLocated SrcSpan HsDocString) con_doc = Maybe (GenLocated SrcSpan HsDocString) con_doc' }) ConDecl GhcPs _ -> String -> HdkM (LConDecl GhcPs) forall a. String -> a panic String "addConTrailingDoc: non-H98 ConDecl" {- Note [Trailing comment on constructor declaration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The trailing comment after a constructor declaration is associated with the constructor itself when there are no other comments inside the declaration: data T = MkT A B -- ^ Comment on MkT data T = MkT { x :: A } -- ^ 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 This makes the trailing comment 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. Process the data constructor declaration in a delimited context where the trailing documentation comment is not visible. Delimiting the context is done in addConTrailingDoc. When processing the declaration, track whether the constructor or any of its fields have a documentation comment associated with them. This is done using WriterT HasInnerDocs, see ConHdkA. 2. Depending on whether HasInnerDocs is True or False, attach the trailing documentation comment to the data constructor itself or to its last field. -} 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 (LHsSigWcType GhcPs) where addHaddock :: LHsSigWcType GhcPs -> HdkA (LHsSigWcType GhcPs) addHaddock (HsWC XHsWC GhcPs (LHsSigType GhcPs) _ LHsSigType GhcPs t) = XHsWC GhcPs (LHsSigType GhcPs) -> LHsSigType GhcPs -> LHsSigWcType GhcPs forall pass thing. XHsWC pass thing -> thing -> HsWildCardBndrs pass thing HsWC NoExtField XHsWC GhcPs (LHsSigType GhcPs) noExtField (LHsSigType GhcPs -> LHsSigWcType GhcPs) -> HdkA (LHsSigType GhcPs) -> HdkA (LHsSigWcType GhcPs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> LHsSigType GhcPs -> HdkA (LHsSigType GhcPs) forall a. HasHaddock a => a -> HdkA a addHaddock LHsSigType GhcPs t instance HasHaddock (LHsSigType GhcPs) where addHaddock :: LHsSigType GhcPs -> HdkA (LHsSigType GhcPs) addHaddock (HsIB XHsIB GhcPs (LHsType GhcPs) _ LHsType GhcPs t) = XHsIB GhcPs (LHsType GhcPs) -> LHsType GhcPs -> LHsSigType GhcPs forall pass thing. XHsIB pass thing -> thing -> HsImplicitBndrs pass thing HsIB NoExtField XHsIB GhcPs (LHsType GhcPs) noExtField (LHsType GhcPs -> LHsSigType GhcPs) -> HdkA (LHsType GhcPs) -> HdkA (LHsSigType GhcPs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> LHsType GhcPs -> HdkA (LHsType GhcPs) forall a. HasHaddock a => a -> HdkA a addHaddock LHsType GhcPs t -- 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 (LHsType GhcPs) where addHaddock :: LHsType GhcPs -> HdkA (LHsType GhcPs) addHaddock (L SrcSpan l HsType GhcPs t) = SrcSpan -> HdkA (LHsType GhcPs) -> HdkA (LHsType GhcPs) forall a. SrcSpan -> HdkA a -> HdkA a extendHdkA SrcSpan l (HdkA (LHsType GhcPs) -> HdkA (LHsType GhcPs)) -> HdkA (LHsType GhcPs) -> HdkA (LHsType GhcPs) forall a b. (a -> b) -> a -> b $ case HsType GhcPs t of -- forall a b c. t HsForAllTy XForAllTy GhcPs _ HsForAllTelescope GhcPs tele LHsType GhcPs body -> do SrcSpan -> HdkA () registerLocHdkA (HsForAllTelescope GhcPs -> SrcSpan getForAllTeleLoc HsForAllTelescope GhcPs tele) LHsType GhcPs body' <- LHsType GhcPs -> HdkA (LHsType GhcPs) forall a. HasHaddock a => a -> HdkA a addHaddock LHsType GhcPs body pure $ SrcSpan -> HsType GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l (XForAllTy GhcPs -> HsForAllTelescope GhcPs -> LHsType GhcPs -> HsType GhcPs forall pass. XForAllTy pass -> HsForAllTelescope pass -> LHsType pass -> HsType pass HsForAllTy NoExtField XForAllTy GhcPs noExtField HsForAllTelescope GhcPs tele LHsType GhcPs body') -- (Eq a, Num a) => t HsQualTy XQualTy GhcPs _ LHsContext GhcPs lhs LHsType GhcPs rhs -> do LHsContext GhcPs -> HdkA () forall a. Located a -> HdkA () registerHdkA LHsContext GhcPs lhs LHsType GhcPs rhs' <- LHsType GhcPs -> HdkA (LHsType GhcPs) forall a. HasHaddock a => a -> HdkA a addHaddock LHsType GhcPs rhs pure $ SrcSpan -> HsType GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l (XQualTy GhcPs -> LHsContext GhcPs -> LHsType GhcPs -> HsType GhcPs forall pass. XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass HsQualTy NoExtField XQualTy GhcPs noExtField LHsContext GhcPs lhs LHsType GhcPs rhs') -- arg -> res HsFunTy XFunTy GhcPs u HsArrow GhcPs mult LHsType GhcPs lhs LHsType GhcPs rhs -> do LHsType GhcPs lhs' <- LHsType GhcPs -> HdkA (LHsType GhcPs) forall a. HasHaddock a => a -> HdkA a addHaddock LHsType GhcPs lhs LHsType GhcPs rhs' <- LHsType GhcPs -> HdkA (LHsType GhcPs) forall a. HasHaddock a => a -> HdkA a addHaddock LHsType GhcPs rhs pure $ SrcSpan -> HsType GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan 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 lhs' LHsType GhcPs rhs') -- other types HsType GhcPs _ -> HdkM (LHsType GhcPs) -> HdkA (LHsType GhcPs) forall a. HdkM a -> HdkA a liftHdkA (HdkM (LHsType GhcPs) -> HdkA (LHsType GhcPs)) -> HdkM (LHsType GhcPs) -> HdkA (LHsType GhcPs) forall a b. (a -> b) -> a -> b $ do Maybe (GenLocated SrcSpan HsDocString) mDoc <- SrcSpan -> HdkM (Maybe (GenLocated SrcSpan HsDocString)) getPrevNextDoc SrcSpan l return (LHsType GhcPs -> Maybe (GenLocated SrcSpan HsDocString) -> LHsType GhcPs mkLHsDocTy (SrcSpan -> HsType GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan 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 !(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 <$ :: forall a b. a -> HdkA b -> HdkA a $c<$ :: forall a b. a -> HdkA b -> HdkA a fmap :: forall a b. (a -> b) -> HdkA a -> HdkA b $cfmap :: forall a b. (a -> b) -> HdkA a -> HdkA b 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 (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 of 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 @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 @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 (f :: * -> *) a. Applicative f => a -> f a pure a a) {- Note [Smart reordering in HdkA (or lack of 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 -> InlineHdkM a forall a. HdkM a -> InlineHdkM a 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 (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 :: Located a -> HdkA () registerHdkA :: forall a. Located a -> HdkA () registerHdkA Located a a = SrcSpan -> HdkA () registerLocHdkA (Located a -> SrcSpan forall l e. GenLocated l e -> l getLoc Located a 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 (ReaderT LocRange (State HdkSt) a) 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 <$ :: forall a b. a -> HdkM b -> HdkM a $c<$ :: forall a b. a -> HdkM b -> HdkM a fmap :: forall a b. (a -> b) -> HdkM a -> HdkM b $cfmap :: forall a b. (a -> b) -> HdkM a -> HdkM b 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 <* :: forall a b. HdkM a -> HdkM b -> HdkM a $c<* :: forall a b. HdkM a -> HdkM b -> HdkM a *> :: forall a b. HdkM a -> HdkM b -> HdkM b $c*> :: forall a b. HdkM a -> HdkM b -> HdkM b liftA2 :: forall a b c. (a -> b -> c) -> HdkM a -> HdkM b -> HdkM c $cliftA2 :: forall a b c. (a -> b -> c) -> HdkM a -> HdkM b -> HdkM c <*> :: forall a b. HdkM (a -> b) -> HdkM a -> HdkM b $c<*> :: forall a b. HdkM (a -> b) -> HdkM a -> HdkM b pure :: forall a. a -> HdkM a $cpure :: forall a. a -> 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 return :: forall a. a -> HdkM a $creturn :: forall a. a -> HdkM a >> :: forall a b. HdkM a -> HdkM b -> HdkM b $c>> :: forall a b. HdkM a -> HdkM b -> HdkM b >>= :: forall a b. HdkM a -> (a -> HdkM b) -> HdkM b $c>>= :: forall a b. HdkM a -> (a -> HdkM b) -> HdkM b Monad) -- | 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 LHsDocString -- 'HdkM' without newtype wrapping/unwrapping. type InlineHdkM a = LocRange -> HdkSt -> (a, HdkSt) mkHdkM :: InlineHdkM a -> HdkM a unHdkM :: HdkM a -> InlineHdkM a mkHdkM :: forall a. InlineHdkM a -> HdkM a mkHdkM = InlineHdkM a -> HdkM a coerce unHdkM :: forall a. HdkM a -> InlineHdkM a unHdkM = HdkM a -> InlineHdkM a coerce -- 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 ReaderT LocRange (State HdkSt) a m) = ReaderT LocRange (State HdkSt) a -> HdkM a forall a. ReaderT LocRange (State HdkSt) a -> HdkM a HdkM ((LocRange -> LocRange) -> ReaderT LocRange (State HdkSt) a -> ReaderT LocRange (State HdkSt) a forall r (m :: * -> *) a. (r -> r) -> ReaderT r m a -> ReaderT r m a local (LocRange -> LocRange -> LocRange forall a. Monoid a => a -> a -> a mappend LocRange r) ReaderT LocRange (State HdkSt) a m) -- 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 = InlineHdkM [a] -> HdkM [a] forall a. InlineHdkM a -> HdkM a mkHdkM (InlineHdkM [a] -> HdkM [a]) -> InlineHdkM [a] -> 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 (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 :: [PsLocated HdkComment] hdk_st_pending = [PsLocated HdkComment] 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) -- Get the docnext or docprev comment for an AST node at the given source span. getPrevNextDoc :: SrcSpan -> HdkM (Maybe LHsDocString) 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 = ReaderT LocRange (State HdkSt) () -> HdkM () forall a. ReaderT LocRange (State HdkSt) a -> HdkM a HdkM ((LocRange -> StateT HdkSt Identity ()) -> ReaderT LocRange (State HdkSt) () forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a ReaderT (\LocRange _ -> (HdkSt -> HdkSt) -> StateT HdkSt Identity () forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m () modify HdkSt -> HdkSt append_warn)) where append_warn :: HdkSt -> HdkSt append_warn HdkSt hdk_st = HdkSt hdk_st { hdk_st_warnings :: [HdkWarn] hdk_st_warnings = HdkWarn e HdkWarn -> [HdkWarn] -> [HdkWarn] forall a. a -> [a] -> [a] : HdkSt -> [HdkWarn] hdk_st_warnings HdkSt hdk_st } selectDocString :: [LHsDocString] -> HdkM (Maybe LHsDocString) 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 (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 (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 :: [LHsDocString] -> 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 :: LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) mkDocHsDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) mkDocHsDecl LayoutInfo layout_info PsLocated HdkComment a = (DocDecl -> HsDecl GhcPs) -> LDocDecl -> LHsDecl GhcPs forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b mapLoc (XDocD GhcPs -> DocDecl -> HsDecl GhcPs forall p. XDocD p -> DocDecl -> HsDecl p DocD NoExtField XDocD GhcPs noExtField) (LDocDecl -> LHsDecl GhcPs) -> Maybe LDocDecl -> Maybe (LHsDecl GhcPs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> LayoutInfo -> PsLocated HdkComment -> Maybe LDocDecl mkDocDecl LayoutInfo layout_info PsLocated HdkComment a mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe LDocDecl mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe LDocDecl mkDocDecl LayoutInfo layout_info (L PsSpan l_comment HdkComment hdk_comment) | Bool indent_mismatch = Maybe LDocDecl forall a. Maybe a Nothing | Bool otherwise = LDocDecl -> Maybe LDocDecl forall a. a -> Maybe a Just (LDocDecl -> Maybe LDocDecl) -> LDocDecl -> Maybe LDocDecl forall a b. (a -> b) -> a -> b $ SrcSpan -> DocDecl -> LDocDecl forall l e. l -> e -> GenLocated l e L (PsSpan -> SrcSpan mkSrcSpanPs PsSpan l_comment) (DocDecl -> LDocDecl) -> DocDecl -> LDocDecl forall a b. (a -> b) -> a -> b $ case HdkComment hdk_comment of HdkCommentNext HsDocString doc -> HsDocString -> DocDecl DocCommentNext HsDocString doc HdkCommentPrev HsDocString doc -> HsDocString -> DocDecl DocCommentPrev HsDocString doc HdkCommentNamed String s HsDocString doc -> String -> HsDocString -> DocDecl DocCommentNamed String s HsDocString doc HdkCommentSection Int n HsDocString doc -> Int -> HsDocString -> DocDecl DocGroup Int n HsDocString doc where -- '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 LayoutInfo layout_info of LayoutInfo NoLayoutInfo -> Bool False LayoutInfo ExplicitBraces -> Bool False VirtualBraces 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 $ SrcSpan -> IE GhcPs -> LIE GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l (XIEGroup GhcPs -> Int -> HsDocString -> IE GhcPs forall pass. XIEGroup pass -> Int -> HsDocString -> IE pass IEGroup NoExtField XIEGroup GhcPs noExtField Int n 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 $ SrcSpan -> IE GhcPs -> LIE GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l (XIEDocNamed GhcPs -> String -> IE GhcPs forall pass. XIEDocNamed pass -> String -> IE pass IEDocNamed NoExtField XIEDocNamed GhcPs 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 $ SrcSpan -> IE GhcPs -> LIE GhcPs forall l e. l -> e -> GenLocated l e L SrcSpan l (XIEDoc GhcPs -> HsDocString -> IE GhcPs forall pass. XIEDoc pass -> HsDocString -> IE pass IEDoc NoExtField XIEDoc GhcPs noExtField HsDocString doc) HdkComment _ -> Maybe (LIE GhcPs) forall a. Maybe a Nothing where l :: SrcSpan l = PsSpan -> SrcSpan mkSrcSpanPs PsSpan l_comment mkDocNext :: PsLocated HdkComment -> Maybe LHsDocString 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 (GenLocated SrcSpan HsDocString -> Maybe (GenLocated SrcSpan HsDocString)) -> GenLocated SrcSpan HsDocString -> Maybe (GenLocated SrcSpan HsDocString) forall a b. (a -> b) -> a -> b $ 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 LHsDocString 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 (GenLocated SrcSpan HsDocString -> Maybe (GenLocated SrcSpan HsDocString)) -> GenLocated SrcSpan HsDocString -> Maybe (GenLocated SrcSpan HsDocString) forall a b. (a -> b) -> a -> b $ 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 :: Maybe BufPos -> LocRange locRangeFrom :: Maybe BufPos -> LocRange locRangeFrom (Just BufPos l) = LocRange forall a. Monoid a => a mempty { loc_range_from :: LowerLocBound loc_range_from = BufPos -> LowerLocBound StartLoc BufPos l } locRangeFrom Maybe BufPos Nothing = LocRange forall a. Monoid a => a mempty -- The location range from the start of the file to the specified position. locRangeTo :: Maybe BufPos -> LocRange locRangeTo :: Maybe BufPos -> LocRange locRangeTo (Just BufPos l) = LocRange forall a. Monoid a => a mempty { loc_range_to :: UpperLocBound loc_range_to = BufPos -> UpperLocBound EndLoc BufPos l } locRangeTo Maybe BufPos 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 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 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 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 LHsDocString -> 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) = SrcSpan -> HsType GhcPs -> LHsType GhcPs forall l e. l -> e -> GenLocated l e L (LHsType GhcPs -> SrcSpan forall l e. GenLocated l e -> l getLoc LHsType GhcPs t) (XDocTy GhcPs -> LHsType GhcPs -> GenLocated SrcSpan HsDocString -> HsType GhcPs forall pass. XDocTy pass -> LHsType pass -> GenLocated SrcSpan HsDocString -> HsType pass HsDocTy NoExtField XDocTy GhcPs noExtField LHsType GhcPs t GenLocated SrcSpan HsDocString doc) getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan getForAllTeleLoc HsForAllTelescope GhcPs tele = (SrcSpan -> SrcSpan -> SrcSpan) -> SrcSpan -> [SrcSpan] -> SrcSpan 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 $ case HsForAllTelescope GhcPs tele of HsForAllVis{ [LHsTyVarBndr () GhcPs] hsf_vis_bndrs :: forall pass. HsForAllTelescope pass -> [LHsTyVarBndr () pass] hsf_vis_bndrs :: [LHsTyVarBndr () GhcPs] hsf_vis_bndrs } -> (LHsTyVarBndr () GhcPs -> SrcSpan) -> [LHsTyVarBndr () GhcPs] -> [SrcSpan] forall a b. (a -> b) -> [a] -> [b] map LHsTyVarBndr () GhcPs -> SrcSpan forall l e. GenLocated l e -> l getLoc [LHsTyVarBndr () GhcPs] hsf_vis_bndrs HsForAllInvis { [LHsTyVarBndr Specificity GhcPs] hsf_invis_bndrs :: forall pass. HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass] hsf_invis_bndrs :: [LHsTyVarBndr Specificity GhcPs] hsf_invis_bndrs } -> (LHsTyVarBndr Specificity GhcPs -> SrcSpan) -> [LHsTyVarBndr Specificity GhcPs] -> [SrcSpan] forall a b. (a -> b) -> [a] -> [b] map LHsTyVarBndr Specificity GhcPs -> SrcSpan forall l e. GenLocated l e -> l getLoc [LHsTyVarBndr Specificity GhcPs] hsf_invis_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]) -> [LHsDecl GhcPs] flattenBindsAndSigs :: (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamDefltDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) -> [LHsDecl GhcPs] flattenBindsAndSigs (LHsBinds GhcPs all_bs, [LSig GhcPs] all_ss, [LFamilyDecl GhcPs] all_ts, [LTyFamDefltDecl GhcPs] all_tfis, [LDataFamInstDecl GhcPs] all_dfis, [LDocDecl] 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' (LHsDecl GhcPs -> LHsDecl GhcPs -> Ordering) -> [[LHsDecl GhcPs]] -> [LHsDecl GhcPs] forall a. (a -> a -> Ordering) -> [[a]] -> [a] mergeListsBy LHsDecl GhcPs -> LHsDecl GhcPs -> Ordering forall a. HasDebugCallStack => Located a -> Located a -> Ordering cmpBufSpan [ (HsBind GhcPs -> HsDecl GhcPs) -> [Located (HsBind GhcPs)] -> [LHsDecl GhcPs] forall a b. (a -> b) -> [Located a] -> [Located b] mapLL (\HsBind GhcPs b -> XValD GhcPs -> HsBind GhcPs -> HsDecl GhcPs forall p. XValD p -> HsBind p -> HsDecl p ValD NoExtField XValD GhcPs noExtField HsBind GhcPs b) (LHsBinds GhcPs -> [Located (HsBind GhcPs)] forall a. Bag a -> [a] bagToList LHsBinds GhcPs all_bs), (Sig GhcPs -> HsDecl GhcPs) -> [LSig GhcPs] -> [LHsDecl GhcPs] forall a b. (a -> b) -> [Located a] -> [Located b] mapLL (\Sig GhcPs s -> XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs forall p. XSigD p -> Sig p -> HsDecl p SigD NoExtField XSigD GhcPs noExtField Sig GhcPs s) [LSig GhcPs] all_ss, (FamilyDecl GhcPs -> HsDecl GhcPs) -> [LFamilyDecl GhcPs] -> [LHsDecl GhcPs] forall a b. (a -> b) -> [Located a] -> [Located b] mapLL (\FamilyDecl GhcPs t -> XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs forall p. XTyClD p -> TyClDecl p -> HsDecl p TyClD NoExtField XTyClD GhcPs noExtField (XFamDecl GhcPs -> FamilyDecl GhcPs -> TyClDecl GhcPs forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass FamDecl NoExtField XFamDecl GhcPs noExtField FamilyDecl GhcPs t)) [LFamilyDecl GhcPs] all_ts, (TyFamInstDecl GhcPs -> HsDecl GhcPs) -> [LTyFamDefltDecl GhcPs] -> [LHsDecl GhcPs] forall a b. (a -> b) -> [Located a] -> [Located b] mapLL (\TyFamInstDecl GhcPs tfi -> XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs forall p. XInstD p -> InstDecl p -> HsDecl p InstD NoExtField XInstD GhcPs noExtField (XTyFamInstD GhcPs -> TyFamInstDecl GhcPs -> InstDecl GhcPs forall pass. XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass TyFamInstD NoExtField XTyFamInstD GhcPs noExtField TyFamInstDecl GhcPs tfi)) [LTyFamDefltDecl GhcPs] all_tfis, (DataFamInstDecl GhcPs -> HsDecl GhcPs) -> [LDataFamInstDecl GhcPs] -> [LHsDecl GhcPs] forall a b. (a -> b) -> [Located a] -> [Located b] mapLL (\DataFamInstDecl GhcPs dfi -> XInstD GhcPs -> InstDecl GhcPs -> HsDecl GhcPs forall p. XInstD p -> InstDecl p -> HsDecl p InstD NoExtField XInstD GhcPs noExtField (XDataFamInstD GhcPs -> DataFamInstDecl GhcPs -> InstDecl GhcPs forall pass. XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass DataFamInstD NoExtField XDataFamInstD GhcPs noExtField DataFamInstDecl GhcPs dfi)) [LDataFamInstDecl GhcPs] all_dfis, (DocDecl -> HsDecl GhcPs) -> [LDocDecl] -> [LHsDecl GhcPs] forall a b. (a -> b) -> [Located a] -> [Located b] mapLL (\DocDecl d -> XDocD GhcPs -> DocDecl -> HsDecl GhcPs forall p. XDocD p -> DocDecl -> HsDecl p DocD NoExtField XDocD GhcPs noExtField DocDecl d) [LDocDecl] all_docs ] {- ********************************************************************* * * * General purpose utilities * * * ********************************************************************* -} -- Cons an element to a list, if exists. mcons :: Maybe a -> [a] -> [a] mcons :: forall a. Maybe a -> [a] -> [a] mcons = ([a] -> [a]) -> (a -> [a] -> [a]) -> Maybe a -> [a] -> [a] forall b a. b -> (a -> b) -> Maybe a -> b maybe [a] -> [a] forall a. a -> a id (:) -- Map a function over a list of located items. mapLL :: (a -> b) -> [Located a] -> [Located b] mapLL :: forall a b. (a -> b) -> [Located a] -> [Located b] mapLL a -> b f = (GenLocated SrcSpan a -> GenLocated SrcSpan b) -> [GenLocated SrcSpan a] -> [GenLocated SrcSpan b] forall a b. (a -> b) -> [a] -> [b] map ((a -> b) -> GenLocated SrcSpan a -> GenLocated SrcSpan b forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b mapLoc 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 succesfully: 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 The issue stems from the lack of location information for keywords. We could utilize API Annotations for this purpose, but not without modification. For example, API Annotations operate on RealSrcSpan, whereas we need BufSpan. Also, there's work towards making API Annotations available in-tree (not in a separate Map), see #17638. This change should make the fix very easy (it is not as easy with the current design). See also testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs -}