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.

6 files changed, 48 insertions, 42 deletions

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
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index a3bdfc8fd7..457d519143 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -259,6 +259,7 @@ gen_hs_source (Info defaults entries) =
                 -- and we don't want a complaint that the constraint is redundant
                 -- Remember, this silly file is only for Haddock's consumption
 
+        ++ "{-# OPTIONS_HADDOCK print-explicit-runtime-reps #-}"
         ++ "module GHC.Prim (\n"
         ++ unlines (map (("        " ++) . hdr) entries')
         ++ ") where\n"
diff --git a/utils/haddock b/utils/haddock
-Subproject b02188ab1cc46dd82395a22b04f890cf15f3fea
+Subproject d2779a3e659d4e9f7044c346a566e5fe4edbdb9