-- | Extract docs from the renamer output so they can be serialized.
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE BangPatterns #-}

{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

module GHC.HsToCore.Docs where

import GHC.Prelude
import GHC.Data.Bag
import GHC.Hs.Binds
import GHC.Hs.Doc
import GHC.Hs.Decls
import Language.Haskell.Syntax.Extension
import GHC.Hs.Extension
import GHC.Hs.Type
import GHC.Hs.Utils
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Tc.Types
import GHC.Parser.Annotation

import Control.Applicative
import Control.Monad.IO.Class
import Data.Bifunctor (first)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Semigroup
import GHC.IORef (readIORef)

-- | Extract docs from renamer output.
-- This is monadic since we need to be able to read documentation added from
-- Template Haskell's @putDoc@, which is stored in 'tcg_th_docs'.
extractDocs :: MonadIO m
            => TcGblEnv
            -> m (Maybe HsDocString, DeclDocMap, ArgDocMap)
            -- ^
            -- 1. Module header
            -- 2. Docs on top level declarations
            -- 3. Docs on arguments
extractDocs :: forall (m :: * -> *).
MonadIO m =>
TcGblEnv -> m (Maybe HsDocString, DeclDocMap, ArgDocMap)
extractDocs TcGblEnv { tcg_semantic_mod :: TcGblEnv -> Module
tcg_semantic_mod = Module
mod
                     , tcg_rn_decls :: TcGblEnv -> Maybe (HsGroup (GhcPass 'Renamed))
tcg_rn_decls = Maybe (HsGroup (GhcPass 'Renamed))
mb_rn_decls
                     , tcg_insts :: TcGblEnv -> [ClsInst]
tcg_insts = [ClsInst]
insts
                     , tcg_fam_insts :: TcGblEnv -> [FamInst]
tcg_fam_insts = [FamInst]
fam_insts
                     , tcg_doc_hdr :: TcGblEnv -> Maybe LHsDocString
tcg_doc_hdr = Maybe LHsDocString
mb_doc_hdr
                     , tcg_th_docs :: TcGblEnv -> TcRef THDocs
tcg_th_docs = TcRef THDocs
th_docs_var
                     } = do
    THDocs
th_docs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef TcRef THDocs
th_docs_var
    let doc_hdr :: Maybe HsDocString
doc_hdr = Maybe HsDocString
th_doc_hdr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LHsDocString
mb_doc_hdr)
        ExtractedTHDocs
          Maybe HsDocString
th_doc_hdr
          (DeclDocMap Map Name HsDocString
th_doc_map)
          (ArgDocMap Map Name (IntMap HsDocString)
th_arg_map)
          (DeclDocMap Map Name HsDocString
th_inst_map) = THDocs -> ExtractedTHDocs
extractTHDocs THDocs
th_docs
    forall (m :: * -> *) a. Monad m => a -> m a
return
      ( Maybe HsDocString
doc_hdr
      , Map Name HsDocString -> DeclDocMap
DeclDocMap (Map Name HsDocString
th_doc_map forall a. Semigroup a => a -> a -> a
<> Map Name HsDocString
th_inst_map forall a. Semigroup a => a -> a -> a
<> Map Name HsDocString
doc_map)
      , Map Name (IntMap HsDocString) -> ArgDocMap
ArgDocMap (Map Name (IntMap HsDocString)
th_arg_map forall b.
Map Name (IntMap b) -> Map Name (IntMap b) -> Map Name (IntMap b)
`unionArgMaps` Map Name (IntMap HsDocString)
arg_map)
      )
  where
    (Map Name HsDocString
doc_map, Map Name (IntMap HsDocString)
arg_map) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall k a. Map k a
M.empty, forall k a. Map k a
M.empty)
                               ([Name]
-> [(LHsDecl (GhcPass 'Renamed), [HsDocString])]
-> (Map Name HsDocString, Map Name (IntMap HsDocString))
mkMaps [Name]
local_insts)
                               Maybe
  [(GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Renamed)),
    [HsDocString])]
mb_decls_with_docs
    mb_decls_with_docs :: Maybe
  [(GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Renamed)),
    [HsDocString])]
mb_decls_with_docs = HsGroup (GhcPass 'Renamed)
-> [(LHsDecl (GhcPass 'Renamed), [HsDocString])]
topDecls forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (HsGroup (GhcPass 'Renamed))
mb_rn_decls
    local_insts :: [Name]
local_insts = forall a. (a -> Bool) -> [a] -> [a]
filter (Module -> Name -> Bool
nameIsLocalOrFrom Module
mod)
                         forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedThing a => a -> Name
getName [ClsInst]
insts forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedThing a => a -> Name
getName [FamInst]
fam_insts

-- | Create decl and arg doc-maps by looping through the declarations.
-- For each declaration, find its names, its subordinates, and its doc strings.
mkMaps :: [Name]
       -> [(LHsDecl GhcRn, [HsDocString])]
       -> (Map Name (HsDocString), Map Name (IntMap HsDocString))
mkMaps :: [Name]
-> [(LHsDecl (GhcPass 'Renamed), [HsDocString])]
-> (Map Name HsDocString, Map Name (IntMap HsDocString))
mkMaps [Name]
instances [(LHsDecl (GhcPass 'Renamed), [HsDocString])]
decls =
    ( forall a. Ord a => [[(a, HsDocString)]] -> Map a HsDocString
f' (forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Name) -> [a] -> [a]
nubByName forall a b. (a, b) -> a
fst) [[(Name, HsDocString)]]
decls')
    , forall a b. (Ord a, Semigroup b) => [[(a, b)]] -> Map a b
f  (forall b a. (b -> Bool) -> [[(a, b)]] -> [[(a, b)]]
filterMapping (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> Bool
IM.null) [[(Name, IntMap HsDocString)]]
args)
    )
  where
    ([[(Name, HsDocString)]]
decls', [[(Name, IntMap HsDocString)]]
args) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. (a -> b) -> [a] -> [b]
map (LHsDecl (GhcPass 'Renamed), [HsDocString])
-> ([(Name, HsDocString)], [(Name, IntMap HsDocString)])
mappings [(LHsDecl (GhcPass 'Renamed), [HsDocString])]
decls)

    f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b
    f :: forall a b. (Ord a, Semigroup b) => [[(a, b)]] -> Map a b
f = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. Semigroup a => a -> a -> a
(<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

    f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString
    f' :: forall a. Ord a => [[(a, HsDocString)]] -> Map a HsDocString
f' = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith HsDocString -> HsDocString -> HsDocString
appendDocs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

    filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]
    filterMapping :: forall b a. (b -> Bool) -> [[(a, b)]] -> [[(a, b)]]
filterMapping b -> Bool
p = forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
filter (b -> Bool
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd))

    mappings :: (LHsDecl GhcRn, [HsDocString])
             -> ( [(Name, HsDocString)]
                , [(Name, IntMap HsDocString)]
                )
    mappings :: (LHsDecl (GhcPass 'Renamed), [HsDocString])
-> ([(Name, HsDocString)], [(Name, IntMap HsDocString)])
mappings (L (SrcSpanAnn EpAnn AnnListItem
_ (RealSrcSpan RealSrcSpan
l Maybe BufSpan
_)) HsDecl (GhcPass 'Renamed)
decl, [HsDocString]
docStrs) =
           ([(Name, HsDocString)]
dm, [(Name, IntMap HsDocString)]
am)
      where
        doc :: Maybe HsDocString
doc = [HsDocString] -> Maybe HsDocString
concatDocs [HsDocString]
docStrs
        args :: IntMap HsDocString
args = HsDecl (GhcPass 'Renamed) -> IntMap HsDocString
declTypeDocs HsDecl (GhcPass 'Renamed)
decl

        subs :: [(Name, [HsDocString], IntMap HsDocString)]
        subs :: [(Name, [HsDocString], IntMap HsDocString)]
subs = Map RealSrcSpan Name
-> HsDecl (GhcPass 'Renamed)
-> [(Name, [HsDocString], IntMap HsDocString)]
subordinates Map RealSrcSpan Name
instanceMap HsDecl (GhcPass 'Renamed)
decl

        ([Maybe HsDocString]
subDocs, [IntMap HsDocString]
subArgs) =
          forall a b. [(a, b)] -> ([a], [b])
unzip (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_, [HsDocString]
strs, IntMap HsDocString
m) -> ([HsDocString] -> Maybe HsDocString
concatDocs [HsDocString]
strs, IntMap HsDocString
m)) [(Name, [HsDocString], IntMap HsDocString)]
subs)

        ns :: [Name]
ns = RealSrcSpan -> HsDecl (GhcPass 'Renamed) -> [Name]
names RealSrcSpan
l HsDecl (GhcPass 'Renamed)
decl
        subNs :: [Name]
subNs = [ Name
n | (Name
n, [HsDocString]
_, IntMap HsDocString
_) <- [(Name, [HsDocString], IntMap HsDocString)]
subs ]
        dm :: [(Name, HsDocString)]
dm = [(Name
n, HsDocString
d) | (Name
n, Just HsDocString
d) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
ns (forall a. a -> [a]
repeat Maybe HsDocString
doc) forall a. [a] -> [a] -> [a]
++ forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
subNs [Maybe HsDocString]
subDocs]
        am :: [(Name, IntMap HsDocString)]
am = [(Name
n, IntMap HsDocString
args) | Name
n <- [Name]
ns] forall a. [a] -> [a] -> [a]
++ forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
subNs [IntMap HsDocString]
subArgs
    mappings (L (SrcSpanAnn EpAnn AnnListItem
_ (UnhelpfulSpan UnhelpfulSpanReason
_)) HsDecl (GhcPass 'Renamed)
_, [HsDocString]
_) = ([], [])

    instanceMap :: Map RealSrcSpan Name
    instanceMap :: Map RealSrcSpan Name
instanceMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(RealSrcSpan
l, Name
n) | Name
n <- [Name]
instances, RealSrcSpan RealSrcSpan
l Maybe BufSpan
_ <- [forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n] ]

    names :: RealSrcSpan -> HsDecl GhcRn -> [Name]
    names :: RealSrcSpan -> HsDecl (GhcPass 'Renamed) -> [Name]
names RealSrcSpan
_ (InstD XInstD (GhcPass 'Renamed)
_ InstDecl (GhcPass 'Renamed)
d) = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall a. SrcSpan -> Map RealSrcSpan a -> Maybe a
lookupSrcSpan (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
InstDecl (GhcPass p) -> SrcSpan
getInstLoc InstDecl (GhcPass 'Renamed)
d) Map RealSrcSpan Name
instanceMap
    names RealSrcSpan
l (DerivD {}) = forall a. Maybe a -> [a]
maybeToList (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup RealSrcSpan
l Map RealSrcSpan Name
instanceMap) -- See Note [1].
    names RealSrcSpan
_ HsDecl (GhcPass 'Renamed)
decl = forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p)) =>
HsDecl (GhcPass p) -> [IdP (GhcPass p)]
getMainDeclBinder HsDecl (GhcPass 'Renamed)
decl

{-
Note [1]:
---------
We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
inside them. That should work for normal user-written instances (from
looking at GHC sources). We can assume that commented instances are
user-written. This lets us relate Names (from ClsInsts) to comments
(associated with InstDecls and DerivDecls).
-}
getMainDeclBinder :: (Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p))
                  => HsDecl (GhcPass p) -> [IdP (GhcPass p)]
getMainDeclBinder :: forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p)) =>
HsDecl (GhcPass p) -> [IdP (GhcPass p)]
getMainDeclBinder (TyClD XTyClD (GhcPass p)
_ TyClDecl (GhcPass p)
d) = [forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl (GhcPass p)
d]
getMainDeclBinder (ValD XValD (GhcPass p)
_ HsBind (GhcPass p)
d) =
  case forall p idR.
CollectPass p =>
CollectFlag p -> HsBindLR p idR -> [IdP p]
collectHsBindBinders forall p. CollectFlag p
CollNoDictBinders HsBind (GhcPass p)
d of
    []       -> []
    (IdP (GhcPass p)
name:[IdP (GhcPass p)]
_) -> [IdP (GhcPass p)
name]
getMainDeclBinder (SigD XSigD (GhcPass p)
_ Sig (GhcPass p)
d) = forall pass. UnXRec pass => Sig pass -> [IdP pass]
sigNameNoLoc Sig (GhcPass p)
d
getMainDeclBinder (ForD XForD (GhcPass p)
_ (ForeignImport XForeignImport (GhcPass p)
_ LIdP (GhcPass p)
name LHsSigType (GhcPass p)
_ ForeignImport
_)) = [forall l e. GenLocated l e -> e
unLoc LIdP (GhcPass p)
name]
getMainDeclBinder (ForD XForD (GhcPass p)
_ (ForeignExport XForeignExport (GhcPass p)
_ LIdP (GhcPass p)
_ LHsSigType (GhcPass p)
_ ForeignExport
_)) = []
getMainDeclBinder HsDecl (GhcPass p)
_ = []


sigNameNoLoc :: forall pass. UnXRec pass => Sig pass -> [IdP pass]
sigNameNoLoc :: forall pass. UnXRec pass => Sig pass -> [IdP pass]
sigNameNoLoc (TypeSig    XTypeSig pass
_   [LIdP pass]
ns LHsSigWcType pass
_)         = forall a b. (a -> b) -> [a] -> [b]
map (forall p a. UnXRec p => XRec p a -> a
unXRec @pass) [LIdP pass]
ns
sigNameNoLoc (ClassOpSig XClassOpSig pass
_ Bool
_ [LIdP pass]
ns LHsSigType pass
_)         = forall a b. (a -> b) -> [a] -> [b]
map (forall p a. UnXRec p => XRec p a -> a
unXRec @pass) [LIdP pass]
ns
sigNameNoLoc (PatSynSig  XPatSynSig pass
_   [LIdP pass]
ns LHsSigType pass
_)         = forall a b. (a -> b) -> [a] -> [b]
map (forall p a. UnXRec p => XRec p a -> a
unXRec @pass) [LIdP pass]
ns
sigNameNoLoc (SpecSig    XSpecSig pass
_   LIdP pass
n [LHsSigType pass]
_ InlinePragma
_)        = [forall p a. UnXRec p => XRec p a -> a
unXRec @pass LIdP pass
n]
sigNameNoLoc (InlineSig  XInlineSig pass
_   LIdP pass
n InlinePragma
_)          = [forall p a. UnXRec p => XRec p a -> a
unXRec @pass LIdP pass
n]
sigNameNoLoc (FixSig XFixSig pass
_ (FixitySig XFixitySig pass
_ [LIdP pass]
ns Fixity
_)) = forall a b. (a -> b) -> [a] -> [b]
map (forall p a. UnXRec p => XRec p a -> a
unXRec @pass) [LIdP pass]
ns
sigNameNoLoc Sig pass
_                             = []

-- Extract the source location where an instance is defined. This is used
-- to correlate InstDecls with their Instance/CoAxiom Names, via the
-- instanceMap.
getInstLoc :: Anno (IdGhcP p) ~ SrcSpanAnnN => InstDecl (GhcPass p) -> SrcSpan
getInstLoc :: forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
InstDecl (GhcPass p) -> SrcSpan
getInstLoc = \case
  ClsInstD XClsInstD (GhcPass p)
_ (ClsInstDecl { cid_poly_ty :: forall pass. ClsInstDecl pass -> LHsSigType pass
cid_poly_ty = LHsSigType (GhcPass p)
ty }) -> forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType (GhcPass p)
ty
  -- The Names of data and type family instances have their SrcSpan's attached
  -- to the *type constructor*. For example, the Name "D:R:Foo:Int" would have
  -- its SrcSpan attached here:
  --   type family Foo a
  --   type instance Foo Int = Bool
  --                 ^^^
  DataFamInstD XDataFamInstD (GhcPass p)
_ (DataFamInstDecl
    { dfid_eqn :: forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn = FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = L SrcSpanAnnN
l IdGhcP p
_ }}) -> forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
l
  -- Since CoAxioms' Names refer to the whole line for type family instances
  -- in particular, we need to dig a bit deeper to pull out the entire
  -- equation. This does not happen for data family instances, for some reason.
  TyFamInstD XTyFamInstD (GhcPass p)
_ (TyFamInstDecl
    { tfid_eqn :: forall pass. TyFamInstDecl pass -> TyFamInstEqn pass
tfid_eqn = FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = L SrcSpanAnnN
l IdGhcP p
_ }}) -> forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
l

-- | Get all subordinate declarations inside a declaration, and their docs.
-- A subordinate declaration is something like the associate type or data
-- family of a type class.
subordinates :: Map RealSrcSpan Name
             -> HsDecl GhcRn
             -> [(Name, [HsDocString], IntMap HsDocString)]
subordinates :: Map RealSrcSpan Name
-> HsDecl (GhcPass 'Renamed)
-> [(Name, [HsDocString], IntMap HsDocString)]
subordinates Map RealSrcSpan Name
instMap HsDecl (GhcPass 'Renamed)
decl = case HsDecl (GhcPass 'Renamed)
decl of
  InstD XInstD (GhcPass 'Renamed)
_ (ClsInstD XClsInstD (GhcPass 'Renamed)
_ ClsInstDecl (GhcPass 'Renamed)
d) -> do
    DataFamInstDecl { dfid_eqn :: forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn =
      FamEqn { feqn_tycon :: forall pass rhs. FamEqn pass rhs -> LIdP pass
feqn_tycon = L SrcSpanAnnN
l Name
_
             , feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs   = HsDataDefn (GhcPass 'Renamed)
defn }} <- forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_datafam_insts ClsInstDecl (GhcPass 'Renamed)
d
    [ (Name
n, [], forall a. IntMap a
IM.empty) | Just Name
n <- [forall a. SrcSpan -> Map RealSrcSpan a -> Maybe a
lookupSrcSpan (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnN
l) Map RealSrcSpan Name
instMap] ] forall a. [a] -> [a] -> [a]
++ HsDataDefn (GhcPass 'Renamed)
-> [(Name, [HsDocString], IntMap HsDocString)]
dataSubs HsDataDefn (GhcPass 'Renamed)
defn

  InstD XInstD (GhcPass 'Renamed)
_ (DataFamInstD XDataFamInstD (GhcPass 'Renamed)
_ (DataFamInstDecl FamEqn (GhcPass 'Renamed) (HsDataDefn (GhcPass 'Renamed))
d))
    -> HsDataDefn (GhcPass 'Renamed)
-> [(Name, [HsDocString], IntMap HsDocString)]
dataSubs (forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs FamEqn (GhcPass 'Renamed) (HsDataDefn (GhcPass 'Renamed))
d)
  TyClD XTyClD (GhcPass 'Renamed)
_ TyClDecl (GhcPass 'Renamed)
d | forall pass. TyClDecl pass -> Bool
isClassDecl TyClDecl (GhcPass 'Renamed)
d -> TyClDecl (GhcPass 'Renamed)
-> [(Name, [HsDocString], IntMap HsDocString)]
classSubs TyClDecl (GhcPass 'Renamed)
d
            | forall pass. TyClDecl pass -> Bool
isDataDecl  TyClDecl (GhcPass 'Renamed)
d -> HsDataDefn (GhcPass 'Renamed)
-> [(Name, [HsDocString], IntMap HsDocString)]
dataSubs (forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn TyClDecl (GhcPass 'Renamed)
d)
  HsDecl (GhcPass 'Renamed)
_ -> []
  where
    classSubs :: TyClDecl (GhcPass 'Renamed)
-> [(Name, [HsDocString], IntMap HsDocString)]
classSubs TyClDecl (GhcPass 'Renamed)
dd = [ (Name
name, [HsDocString]
doc, HsDecl (GhcPass 'Renamed) -> IntMap HsDocString
declTypeDocs HsDecl (GhcPass 'Renamed)
d)
                   | (L SrcSpanAnnA
_ HsDecl (GhcPass 'Renamed)
d, [HsDocString]
doc) <- TyClDecl (GhcPass 'Renamed)
-> [(LHsDecl (GhcPass 'Renamed), [HsDocString])]
classDecls TyClDecl (GhcPass 'Renamed)
dd
                   , Name
name <- forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p)) =>
HsDecl (GhcPass p) -> [IdP (GhcPass p)]
getMainDeclBinder HsDecl (GhcPass 'Renamed)
d, Bool -> Bool
not (forall a. HsDecl a -> Bool
isValD HsDecl (GhcPass 'Renamed)
d)
                   ]
    dataSubs :: HsDataDefn GhcRn
             -> [(Name, [HsDocString], IntMap HsDocString)]
    dataSubs :: HsDataDefn (GhcPass 'Renamed)
-> [(Name, [HsDocString], IntMap HsDocString)]
dataSubs HsDataDefn (GhcPass 'Renamed)
dd = [(Name, [HsDocString], IntMap HsDocString)]
constrs forall a. [a] -> [a] -> [a]
++ [(Name, [HsDocString], IntMap HsDocString)]
fields forall a. [a] -> [a] -> [a]
++ [(Name, [HsDocString], IntMap HsDocString)]
derivs
      where
        cons :: [ConDecl (GhcPass 'Renamed)]
cons = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ (forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons HsDataDefn (GhcPass 'Renamed)
dd)
        constrs :: [(Name, [HsDocString], IntMap HsDocString)]
constrs = [ ( forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
cname
                    , forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall pass. ConDecl pass -> Maybe LHsDocString
con_doc ConDecl (GhcPass 'Renamed)
c
                    , ConDecl (GhcPass 'Renamed) -> IntMap HsDocString
conArgDocs ConDecl (GhcPass 'Renamed)
c)
                  | ConDecl (GhcPass 'Renamed)
c <- [ConDecl (GhcPass 'Renamed)]
cons, GenLocated SrcSpanAnnN Name
cname <- ConDecl (GhcPass 'Renamed) -> [GenLocated SrcSpanAnnN Name]
getConNames ConDecl (GhcPass 'Renamed)
c ]
        fields :: [(Name, [HsDocString], IntMap HsDocString)]
fields  = [ (forall pass. FieldOcc pass -> XCFieldOcc pass
extFieldOcc FieldOcc (GhcPass 'Renamed)
n, forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l e. GenLocated l e -> e
unLoc Maybe LHsDocString
doc, forall a. IntMap a
IM.empty)
                  | Just GenLocated
  SrcSpanAnnL
  [GenLocated SrcSpanAnnA (ConDeclField (GhcPass 'Renamed))]
flds <- forall a b. (a -> b) -> [a] -> [b]
map ConDecl (GhcPass 'Renamed)
-> Maybe (LocatedL [LConDeclField (GhcPass 'Renamed)])
getRecConArgs_maybe [ConDecl (GhcPass 'Renamed)]
cons
                  , (L SrcSpanAnnA
_ (ConDeclField XConDeclField (GhcPass 'Renamed)
_ [LFieldOcc (GhcPass 'Renamed)]
ns XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed))
_ Maybe LHsDocString
doc)) <- (forall l e. GenLocated l e -> e
unLoc GenLocated
  SrcSpanAnnL
  [GenLocated SrcSpanAnnA (ConDeclField (GhcPass 'Renamed))]
flds)
                  , (L SrcSpan
_ FieldOcc (GhcPass 'Renamed)
n) <- [LFieldOcc (GhcPass 'Renamed)]
ns ]
        derivs :: [(Name, [HsDocString], IntMap HsDocString)]
derivs  = [ (Name
instName, [forall l e. GenLocated l e -> e
unLoc LHsDocString
doc], forall a. IntMap a
IM.empty)
                  | (SrcSpan
l, LHsDocString
doc) <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LDerivClauseTys (GhcPass 'Renamed) -> [(SrcSpan, LHsDocString)]
extract_deriv_clause_tys forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                           forall pass. HsDerivingClause pass -> LDerivClauseTys pass
deriv_clause_tys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) forall a b. (a -> b) -> a -> b
$
                                -- unLoc $ dd_derivs dd
                                forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs HsDataDefn (GhcPass 'Renamed)
dd
                  , Just Name
instName <- [forall a. SrcSpan -> Map RealSrcSpan a -> Maybe a
lookupSrcSpan SrcSpan
l Map RealSrcSpan Name
instMap] ]

        extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDocString)]
        extract_deriv_clause_tys :: LDerivClauseTys (GhcPass 'Renamed) -> [(SrcSpan, LHsDocString)]
extract_deriv_clause_tys (L SrcSpanAnnC
_ DerivClauseTys (GhcPass 'Renamed)
dct) =
          case DerivClauseTys (GhcPass 'Renamed)
dct of
            DctSingle XDctSingle (GhcPass 'Renamed)
_ LHsSigType (GhcPass 'Renamed)
ty -> forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ LHsSigType (GhcPass 'Renamed) -> Maybe (SrcSpan, LHsDocString)
extract_deriv_ty LHsSigType (GhcPass 'Renamed)
ty
            DctMulti XDctMulti (GhcPass 'Renamed)
_ [LHsSigType (GhcPass 'Renamed)]
tys -> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe LHsSigType (GhcPass 'Renamed) -> Maybe (SrcSpan, LHsDocString)
extract_deriv_ty [LHsSigType (GhcPass 'Renamed)]
tys

        extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString)
        extract_deriv_ty :: LHsSigType (GhcPass 'Renamed) -> Maybe (SrcSpan, LHsDocString)
extract_deriv_ty (L SrcSpanAnnA
l (HsSig{sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = L SrcSpanAnnA
_ HsType (GhcPass 'Renamed)
ty})) =
          case HsType (GhcPass 'Renamed)
ty of
            -- deriving (C a {- ^ Doc comment -})
            HsDocTy XDocTy (GhcPass 'Renamed)
_ XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed))
_ LHsDocString
doc -> forall a. a -> Maybe a
Just (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l, LHsDocString
doc)
            HsType (GhcPass 'Renamed)
_               -> forall a. Maybe a
Nothing

-- | Extract constructor argument docs from inside constructor decls.
conArgDocs :: ConDecl GhcRn -> IntMap HsDocString
conArgDocs :: ConDecl (GhcPass 'Renamed) -> IntMap HsDocString
conArgDocs (ConDeclH98{con_args :: forall pass. ConDecl pass -> HsConDeclH98Details pass
con_args = HsConDeclH98Details (GhcPass 'Renamed)
args}) =
  HsConDeclH98Details (GhcPass 'Renamed) -> IntMap HsDocString
h98ConArgDocs HsConDeclH98Details (GhcPass 'Renamed)
args
conArgDocs (ConDeclGADT{con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args = HsConDeclGADTDetails (GhcPass 'Renamed)
args, con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_res_ty = XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed))
res_ty}) =
  HsConDeclGADTDetails (GhcPass 'Renamed)
-> HsType (GhcPass 'Renamed) -> IntMap HsDocString
gadtConArgDocs HsConDeclGADTDetails (GhcPass 'Renamed)
args (forall l e. GenLocated l e -> e
unLoc XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed))
res_ty)

h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap HsDocString
h98ConArgDocs :: HsConDeclH98Details (GhcPass 'Renamed) -> IntMap HsDocString
h98ConArgDocs HsConDeclH98Details (GhcPass 'Renamed)
con_args = case HsConDeclH98Details (GhcPass 'Renamed)
con_args of
  PrefixCon [Void]
_ [HsScaled
   (GhcPass 'Renamed)
   (XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed)))]
args   -> Key -> [HsType (GhcPass 'Renamed)] -> IntMap HsDocString
con_arg_docs Key
0 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass a. HsScaled pass a -> a
hsScaledThing) [HsScaled
   (GhcPass 'Renamed)
   (XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed)))]
args
  InfixCon HsScaled
  (GhcPass 'Renamed)
  (XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed)))
arg1 HsScaled
  (GhcPass 'Renamed)
  (XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed)))
arg2 -> Key -> [HsType (GhcPass 'Renamed)] -> IntMap HsDocString
con_arg_docs Key
0 [ forall l e. GenLocated l e -> e
unLoc (forall pass a. HsScaled pass a -> a
hsScaledThing HsScaled
  (GhcPass 'Renamed)
  (XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed)))
arg1)
                                       , forall l e. GenLocated l e -> e
unLoc (forall pass a. HsScaled pass a -> a
hsScaledThing HsScaled
  (GhcPass 'Renamed)
  (XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed)))
arg2) ]
  RecCon XRec (GhcPass 'Renamed) [LConDeclField (GhcPass 'Renamed)]
_           -> forall a. IntMap a
IM.empty

gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString
gadtConArgDocs :: HsConDeclGADTDetails (GhcPass 'Renamed)
-> HsType (GhcPass 'Renamed) -> IntMap HsDocString
gadtConArgDocs HsConDeclGADTDetails (GhcPass 'Renamed)
con_args HsType (GhcPass 'Renamed)
res_ty = case HsConDeclGADTDetails (GhcPass 'Renamed)
con_args of
  PrefixConGADT [HsScaled
   (GhcPass 'Renamed)
   (XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed)))]
args -> Key -> [HsType (GhcPass 'Renamed)] -> IntMap HsDocString
con_arg_docs Key
0 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass a. HsScaled pass a -> a
hsScaledThing) [HsScaled
   (GhcPass 'Renamed)
   (XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed)))]
args forall a. [a] -> [a] -> [a]
++ [HsType (GhcPass 'Renamed)
res_ty]
  RecConGADT XRec (GhcPass 'Renamed) [LConDeclField (GhcPass 'Renamed)]
_       -> Key -> [HsType (GhcPass 'Renamed)] -> IntMap HsDocString
con_arg_docs Key
1 [HsType (GhcPass 'Renamed)
res_ty]

con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString
con_arg_docs :: Key -> [HsType (GhcPass 'Renamed)] -> IntMap HsDocString
con_arg_docs Key
n = forall a. [(Key, a)] -> IntMap a
IM.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {pass} {l} {a}.
(XRec pass (HsType pass) ~ GenLocated l (HsType pass)) =>
a -> HsType pass -> Maybe (a, HsDocString)
f [Key
n..]
  where
    f :: a -> HsType pass -> Maybe (a, HsDocString)
f a
n (HsDocTy XDocTy pass
_ XRec pass (HsType pass)
_ LHsDocString
lds) = forall a. a -> Maybe a
Just (a
n, forall l e. GenLocated l e -> e
unLoc LHsDocString
lds)
    f a
n (HsBangTy XBangTy pass
_ HsSrcBang
_ (L l
_ (HsDocTy XDocTy pass
_ XRec pass (HsType pass)
_ LHsDocString
lds))) = forall a. a -> Maybe a
Just (a
n, forall l e. GenLocated l e -> e
unLoc LHsDocString
lds)
    f a
_ HsType pass
_ = forall a. Maybe a
Nothing

isValD :: HsDecl a -> Bool
isValD :: forall a. HsDecl a -> Bool
isValD (ValD XValD a
_ HsBind a
_) = Bool
True
isValD HsDecl a
_ = Bool
False

-- | All the sub declarations of a class (that we handle), ordered by
-- source location, with documentation attached if it exists.
classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
classDecls :: TyClDecl (GhcPass 'Renamed)
-> [(LHsDecl (GhcPass 'Renamed), [HsDocString])]
classDecls TyClDecl (GhcPass 'Renamed)
class_ = forall p doc. UnXRec p => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]
filterDecls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])]
collectDocs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e.
[GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e]
sortLocatedA forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Renamed))]
decls
  where
    decls :: [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Renamed))]
decls = [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Renamed))]
docs forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Renamed))]
defs forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Renamed))]
sigs forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Renamed))]
ats
    docs :: [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Renamed))]
docs  = forall struct l decl hsDecl.
(struct -> [GenLocated l decl])
-> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
mkDecls forall pass. TyClDecl pass -> [LDocDecl pass]
tcdDocs (forall p. XDocD p -> DocDecl -> HsDecl p
DocD NoExtField
noExtField) TyClDecl (GhcPass 'Renamed)
class_
    defs :: [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Renamed))]
defs  = forall struct l decl hsDecl.
(struct -> [GenLocated l decl])
-> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
mkDecls (forall a. Bag a -> [a]
bagToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths) (forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
noExtField) TyClDecl (GhcPass 'Renamed)
class_
    sigs :: [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Renamed))]
sigs  = forall struct l decl hsDecl.
(struct -> [GenLocated l decl])
-> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
mkDecls forall pass. TyClDecl pass -> [LSig pass]
tcdSigs (forall p. XSigD p -> Sig p -> HsDecl p
SigD NoExtField
noExtField) TyClDecl (GhcPass 'Renamed)
class_
    ats :: [GenLocated SrcSpanAnnA (HsDecl (GhcPass 'Renamed))]
ats   = forall struct l decl hsDecl.
(struct -> [GenLocated l decl])
-> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
mkDecls forall pass. TyClDecl pass -> [LFamilyDecl pass]
tcdATs (forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD NoExtField
noExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. XFamDecl pass -> FamilyDecl pass -> TyClDecl pass
FamDecl NoExtField
noExtField) TyClDecl (GhcPass 'Renamed)
class_

-- | Extract function argument docs from inside top-level decls.
declTypeDocs :: HsDecl GhcRn -> IntMap (HsDocString)
declTypeDocs :: HsDecl (GhcPass 'Renamed) -> IntMap HsDocString
declTypeDocs = \case
  SigD  XSigD (GhcPass 'Renamed)
_ (TypeSig XTypeSig (GhcPass 'Renamed)
_ [LIdP (GhcPass 'Renamed)]
_ LHsSigWcType (GhcPass 'Renamed)
ty)          -> HsSigType (GhcPass 'Renamed) -> IntMap HsDocString
sigTypeDocs (forall l e. GenLocated l e -> e
unLoc (forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType (GhcPass 'Renamed)
ty))
  SigD  XSigD (GhcPass 'Renamed)
_ (ClassOpSig XClassOpSig (GhcPass 'Renamed)
_ Bool
_ [LIdP (GhcPass 'Renamed)]
_ LHsSigType (GhcPass 'Renamed)
ty)     -> HsSigType (GhcPass 'Renamed) -> IntMap HsDocString
sigTypeDocs (forall l e. GenLocated l e -> e
unLoc LHsSigType (GhcPass 'Renamed)
ty)
  SigD  XSigD (GhcPass 'Renamed)
_ (PatSynSig XPatSynSig (GhcPass 'Renamed)
_ [LIdP (GhcPass 'Renamed)]
_ LHsSigType (GhcPass 'Renamed)
ty)        -> HsSigType (GhcPass 'Renamed) -> IntMap HsDocString
sigTypeDocs (forall l e. GenLocated l e -> e
unLoc LHsSigType (GhcPass 'Renamed)
ty)
  ForD  XForD (GhcPass 'Renamed)
_ (ForeignImport XForeignImport (GhcPass 'Renamed)
_ LIdP (GhcPass 'Renamed)
_ LHsSigType (GhcPass 'Renamed)
ty ForeignImport
_)  -> HsSigType (GhcPass 'Renamed) -> IntMap HsDocString
sigTypeDocs (forall l e. GenLocated l e -> e
unLoc LHsSigType (GhcPass 'Renamed)
ty)
  TyClD XTyClD (GhcPass 'Renamed)
_ (SynDecl { tcdRhs :: forall pass. TyClDecl pass -> LHsType pass
tcdRhs = XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed))
ty }) -> HsType (GhcPass 'Renamed) -> IntMap HsDocString
typeDocs (forall l e. GenLocated l e -> e
unLoc XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed))
ty)
  HsDecl (GhcPass 'Renamed)
_                                 -> forall a. IntMap a
IM.empty

nubByName :: (a -> Name) -> [a] -> [a]
nubByName :: forall a. (a -> Name) -> [a] -> [a]
nubByName a -> Name
f [a]
ns = NameSet -> [a] -> [a]
go NameSet
emptyNameSet [a]
ns
  where
    go :: NameSet -> [a] -> [a]
go NameSet
_ [] = []
    go NameSet
s (a
x:[a]
xs)
      | Name
y Name -> NameSet -> Bool
`elemNameSet` NameSet
s = NameSet -> [a] -> [a]
go NameSet
s [a]
xs
      | Bool
otherwise         = let !s' :: NameSet
s' = NameSet -> Name -> NameSet
extendNameSet NameSet
s Name
y
                            in a
x forall a. a -> [a] -> [a]
: NameSet -> [a] -> [a]
go NameSet
s' [a]
xs
      where
        y :: Name
y = a -> Name
f a
x

-- | Extract function argument docs from inside types.
typeDocs :: HsType GhcRn -> IntMap HsDocString
typeDocs :: HsType (GhcPass 'Renamed) -> IntMap HsDocString
typeDocs = forall {pass} {l}.
(XRec pass (HsType pass) ~ GenLocated l (HsType pass)) =>
Key -> HsType pass -> IntMap HsDocString
go Key
0
  where
    go :: Key -> HsType pass -> IntMap HsDocString
go Key
n = \case
      HsForAllTy { hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = XRec pass (HsType pass)
ty }          -> Key -> HsType pass -> IntMap HsDocString
go Key
n (forall l e. GenLocated l e -> e
unLoc XRec pass (HsType pass)
ty)
      HsQualTy   { hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = XRec pass (HsType pass)
ty }          -> Key -> HsType pass -> IntMap HsDocString
go Key
n (forall l e. GenLocated l e -> e
unLoc XRec pass (HsType pass)
ty)
      HsFunTy XFunTy pass
_ HsArrow pass
_ (forall l e. GenLocated l e -> e
unLoc->HsDocTy XDocTy pass
_ XRec pass (HsType pass)
_ LHsDocString
x) XRec pass (HsType pass)
ty -> forall a. Key -> a -> IntMap a -> IntMap a
IM.insert Key
n (forall l e. GenLocated l e -> e
unLoc LHsDocString
x) forall a b. (a -> b) -> a -> b
$ Key -> HsType pass -> IntMap HsDocString
go (Key
nforall a. Num a => a -> a -> a
+Key
1) (forall l e. GenLocated l e -> e
unLoc XRec pass (HsType pass)
ty)
      HsFunTy XFunTy pass
_ HsArrow pass
_ XRec pass (HsType pass)
_ XRec pass (HsType pass)
ty                      -> Key -> HsType pass -> IntMap HsDocString
go (Key
nforall a. Num a => a -> a -> a
+Key
1) (forall l e. GenLocated l e -> e
unLoc XRec pass (HsType pass)
ty)
      HsDocTy XDocTy pass
_ XRec pass (HsType pass)
_ LHsDocString
doc                       -> forall a. Key -> a -> IntMap a
IM.singleton Key
n (forall l e. GenLocated l e -> e
unLoc LHsDocString
doc)
      HsType pass
_                                     -> forall a. IntMap a
IM.empty

-- | Extract function argument docs from inside types.
sigTypeDocs :: HsSigType GhcRn -> IntMap HsDocString
sigTypeDocs :: HsSigType (GhcPass 'Renamed) -> IntMap HsDocString
sigTypeDocs (HsSig{sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed))
body}) = HsType (GhcPass 'Renamed) -> IntMap HsDocString
typeDocs (forall l e. GenLocated l e -> e
unLoc XRec (GhcPass 'Renamed) (HsType (GhcPass 'Renamed))
body)

-- | The top-level declarations of a module that we care about,
-- ordered by source location, with documentation attached if it exists.
topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
topDecls :: HsGroup (GhcPass 'Renamed)
-> [(LHsDecl (GhcPass 'Renamed), [HsDocString])]
topDecls = forall (p :: Pass) doc.
IsPass p =>
[(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)]
filterClasses forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p doc. UnXRec p => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]
filterDecls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])]
collectDocs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e.
[GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e]
sortLocatedA forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsGroup (GhcPass 'Renamed) -> [LHsDecl (GhcPass 'Renamed)]
ungroup

-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
ungroup :: HsGroup (GhcPass 'Renamed) -> [LHsDecl (GhcPass 'Renamed)]
ungroup HsGroup (GhcPass 'Renamed)
group_ =
  forall struct l decl hsDecl.
(struct -> [GenLocated l decl])
-> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
mkDecls (forall pass. [TyClGroup pass] -> [LTyClDecl pass]
tyClGroupTyClDecls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. HsGroup p -> [TyClGroup p]
hs_tyclds) (forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD NoExtField
noExtField)  HsGroup (GhcPass 'Renamed)
group_ forall a. [a] -> [a] -> [a]
++
  forall struct l decl hsDecl.
(struct -> [GenLocated l decl])
-> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
mkDecls forall p. HsGroup p -> [LDerivDecl p]
hs_derivds             (forall p. XDerivD p -> DerivDecl p -> HsDecl p
DerivD NoExtField
noExtField) HsGroup (GhcPass 'Renamed)
group_ forall a. [a] -> [a] -> [a]
++
  forall struct l decl hsDecl.
(struct -> [GenLocated l decl])
-> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
mkDecls forall p. HsGroup p -> [LDefaultDecl p]
hs_defds               (forall p. XDefD p -> DefaultDecl p -> HsDecl p
DefD NoExtField
noExtField)   HsGroup (GhcPass 'Renamed)
group_ forall a. [a] -> [a] -> [a]
++
  forall struct l decl hsDecl.
(struct -> [GenLocated l decl])
-> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
mkDecls forall p. HsGroup p -> [LForeignDecl p]
hs_fords               (forall p. XForD p -> ForeignDecl p -> HsDecl p
ForD NoExtField
noExtField)   HsGroup (GhcPass 'Renamed)
group_ forall a. [a] -> [a] -> [a]
++
  forall struct l decl hsDecl.
(struct -> [GenLocated l decl])
-> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
mkDecls forall p. HsGroup p -> [LDocDecl p]
hs_docs                (forall p. XDocD p -> DocDecl -> HsDecl p
DocD NoExtField
noExtField)   HsGroup (GhcPass 'Renamed)
group_ forall a. [a] -> [a] -> [a]
++
  forall struct l decl hsDecl.
(struct -> [GenLocated l decl])
-> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
mkDecls (forall pass. [TyClGroup pass] -> [LInstDecl pass]
tyClGroupInstDecls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. HsGroup p -> [TyClGroup p]
hs_tyclds) (forall p. XInstD p -> InstDecl p -> HsDecl p
InstD NoExtField
noExtField)  HsGroup (GhcPass 'Renamed)
group_ forall a. [a] -> [a] -> [a]
++
  forall struct l decl hsDecl.
(struct -> [GenLocated l decl])
-> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
mkDecls (HsValBinds (GhcPass 'Renamed) -> [LSig (GhcPass 'Renamed)]
typesigs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. HsGroup p -> HsValBinds p
hs_valds)  (forall p. XSigD p -> Sig p -> HsDecl p
SigD NoExtField
noExtField)   HsGroup (GhcPass 'Renamed)
group_ forall a. [a] -> [a] -> [a]
++
  forall struct l decl hsDecl.
(struct -> [GenLocated l decl])
-> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
mkDecls (HsValBinds (GhcPass 'Renamed) -> [LHsBind (GhcPass 'Renamed)]
valbinds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. HsGroup p -> HsValBinds p
hs_valds)  (forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
noExtField)   HsGroup (GhcPass 'Renamed)
group_
  where
    typesigs :: HsValBinds GhcRn -> [LSig GhcRn]
    typesigs :: HsValBinds (GhcPass 'Renamed) -> [LSig (GhcPass 'Renamed)]
typesigs (XValBindsLR (NValBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
_ [LSig (GhcPass 'Renamed)]
sig)) = forall a. (a -> Bool) -> [a] -> [a]
filter (forall name. Sig name -> Bool
isUserSig forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LSig (GhcPass 'Renamed)]
sig
    typesigs ValBinds{} = forall a. HasCallStack => [Char] -> a
error [Char]
"expected XValBindsLR"

    valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn]
    valbinds :: HsValBinds (GhcPass 'Renamed) -> [LHsBind (GhcPass 'Renamed)]
valbinds (XValBindsLR (NValBinds [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds [LSig (GhcPass 'Renamed)]
_)) =
      forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Bag a -> [a]
bagToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ [(RecFlag, LHsBinds (GhcPass 'Renamed))]
binds
    valbinds ValBinds{} = forall a. HasCallStack => [Char] -> a
error [Char]
"expected XValBindsLR"

-- | Collect docs and attach them to the right declarations.
--
-- A declaration may have multiple doc strings attached to it.
collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])]
-- ^ This is an example.
collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])]
collectDocs = [HsDocString]
-> Maybe (XRec p (HsDecl p))
-> [XRec p (HsDecl p)]
-> [(XRec p (HsDecl p), [HsDocString])]
go [] forall a. Maybe a
Nothing
  where
    go :: [HsDocString]
-> Maybe (XRec p (HsDecl p))
-> [XRec p (HsDecl p)]
-> [(XRec p (HsDecl p), [HsDocString])]
go [HsDocString]
docs Maybe (XRec p (HsDecl p))
mprev [XRec p (HsDecl p)]
decls = case ([XRec p (HsDecl p)]
decls, Maybe (XRec p (HsDecl p))
mprev) of
      ((forall p a. UnXRec p => XRec p a -> a
unXRec @p -> DocD XDocD p
_ (DocCommentNext HsDocString
s)) : [XRec p (HsDecl p)]
ds, Maybe (XRec p (HsDecl p))
Nothing)   -> [HsDocString]
-> Maybe (XRec p (HsDecl p))
-> [XRec p (HsDecl p)]
-> [(XRec p (HsDecl p), [HsDocString])]
go (HsDocString
sforall a. a -> [a] -> [a]
:[HsDocString]
docs) forall a. Maybe a
Nothing [XRec p (HsDecl p)]
ds
      ((forall p a. UnXRec p => XRec p a -> a
unXRec @p -> DocD XDocD p
_ (DocCommentNext HsDocString
s)) : [XRec p (HsDecl p)]
ds, Just XRec p (HsDecl p)
prev) -> forall {a} {a}. a -> [a] -> [(a, [a])] -> [(a, [a])]
finished XRec p (HsDecl p)
prev [HsDocString]
docs forall a b. (a -> b) -> a -> b
$ [HsDocString]
-> Maybe (XRec p (HsDecl p))
-> [XRec p (HsDecl p)]
-> [(XRec p (HsDecl p), [HsDocString])]
go [HsDocString
s] forall a. Maybe a
Nothing [XRec p (HsDecl p)]
ds
      ((forall p a. UnXRec p => XRec p a -> a
unXRec @p -> DocD XDocD p
_ (DocCommentPrev HsDocString
s)) : [XRec p (HsDecl p)]
ds, Maybe (XRec p (HsDecl p))
mprev)     -> [HsDocString]
-> Maybe (XRec p (HsDecl p))
-> [XRec p (HsDecl p)]
-> [(XRec p (HsDecl p), [HsDocString])]
go (HsDocString
sforall a. a -> [a] -> [a]
:[HsDocString]
docs) Maybe (XRec p (HsDecl p))
mprev [XRec p (HsDecl p)]
ds
      (XRec p (HsDecl p)
d                                  : [XRec p (HsDecl p)]
ds, Maybe (XRec p (HsDecl p))
Nothing)   -> [HsDocString]
-> Maybe (XRec p (HsDecl p))
-> [XRec p (HsDecl p)]
-> [(XRec p (HsDecl p), [HsDocString])]
go [HsDocString]
docs (forall a. a -> Maybe a
Just XRec p (HsDecl p)
d) [XRec p (HsDecl p)]
ds
      (XRec p (HsDecl p)
d                                  : [XRec p (HsDecl p)]
ds, Just XRec p (HsDecl p)
prev) -> forall {a} {a}. a -> [a] -> [(a, [a])] -> [(a, [a])]
finished XRec p (HsDecl p)
prev [HsDocString]
docs forall a b. (a -> b) -> a -> b
$ [HsDocString]
-> Maybe (XRec p (HsDecl p))
-> [XRec p (HsDecl p)]
-> [(XRec p (HsDecl p), [HsDocString])]
go [] (forall a. a -> Maybe a
Just XRec p (HsDecl p)
d) [XRec p (HsDecl p)]
ds
      ([]                                     , Maybe (XRec p (HsDecl p))
Nothing)   -> []
      ([]                                     , Just XRec p (HsDecl p)
prev) -> forall {a} {a}. a -> [a] -> [(a, [a])] -> [(a, [a])]
finished XRec p (HsDecl p)
prev [HsDocString]
docs []

    finished :: a -> [a] -> [(a, [a])] -> [(a, [a])]
finished a
decl [a]
docs [(a, [a])]
rest = (a
decl, forall a. [a] -> [a]
reverse [a]
docs) forall a. a -> [a] -> [a]
: [(a, [a])]
rest

-- | Filter out declarations that we don't handle in Haddock
filterDecls :: forall p doc. UnXRec p => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]
filterDecls :: forall p doc. UnXRec p => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]
filterDecls = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. HsDecl a -> Bool
isHandled forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. UnXRec p => XRec p a -> a
unXRec @p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
  where
    isHandled :: HsDecl name -> Bool
isHandled (ForD XForD name
_ (ForeignImport {})) = Bool
True
    isHandled (TyClD {})  = Bool
True
    isHandled (InstD {})  = Bool
True
    isHandled (DerivD {}) = Bool
True
    isHandled (SigD XSigD name
_ Sig name
d)  = forall name. Sig name -> Bool
isUserSig Sig name
d
    isHandled (ValD {})   = Bool
True
    -- we keep doc declarations to be able to get at named docs
    isHandled (DocD {})   = Bool
True
    isHandled HsDecl name
_ = Bool
False


-- | Go through all class declarations and filter their sub-declarations
filterClasses :: forall p doc. (IsPass p) => [(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)]
filterClasses :: forall (p :: Pass) doc.
IsPass p =>
[(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)]
filterClasses = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc forall {p} {l}.
(XRec p (Sig p) ~ XRec p (Sig p),
 XRec p (Sig p) ~ GenLocated l (Sig p), UnXRec p) =>
HsDecl p -> HsDecl p
filterClass))
  where
    filterClass :: HsDecl p -> HsDecl p
filterClass (TyClD XTyClD p
x c :: TyClDecl p
c@(ClassDecl {})) =
      forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD p
x forall a b. (a -> b) -> a -> b
$ TyClDecl p
c { tcdSigs :: [XRec p (Sig p)]
tcdSigs =
        forall a. (a -> Bool) -> [a] -> [a]
filter (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||) (forall name. Sig name -> Bool
isUserSig forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) forall p. UnXRec p => LSig p -> Bool
isMinimalLSig) (forall pass. TyClDecl pass -> [LSig pass]
tcdSigs TyClDecl p
c) }
    filterClass HsDecl p
d = HsDecl p
d

-- | Was this signature given by the user?
isUserSig :: Sig name -> Bool
isUserSig :: forall name. Sig name -> Bool
isUserSig TypeSig {}    = Bool
True
isUserSig ClassOpSig {} = Bool
True
isUserSig PatSynSig {}  = Bool
True
isUserSig Sig name
_             = Bool
False

-- | Take a field of declarations from a data structure and create HsDecls
-- using the given constructor
mkDecls :: (struct -> [GenLocated l decl])
        -> (decl -> hsDecl)
        -> struct
        -> [GenLocated l hsDecl]
mkDecls :: forall struct l decl hsDecl.
(struct -> [GenLocated l decl])
-> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]
mkDecls struct -> [GenLocated l decl]
field decl -> hsDecl
con = forall a b. (a -> b) -> [a] -> [b]
map (forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc decl -> hsDecl
con) forall b c a. (b -> c) -> (a -> b) -> a -> c
. struct -> [GenLocated l decl]
field

-- | Extracts out individual maps of documentation added via Template Haskell's
-- @putDoc@.
extractTHDocs :: THDocs
              -> ExtractedTHDocs
extractTHDocs :: THDocs -> ExtractedTHDocs
extractTHDocs THDocs
docs =
  -- Split up docs into separate maps for each 'DocLoc' type
  Maybe HsDocString
-> DeclDocMap -> ArgDocMap -> DeclDocMap -> ExtractedTHDocs
ExtractedTHDocs
    Maybe HsDocString
docHeader
    (Map Name HsDocString -> DeclDocMap
DeclDocMap (forall a. Monoid a => (a -> (DocLoc, [Char]) -> a) -> a
searchDocs Map Name HsDocString -> (DocLoc, [Char]) -> Map Name HsDocString
decl))
    (Map Name (IntMap HsDocString) -> ArgDocMap
ArgDocMap (forall a. Monoid a => (a -> (DocLoc, [Char]) -> a) -> a
searchDocs Map Name (IntMap HsDocString)
-> (DocLoc, [Char]) -> Map Name (IntMap HsDocString)
args))
    (Map Name HsDocString -> DeclDocMap
DeclDocMap (forall a. Monoid a => (a -> (DocLoc, [Char]) -> a) -> a
searchDocs Map Name HsDocString -> (DocLoc, [Char]) -> Map Name HsDocString
insts))
  where
    docHeader :: Maybe HsDocString
    docHeader :: Maybe HsDocString
docHeader
      | ((DocLoc
_, [Char]
s):[(DocLoc, [Char])]
_) <- forall a. (a -> Bool) -> [a] -> [a]
filter forall {b}. (DocLoc, b) -> Bool
isModDoc (forall k a. Map k a -> [(k, a)]
M.toList THDocs
docs) = forall a. a -> Maybe a
Just ([Char] -> HsDocString
mkHsDocString [Char]
s)
      | Bool
otherwise = forall a. Maybe a
Nothing

    isModDoc :: (DocLoc, b) -> Bool
isModDoc (DocLoc
ModuleDoc, b
_) = Bool
True
    isModDoc (DocLoc, b)
_ = Bool
False

    -- Folds over the docs, applying 'f' as the accumulating function.
    -- We use different accumulating functions to sift out the specific types of
    -- documentation
    searchDocs :: Monoid a => (a -> (DocLoc, String) -> a) -> a
    searchDocs :: forall a. Monoid a => (a -> (DocLoc, [Char]) -> a) -> a
searchDocs a -> (DocLoc, [Char]) -> a
f = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> (DocLoc, [Char]) -> a
f forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList THDocs
docs

    -- Pick out the declaration docs
    decl :: Map Name HsDocString -> (DocLoc, [Char]) -> Map Name HsDocString
decl Map Name HsDocString
acc ((DeclDoc Name
name), [Char]
s) = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name ([Char] -> HsDocString
mkHsDocString [Char]
s) Map Name HsDocString
acc
    decl Map Name HsDocString
acc (DocLoc, [Char])
_ = Map Name HsDocString
acc

    -- Pick out the instance docs
    insts :: Map Name HsDocString -> (DocLoc, [Char]) -> Map Name HsDocString
insts Map Name HsDocString
acc ((InstDoc Name
name), [Char]
s) = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name ([Char] -> HsDocString
mkHsDocString [Char]
s) Map Name HsDocString
acc
    insts Map Name HsDocString
acc (DocLoc, [Char])
_ = Map Name HsDocString
acc

    -- Pick out the argument docs
    args :: Map Name (IntMap HsDocString)
         -> (DocLoc, String)
         -> Map Name (IntMap HsDocString)
    args :: Map Name (IntMap HsDocString)
-> (DocLoc, [Char]) -> Map Name (IntMap HsDocString)
args Map Name (IntMap HsDocString)
acc ((ArgDoc Name
name Key
i), [Char]
s) =
      -- Insert the doc for the arg into the argument map for the function. This
      -- means we have to search to see if an map already exists for the
      -- function, and insert the new argument if it exists, or create a new map
      let ds :: HsDocString
ds = [Char] -> HsDocString
mkHsDocString [Char]
s
       in forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (\IntMap HsDocString
_ IntMap HsDocString
m -> forall a. Key -> a -> IntMap a -> IntMap a
IM.insert Key
i HsDocString
ds IntMap HsDocString
m) Name
name (forall a. Key -> a -> IntMap a
IM.singleton Key
i HsDocString
ds) Map Name (IntMap HsDocString)
acc
    args Map Name (IntMap HsDocString)
acc (DocLoc, [Char])
_ = Map Name (IntMap HsDocString)
acc

-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two
-- maps with values for the same key merge the inner map as well.
-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.
unionArgMaps :: Map Name (IntMap b)
             -> Map Name (IntMap b)
             -> Map Name (IntMap b)
unionArgMaps :: forall b.
Map Name (IntMap b) -> Map Name (IntMap b) -> Map Name (IntMap b)
unionArgMaps Map Name (IntMap b)
a Map Name (IntMap b)
b = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey forall {k} {a}.
Ord k =>
Map k (IntMap a) -> k -> IntMap a -> Map k (IntMap a)
go Map Name (IntMap b)
b Map Name (IntMap b)
a
  where
    go :: Map k (IntMap a) -> k -> IntMap a -> Map k (IntMap a)
go Map k (IntMap a)
acc k
n IntMap a
newArgMap
      | Just IntMap a
oldArgMap <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
n Map k (IntMap a)
acc =
          forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
n (IntMap a
newArgMap forall a. IntMap a -> IntMap a -> IntMap a
`IM.union` IntMap a
oldArgMap) Map k (IntMap a)
acc
      | Bool
otherwise = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
n IntMap a
newArgMap Map k (IntMap a)
acc