never executed always true always false
    1 -- | Extract docs from the renamer output so they can be serialized.
    2 {-# LANGUAGE LambdaCase #-}
    3 {-# LANGUAGE RankNTypes #-}
    4 {-# LANGUAGE TypeApplications #-}
    5 {-# LANGUAGE ScopedTypeVariables #-}
    6 {-# LANGUAGE TypeFamilies #-}
    7 {-# LANGUAGE FlexibleContexts #-}
    8 {-# LANGUAGE ViewPatterns #-}
    9 {-# LANGUAGE BangPatterns #-}
   10 
   11 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
   12 
   13 module GHC.HsToCore.Docs where
   14 
   15 import GHC.Prelude
   16 import GHC.Data.Bag
   17 import GHC.Hs.Binds
   18 import GHC.Hs.Doc
   19 import GHC.Hs.Decls
   20 import Language.Haskell.Syntax.Extension
   21 import GHC.Hs.Extension
   22 import GHC.Hs.Type
   23 import GHC.Hs.Utils
   24 import GHC.Types.Name
   25 import GHC.Types.Name.Set
   26 import GHC.Types.SrcLoc
   27 import GHC.Tc.Types
   28 import GHC.Parser.Annotation
   29 
   30 import Control.Applicative
   31 import Control.Monad.IO.Class
   32 import Data.Bifunctor (first)
   33 import Data.IntMap (IntMap)
   34 import qualified Data.IntMap as IM
   35 import Data.Map (Map)
   36 import qualified Data.Map as M
   37 import Data.Maybe
   38 import Data.Semigroup
   39 import GHC.IORef (readIORef)
   40 
   41 -- | Extract docs from renamer output.
   42 -- This is monadic since we need to be able to read documentation added from
   43 -- Template Haskell's @putDoc@, which is stored in 'tcg_th_docs'.
   44 extractDocs :: MonadIO m
   45             => TcGblEnv
   46             -> m (Maybe HsDocString, DeclDocMap, ArgDocMap)
   47             -- ^
   48             -- 1. Module header
   49             -- 2. Docs on top level declarations
   50             -- 3. Docs on arguments
   51 extractDocs TcGblEnv { tcg_semantic_mod = mod
   52                      , tcg_rn_decls = mb_rn_decls
   53                      , tcg_insts = insts
   54                      , tcg_fam_insts = fam_insts
   55                      , tcg_doc_hdr = mb_doc_hdr
   56                      , tcg_th_docs = th_docs_var
   57                      } = do
   58     th_docs <- liftIO $ readIORef th_docs_var
   59     let doc_hdr = th_doc_hdr <|> (unLoc <$> mb_doc_hdr)
   60         ExtractedTHDocs
   61           th_doc_hdr
   62           (DeclDocMap th_doc_map)
   63           (ArgDocMap th_arg_map)
   64           (DeclDocMap th_inst_map) = extractTHDocs th_docs
   65     return
   66       ( doc_hdr
   67       , DeclDocMap (th_doc_map <> th_inst_map <> doc_map)
   68       , ArgDocMap (th_arg_map `unionArgMaps` arg_map)
   69       )
   70   where
   71     (doc_map, arg_map) = maybe (M.empty, M.empty)
   72                                (mkMaps local_insts)
   73                                mb_decls_with_docs
   74     mb_decls_with_docs = topDecls <$> mb_rn_decls
   75     local_insts = filter (nameIsLocalOrFrom mod)
   76                          $ map getName insts ++ map getName fam_insts
   77 
   78 -- | Create decl and arg doc-maps by looping through the declarations.
   79 -- For each declaration, find its names, its subordinates, and its doc strings.
   80 mkMaps :: [Name]
   81        -> [(LHsDecl GhcRn, [HsDocString])]
   82        -> (Map Name (HsDocString), Map Name (IntMap HsDocString))
   83 mkMaps instances decls =
   84     ( f' (map (nubByName fst) decls')
   85     , f  (filterMapping (not . IM.null) args)
   86     )
   87   where
   88     (decls', args) = unzip (map mappings decls)
   89 
   90     f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b
   91     f = M.fromListWith (<>) . concat
   92 
   93     f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString
   94     f' = M.fromListWith appendDocs . concat
   95 
   96     filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]
   97     filterMapping p = map (filter (p . snd))
   98 
   99     mappings :: (LHsDecl GhcRn, [HsDocString])
  100              -> ( [(Name, HsDocString)]
  101                 , [(Name, IntMap HsDocString)]
  102                 )
  103     mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, docStrs) =
  104            (dm, am)
  105       where
  106         doc = concatDocs docStrs
  107         args = declTypeDocs decl
  108 
  109         subs :: [(Name, [HsDocString], IntMap HsDocString)]
  110         subs = subordinates instanceMap decl
  111 
  112         (subDocs, subArgs) =
  113           unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs)
  114 
  115         ns = names l decl
  116         subNs = [ n | (n, _, _) <- subs ]
  117         dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]
  118         am = [(n, args) | n <- ns] ++ zip subNs subArgs
  119     mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], [])
  120 
  121     instanceMap :: Map RealSrcSpan Name
  122     instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]
  123 
  124     names :: RealSrcSpan -> HsDecl GhcRn -> [Name]
  125     names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap
  126     names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].
  127     names _ decl = getMainDeclBinder decl
  128 
  129 {-
  130 Note [1]:
  131 ---------
  132 We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
  133 inside them. That should work for normal user-written instances (from
  134 looking at GHC sources). We can assume that commented instances are
  135 user-written. This lets us relate Names (from ClsInsts) to comments
  136 (associated with InstDecls and DerivDecls).
  137 -}
  138 getMainDeclBinder :: (Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p))
  139                   => HsDecl (GhcPass p) -> [IdP (GhcPass p)]
  140 getMainDeclBinder (TyClD _ d) = [tcdName d]
  141 getMainDeclBinder (ValD _ d) =
  142   case collectHsBindBinders CollNoDictBinders d of
  143     []       -> []
  144     (name:_) -> [name]
  145 getMainDeclBinder (SigD _ d) = sigNameNoLoc d
  146 getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
  147 getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
  148 getMainDeclBinder _ = []
  149 
  150 
  151 sigNameNoLoc :: forall pass. UnXRec pass => Sig pass -> [IdP pass]
  152 sigNameNoLoc (TypeSig    _   ns _)         = map (unXRec @pass) ns
  153 sigNameNoLoc (ClassOpSig _ _ ns _)         = map (unXRec @pass) ns
  154 sigNameNoLoc (PatSynSig  _   ns _)         = map (unXRec @pass) ns
  155 sigNameNoLoc (SpecSig    _   n _ _)        = [unXRec @pass n]
  156 sigNameNoLoc (InlineSig  _   n _)          = [unXRec @pass n]
  157 sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @pass) ns
  158 sigNameNoLoc _                             = []
  159 
  160 -- Extract the source location where an instance is defined. This is used
  161 -- to correlate InstDecls with their Instance/CoAxiom Names, via the
  162 -- instanceMap.
  163 getInstLoc :: Anno (IdGhcP p) ~ SrcSpanAnnN => InstDecl (GhcPass p) -> SrcSpan
  164 getInstLoc = \case
  165   ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLocA ty
  166   -- The Names of data and type family instances have their SrcSpan's attached
  167   -- to the *type constructor*. For example, the Name "D:R:Foo:Int" would have
  168   -- its SrcSpan attached here:
  169   --   type family Foo a
  170   --   type instance Foo Int = Bool
  171   --                 ^^^
  172   DataFamInstD _ (DataFamInstDecl
  173     { dfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l
  174   -- Since CoAxioms' Names refer to the whole line for type family instances
  175   -- in particular, we need to dig a bit deeper to pull out the entire
  176   -- equation. This does not happen for data family instances, for some reason.
  177   TyFamInstD _ (TyFamInstDecl
  178     { tfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l
  179 
  180 -- | Get all subordinate declarations inside a declaration, and their docs.
  181 -- A subordinate declaration is something like the associate type or data
  182 -- family of a type class.
  183 subordinates :: Map RealSrcSpan Name
  184              -> HsDecl GhcRn
  185              -> [(Name, [HsDocString], IntMap HsDocString)]
  186 subordinates instMap decl = case decl of
  187   InstD _ (ClsInstD _ d) -> do
  188     DataFamInstDecl { dfid_eqn =
  189       FamEqn { feqn_tycon = L l _
  190              , feqn_rhs   = defn }} <- unLoc <$> cid_datafam_insts d
  191     [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn
  192 
  193   InstD _ (DataFamInstD _ (DataFamInstDecl d))
  194     -> dataSubs (feqn_rhs d)
  195   TyClD _ d | isClassDecl d -> classSubs d
  196             | isDataDecl  d -> dataSubs (tcdDataDefn d)
  197   _ -> []
  198   where
  199     classSubs dd = [ (name, doc, declTypeDocs d)
  200                    | (L _ d, doc) <- classDecls dd
  201                    , name <- getMainDeclBinder d, not (isValD d)
  202                    ]
  203     dataSubs :: HsDataDefn GhcRn
  204              -> [(Name, [HsDocString], IntMap HsDocString)]
  205     dataSubs dd = constrs ++ fields ++ derivs
  206       where
  207         cons = map unLoc $ (dd_cons dd)
  208         constrs = [ ( unLoc cname
  209                     , maybeToList $ fmap unLoc $ con_doc c
  210                     , conArgDocs c)
  211                   | c <- cons, cname <- getConNames c ]
  212         fields  = [ (foExt n, maybeToList $ fmap unLoc doc, IM.empty)
  213                   | Just flds <- map getRecConArgs_maybe cons
  214                   , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
  215                   , (L _ n) <- ns ]
  216         derivs  = [ (instName, [unLoc doc], IM.empty)
  217                   | (l, doc) <- concatMap (extract_deriv_clause_tys .
  218                                            deriv_clause_tys . unLoc) $
  219                                 -- unLoc $ dd_derivs dd
  220                                 dd_derivs dd
  221                   , Just instName <- [lookupSrcSpan l instMap] ]
  222 
  223         extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDocString)]
  224         extract_deriv_clause_tys (L _ dct) =
  225           case dct of
  226             DctSingle _ ty -> maybeToList $ extract_deriv_ty ty
  227             DctMulti _ tys -> mapMaybe extract_deriv_ty tys
  228 
  229         extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString)
  230         extract_deriv_ty (L l (HsSig{sig_body = L _ ty})) =
  231           case ty of
  232             -- deriving (C a {- ^ Doc comment -})
  233             HsDocTy _ _ doc -> Just (locA l, doc)
  234             _               -> Nothing
  235 
  236 -- | Extract constructor argument docs from inside constructor decls.
  237 conArgDocs :: ConDecl GhcRn -> IntMap HsDocString
  238 conArgDocs (ConDeclH98{con_args = args}) =
  239   h98ConArgDocs args
  240 conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =
  241   gadtConArgDocs args (unLoc res_ty)
  242 
  243 h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap HsDocString
  244 h98ConArgDocs con_args = case con_args of
  245   PrefixCon _ args   -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args
  246   InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)
  247                                        , unLoc (hsScaledThing arg2) ]
  248   RecCon _           -> IM.empty
  249 
  250 gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString
  251 gadtConArgDocs con_args res_ty = case con_args of
  252   PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]
  253   RecConGADT _ _     -> con_arg_docs 1 [res_ty]
  254 
  255 con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString
  256 con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..]
  257   where
  258     f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
  259     f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)
  260     f _ _ = Nothing
  261 
  262 isValD :: HsDecl a -> Bool
  263 isValD (ValD _ _) = True
  264 isValD _ = False
  265 
  266 -- | All the sub declarations of a class (that we handle), ordered by
  267 -- source location, with documentation attached if it exists.
  268 classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
  269 classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls
  270   where
  271     decls = docs ++ defs ++ sigs ++ ats
  272     docs  = mkDecls tcdDocs (DocD noExtField) class_
  273     defs  = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_
  274     sigs  = mkDecls tcdSigs (SigD noExtField) class_
  275     ats   = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_
  276 
  277 -- | Extract function argument docs from inside top-level decls.
  278 declTypeDocs :: HsDecl GhcRn -> IntMap (HsDocString)
  279 declTypeDocs = \case
  280   SigD  _ (TypeSig _ _ ty)          -> sigTypeDocs (unLoc (dropWildCards ty))
  281   SigD  _ (ClassOpSig _ _ _ ty)     -> sigTypeDocs (unLoc ty)
  282   SigD  _ (PatSynSig _ _ ty)        -> sigTypeDocs (unLoc ty)
  283   ForD  _ (ForeignImport _ _ ty _)  -> sigTypeDocs (unLoc ty)
  284   TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)
  285   _                                 -> IM.empty
  286 
  287 nubByName :: (a -> Name) -> [a] -> [a]
  288 nubByName f ns = go emptyNameSet ns
  289   where
  290     go _ [] = []
  291     go s (x:xs)
  292       | y `elemNameSet` s = go s xs
  293       | otherwise         = let !s' = extendNameSet s y
  294                             in x : go s' xs
  295       where
  296         y = f x
  297 
  298 -- | Extract function argument docs from inside types.
  299 typeDocs :: HsType GhcRn -> IntMap HsDocString
  300 typeDocs = go 0
  301   where
  302     go n = \case
  303       HsForAllTy { hst_body = ty }          -> go n (unLoc ty)
  304       HsQualTy   { hst_body = ty }          -> go n (unLoc ty)
  305       HsFunTy _ _ (unLoc->HsDocTy _ _ x) ty -> IM.insert n (unLoc x) $ go (n+1) (unLoc ty)
  306       HsFunTy _ _ _ ty                      -> go (n+1) (unLoc ty)
  307       HsDocTy _ _ doc                       -> IM.singleton n (unLoc doc)
  308       _                                     -> IM.empty
  309 
  310 -- | Extract function argument docs from inside types.
  311 sigTypeDocs :: HsSigType GhcRn -> IntMap HsDocString
  312 sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body)
  313 
  314 -- | The top-level declarations of a module that we care about,
  315 -- ordered by source location, with documentation attached if it exists.
  316 topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
  317 topDecls = filterClasses . filterDecls . collectDocs . sortLocatedA . ungroup
  318 
  319 -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
  320 ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
  321 ungroup group_ =
  322   mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField)  group_ ++
  323   mkDecls hs_derivds             (DerivD noExtField) group_ ++
  324   mkDecls hs_defds               (DefD noExtField)   group_ ++
  325   mkDecls hs_fords               (ForD noExtField)   group_ ++
  326   mkDecls hs_docs                (DocD noExtField)   group_ ++
  327   mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField)  group_ ++
  328   mkDecls (typesigs . hs_valds)  (SigD noExtField)   group_ ++
  329   mkDecls (valbinds . hs_valds)  (ValD noExtField)   group_
  330   where
  331     typesigs :: HsValBinds GhcRn -> [LSig GhcRn]
  332     typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig
  333     typesigs ValBinds{} = error "expected XValBindsLR"
  334 
  335     valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn]
  336     valbinds (XValBindsLR (NValBinds binds _)) =
  337       concatMap bagToList . snd . unzip $ binds
  338     valbinds ValBinds{} = error "expected XValBindsLR"
  339 
  340 -- | Collect docs and attach them to the right declarations.
  341 --
  342 -- A declaration may have multiple doc strings attached to it.
  343 collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])]
  344 -- ^ This is an example.
  345 collectDocs = go [] Nothing
  346   where
  347     go docs mprev decls = case (decls, mprev) of
  348       ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing)   -> go (s:docs) Nothing ds
  349       ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds
  350       ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev)     -> go (s:docs) mprev ds
  351       (d                                  : ds, Nothing)   -> go docs (Just d) ds
  352       (d                                  : ds, Just prev) -> finished prev docs $ go [] (Just d) ds
  353       ([]                                     , Nothing)   -> []
  354       ([]                                     , Just prev) -> finished prev docs []
  355 
  356     finished decl docs rest = (decl, reverse docs) : rest
  357 
  358 -- | Filter out declarations that we don't handle in Haddock
  359 filterDecls :: forall p doc. UnXRec p => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]
  360 filterDecls = filter (isHandled . unXRec @p . fst)
  361   where
  362     isHandled (ForD _ (ForeignImport {})) = True
  363     isHandled (TyClD {})  = True
  364     isHandled (InstD {})  = True
  365     isHandled (DerivD {}) = True
  366     isHandled (SigD _ d)  = isUserSig d
  367     isHandled (ValD {})   = True
  368     -- we keep doc declarations to be able to get at named docs
  369     isHandled (DocD {})   = True
  370     isHandled _ = False
  371 
  372 
  373 -- | Go through all class declarations and filter their sub-declarations
  374 filterClasses :: forall p doc. (IsPass p) => [(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)]
  375 filterClasses = map (first (mapLoc filterClass))
  376   where
  377     filterClass (TyClD x c@(ClassDecl {})) =
  378       TyClD x $ c { tcdSigs =
  379         filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }
  380     filterClass d = d
  381 
  382 -- | Was this signature given by the user?
  383 isUserSig :: Sig name -> Bool
  384 isUserSig TypeSig {}    = True
  385 isUserSig ClassOpSig {} = True
  386 isUserSig PatSynSig {}  = True
  387 isUserSig _             = False
  388 
  389 -- | Take a field of declarations from a data structure and create HsDecls
  390 -- using the given constructor
  391 mkDecls :: (struct -> [GenLocated l decl])
  392         -> (decl -> hsDecl)
  393         -> struct
  394         -> [GenLocated l hsDecl]
  395 mkDecls field con = map (mapLoc con) . field
  396 
  397 -- | Extracts out individual maps of documentation added via Template Haskell's
  398 -- @putDoc@.
  399 extractTHDocs :: THDocs
  400               -> ExtractedTHDocs
  401 extractTHDocs docs =
  402   -- Split up docs into separate maps for each 'DocLoc' type
  403   ExtractedTHDocs
  404     docHeader
  405     (DeclDocMap (searchDocs decl))
  406     (ArgDocMap (searchDocs args))
  407     (DeclDocMap (searchDocs insts))
  408   where
  409     docHeader :: Maybe HsDocString
  410     docHeader
  411       | ((_, s):_) <- filter isModDoc (M.toList docs) = Just (mkHsDocString s)
  412       | otherwise = Nothing
  413 
  414     isModDoc (ModuleDoc, _) = True
  415     isModDoc _ = False
  416 
  417     -- Folds over the docs, applying 'f' as the accumulating function.
  418     -- We use different accumulating functions to sift out the specific types of
  419     -- documentation
  420     searchDocs :: Monoid a => (a -> (DocLoc, String) -> a) -> a
  421     searchDocs f = foldl' f mempty $ M.toList docs
  422 
  423     -- Pick out the declaration docs
  424     decl acc ((DeclDoc name), s) = M.insert name (mkHsDocString s) acc
  425     decl acc _ = acc
  426 
  427     -- Pick out the instance docs
  428     insts acc ((InstDoc name), s) = M.insert name (mkHsDocString s) acc
  429     insts acc _ = acc
  430 
  431     -- Pick out the argument docs
  432     args :: Map Name (IntMap HsDocString)
  433          -> (DocLoc, String)
  434          -> Map Name (IntMap HsDocString)
  435     args acc ((ArgDoc name i), s) =
  436       -- Insert the doc for the arg into the argument map for the function. This
  437       -- means we have to search to see if an map already exists for the
  438       -- function, and insert the new argument if it exists, or create a new map
  439       let ds = mkHsDocString s
  440        in M.insertWith (\_ m -> IM.insert i ds m) name (IM.singleton i ds) acc
  441     args acc _ = acc
  442 
  443 -- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two
  444 -- maps with values for the same key merge the inner map as well.
  445 -- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.
  446 unionArgMaps :: Map Name (IntMap b)
  447              -> Map Name (IntMap b)
  448              -> Map Name (IntMap b)
  449 unionArgMaps a b = M.foldlWithKey go b a
  450   where
  451     go acc n newArgMap
  452       | Just oldArgMap <- M.lookup n acc =
  453           M.insert n (newArgMap `IM.union` oldArgMap) acc
  454       | otherwise = M.insert n newArgMap acc