From b91798be48d9fa02610b419ccea15a7dfd663823 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 12 Mar 2022 00:07:56 +0000 Subject: hi haddock: Lex and store haddock docs in interface files Names appearing in Haddock docstrings are lexed and renamed like any other names appearing in the AST. We currently rename names irrespective of the namespace, so both type and constructor names corresponding to an identifier will appear in the docstring. Haddock will select a given name as the link destination based on its own heuristics. This patch also restricts the limitation of `-haddock` being incompatible with `Opt_KeepRawTokenStream`. The export and documenation structure is now computed in GHC and serialised in .hi files. This can be used by haddock to directly generate doc pages without reparsing or renaming the source. At the moment the operation of haddock is not modified, that's left to a future patch. Updates the haddock submodule with the minimum changes needed. --- utils/check-exact/ExactPrint.hs | 53 +++++++++++++++++++++++++---------------- utils/check-exact/Main.hs | 5 ---- utils/check-exact/Transform.hs | 26 ++++++++++---------- utils/check-exact/Utils.hs | 5 +--- 4 files changed, 47 insertions(+), 42 deletions(-) (limited to 'utils/check-exact') diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 3b6a0ba148..67aa1f280d 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -43,7 +43,7 @@ import Control.Monad.RWS import Data.Data ( Data ) import Data.Foldable import Data.Typeable -import Data.List ( partition, sort, sortBy) +import Data.List ( partition, sortBy) import Data.List.NonEmpty ( NonEmpty ) import Data.Maybe ( isJust ) @@ -52,6 +52,7 @@ import Data.Void import Lookup import Utils import Types +import Data.Ord -- import Debug.Trace @@ -586,7 +587,7 @@ markAnnKw (EpAnn _ a _) f kw = markKwA kw (f a) markAnnKwAll :: EpAnn a -> (a -> [EpaLocation]) -> AnnKeywordId -> EPP () markAnnKwAll EpAnnNotUsed _ _ = return () -markAnnKwAll (EpAnn _ a _) f kw = mapM_ (markKwA kw) (sort (f a)) +markAnnKwAll (EpAnn _ a _) f kw = mapM_ (markKwA kw) (sortBy (comparing unsafeGetEpaLoc) (f a)) markAnnKwM :: EpAnn a -> (a -> Maybe EpaLocation) -> AnnKeywordId -> EPP () markAnnKwM EpAnnNotUsed _ _ = return () @@ -609,12 +610,20 @@ markEpAnn' (EpAnn _ a _) f kw = mark (f a) kw markEpAnnAll :: EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP () markEpAnnAll EpAnnNotUsed _ _ = return () -markEpAnnAll (EpAnn _ a _) f kw = mapM_ markKw (sort anns) +markEpAnnAll (EpAnn _ a _) f kw = mapM_ markKw (sortBy (comparing unsafeGetEpAnnLoc) anns) where anns = filter (\(AddEpAnn ka _) -> ka == kw) (f a) +unsafeGetEpAnnLoc :: AddEpAnn -> RealSrcSpan +unsafeGetEpAnnLoc (AddEpAnn _ ss) = unsafeGetEpaLoc ss + + +unsafeGetEpaLoc :: EpaLocation -> RealSrcSpan +unsafeGetEpaLoc (EpaSpan real) = real +unsafeGetEpaLoc (EpaDelta _ _) = error "DELTA" + markAnnAll :: [AddEpAnn] -> AnnKeywordId -> EPP () -markAnnAll a kw = mapM_ markKw (sort anns) +markAnnAll a kw = mapM_ markKw (sortBy (comparing unsafeGetEpAnnLoc) anns) where anns = filter (\(AddEpAnn ka _) -> ka == kw) a @@ -658,7 +667,7 @@ markAnnList' reallyTrail ann action = do debugM $ "markAnnList : " ++ showPprUnsafe (p, ann) mapM_ markAddEpAnn (al_open ann) unless reallyTrail $ markTrailing (al_trailing ann) -- Only makes sense for HsModule. - markAnnAll (sort $ al_rest ann) AnnSemi + markAnnAll (sortBy (comparing unsafeGetEpAnnLoc) $ al_rest ann) AnnSemi action mapM_ markAddEpAnn (al_close ann) debugM $ "markAnnList: calling markTrailing with:" ++ showPprUnsafe (al_trailing ann) @@ -731,7 +740,7 @@ instance ExactPrint ModuleName where -- --------------------------------------------------------------------- -instance ExactPrint (LocatedP WarningTxt) where +instance ExactPrint (LocatedP (WarningTxt GhcPs)) where getAnnotationEntry = entryFromLocatedA exact (L (SrcSpanAnn an _) (WarningTxt (L _ src) ws)) = do markAnnOpenP an src "{-# WARNING" @@ -798,7 +807,11 @@ instance ExactPrint (ImportDecl GhcPs) where instance ExactPrint HsDocString where getAnnotationEntry _ = NoEntryVal - exact = withPpr -- TODO:AZ use annotations + exact = printStringAdvance . exactPrintHsDocString + +instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where + getAnnotationEntry _ = NoEntryVal + exact = exact . hsDocString -- --------------------------------------------------------------------- @@ -1088,18 +1101,14 @@ instance ExactPrint (SpliceDecl GhcPs) where -- --------------------------------------------------------------------- -instance ExactPrint DocDecl where +instance ExactPrint (DocDecl GhcPs) where getAnnotationEntry = const NoEntryVal - exact v = - let str = - case v of - (DocCommentNext ds) -> unpackHDS ds - (DocCommentPrev ds) -> unpackHDS ds - (DocCommentNamed _s ds) -> unpackHDS ds - (DocGroup _i ds) -> unpackHDS ds - in - printStringAdvance str + exact v = case v of + (DocCommentNext ds) -> exact ds + (DocCommentPrev ds) -> exact ds + (DocCommentNamed _s ds) -> exact ds + (DocGroup _i ds) -> exact ds -- --------------------------------------------------------------------- @@ -3044,9 +3053,9 @@ instance (ExactPrint a) => ExactPrint (LocatedC a) where -- Just (UnicodeSyntax, rs) -> markKw' AnnDarrowU rs -- Just (NormalSyntax, rs) -> markKw' AnnDarrow rs -- Nothing -> pure () - mapM_ (markKwA AnnOpenP) (sort opens) + mapM_ (markKwA AnnOpenP) (sortBy (comparing unsafeGetEpaLoc) opens) markAnnotated a - mapM_ (markKwA AnnCloseP) (sort closes) + mapM_ (markKwA AnnCloseP) (sortBy (comparing unsafeGetEpaLoc) closes) case ma of Just (UnicodeSyntax, r) -> markKwA AnnDarrowU r Just (NormalSyntax, r) -> markKwA AnnDarrow r @@ -3136,7 +3145,11 @@ markTrailing :: [TrailingAnn] -> EPP () markTrailing ts = do p <- getPosP debugM $ "markTrailing:" ++ showPprUnsafe (p,ts) - mapM_ markKwT (sort ts) + mapM_ markKwT (sortBy (comparing (unsafeGetEpaLoc . k)) ts) + where + k (AddSemiAnn l) = l + k (AddCommaAnn l) = l + k (AddVbarAnn l) = l -- --------------------------------------------------------------------- diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index f0617f3bfc..d170e5e945 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -32,8 +32,6 @@ import Parsers import GHC.Parser.Lexer import GHC.Data.FastString -import GHC.Types.SrcLoc - -- --------------------------------------------------------------------- @@ -276,9 +274,6 @@ main = do _ -> putStrLn usage deriving instance Data Token -deriving instance Data PsSpan -deriving instance Data BufSpan -deriving instance Data BufPos writeBinFile :: FilePath -> String -> IO() writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 >> hPutStr h x) diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs index f59359a61d..d6ea9a627d 100644 --- a/utils/check-exact/Transform.hs +++ b/utils/check-exact/Transform.hs @@ -119,7 +119,7 @@ import GHC.Data.Bag import GHC.Data.FastString import Data.Data -import Data.List (sort, sortBy, find) +import Data.List (sortBy, sortOn, find) import Data.Maybe import qualified Data.Map as Map @@ -472,7 +472,7 @@ setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an (EpaComments [])) l) a) dp (EpAnn (Anchor r (MovedAnchor dp)) an (EpaComments [])) l) a setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp - = case sort (priorComments cs) of + = case sortAnchorLocated (priorComments cs) of [] -> L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor dp)) an cs) @@ -631,11 +631,11 @@ balanceCommentsFB (L lf (FunBind x n (MG mx (L lm matches) o) t)) second = do -- + move the trailing ones to the last match. let split = splitCommentsEnd (realSrcSpan $ locA lf) (epAnnComments $ ann lf) - split2 = splitCommentsStart (realSrcSpan $ locA lf) (EpaComments (sort $ priorComments split)) + split2 = splitCommentsStart (realSrcSpan $ locA lf) (EpaComments (sortAnchorLocated $ priorComments split)) - before = sort $ priorComments split2 - middle = sort $ getFollowingComments split2 - after = sort $ getFollowingComments split + before = sortAnchorLocated $ priorComments split2 + middle = sortAnchorLocated $ getFollowingComments split2 + after = sortAnchorLocated $ getFollowingComments split lf' = setCommentsSrcAnn lf (EpaComments before) logTr $ "balanceCommentsFB (before, after): " ++ showAst (before, after) @@ -736,7 +736,7 @@ balanceComments' la1 la2 = do logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2) logTr $ "balanceComments': (anc1)=" ++ showAst (anc1) logTr $ "balanceComments': (cs1s)=" ++ showAst (cs1s) - logTr $ "balanceComments': (sort cs1f)=" ++ showAst (sort cs1f) + logTr $ "balanceComments': (sort cs1f)=" ++ showAst (sortOn fst cs1f) logTr $ "balanceComments': (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move) logTr $ "balanceComments': (an1',an2')=" ++ showAst (an1',an2') return (la1', la2') @@ -762,8 +762,8 @@ balanceComments' la1 la2 = do -- Need to also check for comments more closely attached to la1, -- ie trailing on the same line (move'',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchorFromLocatedA la1) (map snd stay'')) - move = sort $ map snd (cs1move ++ move'' ++ move') - stay = sort $ map snd (cs1stay ++ stay') + move = sortAnchorLocated $ map snd (cs1move ++ move'' ++ move') + stay = sortAnchorLocated $ map snd (cs1stay ++ stay') an1' = setCommentsSrcAnn (getLoc la1) (EpaCommentsBalanced (map snd cs1p) move) an2' = setCommentsSrcAnn (getLoc la2) (EpaCommentsBalanced stay (map snd cs2f)) @@ -785,7 +785,7 @@ trailingCommentsDeltas anc (la@(L l _):las) -- AZ:TODO: this is identical to commentsDeltas priorCommentsDeltas :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] -priorCommentsDeltas anc cs = go anc (reverse $ sort cs) +priorCommentsDeltas anc cs = go anc (reverse $ sortAnchorLocated cs) where go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] go _ [] = [] @@ -839,8 +839,8 @@ moveLeadingComments (L la a) lb = (L la' a, lb') `debug` ("moveLeadingComments: (before, after, la', lb'):" ++ showAst (before, after, la', lb')) where split = splitCommentsEnd (realSrcSpan $ locA la) (epAnnComments $ ann la) - before = sort $ priorComments split - after = sort $ getFollowingComments split + before = sortAnchorLocated $ priorComments split + after = sortAnchorLocated $ getFollowingComments split -- TODO: need to set an entry delta on lb' to zero, and move the -- original spacing to the first comment. @@ -917,7 +917,7 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do gac = addCommentOrigDeltas $ epAnnComments ga gfc = getFollowingComments gac - gac' = setFollowingComments gac (sort $ gfc ++ move) + gac' = setFollowingComments gac (sortAnchorLocated $ gfc ++ move) ga' = (EpAnn anc an gac') an1' = setCommentsSrcAnn la cs1 diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs index a9b7640107..4f94222370 100644 --- a/utils/check-exact/Utils.hs +++ b/utils/check-exact/Utils.hs @@ -237,10 +237,7 @@ insertCppComments (L l p) cs = L l p' -- --------------------------------------------------------------------- ghcCommentText :: LEpaComment -> String -ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentNext s) _)) = s -ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentPrev s) _)) = s -ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentNamed s) _)) = s -ghcCommentText (L _ (GHC.EpaComment (EpaDocSection _ s) _)) = s +ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s ghcCommentText (L _ (GHC.EpaComment (EpaLineComment s) _)) = s ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s -- cgit v1.2.1