diff options
Diffstat (limited to 'compiler/GHC/Parser/PostProcess/Haddock.hs')
| -rw-r--r-- | compiler/GHC/Parser/PostProcess/Haddock.hs | 80 |
1 files changed, 51 insertions, 29 deletions
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 08bebc4683..271d9db30f 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -67,7 +67,9 @@ import Control.Monad.Trans.Writer import Data.Functor.Identity import qualified Data.Monoid +import {-# SOURCE #-} GHC.Parser (parseIdentifier) import GHC.Parser.Lexer +import GHC.Parser.HaddockLex import GHC.Parser.Errors.Types import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>)) import qualified GHC.Data.Strict as Strict @@ -252,7 +254,8 @@ instance HasHaddock (Located HsModule) where docs <- inLocRange (locRangeTo (getBufPos (srcSpanStart (locA l_name)))) $ takeHdkComments mkDocNext - selectDocString docs + dc <- selectDocString docs + pure $ lexLHsDocString <$> dc -- Step 2, process documentation comments in the export list: -- @@ -292,6 +295,12 @@ instance HasHaddock (Located HsModule) where , hsmodDecls = hsmodDecls' , hsmodHaddockModHeader = join @Maybe headerDocs } +lexHsDocString :: HsDocString -> HsDoc GhcPs +lexHsDocString = lexHsDoc parseIdentifier + +lexLHsDocString :: Located HsDocString -> LHsDoc GhcPs +lexLHsDocString = fmap lexHsDocString + -- Only for module exports, not module imports. -- -- module M (a, b, c) where -- use on this [LIE GhcPs] @@ -700,7 +709,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where con_res_ty' <- addHaddock con_res_ty pure $ L l_con_decl $ ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, - con_doc = con_doc', + con_doc = lexLHsDocString <$> con_doc', con_g_args = con_g_args', con_res_ty = con_res_ty' } ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } -> @@ -711,7 +720,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where ts' <- traverse addHaddockConDeclFieldTy ts pure $ L l_con_decl $ ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, - con_doc = con_doc', + con_doc = lexLHsDocString <$> con_doc', con_args = PrefixCon noTypeArgs ts' } InfixCon t1 t2 -> do t1' <- addHaddockConDeclFieldTy t1 @@ -719,14 +728,14 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where t2' <- addHaddockConDeclFieldTy t2 pure $ L l_con_decl $ ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, - con_doc = con_doc', + con_doc = lexLHsDocString <$> con_doc', con_args = InfixCon t1' t2' } RecCon (L l_rec flds) -> do con_doc' <- getConDoc (getLocA con_name) flds' <- traverse addHaddockConDeclField flds pure $ L l_con_decl $ ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, - con_doc = con_doc', + con_doc = lexLHsDocString <$> con_doc', con_args = RecCon (L l_rec flds') } -- Keep track of documentation comments on the data constructor or any of its @@ -768,7 +777,7 @@ discardHasInnerDocs = fmap fst . runWriterT -- data/newtype declaration. getConDoc :: SrcSpan -- Location of the data constructor - -> ConHdkA (Maybe LHsDocString) + -> ConHdkA (Maybe (Located HsDocString)) getConDoc l = WriterT $ extendHdkA l $ liftHdkA $ do mDoc <- getPrevNextDoc l @@ -792,7 +801,7 @@ addHaddockConDeclField -> ConHdkA (LConDeclField GhcPs) addHaddockConDeclField (L l_fld fld) = WriterT $ extendHdkA (locA l_fld) $ liftHdkA $ do - cd_fld_doc <- getPrevNextDoc (locA l_fld) + cd_fld_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld) return (L l_fld (fld { cd_fld_doc }), HasInnerDocs (isJust cd_fld_doc)) @@ -861,7 +870,7 @@ addConTrailingDoc l_sep = x <$ reportExtraDocs trailingDocs mk_doc_fld (L l' con_fld) = do doc <- selectDocString trailingDocs - return $ L l' (con_fld { cd_fld_doc = doc }) + return $ L l' (con_fld { cd_fld_doc = fmap lexLHsDocString doc }) con_args' <- case con_args con_decl of x@(PrefixCon _ []) -> x <$ reportExtraDocs trailingDocs x@(RecCon (L _ [])) -> x <$ reportExtraDocs trailingDocs @@ -872,7 +881,7 @@ addConTrailingDoc l_sep = return (RecCon (L l_rec flds')) return $ L l (con_decl{ con_args = con_args' }) else do - con_doc' <- selectDocString (con_doc con_decl `mcons` trailingDocs) + con_doc' <- selectDoc (con_doc con_decl `mcons` (map lexLHsDocString trailingDocs)) return $ L l (con_decl{ con_doc = con_doc' }) _ -> panic "addConTrailingDoc: non-H98 ConDecl" @@ -1196,7 +1205,7 @@ data HdkSt = -- | Warnings accumulated in HdkM. data HdkWarn = HdkWarnInvalidComment (PsLocated HdkComment) - | HdkWarnExtraComment LHsDocString + | HdkWarnExtraComment (Located HsDocString) -- Restrict the range in which a HdkM computation will look up comments: -- @@ -1238,8 +1247,7 @@ takeHdkComments f = (items, other_comments) = foldr add_comment ([], []) comments_in_range remaining_comments = comments_before_range ++ other_comments ++ comments_after_range hdk_st' = hdk_st{ hdk_st_pending = remaining_comments } - in - (items, hdk_st') + in (items, hdk_st') where is_after StartOfFile _ = True is_after (StartLoc l) (L l_comment _) = bufSpanStart (psBufSpan l_comment) >= l @@ -1257,7 +1265,7 @@ takeHdkComments f = Nothing -> (items, hdk_comment : 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 (Located HsDocString)) getPrevNextDoc l = do let (l_start, l_end) = (srcSpanStart l, srcSpanEnd l) before_t = locRangeTo (getBufPos l_start) @@ -1271,7 +1279,7 @@ appendHdkWarning e = HdkM $ \_ hdk_st -> let hdk_st' = hdk_st { hdk_st_warnings = e : hdk_st_warnings hdk_st } in ((), hdk_st') -selectDocString :: [LHsDocString] -> HdkM (Maybe LHsDocString) +selectDocString :: [Located HsDocString] -> HdkM (Maybe (Located HsDocString)) selectDocString = select . filterOut (isEmptyDocString . unLoc) where select [] = return Nothing @@ -1280,7 +1288,16 @@ selectDocString = select . filterOut (isEmptyDocString . unLoc) reportExtraDocs extra_docs return (Just doc) -reportExtraDocs :: [LHsDocString] -> HdkM () +selectDoc :: forall a. [LHsDoc a] -> HdkM (Maybe (LHsDoc a)) +selectDoc = select . filterOut (isEmptyDocString . hsDocString . unLoc) + where + select [] = return Nothing + select [doc] = return (Just doc) + select (doc : extra_docs) = do + reportExtraDocs $ map (\(L l d) -> L l $ hsDocString d) extra_docs + return (Just doc) + +reportExtraDocs :: [Located HsDocString] -> HdkM () reportExtraDocs = traverse_ (\extra_doc -> appendHdkWarning (HdkWarnExtraComment extra_doc)) @@ -1297,13 +1314,14 @@ mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) mkDocDecl layout_info (L l_comment hdk_comment) | indent_mismatch = Nothing | otherwise = - Just $ L (noAnnSrcSpan $ mkSrcSpanPs l_comment) $ + Just $ L (noAnnSrcSpan span) $ case hdk_comment of - HdkCommentNext doc -> DocCommentNext doc - HdkCommentPrev doc -> DocCommentPrev doc - HdkCommentNamed s doc -> DocCommentNamed s doc - HdkCommentSection n doc -> DocGroup n doc + HdkCommentNext doc -> DocCommentNext (L span $ lexHsDocString doc) + HdkCommentPrev doc -> DocCommentPrev (L span $ lexHsDocString doc) + HdkCommentNamed s doc -> DocCommentNamed s (L span $ lexHsDocString doc) + HdkCommentSection n doc -> DocGroup n (L span $ lexHsDocString doc) where + span = mkSrcSpanPs l_comment -- 'indent_mismatch' checks if the documentation comment has the exact -- indentation level expected by the parent node. -- @@ -1332,18 +1350,19 @@ mkDocDecl layout_info (L l_comment hdk_comment) mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) mkDocIE (L l_comment hdk_comment) = case hdk_comment of - HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n doc) + HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n $ L span $ lexHsDocString doc) HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s) - HdkCommentNext doc -> Just $ L l (IEDoc noExtField doc) + HdkCommentNext doc -> Just $ L l (IEDoc noExtField $ L span $ lexHsDocString doc) _ -> Nothing - where l = noAnnSrcSpan $ mkSrcSpanPs l_comment + where l = noAnnSrcSpan span + span = mkSrcSpanPs l_comment -mkDocNext :: PsLocated HdkComment -> Maybe LHsDocString -mkDocNext (L l (HdkCommentNext doc)) = Just $ L (mkSrcSpanPs l) doc +mkDocNext :: PsLocated HdkComment -> Maybe (Located HsDocString) +mkDocNext (L l (HdkCommentNext doc)) = Just (L (mkSrcSpanPs l) doc) mkDocNext _ = Nothing -mkDocPrev :: PsLocated HdkComment -> Maybe LHsDocString -mkDocPrev (L l (HdkCommentPrev doc)) = Just $ L (mkSrcSpanPs l) doc +mkDocPrev :: PsLocated HdkComment -> Maybe (Located HsDocString) +mkDocPrev (L l (HdkCommentPrev doc)) = Just (L (mkSrcSpanPs l) doc) mkDocPrev _ = Nothing @@ -1396,6 +1415,7 @@ locRangeTo Strict.Nothing = mempty -- We'd rather only do the (>=40) check. So we reify the predicate to make -- sure we only check for the most restrictive bound. data LowerLocBound = StartOfFile | StartLoc !BufPos + deriving Show instance Semigroup LowerLocBound where StartOfFile <> l = l @@ -1424,6 +1444,7 @@ instance Monoid LowerLocBound where -- We'd rather only do the (<=20) check. So we reify the predicate to make -- sure we only check for the most restrictive bound. data UpperLocBound = EndOfFile | EndLoc !BufPos + deriving Show instance Semigroup UpperLocBound where EndOfFile <> l = l @@ -1442,6 +1463,7 @@ instance Monoid UpperLocBound where -- The semigroup instance corresponds to (&&). -- newtype ColumnBound = ColumnFrom Int -- n >= GHC.Types.SrcLoc.leftmostColumn + deriving Show instance Semigroup ColumnBound where ColumnFrom n <> ColumnFrom m = ColumnFrom (max n m) @@ -1456,9 +1478,9 @@ instance Monoid ColumnBound where * * ********************************************************************* -} -mkLHsDocTy :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs +mkLHsDocTy :: LHsType GhcPs -> Maybe (Located HsDocString) -> LHsType GhcPs mkLHsDocTy t Nothing = t -mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t doc) +mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t $ lexLHsDocString doc) getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan getForAllTeleLoc tele = |