From 904dce0cafe0a241dd3ef355775db47fc12f434d Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Tue, 30 Jun 2020 11:49:52 +0200
Subject: Rename hscTarget into backend

---
 haddock-api/src/Haddock.hs | 7 ++++---
 1 file changed, 4 insertions(+), 3 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 63ceeb16..526e7d18 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -67,6 +67,7 @@ import Text.ParserCombinators.ReadP (readP_to_S)
 import GHC hiding (verbosity)
 import GHC.Settings.Config
 import GHC.Driver.Session hiding (projectVersion, verbosity)
+import GHC.Driver.Backend
 import GHC.Utils.Error
 import GHC.Unit
 import GHC.Utils.Panic (handleGhcException)
@@ -495,9 +496,9 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
       let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock]
                      | otherwise = [Opt_Haddock]
           dynflags' = (foldl' gopt_set dynflags extra_opts)
-                        { hscTarget = HscNothing
-                        , ghcMode   = CompManager
-                        , ghcLink   = NoLink
+                        { backend = NoBackend
+                        , ghcMode = CompManager
+                        , ghcLink = NoLink
                         }
           flags' = filterRtsFlags flags
 
-- 
cgit v1.2.3


From 7e6628febc482b4ad451f49ad416722375d1b170 Mon Sep 17 00:00:00 2001
From: Zubin Duggal <zubin@cmi.ac.in>
Date: Fri, 26 Jun 2020 15:29:18 +0530
Subject: Update for modular ping pong

---
 haddock-api/src/Haddock/Backends/Hoogle.hs         |  2 +-
 haddock-api/src/Haddock/Backends/LaTeX.hs          |  1 -
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs     |  5 +-
 haddock-api/src/Haddock/Convert.hs                 |  2 -
 haddock-api/src/Haddock/GhcUtils.hs                | 62 +++++++++-------------
 .../src/Haddock/Interface/AttachInstances.hs       |  1 -
 haddock-api/src/Haddock/Interface/Create.hs        |  8 +--
 haddock-api/src/Haddock/Interface/Rename.hs        | 16 +++---
 haddock-api/src/Haddock/Interface/Specialize.hs    |  9 ++--
 haddock-api/src/Haddock/Types.hs                   |  8 ++-
 haddock-api/src/Haddock/Utils.hs                   |  3 +-
 11 files changed, 52 insertions(+), 65 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 75a49036..d280ed23 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -69,7 +69,7 @@ ppModule dflags iface =
 ---------------------------------------------------------------------
 -- Utility functions
 
-dropHsDocTy :: HsType a -> HsType a
+dropHsDocTy :: HsType (GhcPass p) -> HsType (GhcPass p)
 dropHsDocTy = f
     where
         g (L src x) = L src (f x)
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index badb1914..c439be8f 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -41,7 +41,6 @@ import Control.Monad
 import Data.Maybe
 import Data.List
 import Prelude hiding ((<>))
-import GHC.Core.Multiplicity
 
 import Haddock.Doc (combineDocumentation)
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 6e210b61..20e099ee 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -41,7 +41,6 @@ import GHC.Exts
 import GHC.Types.Name
 import GHC.Data.BooleanFormula
 import GHC.Types.Name.Reader ( rdrNameOcc )
-import GHC.Core.Multiplicity
 
 -- | Pretty print a declaration
 ppDecl :: Bool                                     -- ^ print summary info only
@@ -1143,18 +1142,16 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y)
 ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html
 ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts
 
-patSigContext :: LHsType name -> HideEmptyContexts
+patSigContext :: LHsType DocNameI -> HideEmptyContexts
 patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmptyToplevelContexts
                   | otherwise = HideEmptyContexts
   where
-    hasNonEmptyContext :: LHsType name -> Bool
     hasNonEmptyContext t =
       case unLoc t of
         HsForAllTy _ _ s -> hasNonEmptyContext s
         HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
         HsFunTy _ _ _ s    -> hasNonEmptyContext s
         _ -> False
-    isFirstContextEmpty :: LHsType name -> Bool
     isFirstContextEmpty t =
       case unLoc t of
         HsForAllTy _ _ s -> isFirstContextEmpty s
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 3b73dcd1..d8f7206f 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -35,7 +35,6 @@ import GHC.Types.Name
 import GHC.Types.Name.Set    ( emptyNameSet )
 import GHC.Types.Name.Reader ( mkVarUnqual )
 import GHC.Core.PatSyn
-import GHC.Types.SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan )
 import GHC.Tc.Utils.TcType
 import GHC.Core.TyCon
 import GHC.Core.Type
@@ -57,7 +56,6 @@ import Haddock.Types
 import Haddock.Interface.Specialize
 import Haddock.GhcUtils                      ( orderedFVs, defaultRuntimeRepVars )
 
-import GHC.Core.Multiplicity
 
 import Data.Maybe                            ( catMaybes, mapMaybe, maybeToList )
 
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 3abb6481..6fae5f58 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,5 +1,8 @@
 {-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_HADDOCK hide #-}
@@ -23,17 +26,14 @@ import Data.Char ( isSpace )
 
 import Haddock.Types( DocName, DocNameI )
 
-import GHC.Utils.Exception
 import GHC.Utils.FV as FV
 import GHC.Utils.Outputable ( Outputable, panic, showPpr )
 import GHC.Types.Name
-import GHC.Types.Name.Set
 import GHC.Unit.Module
 import GHC.Driver.Types
 import GHC
 import GHC.Core.Class
 import GHC.Driver.Session
-import GHC.Core.Multiplicity
 import GHC.Types.SrcLoc  ( advanceSrcLoc )
 import GHC.Types.Var     ( Specificity, VarBndr(..), TyVarBinder
                          , tyVarKind, updateTyVarKind, isInvisibleArgFlag )
@@ -50,6 +50,8 @@ import           Data.ByteString ( ByteString )
 import qualified Data.ByteString          as BS
 import qualified Data.ByteString.Internal as BS
 
+import GHC.HsToCore.Docs
+
 moduleString :: Module -> String
 moduleString = moduleNameString . moduleName
 
@@ -89,25 +91,12 @@ ifTrueJust :: Bool -> name -> Maybe name
 ifTrueJust True  = Just
 ifTrueJust False = const Nothing
 
-sigName :: LSig name -> [IdP name]
+sigName :: LSig GhcRn -> [IdP GhcRn]
 sigName (L _ sig) = sigNameNoLoc sig
 
-sigNameNoLoc :: Sig name -> [IdP name]
-sigNameNoLoc (TypeSig    _   ns _)         = map unLoc ns
-sigNameNoLoc (ClassOpSig _ _ ns _)         = map unLoc ns
-sigNameNoLoc (PatSynSig  _   ns _)         = map unLoc ns
-sigNameNoLoc (SpecSig    _   n _ _)        = [unLoc n]
-sigNameNoLoc (InlineSig  _   n _)          = [unLoc n]
-sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
-sigNameNoLoc _                             = []
-
 -- | Was this signature given by the user?
-isUserLSig :: LSig name -> Bool
-isUserLSig (L _ (TypeSig {}))    = True
-isUserLSig (L _ (ClassOpSig {})) = True
-isUserLSig (L _ (PatSynSig {}))  = True
-isUserLSig _                     = False
-
+isUserLSig :: forall p. UnXRec p => LSig p -> Bool
+isUserLSig = isUserSig . unXRec @p
 
 isClassD :: HsDecl a -> Bool
 isClassD (TyClD _ d) = isClassDecl d
@@ -258,18 +247,18 @@ data Precedence
 --
 -- We cannot add parens that may be required by fixities because we do not have
 -- any fixity information to work with in the first place :(.
-reparenTypePrec :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a
+reparenTypePrec :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => Precedence -> HsType a -> HsType a
 reparenTypePrec = go
   where
 
   -- Shorter name for 'reparenType'
-  go :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a
+  go :: Precedence -> HsType a -> HsType a
   go _ (HsBangTy x b ty)     = HsBangTy x b (reparenLType ty)
   go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)
   go _ (HsSumTy x tys)       = HsSumTy x (map reparenLType tys)
   go _ (HsKindSig x ty kind) = HsKindSig x (reparenLType ty) (reparenLType kind)
   go _ (HsListTy x ty)       = HsListTy x (reparenLType ty)
-  go _ (HsRecTy x flds)      = HsRecTy x (map (fmap reparenConDeclField) flds)
+  go _ (HsRecTy x flds)      = HsRecTy x (map (mapXRec @a reparenConDeclField) flds)
   go p (HsDocTy x ty d)      = HsDocTy x (goL p ty) d
   go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)
   go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)
@@ -278,7 +267,7 @@ reparenTypePrec = go
   go p (HsForAllTy x tele ty)
     = paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty)
   go p (HsQualTy x ctxt ty)
-    = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty)
+    = paren p PREC_FUN $ HsQualTy x (mapXRec @a (map reparenLType) ctxt) (reparenLType ty)
   go p (HsFunTy x w ty1 ty2)
     = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)
   go p (HsAppTy x fun_ty arg_ty)
@@ -287,7 +276,7 @@ reparenTypePrec = go
     = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki)
   go p (HsOpTy x ty1 op ty2)
     = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)
-  go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed
+  go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed
   go _ t@HsTyVar{} = t
   go _ t@HsStarTy{} = t
   go _ t@HsSpliceTy{} = t
@@ -296,43 +285,42 @@ reparenTypePrec = go
   go _ t@XHsType{} = t
 
   -- Located variant of 'go'
-  goL :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a
-  goL ctxt_prec = fmap (go ctxt_prec)
+  goL :: Precedence -> LHsType a -> LHsType a
+  goL ctxt_prec = mapXRec @a (go ctxt_prec)
 
   -- Optionally wrap a type in parens
-  paren :: (XParTy a ~ NoExtField)
-        => Precedence            -- Precedence of context
+  paren :: Precedence            -- Precedence of context
         -> Precedence            -- Precedence of top-level operator
         -> HsType a -> HsType a  -- Wrap in parens if (ctxt >= op)
-  paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . noLoc
+  paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . wrapXRec @a
                           | otherwise            = id
 
 
 -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')
-reparenType :: (XParTy a ~ NoExtField) => HsType a -> HsType a
+reparenType :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsType a -> HsType a
 reparenType = reparenTypePrec PREC_TOP
 
 -- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')
-reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a
-reparenLType = fmap reparenType
+reparenLType :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => LHsType a -> LHsType a
+reparenLType = mapXRec @a reparenType
 
 -- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
-reparenHsForAllTelescope :: (XParTy a ~ NoExtField)
+reparenHsForAllTelescope :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a)
                          => HsForAllTelescope a -> HsForAllTelescope a
 reparenHsForAllTelescope (HsForAllVis x bndrs) =
-  HsForAllVis x (map (fmap reparenTyVar) bndrs)
+  HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs)
 reparenHsForAllTelescope (HsForAllInvis x bndrs) =
-  HsForAllInvis x (map (fmap reparenTyVar) bndrs)
+  HsForAllInvis x (map (mapXRec @a reparenTyVar) bndrs)
 reparenHsForAllTelescope v@XHsForAllTelescope{} = v
 
 -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
-reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a
+reparenTyVar :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsTyVarBndr flag a -> HsTyVarBndr flag a
 reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n
 reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind)
 reparenTyVar v@XTyVarBndr{} = v
 
 -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
-reparenConDeclField :: (XParTy a ~ NoExtField) => ConDeclField a -> ConDeclField a
+reparenConDeclField :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => ConDeclField a -> ConDeclField a
 reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d
 reparenConDeclField c@XConDeclField{} = c
 
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 0840bd77..d5fe878b 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -17,7 +17,6 @@ module Haddock.Interface.AttachInstances (attachInstances) where
 
 import Haddock.Types
 import Haddock.Convert
-import Haddock.GhcUtils
 
 import Control.Applicative ((<|>))
 import Control.Arrow hiding ((<+>))
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 7b9674a6..1f223282 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -34,7 +34,6 @@ import qualified Data.Map as M
 import Data.Map (Map)
 import Data.List
 import Data.Maybe
-import Control.Applicative
 import Control.Monad
 import Data.Traversable
 
@@ -49,7 +48,6 @@ import GHC.Types.Name
 import GHC.Types.Name.Set
 import GHC.Types.Name.Env
 import GHC.Unit.State
-import GHC.Data.Bag
 import GHC.Types.Name.Reader
 import GHC.Tc.Types
 import GHC.Data.FastString ( unpackFS, bytesFS )
@@ -57,8 +55,6 @@ import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
 import qualified GHC.Utils.Outputable as O
 import GHC.HsToCore.Docs hiding (mkMaps)
 
-import GHC.Core.Multiplicity
-
 
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
 -- To do this, we need access to already processed modules in the topological
@@ -240,7 +236,7 @@ mkAliasMap state mRenamedSource =
 --
 -- With our mapping we know that we can display exported modules M1 and M2.
 --
-unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName]
+unrestrictedModuleImports :: [ImportDecl GhcRn] -> M.Map ModuleName [ModuleName]
 unrestrictedModuleImports idecls =
   M.map (map (unLoc . ideclName))
   $ M.filter (all isInteresting) impModMap
@@ -958,7 +954,7 @@ extractPatternSyn nm t tvs cons =
         typ'' = noLoc (HsQualTy noExtField (noLoc []) typ')
     in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'')
 
-  longArrow :: (XFunTy name ~ NoExtField) => [LHsType name] -> LHsType name -> LHsType name
+  longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
   longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField HsUnrestrictedArrow x y)) output inputs
 
   data_ty con
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 27bad4b9..39a1ae17 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -474,7 +474,8 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
 renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
 renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
                            , con_mb_cxt = lcontext, con_args = details
-                           , con_doc = mbldoc }) = do
+                           , con_doc = mbldoc
+                           , con_forall = forall }) = do
       lname'    <- renameL lname
       ltyvars'  <- mapM renameLTyVarBndr ltyvars
       lcontext' <- traverse renameLContext lcontext
@@ -482,21 +483,24 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
       mbldoc'   <- mapM renameLDocHsSyn mbldoc
       return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars'
                    , con_mb_cxt = lcontext'
+                   , con_forall = forall -- Remove when #18311 is fixed
                    , con_args = details', con_doc = mbldoc' })
 
-renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars
+renameCon ConDeclGADT { con_names = lnames, con_qvars = ltyvars
                             , con_mb_cxt = lcontext, con_args = details
-                            , con_res_ty = res_ty
-                            , con_doc = mbldoc }) = do
+                            , con_res_ty = res_ty, con_forall = forall
+                            , con_doc = mbldoc } = do
       lnames'   <- mapM renameL lnames
       ltyvars'  <- mapM renameLTyVarBndr ltyvars
       lcontext' <- traverse renameLContext lcontext
       details'  <- renameDetails details
       res_ty'   <- renameLType res_ty
       mbldoc'   <- mapM renameLDocHsSyn mbldoc
-      return (decl { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars'
+      return (ConDeclGADT
+                   { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars'
                    , con_mb_cxt = lcontext', con_args = details'
-                   , con_res_ty = res_ty', con_doc = mbldoc' })
+                   , con_res_ty = res_ty', con_doc = mbldoc'
+                   , con_forall = forall}) -- Remove when #18311 is fixed
 
 renameHsScaled :: HsScaled GhcRn (LHsType GhcRn)
                -> RnM (HsScaled DocNameI (LHsType DocNameI))
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 5c933f25..66627c15 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GADTs #-}
 
 module Haddock.Interface.Specialize
     ( specializeInstHead
@@ -15,7 +16,6 @@ import Haddock.Types
 import GHC
 import GHC.Types.Name
 import GHC.Data.FastString
-import GHC.Builtin.Types.Prim ( funTyConName )
 import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )
 
 import Control.Monad
@@ -36,7 +36,7 @@ specialize specs = go spec_map0
     go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x
     go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map
 
-    strip_kind_sig :: HsType name -> HsType name
+    strip_kind_sig :: HsType GhcRn -> HsType GhcRn
     strip_kind_sig (HsKindSig _ (L _ t) _) = t
     strip_kind_sig typ = typ
 
@@ -205,6 +205,7 @@ freeVariables :: HsType GhcRn -> Set Name
 freeVariables =
     everythingWithState Set.empty Set.union query
   where
+    query :: forall a . Data a => a -> Set Name -> (Set Name, Set Name)
     query term ctx = case cast term :: Maybe (HsType GhcRn) of
         Just (HsForAllTy _ tele _) ->
             (Set.empty, Set.union ctx (teleNames tele))
@@ -213,6 +214,7 @@ freeVariables =
             | otherwise -> (Set.singleton $ getName name, ctx)
         _ -> (Set.empty, ctx)
 
+    teleNames :: HsForAllTelescope GhcRn -> Set Name
     teleNames (HsForAllVis   _ bndrs) = bndrsNames bndrs
     teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs
 
@@ -366,7 +368,6 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b)
 located f (L loc e) = L loc <$> f e
 
 
-tyVarName :: HsTyVarBndr flag name -> IdP name
+tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn
 tyVarName (UserTyVar _ _ name) = unLoc name
 tyVarName (KindedTyVar _ _ (L _ name) _) = name
-tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 21c7d19b..89fd6658 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -669,7 +669,13 @@ instance MonadIO ErrMsgGhc where
 -- * Pass sensitive types
 -----------------------------------------------------------------------------
 
-type instance XRec DocNameI f = Located (f DocNameI)
+type instance XRec DocNameI a = Located a
+instance UnXRec DocNameI where
+  unXRec = unLoc
+instance MapXRec DocNameI where
+  mapXRec = fmap
+instance WrapXRec DocNameI where
+  wrapXRec = noLoc
 
 type instance XForAllTy        DocNameI = NoExtField
 type instance XQualTy          DocNameI = NoExtField
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 8346a477..33fbd000 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Utils
@@ -90,8 +91,6 @@ import qualified System.Posix.Internals
 
 import GHC.Utils.Monad ( MonadIO(..) )
 
-import GHC.Core.Multiplicity
-
 
 --------------------------------------------------------------------------------
 -- * Logging
-- 
cgit v1.2.3


From cdae236f0ab7015f3a466b2c9b2449ba038b45f6 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Fri, 26 Jun 2020 16:48:44 +0200
Subject: Fix after Outputable refactoring

---
 haddock-api/src/Haddock/Backends/Hoogle.hs             | 8 +++++---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 4 +++-
 haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs  | 2 +-
 haddock-api/src/Haddock/Backends/LaTeX.hs              | 2 +-
 haddock-api/src/Haddock/Convert.hs                     | 2 +-
 haddock-api/src/Haddock/GhcUtils.hs                    | 4 +++-
 haddock-api/src/Haddock/Interface/Create.hs            | 8 +++++---
 haddock-api/src/Haddock/Interface/LexParseRn.hs        | 2 +-
 8 files changed, 20 insertions(+), 12 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index d280ed23..8d56a1ed 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -26,7 +26,9 @@ import Haddock.Types hiding (Version)
 import Haddock.Utils hiding (out)
 
 import GHC
+import GHC.Driver.Ppr
 import GHC.Utils.Outputable as Outputable
+import GHC.Utils.Panic
 
 import Data.Char
 import Data.List
@@ -106,14 +108,14 @@ outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr
         f [] = []
 
 out :: Outputable a => DynFlags -> a -> String
-out dflags = outWith $ showSDocUnqual dflags
+out dflags = outWith $ showSDoc dflags
 
 operator :: String -> String
 operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")"
 operator x = x
 
 commaSeparate :: Outputable a => DynFlags -> [a] -> String
-commaSeparate dflags = showSDocUnqual dflags . interpp'SP
+commaSeparate dflags = showSDoc dflags . interpp'SP
 
 ---------------------------------------------------------------------
 -- How to print each export
@@ -173,7 +175,7 @@ ppClass dflags decl subdocs =
 
         ppTyFams
             | null $ tcdATs decl = ""
-            | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat
+            | otherwise = (" " ++) . showSDoc dflags . whereWrapper $ concat
                 [ map pprTyFam (tcdATs decl)
                 , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl)
                 ]
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 5fd040a8..114eafa9 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -17,7 +17,9 @@ import GHC.Parser.Lexer    as Lexer
                            ( P(..), ParseResult(..), PState(..), Token(..)
                            , mkPStatePure, lexer, mkParserFlags', getErrorMessages)
 import GHC.Data.Bag         ( bagToList )
-import GHC.Utils.Outputable ( showSDoc, panic, text, ($$) )
+import GHC.Utils.Outputable ( text, ($$) )
+import GHC.Utils.Panic      ( panic )
+import GHC.Driver.Ppr       ( showSDoc )
 import GHC.Types.SrcLoc
 import GHC.Data.StringBuffer ( StringBuffer, atEnd )
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index ce5ff11c..5daa5522 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -21,7 +21,7 @@ import GHC
 import GHC.Iface.Ext.Types ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat )
 import GHC.Iface.Type
 import GHC.Types.Name      ( getOccFS, getOccString )
-import GHC.Utils.Outputable( showSDoc )
+import GHC.Driver.Ppr      ( showSDoc )
 import GHC.Types.Var       ( VarBndr(..) )
 
 import System.FilePath.Posix ((</>), (<.>))
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index c439be8f..32ca4f6a 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -31,7 +31,7 @@ import GHC.Types.Name        ( nameOccName )
 import GHC.Types.Name.Reader ( rdrNameOcc )
 import GHC.Core.Type         ( Specificity(..) )
 import GHC.Data.FastString   ( unpackFS )
-import GHC.Utils.Outputable  ( panic)
+import GHC.Utils.Panic       ( panic)
 
 import qualified Data.Map as Map
 import System.Directory
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index d8f7206f..35cb3d92 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -47,7 +47,7 @@ import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
 import GHC.Types.Unique ( getUnique )
 import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength
                       , filterByList, filterOut )
-import GHC.Utils.Outputable ( assertPanic )
+import GHC.Utils.Panic ( assertPanic )
 import GHC.Types.Var
 import GHC.Types.Var.Set
 import GHC.Types.SrcLoc
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 6fae5f58..b4964d9f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -27,7 +27,9 @@ import Data.Char ( isSpace )
 import Haddock.Types( DocName, DocNameI )
 
 import GHC.Utils.FV as FV
-import GHC.Utils.Outputable ( Outputable, panic, showPpr )
+import GHC.Utils.Outputable ( Outputable )
+import GHC.Utils.Panic ( panic )
+import GHC.Driver.Ppr (showPpr )
 import GHC.Types.Name
 import GHC.Unit.Module
 import GHC.Driver.Types
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 1f223282..ffaec7f1 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -44,6 +44,7 @@ import qualified GHC.Types.SrcLoc as SrcLoc
 import GHC.Core.ConLike (ConLike(..))
 import GHC
 import GHC.Driver.Types
+import GHC.Driver.Ppr
 import GHC.Types.Name
 import GHC.Types.Name.Set
 import GHC.Types.Name.Env
@@ -53,6 +54,7 @@ import GHC.Tc.Types
 import GHC.Data.FastString ( unpackFS, bytesFS )
 import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
 import qualified GHC.Utils.Outputable as O
+import GHC.Utils.Panic
 import GHC.HsToCore.Docs hiding (mkMaps)
 
 
@@ -722,7 +724,7 @@ hiDecl dflags t = do
       warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<>
                    O.comma O.<+> O.quotes (O.ppr t) O.<+>
                    O.text "-- Please report this on Haddock issue tracker!"
-      bugWarn = O.showSDoc dflags . warnLine
+      bugWarn = showSDoc dflags . warnLine
 
 -- | This function is called for top-level bindings without type signatures.
 -- It gets the type signature from GHC and that means it's not going to
@@ -884,7 +886,7 @@ extractDecl declMap name decl
           ([], [])
             | Just (famInstDecl:_) <- M.lookup name declMap
             -> extractDecl declMap name famInstDecl
-          _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:"
+          _ -> pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:"
                                          O.$$ O.nest 4 (O.ppr d)
                                          O.$$ O.text "Matches:"
                                          O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType))
@@ -927,7 +929,7 @@ extractDecl declMap name decl
             in case matches of
               [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0)
               _ -> error "internal: extractDecl (ClsInstD)"
-      _ -> O.pprPanic "extractDecl" $
+      _ -> pprPanic "extractDecl" $
         O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":"
         O.$$ O.nest 4 (O.ppr decl)
 
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 2b03ecfa..2c06438f 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -32,7 +32,7 @@ import Haddock.Interface.ParseModuleHeader
 import Haddock.Parser
 import Haddock.Types
 import GHC.Types.Name
-import GHC.Utils.Outputable ( showPpr, showSDoc )
+import GHC.Driver.Ppr ( showPpr, showSDoc )
 import GHC.Types.Name.Reader
 import GHC.Data.EnumSet as EnumSet
 import GHC.Rename.Env (dataTcOccs)
-- 
cgit v1.2.3


From 4e12c3fa784dd906a69306f88f466248fb1ff933 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Wed, 5 Aug 2020 11:31:49 +0200
Subject: Fix after HomeUnit

---
 haddock-api/src/Haddock.hs                             | 1 -
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 3 ++-
 haddock-api/src/Haddock/Interface.hs                   | 5 +++--
 3 files changed, 5 insertions(+), 4 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 526e7d18..662226a8 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -67,7 +67,6 @@ import Text.ParserCombinators.ReadP (readP_to_S)
 import GHC hiding (verbosity)
 import GHC.Settings.Config
 import GHC.Driver.Session hiding (projectVersion, verbosity)
-import GHC.Driver.Backend
 import GHC.Utils.Error
 import GHC.Unit
 import GHC.Utils.Panic (handleGhcException)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 114eafa9..77017689 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -22,6 +22,7 @@ import GHC.Utils.Panic      ( panic )
 import GHC.Driver.Ppr       ( showSDoc )
 import GHC.Types.SrcLoc
 import GHC.Data.StringBuffer ( StringBuffer, atEnd )
+import GHC.Unit              ( homeUnitId )
 
 import Haddock.Backends.Hyperlinker.Types as T
 import Haddock.GhcUtils
@@ -48,7 +49,7 @@ parse dflags fpath bs = case unP (go False []) initState of
     start = mkRealSrcLoc (mkFastString fpath) 1 1
     pflags = mkParserFlags' (warningFlags dflags)
                             (extensionFlags dflags)
-                            (homeUnitId dflags)
+                            (homeUnitId (mkHomeUnitFromFlags dflags))
                             (safeImportsOn dflags)
                             False -- lex Haddocks as comment tokens
                             True  -- produce comment tokens
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index fa20b836..a702d3d6 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -51,6 +51,7 @@ import Distribution.Verbosity
 import Text.Printf
 
 import GHC.Unit.Module.Env (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)
+import GHC.Unit.Types
 import GHC.Data.Graph.Directed
 import GHC.Driver.Session hiding (verbosity)
 import GHC hiding (verbosity)
@@ -168,11 +169,11 @@ processModule verbosity modsum flags modMap instIfaceMap = do
       -- See https://github.com/haskell/haddock/issues/469.
       hsc_env <- getSession
       let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
-          this_pkg = homeUnit (hsc_dflags hsc_env)
+          home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
           !mods = mkModuleSet [ nameModule name
                               | gre <- globalRdrEnvElts new_rdr_env
                               , let name = gre_name gre
-                              , nameIsFromExternalPackage this_pkg name
+                              , nameIsFromExternalPackage home_unit name
                               , isTcOcc (nameOccName name)   -- Types and classes only
                               , unQualOK gre ]               -- In scope unqualified
 
-- 
cgit v1.2.3


From 54468d1e60cb10093120137766cfc9dd91671c98 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Wed, 12 Aug 2020 10:56:32 +0200
Subject: Remove Ord FastString instance

---
 haddock-api/src/Haddock/Backends/Hyperlinker.hs |  4 ++--
 haddock-api/src/Haddock/Interface/Specialize.hs | 16 +++++++++++-----
 2 files changed, 13 insertions(+), 7 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index d315ced0..2ae4dcdb 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -18,7 +18,7 @@ import Data.Maybe
 import System.Directory
 import System.FilePath
 
-import GHC.Iface.Ext.Types  ( HieFile(..), HieASTs(..) )
+import GHC.Iface.Ext.Types
 import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..))
 import Data.Map as M
 import GHC.Data.FastString     ( mkFastString )
@@ -67,7 +67,7 @@ ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of
 
         -- Get the AST and tokens corresponding to the source file we want
         let mast | M.size asts == 1 = snd <$> M.lookupMin asts
-                 | otherwise        = M.lookup (mkFastString file) asts
+                 | otherwise        = M.lookup (HiePath (mkFastString file)) asts
             tokens = parse df file rawSrc
 
         -- Produce and write out the hyperlinked sources
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 66627c15..28806f04 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -178,19 +178,25 @@ parseTupleArity _ = Nothing
 -- not converted to 'String' or alike to avoid new allocations. Additionally,
 -- since it is stored mostly in 'Set', fast comparison of 'FastString' is also
 -- quite nice.
-type NameRep = FastString
+newtype NameRep
+   = NameRep FastString
+   deriving (Eq)
+
+instance Ord NameRep where
+   compare (NameRep fs1) (NameRep fs2) = uniqCompareFS fs1 fs2
+
 
 getNameRep :: NamedThing name => name -> NameRep
-getNameRep = getOccFS
+getNameRep = NameRep . getOccFS
 
 nameRepString :: NameRep -> String
-nameRepString = unpackFS
+nameRepString (NameRep fs) = unpackFS fs
 
 stringNameRep :: String -> NameRep
-stringNameRep = mkFastString
+stringNameRep = NameRep . mkFastString
 
 setInternalNameRep :: SetName name => NameRep -> name -> name
-setInternalNameRep = setInternalOccName . mkVarOccFS
+setInternalNameRep (NameRep fs) = setInternalOccName (mkVarOccFS fs)
 
 setInternalOccName :: SetName name => OccName -> name -> name
 setInternalOccName occ name =
-- 
cgit v1.2.3


From 6dbf30c304505b94112663b9118ec47307d10e01 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Mon, 7 Sep 2020 21:47:41 +0100
Subject: Match GHC for #18639, remove GENERATED pragma

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 --
 1 file changed, 2 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 77017689..ab3ddf76 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -242,7 +242,6 @@ classify tok =
     ITline_prag         {} -> TkPragma
     ITcolumn_prag       {} -> TkPragma
     ITscc_prag          {} -> TkPragma
-    ITgenerated_prag    {} -> TkPragma
     ITunpack_prag       {} -> TkPragma
     ITnounpack_prag     {} -> TkPragma
     ITann_prag          {} -> TkPragma
@@ -382,7 +381,6 @@ inPragma False tok =
     ITline_prag         {} -> True
     ITcolumn_prag       {} -> True
     ITscc_prag          {} -> True
-    ITgenerated_prag    {} -> True
     ITunpack_prag       {} -> True
     ITnounpack_prag     {} -> True
     ITann_prag          {} -> True
-- 
cgit v1.2.3


From 2a15172bde75ec151a52fef586d1e362d478aae8 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Tue, 28 Jul 2020 13:06:53 -0400
Subject: Bump GHC version to 9.1

---
 haddock-api/haddock-api.cabal            | 2 +-
 haddock-api/src/Haddock/InterfaceFile.hs | 2 +-
 haddock.cabal                            | 4 ++--
 3 files changed, 4 insertions(+), 4 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 759e12f6..94c6e676 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -45,7 +45,7 @@ library
   -- this package typically supports only single major versions
   build-depends: base            ^>= 4.15.0
                , Cabal           ^>= 2.4.0
-               , ghc             ^>= 8.11
+               , ghc             ^>= 9.1
                , ghc-paths       ^>= 0.1.0.9
                , haddock-library ^>= 1.8.0
                , xhtml           ^>= 3000.2.2
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 39de2395..fffef2fa 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface
 -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
 --
 binaryInterfaceVersion :: Word16
-#if MIN_VERSION_ghc(8,11,0) && !MIN_VERSION_ghc(8,13,0)
+#if MIN_VERSION_ghc(9,1,0) && !MIN_VERSION_ghc(9,2,0)
 binaryInterfaceVersion = 34
 
 binaryInterfaceVersionCompatibility :: [Word16]
diff --git a/haddock.cabal b/haddock.cabal
index 52113bd1..9f5bcecf 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -33,7 +33,7 @@ bug-reports:          https://github.com/haskell/haddock/issues
 copyright:            (c) Simon Marlow, David Waern
 category:             Documentation
 build-type:           Simple
-tested-with:          GHC==8.12.*, GHC==8.10.*, GHC==8.8.1
+tested-with:          GHC==9.0.*, GHC==8.10.*
 
 extra-source-files:
   CHANGES.md
@@ -80,7 +80,7 @@ executable haddock
       Cabal >= 1.10,
       ghc-boot,
       ghc-boot-th,
-      ghc == 8.11.*,
+      ghc == 9.1.*,
       bytestring,
       parsec,
       text,
-- 
cgit v1.2.3


From 64229b808ca3a434e86a044aa8fa12649e63be28 Mon Sep 17 00:00:00 2001
From: Vladislav Zavialov <vlad.z.4096@gmail.com>
Date: Fri, 18 Sep 2020 14:05:15 +0300
Subject: Bump base upper bound to 4.16

---
 haddock-api/haddock-api.cabal         | 2 +-
 haddock-library/haddock-library.cabal | 2 +-
 haddock-test/haddock-test.cabal       | 2 +-
 haddock.cabal                         | 2 +-
 4 files changed, 4 insertions(+), 4 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 94c6e676..801fbb0f 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -43,7 +43,7 @@ library
   default-language: Haskell2010
 
   -- this package typically supports only single major versions
-  build-depends: base            ^>= 4.15.0
+  build-depends: base            ^>= 4.16.0
                , Cabal           ^>= 2.4.0
                , ghc             ^>= 9.1
                , ghc-paths       ^>= 0.1.0.9
diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal
index 8c20d7ad..ef802a64 100644
--- a/haddock-library/haddock-library.cabal
+++ b/haddock-library/haddock-library.cabal
@@ -26,7 +26,7 @@ common lib-defaults
   default-language: Haskell2010
 
   build-depends:
-    , base         >= 4.5     && < 4.16
+    , base         >= 4.5     && < 4.17
     , bytestring   ^>= 0.9.2.1 || ^>= 0.10.0.0
     , containers   ^>= 0.4.2.1 || ^>= 0.5.0.0 || ^>= 0.6.0.1
     , transformers ^>= 0.3.0.0 || ^>= 0.4.1.0 || ^>= 0.5.0.0
diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal
index f5105f92..1adcb7c2 100644
--- a/haddock-test/haddock-test.cabal
+++ b/haddock-test/haddock-test.cabal
@@ -17,7 +17,7 @@ library
   default-language: Haskell2010
   ghc-options: -Wall
   hs-source-dirs:   src
-  build-depends:    base >= 4.3 && < 4.13, bytestring, directory, process, filepath, Cabal
+  build-depends:    base >= 4.3 && < 4.17, bytestring, directory, process, filepath, Cabal
 
   exposed-modules:
     Test.Haddock
diff --git a/haddock.cabal b/haddock.cabal
index 9f5bcecf..424a255b 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -64,7 +64,7 @@ executable haddock
 
   -- haddock typically only supports a single GHC major version
   build-depends:
-    base ^>= 4.13.0.0 || ^>= 4.14.0.0 || ^>= 4.15.0.0
+    base ^>= 4.13.0.0 || ^>= 4.14.0.0 || ^>= 4.15.0.0 || ^>= 4.16.0.0
 
   if flag(in-ghc-tree)
     hs-source-dirs: haddock-api/src,  haddock-library/src
-- 
cgit v1.2.3


From 37c47822d390b553ce24fe256c9700d5fd83bf9f Mon Sep 17 00:00:00 2001
From: Vladislav Zavialov <vlad.z.4096@gmail.com>
Date: Sat, 26 Sep 2020 20:59:49 +0300
Subject: Updates for the new linear types syntax: a %p -> b

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 +
 1 file changed, 1 insertion(+)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index ab3ddf76..b97ada16 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -276,6 +276,7 @@ classify tok =
     ITdot                  -> TkOperator
     ITstar              {} -> TkOperator
     ITtypeApp              -> TkGlyph
+    ITpercent              -> TkGlyph
 
     ITbiglam               -> TkGlyph
 
-- 
cgit v1.2.3


From a18c3af7f983f3b6d3cd84093c9079031da58468 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Tue, 29 Sep 2020 17:18:32 +0200
Subject: Update for parser (#1234)

---
 haddock-api/src/Haddock/Backends/Hoogle.hs             | 2 --
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 6 +++---
 haddock-api/src/Haddock/Parser.hs                      | 5 +++--
 3 files changed, 6 insertions(+), 7 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 8d56a1ed..90bd6b66 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -38,8 +38,6 @@ import Data.Version
 import System.Directory
 import System.FilePath
 
-import GHC.Core.Multiplicity
-
 prefix :: [String]
 prefix = ["-- Hoogle documentation, generated by Haddock"
          ,"-- See Hoogle, http://www.haskell.org/hoogle/"
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index b97ada16..d9746189 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -15,7 +15,7 @@ import GHC.Utils.Error     ( pprLocErrMsg )
 import GHC.Data.FastString ( mkFastString )
 import GHC.Parser.Lexer    as Lexer
                            ( P(..), ParseResult(..), PState(..), Token(..)
-                           , mkPStatePure, lexer, mkParserFlags', getErrorMessages)
+                           , initParserState, lexer, mkParserOpts, getErrorMessages)
 import GHC.Data.Bag         ( bagToList )
 import GHC.Utils.Outputable ( text, ($$) )
 import GHC.Utils.Panic      ( panic )
@@ -44,10 +44,10 @@ parse dflags fpath bs = case unP (go False []) initState of
         text "Hyperlinker parse error:" $$ pprLocErrMsg err
   where
 
-    initState = mkPStatePure pflags buf start
+    initState = initParserState pflags buf start
     buf = stringBufferFromByteString bs
     start = mkRealSrcLoc (mkFastString fpath) 1 1
-    pflags = mkParserFlags' (warningFlags dflags)
+    pflags = mkParserOpts   (warningFlags dflags)
                             (extensionFlags dflags)
                             (homeUnitId (mkHomeUnitFromFlags dflags))
                             (safeImportsOn dflags)
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
index e1b5c787..366bcd55 100644
--- a/haddock-api/src/Haddock/Parser.hs
+++ b/haddock-api/src/Haddock/Parser.hs
@@ -17,8 +17,9 @@ import qualified Documentation.Haddock.Parser as P
 import Documentation.Haddock.Types
 
 import GHC.Driver.Session ( DynFlags )
+import GHC.Driver.Config
 import GHC.Data.FastString   ( fsLit )
-import GHC.Parser.Lexer ( mkPState, unP, ParseResult(POk) )
+import GHC.Parser.Lexer ( initParserState, unP, ParseResult(POk) )
 import GHC.Parser       ( parseIdentifier )
 import GHC.Types.Name.Reader ( RdrName )
 import GHC.Types.SrcLoc ( mkRealSrcLoc, unLoc )
@@ -34,7 +35,7 @@ parseIdent :: DynFlags -> String -> Maybe RdrName
 parseIdent dflags str0 =
   let buffer = stringToStringBuffer str0
       realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0
-      pstate = mkPState dflags buffer realSrcLc
+      pstate = initParserState (initParserOpts dflags) buffer realSrcLc
   in case unP parseIdentifier pstate of
     POk _ name -> Just (unLoc name)
     _ -> Nothing
-- 
cgit v1.2.3


From 7b5972402afad755cd45aaad1a96aac509e9d5d2 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Tue, 22 Sep 2020 19:30:28 +0200
Subject: Adapt to GHC parser changes

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index d9746189..eb6c061c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -13,6 +13,7 @@ import GHC.Types.Basic     ( IntegralLit(..) )
 import GHC.Driver.Session
 import GHC.Utils.Error     ( pprLocErrMsg )
 import GHC.Data.FastString ( mkFastString )
+import GHC.Parser.Errors.Ppr ( pprError )
 import GHC.Parser.Lexer    as Lexer
                            ( P(..), ParseResult(..), PState(..), Token(..)
                            , initParserState, lexer, mkParserOpts, getErrorMessages)
@@ -39,7 +40,7 @@ parse
 parse dflags fpath bs = case unP (go False []) initState of
     POk _ toks -> reverse toks
     PFailed pst ->
-      let err:_ = bagToList (getErrorMessages pst dflags) in
+      let err:_ = bagToList (fmap pprError (getErrorMessages pst)) in
       panic $ showSDoc dflags $
         text "Hyperlinker parse error:" $$ pprLocErrMsg err
   where
-- 
cgit v1.2.3


From 6f16399e0320d0ef5e6c3dd0329ce7ed3715b6b2 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Mon, 12 Oct 2020 15:13:38 +0200
Subject: Don't pass the HomeUnitId (#1239)

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 -
 1 file changed, 1 deletion(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index eb6c061c..1b3ed35c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -50,7 +50,6 @@ parse dflags fpath bs = case unP (go False []) initState of
     start = mkRealSrcLoc (mkFastString fpath) 1 1
     pflags = mkParserOpts   (warningFlags dflags)
                             (extensionFlags dflags)
-                            (homeUnitId (mkHomeUnitFromFlags dflags))
                             (safeImportsOn dflags)
                             False -- lex Haddocks as comment tokens
                             True  -- produce comment tokens
-- 
cgit v1.2.3


From 77261e89c31b41eb5d7f1d16bb1de5b14b4296f4 Mon Sep 17 00:00:00 2001
From: Vladislav Zavialov <vlad.z.4096@gmail.com>
Date: Tue, 13 Oct 2020 16:31:52 +0300
Subject: Add whitespace in: map ($ v)

---
 haddock-api/src/Haddock/Backends/LaTeX.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 32ca4f6a..a90d9a6e 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1201,14 +1201,14 @@ parLatexMarkup ppId = Markup {
   markupEmphasis             = \p v -> emph (p v),
   markupBold                 = \p v -> bold (p v),
   markupMonospaced           = \p _ -> tt (p Mono),
-  markupUnorderedList        = \p v -> itemizedList (map ($v) p) $$ text "",
+  markupUnorderedList        = \p v -> itemizedList (map ($ v) p) $$ text "",
   markupPic                  = \p _ -> markupPic p,
   markupMathInline           = \p _ -> markupMathInline p,
   markupMathDisplay          = \p _ -> markupMathDisplay p,
-  markupOrderedList          = \p v -> enumeratedList (map ($v) p) $$ text "",
+  markupOrderedList          = \p v -> enumeratedList (map ($ v) p) $$ text "",
   markupDefList              = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
   markupCodeBlock            = \p _ -> quote (verb (p Verb)) $$ text "",
-  markupHyperlink            = \(Hyperlink u l) p -> markupLink u (fmap ($p) l),
+  markupHyperlink            = \(Hyperlink u l) p -> markupLink u (fmap ($ p) l),
   markupAName                = \_ _ -> empty,
   markupProperty             = \p _ -> quote $ verb $ text p,
   markupExample              = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
-- 
cgit v1.2.3


From a7d1d8e034d25612d5d08ed8fdbf6f472aded4a1 Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Tue, 6 Oct 2020 18:38:35 +0100
Subject: Match GHC, adding IsUnicodeSyntax field to HsFunTy and HsScaled

---
 haddock-api/src/Haddock/Backends/Hoogle.hs      | 3 ++-
 haddock-api/src/Haddock/Convert.hs              | 7 ++++---
 haddock-api/src/Haddock/GhcUtils.hs             | 7 ++++---
 haddock-api/src/Haddock/Interface/Create.hs     | 5 +++--
 haddock-api/src/Haddock/Interface/Rename.hs     | 6 +++---
 haddock-api/src/Haddock/Interface/Specialize.hs | 5 +++--
 6 files changed, 19 insertions(+), 14 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 90bd6b66..ecc4bf97 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -29,6 +29,7 @@ import GHC
 import GHC.Driver.Ppr
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
+import GHC.Parser.Annotation (IsUnicodeSyntax(..))
 
 import Data.Char
 import Data.List
@@ -245,7 +246,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
                            [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
                           | r <- map unLoc recs]
 
-        funs = foldr1 (\x y -> reL $ HsFunTy noExtField HsUnrestrictedArrow x y)
+        funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)
         apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
 
         typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 35cb3d92..650f8a1d 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -51,6 +51,7 @@ import GHC.Utils.Panic ( assertPanic )
 import GHC.Types.Var
 import GHC.Types.Var.Set
 import GHC.Types.SrcLoc
+import GHC.Parser.Annotation (IsUnicodeSyntax(..))
 
 import Haddock.Types
 import Haddock.Interface.Specialize
@@ -767,9 +768,9 @@ noKindTyVars _ _ = emptyVarSet
 
 synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn
 synifyMult vs t = case t of
-                    One  -> HsLinearArrow
-                    Many -> HsUnrestrictedArrow
-                    ty -> HsExplicitMult (synifyType WithinType vs ty)
+                    One  -> HsLinearArrow NormalSyntax
+                    Many -> HsUnrestrictedArrow NormalSyntax
+                    ty -> HsExplicitMult NormalSyntax (synifyType WithinType vs ty)
 
 
 
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index b4964d9f..a03587b4 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -44,6 +44,7 @@ import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
 import GHC.Core.TyCo.Rep ( Type(..) )
 import GHC.Core.Type     ( isRuntimeRepVar )
 import GHC.Builtin.Types( liftedRepDataConTyCon )
+import GHC.Parser.Annotation (IsUnicodeSyntax(..))
 
 import           GHC.Data.StringBuffer ( StringBuffer )
 import qualified GHC.Data.StringBuffer             as S
@@ -156,13 +157,13 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall
             | otherwise
             = tau_ty
 
---   tau_ty :: LHsType DocNameI
+--  tau_ty :: LHsType DocNameI
    tau_ty = case args of
               RecCon flds ->  mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
               PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
               InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)
 
-   mkFunTy a b = noLoc (HsFunTy noExtField HsUnrestrictedArrow a b)
+   mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
 
 getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
   -- Should only be called on ConDeclGADT
@@ -218,7 +219,7 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
               InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)
 
    -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
-   mkFunTy a b = noLoc (HsFunTy noExtField HsUnrestrictedArrow a b)
+   mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
 
 getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
   -- Should only be called on ConDeclGADT
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index ffaec7f1..46f0cfe8 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -56,6 +56,7 @@ import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
 import qualified GHC.Utils.Outputable as O
 import GHC.Utils.Panic
 import GHC.HsToCore.Docs hiding (mkMaps)
+import GHC.Parser.Annotation (IsUnicodeSyntax(..))
 
 
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
@@ -957,7 +958,7 @@ extractPatternSyn nm t tvs cons =
     in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'')
 
   longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
-  longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField HsUnrestrictedArrow x y)) output inputs
+  longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs
 
   data_ty con
     | ConDeclGADT{} <- con = con_res_ty con
@@ -974,7 +975,7 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
 extractRecSel nm t tvs (L _ con : rest) =
   case getConArgs con of
     RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
-      L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField HsUnrestrictedArrow data_ty (getBangType ty)))))
+      L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))
     _ -> extractRecSel nm t tvs rest
  where
   matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 39a1ae17..67439383 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -223,9 +223,9 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
 renameMaybeInjectivityAnn = traverse renameInjectivityAnn
 
 renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)
-renameArrow HsUnrestrictedArrow = return HsUnrestrictedArrow
-renameArrow HsLinearArrow = return HsLinearArrow
-renameArrow (HsExplicitMult p) = HsExplicitMult <$> renameLType p
+renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u)
+renameArrow (HsLinearArrow u) = return (HsLinearArrow u)
+renameArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p
 
 renameType :: HsType GhcRn -> RnM (HsType DocNameI)
 renameType t = case t of
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 28806f04..ad5063b3 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -17,6 +17,7 @@ import GHC
 import GHC.Types.Name
 import GHC.Data.FastString
 import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )
+import GHC.Parser.Annotation (IsUnicodeSyntax(..))
 
 import Control.Monad
 import Control.Monad.Trans.State
@@ -136,7 +137,7 @@ sugarTuples typ =
 sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
 sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)
     | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
-    | unrestrictedFunTyConName == name' = HsFunTy noExtField HsUnrestrictedArrow la lb
+    | unrestrictedFunTyConName == name' = HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) la lb
   where
     name' = getName name
 sugarOperators typ = typ
@@ -290,7 +291,7 @@ renameType t@(HsTyLit _ _) = pure t
 renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
 
 renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)
-renameHsArrow (HsExplicitMult p) = HsExplicitMult <$> renameLType p
+renameHsArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p
 renameHsArrow mult = pure mult
 
 
-- 
cgit v1.2.3


From 904a3c276643d15da24303493b62e95dfb0b7726 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Mon, 26 Oct 2020 19:31:54 +0100
Subject: GHC.Driver.Types refactoring (#1242)

---
 haddock-api/src/Haddock/Backends/Hoogle.hs             | 5 +++--
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 +-
 haddock-api/src/Haddock/Convert.hs                     | 6 ++++--
 haddock-api/src/Haddock/GhcUtils.hs                    | 1 -
 haddock-api/src/Haddock/Interface.hs                   | 3 ++-
 haddock-api/src/Haddock/Interface/Create.hs            | 8 ++++++--
 haddock-api/src/Haddock/Interface/Json.hs              | 2 +-
 haddock-api/src/Haddock/InterfaceFile.hs               | 2 +-
 haddock-api/src/Haddock/Types.hs                       | 3 ++-
 9 files changed, 20 insertions(+), 12 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index ecc4bf97..c9aad6ed 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -17,8 +17,9 @@ module Haddock.Backends.Hoogle (
     ppHoogle
   ) where
 
-import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), SourceText(..)
-                  , PromotionFlag(..), TopLevelFlag(..) )
+import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..),
+                         PromotionFlag(..), TopLevelFlag(..) )
+import GHC.Types.SourceText
 import GHC.Core.InstEnv (ClsInst(..))
 import Documentation.Haddock.Markup
 import Haddock.GhcUtils
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 1b3ed35c..1de62a2e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -9,7 +9,7 @@ import Data.List           ( isPrefixOf, isSuffixOf )
 
 import qualified Data.ByteString as BS
 
-import GHC.Types.Basic     ( IntegralLit(..) )
+import GHC.Types.SourceText
 import GHC.Driver.Session
 import GHC.Utils.Error     ( pprLocErrMsg )
 import GHC.Data.FastString ( mkFastString )
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 650f8a1d..7eb9c683 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -22,8 +22,9 @@ module Haddock.Convert (
 #include "HsVersions.h"
 
 import GHC.Data.Bag ( emptyBag )
-import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..)
-                  , PromotionFlag(..), DefMethSpec(..) )
+import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..) )
+import GHC.Types.SourceText (SourceText(..))
+import GHC.Types.Fixity (LexicalFixity(..))
 import GHC.Core.Class
 import GHC.Core.Coercion.Axiom
 import GHC.Core.ConLike
@@ -31,6 +32,7 @@ import Data.Either (lefts, rights)
 import GHC.Core.DataCon
 import GHC.Core.FamInstEnv
 import GHC.Hs
+import GHC.Types.TyThing
 import GHC.Types.Name
 import GHC.Types.Name.Set    ( emptyNameSet )
 import GHC.Types.Name.Reader ( mkVarUnqual )
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index a03587b4..8d0b382b 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -32,7 +32,6 @@ import GHC.Utils.Panic ( panic )
 import GHC.Driver.Ppr (showPpr )
 import GHC.Types.Name
 import GHC.Unit.Module
-import GHC.Driver.Types
 import GHC
 import GHC.Core.Class
 import GHC.Driver.Session
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index a702d3d6..583cacf8 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -51,11 +51,12 @@ import Distribution.Verbosity
 import Text.Printf
 
 import GHC.Unit.Module.Env (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)
+import GHC.Unit.Module.ModSummary
 import GHC.Unit.Types
 import GHC.Data.Graph.Directed
 import GHC.Driver.Session hiding (verbosity)
 import GHC hiding (verbosity)
-import GHC.Driver.Types
+import GHC.Driver.Env
 import GHC.Data.FastString (unpackFS)
 import GHC.Tc.Types (tcg_rdr_env)
 import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 46f0cfe8..59809e89 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -40,10 +40,12 @@ import Data.Traversable
 import GHC.Types.Avail hiding (avail)
 import qualified GHC.Types.Avail  as Avail
 import qualified GHC.Unit.Module as Module
+import GHC.Unit.Module.ModDetails
+import GHC.Unit.Module.ModSummary
 import qualified GHC.Types.SrcLoc as SrcLoc
+import GHC.Types.SourceFile
 import GHC.Core.ConLike (ConLike(..))
 import GHC
-import GHC.Driver.Types
 import GHC.Driver.Ppr
 import GHC.Types.Name
 import GHC.Types.Name.Set
@@ -52,11 +54,13 @@ import GHC.Unit.State
 import GHC.Types.Name.Reader
 import GHC.Tc.Types
 import GHC.Data.FastString ( unpackFS, bytesFS )
-import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
+import GHC.Types.Basic ( PromotionFlag(..) )
+import GHC.Types.SourceText
 import qualified GHC.Utils.Outputable as O
 import GHC.Utils.Panic
 import GHC.HsToCore.Docs hiding (mkMaps)
 import GHC.Parser.Annotation (IsUnicodeSyntax(..))
+import GHC.Unit.Module.Warnings
 
 
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs
index 043a1530..df585f29 100644
--- a/haddock-api/src/Haddock/Interface/Json.hs
+++ b/haddock-api/src/Haddock/Interface/Json.hs
@@ -5,7 +5,7 @@ module Haddock.Interface.Json (
   , renderJson
   ) where
 
-import GHC.Types.Basic
+import GHC.Types.Fixity
 import GHC.Utils.Json
 import GHC.Unit.Module
 import GHC.Types.Name
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index fffef2fa..72fcb79b 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -38,7 +38,7 @@ import GHC.Data.FastMutInt
 import GHC.Data.FastString
 import GHC hiding (NoLink)
 import GHC.Driver.Monad (withSession)
-import GHC.Driver.Types
+import GHC.Driver.Env
 import GHC.Types.Name.Cache
 import GHC.Iface.Env
 import GHC.Types.Name
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 89fd6658..6aad5dd1 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -36,7 +36,8 @@ import Data.Typeable (Typeable)
 import Data.Map (Map)
 import Data.Data (Data)
 import Documentation.Haddock.Types
-import GHC.Types.Basic (Fixity(..), PromotionFlag(..))
+import GHC.Types.Basic (PromotionFlag(..))
+import GHC.Types.Fixity (Fixity(..))
 
 import GHC
 import GHC.Driver.Session (Language)
-- 
cgit v1.2.3


From 87a9f86d1ad7de67ff011311905ecf76578b26e9 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Fri, 16 Oct 2020 10:46:47 -0400
Subject: Adapt to the removal of Hs{Boxed,Constraint}Tuple

See ghc/ghc!4097 and GHC#18723.
---
 haddock-api/src/Haddock/Convert.hs              | 4 ++--
 haddock-api/src/Haddock/Interface/Specialize.hs | 2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 7eb9c683..b7faf6cd 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -561,8 +561,8 @@ synifyType _ vs (TyConApp tc tys)
       , tyConArity tc == tys_len
       = noLoc $ HsTupleTy noExtField
                           (case sort of
-                              BoxedTuple      -> HsBoxedTuple
-                              ConstraintTuple -> HsConstraintTuple
+                              BoxedTuple      -> HsBoxedOrConstraintTuple
+                              ConstraintTuple -> HsBoxedOrConstraintTuple
                               UnboxedTuple    -> HsUnboxedTuple)
                            (map (synifyType WithinType vs) vis_tys)
       | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExtField (map (synifyType WithinType vs) vis_tys)
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index ad5063b3..35e5258f 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -124,7 +124,7 @@ sugarTuples typ =
     aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp
     aux apps (HsParTy _ (L _ typ')) = aux apps typ'
     aux apps (HsTyVar _ _ (L _ name))
-        | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedTuple apps
+        | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedOrConstraintTuple apps
       where
         name' = getName name
         strName = getOccString name
-- 
cgit v1.2.3


From 3cce1bdee8c61bb6daa089059e12435178f50770 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Sat, 24 Oct 2020 10:38:55 -0400
Subject: Adapt to HsConDecl{H98,GADT}Details split

Needed for GHC#18844.
---
 haddock-api/src/Haddock/Backends/Hoogle.hs     |  4 +-
 haddock-api/src/Haddock/Backends/LaTeX.hs      | 30 ++++++------
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 30 ++++++------
 haddock-api/src/Haddock/Convert.hs             | 64 +++++++++++++++-----------
 haddock-api/src/Haddock/GhcUtils.hs            | 17 +++----
 haddock-api/src/Haddock/Interface/Create.hs    | 18 +++++---
 haddock-api/src/Haddock/Interface/Rename.hs    | 26 +++++++----
 haddock-api/src/Haddock/Utils.hs               | 28 +++++++----
 8 files changed, 124 insertions(+), 93 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index c9aad6ed..8939664d 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -236,9 +236,9 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
   _ -> []
 
 ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String]
-ppCtor dflags dat subdocs con@ConDeclH98 {}
+ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
   -- AZ:TODO get rid of the concatMap
-   = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con)
+   = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args'
     where
         f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
         f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index a90d9a6e..d0528322 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -796,20 +796,22 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
                             , ppLType unicode (getGADTConType con)
                             ]
 
-    fieldPart = case (con, getConArgsI con) of
-        -- Record style GADTs
-        (ConDeclGADT{}, RecCon _)            -> doConstrArgsWithDocs []
-
-        -- Regular record declarations
-        (_, RecCon (L _ fields))             -> doRecordFields fields
-
-        -- Any GADT or a regular H98 prefix data constructor
-        (_, PrefixCon args)     | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
-
-        -- An infix H98 data constructor
-        (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])
-
-        _ -> empty
+    fieldPart = case con of
+        ConDeclGADT{con_g_args = con_args'} -> case con_args' of
+          -- GADT record declarations
+          RecConGADT _                    -> doConstrArgsWithDocs []
+          -- GADT prefix data constructors
+          PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)
+          _                               -> empty
+
+        ConDeclH98{con_args = con_args'} -> case con_args' of
+          -- H98 record declarations
+          RecCon (L _ fields)             -> doRecordFields fields
+          -- H98 prefix data constructors
+          PrefixCon args | hasArgDocs     -> doConstrArgsWithDocs (map hsScaledThing args)
+          -- H98 infix data constructor
+          InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])
+          _                               -> empty
 
     doRecordFields fields =
       vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 20e099ee..d80f8e95 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -937,20 +937,22 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
                               , fixity
                               ]
 
-    fieldPart = case (con, getConArgsI con) of
-        -- Record style GADTs
-        (ConDeclGADT{}, RecCon _)            -> [ doConstrArgsWithDocs [] ]
-
-        -- Regular record declarations
-        (_, RecCon (L _ fields))             -> [ doRecordFields fields ]
-
-        -- Any GADT or a regular H98 prefix data constructor
-        (_, PrefixCon args)     | hasArgDocs -> [ doConstrArgsWithDocs args ]
-
-        -- An infix H98 data constructor
-        (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]
-
-        _ -> []
+    fieldPart = case con of
+        ConDeclGADT{con_g_args = con_args'} -> case con_args' of
+          -- GADT record declarations
+          RecConGADT _                    -> [ doConstrArgsWithDocs [] ]
+          -- GADT prefix data constructors
+          PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ]
+          _                               -> []
+
+        ConDeclH98{con_args = con_args'} -> case con_args' of
+          -- H98 record declarations
+          RecCon (L _ fields)             -> [ doRecordFields fields ]
+          -- H98 prefix data constructors
+          PrefixCon args | hasArgDocs     -> [ doConstrArgsWithDocs args ]
+          -- H98 infix data constructor
+          InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]
+          _                               -> []
 
     doRecordFields fields = subFields pkg qual
       (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index b7faf6cd..c0347e56 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -387,34 +387,44 @@ synifyDataCon use_gadt_syntax dc =
   con_decl_field fl synTy = noLoc $
     ConDeclField noExtField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy
                  Nothing
-  hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
-          (True,True) -> Left "synifyDataCon: contradiction!"
-          (True,False) -> return $ RecCon (noLoc field_tys)
-          (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys)
-          (False,True) -> case linear_tys of
-                           [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)
-                           _ -> Left "synifyDataCon: infix with non-2 args?"
+
+  mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn)
+  mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
+    (True,True) -> Left "synifyDataCon: contradiction!"
+    (True,False) -> return $ RecCon (noLoc field_tys)
+    (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys)
+    (False,True) -> case linear_tys of
+                     [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)
+                     _ -> Left "synifyDataCon: infix with non-2 args?"
+
+  mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn
+  mk_gadt_arg_tys
+    | use_named_field_syntax = RecConGADT (noLoc field_tys)
+    | otherwise              = PrefixConGADT (map hsUnrestricted linear_tys)
+
  -- finally we get synifyDataCon's result!
- in hs_arg_tys >>=
-      \hat ->
-        if use_gadt_syntax
-           then return $ noLoc $
-              ConDeclGADT { con_g_ext  = []
-                          , con_names  = [name]
-                          , con_forall = noLoc $ not $ null user_tvbndrs
-                          , con_qvars  = map synifyTyVarBndr user_tvbndrs
-                          , con_mb_cxt = ctx
-                          , con_args   = hat
-                          , con_res_ty = synifyType WithinType [] res_ty
-                          , con_doc    = Nothing }
-           else return $ noLoc $
-              ConDeclH98 { con_ext    = noExtField
-                         , con_name   = name
-                         , con_forall = noLoc False
-                         , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs
-                         , con_mb_cxt = ctx
-                         , con_args   = hat
-                         , con_doc    = Nothing }
+ in if use_gadt_syntax
+       then do
+         let hat = mk_gadt_arg_tys
+         return $ noLoc $ ConDeclGADT
+           { con_g_ext  = []
+           , con_names  = [name]
+           , con_forall = noLoc $ not $ null user_tvbndrs
+           , con_qvars  = map synifyTyVarBndr user_tvbndrs
+           , con_mb_cxt = ctx
+           , con_g_args = hat
+           , con_res_ty = synifyType WithinType [] res_ty
+           , con_doc    = Nothing }
+       else do
+         hat <- mk_h98_arg_tys
+         return $ noLoc $ ConDeclH98
+           { con_ext    = noExtField
+           , con_name   = name
+           , con_forall = noLoc False
+           , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs
+           , con_mb_cxt = ctx
+           , con_args   = hat
+           , con_doc    = Nothing }
 
 synifyName :: NamedThing n => n -> Located Name
 synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 8d0b382b..d6d12e4e 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -134,9 +134,6 @@ mkHsForAllInvisTeleI ::
 mkHsForAllInvisTeleI invis_bndrs =
   HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs }
 
-getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI
-getConArgsI d = con_args d
-
 getGADTConType :: ConDecl DocNameI -> LHsType DocNameI
 -- The full type of a GADT data constructor We really only get this in
 -- order to pretty-print it, and currently only in Haddock's code.  So
@@ -144,7 +141,7 @@ getGADTConType :: ConDecl DocNameI -> LHsType DocNameI
 -- 'undefined's
 getGADTConType (ConDeclGADT { con_forall = L _ has_forall
                             , con_qvars = qtvs
-                            , con_mb_cxt = mcxt, con_args = args
+                            , con_mb_cxt = mcxt, con_g_args = args
                             , con_res_ty = res_ty })
  | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
                                   , hst_tele = mkHsForAllInvisTeleI qtvs
@@ -158,9 +155,8 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall
 
 --  tau_ty :: LHsType DocNameI
    tau_ty = case args of
-              RecCon flds ->  mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
-              PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
-              InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)
+              RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
+              PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
 
    mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
 
@@ -199,7 +195,7 @@ getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn
 -- 'undefined's
 getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
                             , con_qvars = qtvs
-                            , con_mb_cxt = mcxt, con_args = args
+                            , con_mb_cxt = mcxt, con_g_args = args
                             , con_res_ty = res_ty })
  | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
                                   , hst_tele = mkHsForAllInvisTele qtvs
@@ -213,9 +209,8 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
 
 --   tau_ty :: LHsType DocNameI
    tau_ty = case args of
-              RecCon flds ->  mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
-              PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
-              InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)
+              RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
+              PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
 
    -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
    mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 59809e89..ecaf1a5d 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -926,7 +926,7 @@ extractDecl declMap name decl
             let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
                                    <- insts
                                  -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)
-                               , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d))
+                               , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d))
                                , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
                                , L _ n <- ns
                                , extFieldOcc n == name
@@ -949,10 +949,14 @@ extractPatternSyn nm t tvs cons =
   extract :: ConDecl GhcRn -> Sig GhcRn
   extract con =
     let args =
-          case getConArgs con of
-            PrefixCon args' -> (map hsScaledThing args')
-            RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
-            InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
+          case con of
+            ConDeclH98 { con_args = con_args' } -> case con_args' of
+              PrefixCon args' -> map hsScaledThing args'
+              RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
+              InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
+            ConDeclGADT { con_g_args = con_args' } -> case con_args' of
+              PrefixConGADT args' -> map hsScaledThing args'
+              RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields
         typ = longArrow args (data_ty con)
         typ' =
           case con of
@@ -977,8 +981,8 @@ extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]
 extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
 
 extractRecSel nm t tvs (L _ con : rest) =
-  case getConArgs con of
-    RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
+  case getRecConArgs_maybe con of
+    Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->
       L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))
     _ -> extractRecSel nm t tvs rest
  where
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 67439383..e7d19dfe 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -479,7 +479,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
       lname'    <- renameL lname
       ltyvars'  <- mapM renameLTyVarBndr ltyvars
       lcontext' <- traverse renameLContext lcontext
-      details'  <- renameDetails details
+      details'  <- renameH98Details details
       mbldoc'   <- mapM renameLDocHsSyn mbldoc
       return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars'
                    , con_mb_cxt = lcontext'
@@ -487,18 +487,18 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
                    , con_args = details', con_doc = mbldoc' })
 
 renameCon ConDeclGADT { con_names = lnames, con_qvars = ltyvars
-                            , con_mb_cxt = lcontext, con_args = details
+                            , con_mb_cxt = lcontext, con_g_args = details
                             , con_res_ty = res_ty, con_forall = forall
                             , con_doc = mbldoc } = do
       lnames'   <- mapM renameL lnames
       ltyvars'  <- mapM renameLTyVarBndr ltyvars
       lcontext' <- traverse renameLContext lcontext
-      details'  <- renameDetails details
+      details'  <- renameGADTDetails details
       res_ty'   <- renameLType res_ty
       mbldoc'   <- mapM renameLDocHsSyn mbldoc
       return (ConDeclGADT
                    { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars'
-                   , con_mb_cxt = lcontext', con_args = details'
+                   , con_mb_cxt = lcontext', con_g_args = details'
                    , con_res_ty = res_ty', con_doc = mbldoc'
                    , con_forall = forall}) -- Remove when #18311 is fixed
 
@@ -506,18 +506,24 @@ renameHsScaled :: HsScaled GhcRn (LHsType GhcRn)
                -> RnM (HsScaled DocNameI (LHsType DocNameI))
 renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty
 
-renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI)
-renameDetails (RecCon (L l fields)) = do
+renameH98Details :: HsConDeclH98Details GhcRn
+                 -> RnM (HsConDeclH98Details DocNameI)
+renameH98Details (RecCon (L l fields)) = do
   fields' <- mapM renameConDeclFieldField fields
   return (RecCon (L l fields'))
-                               -- This causes an assertion failure
---renameDetails (PrefixCon ps) = -- return . PrefixCon =<< mapM (_renameLType) ps
-renameDetails (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps
-renameDetails (InfixCon a b) = do
+renameH98Details (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps
+renameH98Details (InfixCon a b) = do
   a' <- renameHsScaled a
   b' <- renameHsScaled b
   return (InfixCon a' b')
 
+renameGADTDetails :: HsConDeclGADTDetails GhcRn
+                  -> RnM (HsConDeclGADTDetails DocNameI)
+renameGADTDetails (RecConGADT (L l fields)) = do
+  fields' <- mapM renameConDeclFieldField fields
+  return (RecConGADT (L l fields'))
+renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps
+
 renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
 renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do
   names' <- mapM renameLFieldOcc names
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 33fbd000..1177fb18 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -187,21 +187,33 @@ restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn]
 restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
   where
     keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =
-      case con_args d of
-        PrefixCon _ -> Just d
-        RecCon fields
-          | all field_avail (unL fields) -> Just d
-          | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) })
+      case d of
+        ConDeclH98 { con_args = args }    -> restrict_h98_args args
+        ConDeclGADT { con_g_args = args } -> restrict_gadt_args args
+      where
+        restrict_h98_args :: HsConDeclH98Details GhcRn -> Maybe (ConDecl GhcRn)
+        restrict_h98_args (PrefixCon _) = Just d
+        restrict_h98_args (RecCon (L _ fields))
+          | all field_avail fields = Just d
+          | otherwise = Just (d { con_args = PrefixCon (field_types fields) })
           -- if we have *all* the field names available, then
           -- keep the record declaration.  Otherwise degrade to
           -- a constructor declaration.  This isn't quite right, but
           -- it's the best we can do.
-        InfixCon _ _ -> Just d
-      where
+
+        restrict_h98_args (InfixCon _ _) = Just d
+
+        restrict_gadt_args :: HsConDeclGADTDetails GhcRn -> Maybe (ConDecl GhcRn)
+        restrict_gadt_args (PrefixConGADT _) = Just d
+        restrict_gadt_args (RecConGADT (L _ fields))
+          | all field_avail fields = Just d
+          | otherwise = Just (d { con_g_args = PrefixConGADT (field_types fields) })
+          -- see the comments for the RecCon case of `restrict_h98_args` above
+
         field_avail :: LConDeclField GhcRn -> Bool
         field_avail (L _ (ConDeclField _ fs _ _))
             = all (\f -> extFieldOcc (unLoc f) `elem` names) fs
-        field_types flds = [ hsUnrestricted t | ConDeclField _ _ t _ <- flds ]
+        field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ]
 
     keep _ = Nothing
 
-- 
cgit v1.2.3


From ad9cbad7312a64e6757c32bd9488c55ba4f2fec9 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Wed, 23 Sep 2020 20:37:34 -0400
Subject: Adapt to HsOuterTyVarBndrs

These changes accompany ghc/ghc!4107, which aims to be a fix
for #16762.
---
 haddock-api/src/Haddock/Backends/Hoogle.hs      |  61 +++---
 haddock-api/src/Haddock/Backends/LaTeX.hs       |  66 ++++--
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs  |  94 +++++---
 haddock-api/src/Haddock/Convert.hs              |  44 ++--
 haddock-api/src/Haddock/GhcUtils.hs             |  76 ++++---
 haddock-api/src/Haddock/Interface/Create.hs     |  17 +-
 haddock-api/src/Haddock/Interface/Rename.hs     |  70 +++---
 haddock-api/src/Haddock/Interface/Specialize.hs |  69 ++++--
 haddock-api/src/Haddock/Syb.hs                  |  17 +-
 haddock-api/src/Haddock/Types.hs                |  11 +-
 haddock-api/src/Haddock/Utils.hs                |  34 ++-
 hypsrc-test/ref/src/Classes.html                | 276 ++++++++++++------------
 12 files changed, 488 insertions(+), 347 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 8939664d..44841bc5 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -71,27 +71,31 @@ ppModule dflags iface =
 ---------------------------------------------------------------------
 -- Utility functions
 
-dropHsDocTy :: HsType (GhcPass p) -> HsType (GhcPass p)
-dropHsDocTy = f
+dropHsDocTy :: HsSigType (GhcPass p) -> HsSigType (GhcPass p)
+dropHsDocTy = drop_sig_ty
     where
-        g (L src x) = L src (f x)
-        f (HsForAllTy x a e) = HsForAllTy x a (g e)
-        f (HsQualTy x a e) = HsQualTy x a (g e)
-        f (HsBangTy x a b) = HsBangTy x a (g b)
-        f (HsAppTy x a b) = HsAppTy x (g a) (g b)
-        f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b)
-        f (HsFunTy x w a b) = HsFunTy x w (g a) (g b)
-        f (HsListTy x a) = HsListTy x (g a)
-        f (HsTupleTy x a b) = HsTupleTy x a (map g b)
-        f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)
-        f (HsParTy x a) = HsParTy x (g a)
-        f (HsKindSig x a b) = HsKindSig x (g a) b
-        f (HsDocTy _ a _) = f $ unL a
-        f x = x
-
-outHsType :: (OutputableBndrId p)
-          => DynFlags -> HsType (GhcPass p) -> String
-outHsType dflags = out dflags . reparenType . dropHsDocTy
+        drop_sig_ty (HsSig x a b)  = HsSig x a (drop_lty b)
+        drop_sig_ty x@XHsSigType{} = x
+
+        drop_lty (L src x) = L src (drop_ty x)
+
+        drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e)
+        drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e)
+        drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b)
+        drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b)
+        drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b)
+        drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)
+        drop_ty (HsListTy x a) = HsListTy x (drop_lty a)
+        drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b)
+        drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c)
+        drop_ty (HsParTy x a) = HsParTy x (drop_lty a)
+        drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b
+        drop_ty (HsDocTy _ a _) = drop_ty $ unL a
+        drop_ty x = x
+
+outHsSigType :: (OutputableBndrId p, NoGhcTcPass p ~ p)
+             => DynFlags -> HsSigType (GhcPass p) -> String
+outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy
 
 
 dropComment :: String -> String
@@ -135,8 +139,8 @@ ppExport dflags ExportDecl { expItemDecl    = L _ decl
         f (TyClD _ d@SynDecl{})   = ppSynonym dflags d
         f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs
         f (TyClD _ (FamDecl _ d)) = ppFam dflags d
-        f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
-        f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]
+        f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ]
+        f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ]
         f (SigD _ sig) = ppSig dflags sig
         f _ = []
 
@@ -145,8 +149,8 @@ ppExport _ _ = []
 
 ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]
 ppSigWithDoc dflags sig subdocs = case sig of
-    TypeSig _ names t -> concatMap (mkDocSig "" (hsSigWcType t)) names
-    PatSynSig _ names t -> concatMap (mkDocSig "pattern " (hsSigType t)) names
+    TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names
+    PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names
     _ -> []
   where
     mkDocSig leader typ n = mkSubdoc dflags n subdocs
@@ -155,9 +159,9 @@ ppSigWithDoc dflags sig subdocs = case sig of
 ppSig :: DynFlags -> Sig GhcRn -> [String]
 ppSig dflags x  = ppSigWithDoc dflags x []
 
-pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String
+pp_sig :: DynFlags -> [Located Name] -> LHsSigType GhcRn -> String
 pp_sig dflags names (L _ typ)  =
-    operator prettyNames ++ " :: " ++ outHsType dflags typ
+    operator prettyNames ++ " :: " ++ outHsSigType dflags typ
     where
       prettyNames = intercalate ", " $ map (out dflags) names
 
@@ -250,7 +254,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
         funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)
         apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
 
-        typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
+        typeSig nm flds = operator nm ++ " :: " ++
+                          outHsSigType dflags (unL $ mkEmptySigType $ funs flds)
 
         -- We print the constructors as comma-separated list. See GHC
         -- docs for con_names on why it is a list to begin with.
@@ -269,7 +274,7 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { })
     where
         f = [typeSig name (getGADTConTypeG con)]
 
-        typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)
+        typeSig nm ty = operator nm ++ " :: " ++ outHsSigType dflags (unL ty)
         name = out dflags $ map unL $ getConNames con
 
 ppFixity :: DynFlags -> (Name, Fixity) -> [String]
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index d0528322..3a774ace 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -210,10 +210,10 @@ processExports (e : es) =
   processExport e $$ processExports es
 
 
-isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI)
+isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI)
 isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t))
                        , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
-  | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))
+  | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t))
 isSimpleSig _ = Nothing
 
 
@@ -296,7 +296,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
 --    | Just _  <- tcdTyPats d    -> ppTyInst False loc doc d unicode
 -- Family instances happen via FamInst now
   TyClD _ d@ClassDecl{}          -> ppClassDecl instances doc subdocs d unicode
-  SigD _ (TypeSig _ lnames ty)   -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode
+  SigD _ (TypeSig _ lnames ty)   -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode
   SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode
   ForD _ d                       -> ppFor (doc, fnArgsDoc) d unicode
   InstD _ _                      -> empty
@@ -308,7 +308,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of
 
 ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX
 ppFor doc (ForeignImport _ (L _ name) typ _) unicode =
-  ppFunSig doc [name] (hsSigTypeI typ) unicode
+  ppFunSig doc [name] typ unicode
 ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
 --  error "foreign declarations are currently not supported by --latex"
 
@@ -343,9 +343,9 @@ ppFamDecl doc instances decl unicode =
 
     -- Individual equations of a closed type family
     ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX
-    ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
-                                            , feqn_rhs = rhs
-                                            , feqn_pats = ts } })
+    ppFamDeclEqn (FamEqn { feqn_tycon = L _ n
+                         , feqn_rhs = rhs
+                         , feqn_pats = ts })
       = hsep [ ppAppNameTypeArgs n ts unicode
              , equals
              , ppType unicode (unLoc rhs)
@@ -396,7 +396,7 @@ ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX
 
 ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
                          , tcdRhs = ltype }) unicode
-  = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode
+  = ppTypeOrFunSig (mkHsImplicitSigTypeI ltype) doc (full, hdr, char '=') unicode
   where
     hdr  = hsep (keyword "type"
                  : ppDocBinder name
@@ -411,7 +411,7 @@ ppTySyn _ _ _ = error "declaration not supported by ppTySyn"
 -------------------------------------------------------------------------------
 
 
-ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI
+ppFunSig :: DocForDecl DocName -> [DocName] -> LHsSigType DocNameI
          -> Bool -> LaTeX
 ppFunSig doc docnames (L _ typ) unicode =
   ppTypeOrFunSig typ doc
@@ -437,12 +437,12 @@ ppLPatSig doc docnames ty unicode
       )
       unicode
   where
-    typ = unLoc (hsSigTypeI ty)
+    typ = unLoc ty
     names = map getName docnames
 
 -- | Pretty-print a type, adding documentation to the whole type and its
 -- arguments as needed.
-ppTypeOrFunSig :: HsType DocNameI
+ppTypeOrFunSig :: HsSigType DocNameI
                -> DocForDecl DocName  -- ^ documentation
                -> ( LaTeX             --   first-line (no-argument docs only)
                   , LaTeX             --   first-line (argument docs only)
@@ -462,13 +462,24 @@ ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode
 -- to the arguments. The output is a list of (leader/seperator, argument and
 -- its doc)
 ppSubSigLike :: Bool                  -- ^ unicode
-             -> HsType DocNameI       -- ^ type signature
+             -> HsSigType DocNameI    -- ^ type signature
              -> FnArgsDoc DocName     -- ^ docs to add
              -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`)
              -> LaTeX                 -- ^ seperator (beginning of first line)
              -> [(LaTeX, LaTeX)]      -- ^ arguments (leader/sep, type)
-ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
+ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ
   where
+    do_sig_args :: Int -> LaTeX -> HsSigType DocNameI -> [(LaTeX, LaTeX)]
+    do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) =
+      case outer_bndrs of
+        HsOuterExplicit{hso_bndrs = bndrs} ->
+          [ ( decltt leader
+            , decltt (ppHsForAllTelescope (mkHsForAllInvisTeleI bndrs) unicode)
+                <+> ppLType unicode ltype
+            ) ]
+        HsOuterImplicit{} -> do_largs n leader ltype
+
+    do_largs :: Int -> LaTeX -> LHsType DocNameI -> [(LaTeX, LaTeX)]
     do_largs n leader (L _ t) = do_args n leader t
 
     arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
@@ -505,12 +516,16 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
     gadtOpen = text "\\{"
 
 
-ppTypeSig :: [Name] -> HsType DocNameI  -> Bool -> LaTeX
+ppTypeSig :: [Name] -> HsSigType DocNameI  -> Bool -> LaTeX
 ppTypeSig nms ty unicode =
   hsep (punctuate comma $ map ppSymName nms)
     <+> dcolon unicode
-    <+> ppType unicode ty
+    <+> ppSigType unicode ty
 
+ppHsOuterTyVarBndrs :: HsOuterTyVarBndrs flag DocNameI -> Bool -> LaTeX
+ppHsOuterTyVarBndrs (HsOuterImplicit{}) _ = empty
+ppHsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) unicode =
+    hsep (forallSymbol unicode : ppTyVars bndrs) <> dot
 
 ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX
 ppHsForAllTelescope tele unicode = case tele of
@@ -617,7 +632,7 @@ ppClassDecl instances doc subdocs
 
     methodTable =
       text "\\haddockpremethods{}" <> emph (text "Methods") $$
-      vcat  [ ppFunSig doc names (hsSigWcType typ) unicode
+      vcat  [ ppFunSig doc names (dropWildCards typ) unicode
             | L _ (TypeSig _ lnames typ) <- lsigs
             , let doc = lookupAnySubdoc (head names) subdocs
                   names = map unLoc lnames ]
@@ -793,7 +808,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
         | otherwise -> hsep [ ppOcc
                             , dcolon unicode
                             -- ++AZ++ make this prepend "{..}" when it is a record style GADT
-                            , ppLType unicode (getGADTConType con)
+                            , ppLSigType unicode (getGADTConType con)
                             ]
 
     fieldPart = case con of
@@ -868,18 +883,16 @@ ppSideBySidePat lnames typ (doc, argDocs) unicode =
          | otherwise = hsep [ keyword "pattern"
                             , ppOcc
                             , dcolon unicode
-                            , ppLType unicode (hsSigTypeI typ)
+                            , ppLSigType unicode typ
                             ]
 
     fieldPart
       | not hasArgDocs = empty
       | otherwise = vcat
           [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r
-          | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode)
+          | (l,r) <- ppSubSigLike unicode (unLoc typ) argDocs [] (dcolon unicode)
           ]
 
-    patTy = hsSigTypeI typ
-
     mDoc = fmap _doc $ combineDocumentation doc
 
 
@@ -1000,12 +1013,18 @@ ppLType       unicode y = ppType unicode (unLoc y)
 ppLParendType unicode y = ppParendType unicode (unLoc y)
 ppLFunLhType  unicode y = ppFunLhType unicode (unLoc y)
 
+ppLSigType :: Bool -> LHsSigType DocNameI -> LaTeX
+ppLSigType unicode y = ppSigType unicode (unLoc y)
+
 ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX
 ppType       unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
 ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
 ppFunLhType  unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode
 ppCtxType    unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode
 
+ppSigType :: Bool -> HsSigType DocNameI -> LaTeX
+ppSigType unicode sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode
+
 ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX
 ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty
 ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <>
@@ -1038,6 +1057,11 @@ ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode
 -- Drop top-level for-all type variables in user style
 -- since they are implicit in Haskell
 
+ppr_sig_ty :: HsSigType DocNameI -> Bool -> LaTeX
+ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode
+  = sep [ ppHsOuterTyVarBndrs outer_bndrs unicode
+        , ppr_mono_lty ltype unicode ]
+
 ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX
 ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index d80f8e95..8b9739f1 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -62,9 +62,9 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
   TyClD _ d@(SynDecl {})         -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual
   TyClD _ d@(ClassDecl {})       -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual
   SigD _ (TypeSig _ lnames lty)  -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
-                                         (hsSigWcType lty) fixities splice unicode pkg qual
+                                         (dropWildCards lty) fixities splice unicode pkg qual
   SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
-                                         (hsSigTypeI lty) fixities splice unicode pkg qual
+                                         lty fixities splice unicode pkg qual
   ForD _ d                       -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
   InstD _ _                      -> noHtml
   DerivD _ _                     -> noHtml
@@ -72,25 +72,25 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc
 
 
 ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
-             [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
+             [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->
              Splice -> Unicode -> Maybe Package -> Qualification -> Html
 ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual =
   ppFunSig summary links loc doc (map unLoc lnames) lty fixities
            splice unicode pkg qual
 
 ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
-            [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->
+            [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->
             Splice -> Unicode -> Maybe Package -> Qualification -> Html
 ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual =
   ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)
             splice unicode pkg qual HideEmptyContexts
   where
-    pp_typ = ppLType unicode qual HideEmptyContexts typ
+    pp_typ = ppLSigType unicode qual HideEmptyContexts typ
 
 -- | Pretty print a pattern synonym
 ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
           -> [Located DocName]     -- ^ names of patterns in declaration
-          -> LHsType DocNameI      -- ^ type of patterns in declaration
+          -> LHsSigType DocNameI   -- ^ type of patterns in declaration
           -> [(DocName, Fixity)]
           -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
 ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual =
@@ -101,7 +101,7 @@ ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual =
 
 
 ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
-             [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->
+             [DocName] -> [(DocName, Fixity)] -> (HsSigType DocNameI, Html) ->
              Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html
 ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
           splice unicode pkg qual emptyCtxts =
@@ -118,7 +118,7 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
       | otherwise = html <+> ppFixities fixities qual
 
 
-ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI
+ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsSigType DocNameI
                -> DocForDecl DocName -> (Html, Html, Html)
                -> Splice -> Unicode -> Maybe Package -> Qualification
                -> HideEmptyContexts -> Html
@@ -139,15 +139,24 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
 -- If one passes in a list of the available subdocs, any top-level `HsRecTy`
 -- found will be expanded out into their fields.
 ppSubSigLike :: Unicode -> Qualification
-             -> HsType DocNameI                  -- ^ type signature
+             -> HsSigType DocNameI               -- ^ type signature
              -> FnArgsDoc DocName                -- ^ docs to add
              -> [(DocName, DocForDecl DocName)]  -- ^ all subdocs (useful when
                                                  -- we expand an `HsRecTy`)
              -> Html -> HideEmptyContexts -> [SubDecl]
-ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
+ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep typ
   where
+    do_sig_args :: Int -> Html -> HsSigType DocNameI -> [SubDecl]
+    do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) =
+      case outer_bndrs of
+        HsOuterExplicit{hso_bndrs = bndrs} -> do_largs n (leader' bndrs) ltype
+        HsOuterImplicit{}                  -> do_largs n leader          ltype
+      where
+        leader' bndrs = leader <+> ppForAll (mkHsForAllInvisTeleI bndrs) unicode qual
+
     argDoc n = Map.lookup n argDocs
 
+    do_largs :: Int -> Html -> LHsType DocNameI -> [SubDecl]
     do_largs n leader (L _ t) = do_args n leader t
 
     do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
@@ -239,7 +248,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
       -> Splice -> Unicode -> Maybe Package -> Qualification -> Html
 ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities
       splice unicode pkg qual
-  = ppFunSig summary links loc doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual
+  = ppFunSig summary links loc doc [name] typ fixities splice unicode pkg qual
 ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"
 
 
@@ -250,13 +259,14 @@ ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan
 ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
                                                 , tcdRhs = ltype })
         splice unicode pkg qual
-  = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
+  = ppTypeOrFunSig summary links loc [name] sig_type doc
                    (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
                    splice unicode pkg qual ShowEmptyToplevelContexts
   where
+    sig_type = mkHsImplicitSigTypeI ltype
     hdr  = hsep ([keyword "type", ppBinder summary occ]
                  ++ ppTyVars unicode qual (hsQTvExplicit ltyvars))
-    full = hdr <+> equals <+> ppPatSigType unicode qual ltype
+    full = hdr <+> equals <+> ppPatSigType unicode qual (noLoc sig_type)
     occ  = nameOccName . getName $ name
     fixs
       | summary   = noHtml
@@ -276,13 +286,13 @@ ppTyName = ppName Prefix
 
 
 ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan
-            -> [DocName] -> HsType DocNameI
+            -> [DocName] -> HsSigType DocNameI
             -> Html
 ppSimpleSig links splice unicode qual emptyCtxts loc names typ =
     topDeclElem' names $ ppTypeSig True occNames ppTyp unicode
   where
     topDeclElem' = topDeclElem links loc splice
-    ppTyp = ppType unicode qual emptyCtxts typ
+    ppTyp = ppSigType unicode qual emptyCtxts typ
     occNames = map getOccName names
 
 
@@ -322,9 +332,9 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod
 
     -- Individual equation of a closed type family
     ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl
-    ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
-                                            , feqn_rhs = rhs
-                                            , feqn_pats = ts } })
+    ppFamDeclEqn (FamEqn { feqn_tycon = L _ n
+                         , feqn_rhs = rhs
+                         , feqn_pats = ts })
       = ( ppAppNameTypeArgs n ts unicode qual
           <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
         , Nothing
@@ -518,7 +528,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
 
                 -- ToDo: add associated type defaults
 
-            [ ppFunSig summary links loc doc names (hsSigTypeI typ)
+            [ ppFunSig summary links loc doc names typ
                        [] splice unicode pkg qual
               | L _ (ClassOpSig _ False lnames typ) <- sigs
               , let doc = lookupAnySubdoc (head names) subdocs
@@ -568,7 +578,7 @@ ppClassDecl summary links instances fixities loc d subdocs
                             doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
                             subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
 
-    methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigTypeI typ)
+    methodBit = subMethods [ ppFunSig summary links loc doc [name] typ
                                       subfixs splice unicode pkg qual
                            | L _ (ClassOpSig _ _ lnames typ) <- lsigs
                            , name <- map unLoc lnames
@@ -692,7 +702,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
 ppInstanceSigs links splice unicode qual sigs = do
     TypeSig _ lnames typ <- sigs
     let names = map unLoc lnames
-        L _ rtyp = hsSigWcType typ
+        L _ rtyp = dropWildCards typ
     -- Instance methods signatures are synified and thus don't have a useful
     -- SrcSpan value. Use the methods name location instead.
     return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp
@@ -755,7 +765,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual
     pats1 = [ hsep [ keyword "pattern"
                    , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
                    , dcolon unicode
-                   , ppPatSigType unicode qual (hsSigTypeI typ)
+                   , ppPatSigType unicode qual typ
                    ]
             | (SigD _ (PatSynSig _ lnames typ),_) <- pats
             ]
@@ -863,7 +873,7 @@ ppShortConstrParts summary dataInst con unicode qual
 
       -- GADT constructor, e.g. 'Foo :: Int -> Foo'
       ConDeclGADT {} ->
-          ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ]
+          ( hsep [ ppOcc, dcolon unicode, ppLSigType unicode qual HideEmptyContexts (getGADTConType con) ]
           , noHtml
           , noHtml
           )
@@ -933,7 +943,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
           | otherwise -> hsep [ ppOcc
                               , dcolon unicode
                               -- ++AZ++ make this prepend "{..}" when it is a record style GADT
-                              , ppLType unicode qual HideEmptyContexts (getGADTConType con)
+                              , ppLSigType unicode qual HideEmptyContexts (getGADTConType con)
                               , fixity
                               ]
 
@@ -1037,18 +1047,17 @@ ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =
          | otherwise = hsep [ keyword "pattern"
                             , ppOcc
                             , dcolon unicode
-                            , ppPatSigType unicode qual (hsSigTypeI typ)
+                            , ppPatSigType unicode qual typ
                             , fixity
                             ]
 
     fieldPart
       | not hasArgDocs = []
-      | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy)
+      | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc typ)
                                                         argDocs [] (dcolon unicode)
                                                         emptyCtxt) ]
 
-    patTy = hsSigTypeI typ
-    emptyCtxt = patSigContext patTy
+    emptyCtxt = patSigContext typ
 
 
 -- | Print the LHS of a data\/newtype declaration.
@@ -1102,6 +1111,9 @@ ppLType       unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc
 ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y)
 ppLFunLhType  unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y)
 
+ppLSigType ::  Unicode -> Qualification -> HideEmptyContexts -> LHsSigType DocNameI -> Html
+ppLSigType unicode qual emptyCtxts y = ppSigType unicode qual emptyCtxts (unLoc y)
+
 ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html
 ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts
 
@@ -1110,6 +1122,9 @@ ppType       unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP
 ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts
 ppFunLhType  unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts
 
+ppSigType ::  Unicode -> Qualification -> HideEmptyContexts -> HsSigType DocNameI -> Html
+ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode qual emptyCtxts
+
 ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html
 ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty
 ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <>
@@ -1144,10 +1159,12 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y)
 ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html
 ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts
 
-patSigContext :: LHsType DocNameI -> HideEmptyContexts
-patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmptyToplevelContexts
-                  | otherwise = HideEmptyContexts
+patSigContext :: LHsSigType DocNameI -> HideEmptyContexts
+patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmptyToplevelContexts
+                      | otherwise = HideEmptyContexts
   where
+    typ = sig_body (unLoc sig_typ)
+
     hasNonEmptyContext t =
       case unLoc t of
         HsForAllTy _ _ s -> hasNonEmptyContext s
@@ -1164,9 +1181,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmp
 
 -- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in
 -- the right 'HideEmptyContext' value)
-ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html
+ppPatSigType :: Unicode -> Qualification -> LHsSigType DocNameI -> Html
 ppPatSigType unicode qual typ =
-  let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ
+  let emptyCtxts = patSigContext typ in ppLSigType unicode qual emptyCtxts typ
+
+ppHsOuterTyVarBndrs :: RenderableBndrFlag flag
+                    => Unicode -> Qualification -> HsOuterTyVarBndrs flag DocNameI -> Html
+ppHsOuterTyVarBndrs unicode qual outer_bndrs = case outer_bndrs of
+  HsOuterImplicit{} -> noHtml
+  HsOuterExplicit{hso_bndrs = bndrs} ->
+    hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot
 
 ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html
 ppForAllPart unicode qual tele = case tele of
@@ -1176,6 +1200,10 @@ ppForAllPart unicode qual tele = case tele of
   HsForAllInvis { hsf_invis_bndrs = bndrs } ->
     hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot
 
+ppr_sig_ty :: HsSigType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode qual emptyCtxts
+  = ppHsOuterTyVarBndrs unicode qual outer_bndrs <+> ppr_mono_lty ltype unicode qual emptyCtxts
+
 ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
 ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
 
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index c0347e56..2f342ba4 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -58,7 +58,7 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..))
 import Haddock.Types
 import Haddock.Interface.Specialize
 import Haddock.GhcUtils                      ( orderedFVs, defaultRuntimeRepVars )
-
+import Haddock.Utils                         ( mkEmptySigType )
 
 import Data.Maybe                            ( catMaybes, mapMaybe, maybeToList )
 
@@ -104,15 +104,14 @@ tyThingToLHsDecl prr t = case t of
 
            extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn
            extractFamDefDecl fd rhs =
-             TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd)
-                                  , hsib_body = FamEqn
+             TyFamInstDecl $ FamEqn
              { feqn_ext = noExtField
              , feqn_tycon = fdLName fd
-             , feqn_bndrs = Nothing
+             , feqn_bndrs = HsOuterImplicit{hso_ximplicit = hsq_ext (fdTyVars fd)}
              , feqn_pats = map (HsValArg . hsLTyVarBndrToType) $
                            hsq_explicit $ fdTyVars fd
              , feqn_fixity = fdFixity fd
-             , feqn_rhs = synifyType WithinType [] rhs }}
+             , feqn_rhs = synifyType WithinType [] rhs }
 
            extractAtItem
              :: ClassATItem
@@ -170,14 +169,14 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
         annot_typats    = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
                                    args_types_only typats
         hs_rhs          = synifyType WithinType [] rhs
-    in HsIB { hsib_ext = map tyVarName tkvs
-            , hsib_body   = FamEqn { feqn_ext    = noExtField
-                                   , feqn_tycon  = name
-                                   , feqn_bndrs  = Nothing
+        outer_bndrs     = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs}
                                        -- TODO: this must change eventually
-                                   , feqn_pats   = map HsValArg annot_typats
-                                   , feqn_fixity = synifyFixity name
-                                   , feqn_rhs    = hs_rhs } }
+    in FamEqn { feqn_ext    = noExtField
+              , feqn_tycon  = name
+              , feqn_bndrs  = outer_bndrs
+              , feqn_pats   = map HsValArg annot_typats
+              , feqn_fixity = synifyFixity name
+              , feqn_rhs    = hs_rhs }
   where
     fam_tvs = tyConVisibleTyVars tc
 
@@ -371,6 +370,12 @@ synifyDataCon use_gadt_syntax dc =
   (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
   user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors
 
+  outer_bndrs | null user_tvbndrs
+              = HsOuterImplicit { hso_ximplicit = [] }
+              | otherwise
+              = HsOuterExplicit { hso_xexplicit = noExtField
+                                , hso_bndrs = map synifyTyVarBndr user_tvbndrs }
+
   -- skip any EqTheta, use 'orig'inal syntax
   ctx | null theta = Nothing
       | otherwise = Just $ synifyCtx theta
@@ -407,10 +412,9 @@ synifyDataCon use_gadt_syntax dc =
        then do
          let hat = mk_gadt_arg_tys
          return $ noLoc $ ConDeclGADT
-           { con_g_ext  = []
+           { con_g_ext  = noExtField
            , con_names  = [name]
-           , con_forall = noLoc $ not $ null user_tvbndrs
-           , con_qvars  = map synifyTyVarBndr user_tvbndrs
+           , con_bndrs  = noLoc outer_bndrs
            , con_mb_cxt = ctx
            , con_g_args = hat
            , con_res_ty = synifyType WithinType [] res_ty
@@ -531,17 +535,17 @@ data SynifyTypeState
 
 
 synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn
--- The empty binders is a bit suspicious;
--- what if the type has free variables?
-synifySigType s vs ty = mkEmptyImplicitBndrs (synifyType s vs ty)
+-- The use of mkEmptySigType (which uses empty binders in OuterImplicit)
+-- is a bit suspicious; what if the type has free variables?
+synifySigType s vs ty = mkEmptySigType (synifyType s vs ty)
 
 synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn
 -- Ditto (see synifySigType)
-synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s vs ty))
+synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (synifyType s vs ty))
 
 synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
 -- Ditto (see synifySigType)
-synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)
+synifyPatSynSigType ps = mkEmptySigType (synifyPatSynType ps)
 
 -- | Depending on the first argument, try to default all type variables of kind
 -- 'RuntimeRep' to 'LiftedType'.
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index d6d12e4e..39d6d3fd 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -123,30 +123,28 @@ getConNamesI :: ConDecl DocNameI -> [Located DocName]
 getConNamesI ConDeclH98  {con_name  = name}  = [name]
 getConNamesI ConDeclGADT {con_names = names} = names
 
-hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing
-hsImplicitBodyI (HsIB { hsib_body = body }) = body
-
-hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI
-hsSigTypeI = hsImplicitBodyI
-
 mkHsForAllInvisTeleI ::
   [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI
 mkHsForAllInvisTeleI invis_bndrs =
   HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs }
 
-getGADTConType :: ConDecl DocNameI -> LHsType DocNameI
+mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI
+mkHsImplicitSigTypeI body =
+  HsSig { sig_ext   = noExtField
+        , sig_bndrs = HsOuterImplicit{hso_ximplicit = noExtField}
+        , sig_body  = body }
+
+getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI
 -- The full type of a GADT data constructor We really only get this in
 -- order to pretty-print it, and currently only in Haddock's code.  So
 -- we are cavalier about locations and extensions, hence the
 -- 'undefined's
-getGADTConType (ConDeclGADT { con_forall = L _ has_forall
-                            , con_qvars = qtvs
+getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs
                             , con_mb_cxt = mcxt, con_g_args = args
                             , con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
-                                  , hst_tele = mkHsForAllInvisTeleI qtvs
-                                  , hst_body  = theta_ty })
- | otherwise  = theta_ty
+ = noLoc (HsSig { sig_ext   = noExtField
+                , sig_bndrs = outer_bndrs
+                , sig_body  = theta_ty })
  where
    theta_ty | Just theta <- mcxt
             = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
@@ -188,19 +186,17 @@ tcdNameI = unLoc . tyClDeclLNameI
 
 -- -------------------------------------
 
-getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn
+getGADTConTypeG :: ConDecl GhcRn -> LHsSigType GhcRn
 -- The full type of a GADT data constructor We really only get this in
 -- order to pretty-print it, and currently only in Haddock's code.  So
 -- we are cavalier about locations and extensions, hence the
 -- 'undefined's
-getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall
-                            , con_qvars = qtvs
+getGADTConTypeG (ConDeclGADT { con_bndrs = L _ outer_bndrs
                             , con_mb_cxt = mcxt, con_g_args = args
                             , con_res_ty = res_ty })
- | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField
-                                  , hst_tele = mkHsForAllInvisTele qtvs
-                                  , hst_body  = theta_ty })
- | otherwise  = theta_ty
+ = noLoc (HsSig { sig_ext   = noExtField
+                , sig_bndrs = outer_bndrs
+                , sig_body  = theta_ty })
  where
    theta_ty | Just theta <- mcxt
             = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
@@ -244,7 +240,9 @@ data Precedence
 --
 -- We cannot add parens that may be required by fixities because we do not have
 -- any fixity information to work with in the first place :(.
-reparenTypePrec :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => Precedence -> HsType a -> HsType a
+reparenTypePrec :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+                             , MapXRec a, UnXRec a, WrapXRec a )
+                => Precedence -> HsType a -> HsType a
 reparenTypePrec = go
   where
 
@@ -294,15 +292,37 @@ reparenTypePrec = go
 
 
 -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')
-reparenType :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsType a -> HsType a
+reparenType :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+               , MapXRec a, UnXRec a, WrapXRec a )
+            => HsType a -> HsType a
 reparenType = reparenTypePrec PREC_TOP
 
 -- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')
-reparenLType :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => LHsType a -> LHsType a
+reparenLType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+                          , MapXRec a, UnXRec a, WrapXRec a )
+             => LHsType a -> LHsType a
 reparenLType = mapXRec @a reparenType
 
+-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec')
+reparenSigType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+                            , MapXRec a, UnXRec a, WrapXRec a )
+               => HsSigType a -> HsSigType a
+reparenSigType (HsSig x bndrs body) =
+  HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body)
+reparenSigType v@XHsSigType{} = v
+
+-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec')
+reparenOuterTyVarBndrs :: forall flag a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+                                         , MapXRec a, UnXRec a, WrapXRec a )
+                       => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a
+reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp
+reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
+  HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs)
+reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v
+
 -- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
-reparenHsForAllTelescope :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a)
+reparenHsForAllTelescope :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+                                      , MapXRec a, UnXRec a, WrapXRec a )
                          => HsForAllTelescope a -> HsForAllTelescope a
 reparenHsForAllTelescope (HsForAllVis x bndrs) =
   HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs)
@@ -311,13 +331,17 @@ reparenHsForAllTelescope (HsForAllInvis x bndrs) =
 reparenHsForAllTelescope v@XHsForAllTelescope{} = v
 
 -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
-reparenTyVar :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsTyVarBndr flag a -> HsTyVarBndr flag a
+reparenTyVar :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+                , MapXRec a, UnXRec a, WrapXRec a )
+             => HsTyVarBndr flag a -> HsTyVarBndr flag a
 reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n
 reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind)
 reparenTyVar v@XTyVarBndr{} = v
 
 -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
-reparenConDeclField :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => ConDeclField a -> ConDeclField a
+reparenConDeclField :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
+                       , MapXRec a, UnXRec a, WrapXRec a )
+                    => ConDeclField a -> ConDeclField a
 reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d
 reparenConDeclField c@XConDeclField{} = c
 
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index ecaf1a5d..a0e56f07 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -422,7 +422,7 @@ mkMaps dflags pkgName gre instances decls = do
               -- The CoAx's loc is the whole line, but only for TFs. The
               -- workaround is to dig into the family instance declaration and
               -- get the identifier with the right location.
-              TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d'))
+              TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon d')
               _ -> getInstLoc d
     names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].
     names _ decl = getMainDeclBinder decl
@@ -904,26 +904,23 @@ extractDecl declMap name decl
         | isValName name
         , Just (famInst:_) <- M.lookup name declMap
         -> extractDecl declMap name famInst
-      InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body =
-                             FamEqn { feqn_tycon = L _ n
+      InstD _ (DataFamInstD _ (DataFamInstDecl
+                            (FamEqn { feqn_tycon = L _ n
                                     , feqn_pats  = tys
-                                    , feqn_rhs   = defn }}))) ->
+                                    , feqn_rhs   = defn }))) ->
         if isDataConName name
         then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn)
         else SigD noExtField <$> extractRecSel name n tys (dd_cons defn)
       InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts })
         | isDataConName name ->
-            let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body =
-                                          FamEqn { feqn_rhs   = dd
-                                                 }
-                                         })) <- insts
+            let matches = [ d' | L _ d'@(DataFamInstDecl (FamEqn { feqn_rhs = dd })) <- insts
                                , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd))
                                ]
             in case matches of
                 [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0)))
                 _    -> error "internal: extractDecl (ClsInstD)"
         | otherwise ->
-            let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))
+            let matches = [ d' | L _ d'@(DataFamInstDecl d)
                                    <- insts
                                  -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)
                                , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d))
@@ -963,7 +960,7 @@ extractPatternSyn nm t tvs cons =
             ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ)
             _ -> typ
         typ'' = noLoc (HsQualTy noExtField (noLoc []) typ')
-    in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'')
+    in PatSynSig noExtField [noLoc nm] (mkEmptySigType typ'')
 
   longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
   longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index e7d19dfe..a1e712e0 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -191,10 +191,10 @@ renameLTypeArg (HsTypeArg l ki) = do { ki' <- renameLKind ki
 renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp
 
 renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI)
-renameLSigType = renameImplicit renameLType
+renameLSigType = mapM renameSigType
 
 renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI)
-renameLSigWcType = renameWc (renameImplicit renameLType)
+renameLSigWcType = renameWc renameLSigType
 
 renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI)
 renameLKind = renameLType
@@ -294,6 +294,12 @@ renameType t = case t of
   HsSpliceTy _ s          -> renameHsSpliceTy s
   HsWildCardTy a          -> pure (HsWildCardTy a)
 
+renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI)
+renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do
+  bndrs' <- renameOuterTyVarBndrs bndrs
+  body'  <- renameLType body
+  pure $ HsSig { sig_ext = noExtField, sig_bndrs = bndrs', sig_body = body' }
+
 -- | Rename splices, but _only_ those that turn out to be for types.
 -- I think this is actually safe for our possible inputs:
 --
@@ -486,21 +492,20 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
                    , con_forall = forall -- Remove when #18311 is fixed
                    , con_args = details', con_doc = mbldoc' })
 
-renameCon ConDeclGADT { con_names = lnames, con_qvars = ltyvars
+renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs
                             , con_mb_cxt = lcontext, con_g_args = details
-                            , con_res_ty = res_ty, con_forall = forall
+                            , con_res_ty = res_ty
                             , con_doc = mbldoc } = do
       lnames'   <- mapM renameL lnames
-      ltyvars'  <- mapM renameLTyVarBndr ltyvars
+      bndrs'    <- mapM renameOuterTyVarBndrs bndrs
       lcontext' <- traverse renameLContext lcontext
       details'  <- renameGADTDetails details
       res_ty'   <- renameLType res_ty
       mbldoc'   <- mapM renameLDocHsSyn mbldoc
       return (ConDeclGADT
-                   { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars'
+                   { con_g_ext = noExtField, con_names = lnames', con_bndrs = bndrs'
                    , con_mb_cxt = lcontext', con_g_args = details'
-                   , con_res_ty = res_ty', con_doc = mbldoc'
-                   , con_forall = forall}) -- Remove when #18311 is fixed
+                   , con_res_ty = res_ty', con_doc = mbldoc' })
 
 renameHsScaled :: HsScaled GhcRn (LHsType GhcRn)
                -> RnM (HsScaled DocNameI (LHsType DocNameI))
@@ -618,32 +623,26 @@ renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
        ; return (TyFamInstDecl { tfid_eqn = eqn' }) }
 
 renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)
-renameTyFamInstEqn eqn
-  = renameImplicit rename_ty_fam_eqn eqn
-  where
-    rename_ty_fam_eqn
-      :: FamEqn GhcRn (LHsType GhcRn)
-      -> RnM (FamEqn DocNameI (LHsType DocNameI))
-    rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
-                              , feqn_pats = pats, feqn_fixity = fixity
-                              , feqn_rhs = rhs })
-      = do { tc' <- renameL tc
-           ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
-           ; pats' <- mapM renameLTypeArg pats
-           ; rhs' <- renameLType rhs
-           ; return (FamEqn { feqn_ext    = noExtField
-                            , feqn_tycon  = tc'
-                            , feqn_bndrs  = bndrs'
-                            , feqn_pats   = pats'
-                            , feqn_fixity = fixity
-                            , feqn_rhs    = rhs' }) }
+renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs
+                           , feqn_pats = pats, feqn_fixity = fixity
+                           , feqn_rhs = rhs })
+  = do { tc' <- renameL tc
+       ; bndrs' <- renameOuterTyVarBndrs bndrs
+       ; pats' <- mapM renameLTypeArg pats
+       ; rhs' <- renameLType rhs
+       ; return (FamEqn { feqn_ext    = noExtField
+                        , feqn_tycon  = tc'
+                        , feqn_bndrs  = bndrs'
+                        , feqn_pats   = pats'
+                        , feqn_fixity = fixity
+                        , feqn_rhs    = rhs' }) }
 
 renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI)
 renameTyFamDefltD = renameTyFamInstD
 
 renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)
 renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
-  = do { eqn' <- renameImplicit rename_data_fam_eqn eqn
+  = do { eqn' <- rename_data_fam_eqn eqn
        ; return (DataFamInstDecl { dfid_eqn = eqn' }) }
   where
     rename_data_fam_eqn
@@ -653,7 +652,7 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
                                 , feqn_pats = pats, feqn_fixity = fixity
                                 , feqn_rhs = defn })
       = do { tc' <- renameL tc
-           ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs
+           ; bndrs' <- renameOuterTyVarBndrs bndrs
            ; pats' <- mapM renameLTypeArg pats
            ; defn' <- renameDataDefn defn
            ; return (FamEqn { feqn_ext    = noExtField
@@ -663,13 +662,12 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
                             , feqn_fixity = fixity
                             , feqn_rhs    = defn' }) }
 
-renameImplicit :: (in_thing -> RnM out_thing)
-               -> HsImplicitBndrs GhcRn in_thing
-               -> RnM (HsImplicitBndrs DocNameI out_thing)
-renameImplicit rn_thing (HsIB { hsib_body = thing })
-  = do { thing' <- rn_thing thing
-       ; return (HsIB { hsib_body = thing'
-                      , hsib_ext = noExtField }) }
+renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn
+                      -> RnM (HsOuterTyVarBndrs flag DocNameI)
+renameOuterTyVarBndrs (HsOuterImplicit{}) =
+  pure $ HsOuterImplicit{hso_ximplicit = noExtField}
+renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) =
+  HsOuterExplicit noExtField <$> mapM renameLTyVarBndr exp_bndrs
 
 renameWc :: (in_thing -> RnM out_thing)
          -> HsWildCardBndrs GhcRn in_thing
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 35e5258f..b19f52d0 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -56,7 +56,7 @@ specialize specs = go spec_map0
 --
 -- Again, it is just a convenience function around 'specialize'. Note that
 -- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn
+specializeTyVarBndrs :: Data a => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a
 specializeTyVarBndrs bndrs typs =
     specialize $ zip bndrs' typs
   where
@@ -77,13 +77,13 @@ specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
               -> Sig GhcRn
               -> Sig GhcRn
 specializeSig bndrs typs (TypeSig _ lnames typ) =
-  TypeSig noExtField lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})
+  TypeSig noExtField lnames (typ {hswc_body = noLoc typ'})
   where
-    true_type :: HsType GhcRn
-    true_type = unLoc (hsSigWcType typ)
-    typ' :: HsType GhcRn
+    true_type :: HsSigType GhcRn
+    true_type = unLoc (dropWildCards typ)
+    typ' :: HsSigType GhcRn
     typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type
-    fv = foldr Set.union Set.empty . map freeVariables $ typs
+    fv = foldr Set.union Set.empty . map freeVariablesType $ typs
 specializeSig _ _ sig = sig
 
 
@@ -207,25 +207,37 @@ setInternalOccName occ name =
     nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)
 
 
--- | Compute set of free variables of given type.
-freeVariables :: HsType GhcRn -> Set Name
-freeVariables =
-    everythingWithState Set.empty Set.union query
+-- | Compute set of free variables of a given 'HsType'.
+freeVariablesType :: HsType GhcRn -> Set Name
+freeVariablesType =
+    everythingWithState Set.empty Set.union
+      (mkQ (\ctx -> (Set.empty, ctx)) queryType)
+
+-- | Compute set of free variables of a given 'HsType'.
+freeVariablesSigType :: HsSigType GhcRn -> Set Name
+freeVariablesSigType =
+    everythingWithState Set.empty Set.union
+      (mkQ (\ctx -> (Set.empty, ctx)) queryType `extQ` querySigType)
+
+queryType :: HsType GhcRn -> Set Name -> (Set Name, Set Name)
+queryType term ctx = case term of
+    HsForAllTy _ tele _ ->
+        (Set.empty, Set.union ctx (teleNames tele))
+    HsTyVar _ _ (L _ name)
+        | getName name `Set.member` ctx -> (Set.empty, ctx)
+        | otherwise -> (Set.singleton $ getName name, ctx)
+    _ -> (Set.empty, ctx)
   where
-    query :: forall a . Data a => a -> Set Name -> (Set Name, Set Name)
-    query term ctx = case cast term :: Maybe (HsType GhcRn) of
-        Just (HsForAllTy _ tele _) ->
-            (Set.empty, Set.union ctx (teleNames tele))
-        Just (HsTyVar _ _ (L _ name))
-            | getName name `Set.member` ctx -> (Set.empty, ctx)
-            | otherwise -> (Set.singleton $ getName name, ctx)
-        _ -> (Set.empty, ctx)
-
     teleNames :: HsForAllTelescope GhcRn -> Set Name
     teleNames (HsForAllVis   _ bndrs) = bndrsNames bndrs
     teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs
 
-    bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
+querySigType :: HsSigType GhcRn -> Set Name -> (Set Name, Set Name)
+querySigType (HsSig { sig_bndrs = outer_bndrs }) ctx =
+  (Set.empty, Set.union ctx (bndrsNames (hsOuterExplicitBndrs outer_bndrs)))
+
+bndrsNames :: [LHsTyVarBndr flag GhcRn] -> Set Name
+bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
 
 
 -- | Make given type visually unambiguous.
@@ -236,12 +248,12 @@ freeVariables =
 -- different type variable than latter one. Applying 'rename' function
 -- will fix that type to be visually unambiguous again (making it something
 -- like @(a -> b0) -> b@).
-rename :: Set Name -> HsType GhcRn -> HsType GhcRn
-rename fv typ = evalState (renameType typ) env
+rename :: Set Name -> HsSigType GhcRn -> HsSigType GhcRn
+rename fv typ = evalState (renameSigType typ) env
   where
     env = RenameEnv
       { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv
-      , rneSigFVs = Set.map getNameRep $ freeVariables typ
+      , rneSigFVs = Set.map getNameRep $ freeVariablesSigType typ
       , rneCtx = Map.empty
       }
     mkPair name = (getNameRep name, name)
@@ -256,6 +268,17 @@ data RenameEnv name = RenameEnv
   }
 
 
+renameSigType :: HsSigType GhcRn -> Rename (IdP GhcRn) (HsSigType GhcRn)
+renameSigType (HsSig x bndrs body) =
+  HsSig x <$> renameOuterTyVarBndrs bndrs <*> renameLType body
+
+renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn
+                      -> Rename (IdP GhcRn) (HsOuterTyVarBndrs flag GhcRn)
+renameOuterTyVarBndrs (HsOuterImplicit imp_tvs) =
+  HsOuterImplicit <$> mapM renameName imp_tvs
+renameOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
+  HsOuterExplicit x <$> mapM renameLBinder exp_bndrs
+
 renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
 renameType (HsForAllTy x tele lt) =
     HsForAllTy x
diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs
index 7e34ae8c..fc946c8e 100644
--- a/haddock-api/src/Haddock/Syb.hs
+++ b/haddock-api/src/Haddock/Syb.hs
@@ -6,7 +6,7 @@
 module Haddock.Syb
     ( everything, everythingButType, everythingWithState
     , everywhere, everywhereButType
-    , mkT
+    , mkT, mkQ, extQ
     , combine
     ) where
 
@@ -91,6 +91,21 @@ mkT f = case cast f of
     Just f' -> f'
     Nothing -> id
 
+-- | Create generic query.
+--
+-- Another function stolen from SYB package.
+mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
+(r `mkQ` br) a = case cast a of
+                        Just b  -> br b
+                        Nothing -> r
+
+
+-- | Extend a generic query by a type-specific case.
+--
+-- Another function stolen from SYB package.
+extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q
+extQ f g a = maybe (f a) g (cast a)
+
 -- | Combine two queries into one using alternative combinator.
 combine :: Alternative f => (forall a. Data a => a -> f r)
                          -> (forall a. Data a => a -> f r)
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 6aad5dd1..7b261f4e 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -755,9 +755,14 @@ type instance XFamDecl      DocNameI = NoExtField
 type instance XXFamilyDecl  DocNameI = NoExtCon
 type instance XXTyClDecl    DocNameI = NoExtCon
 
-type instance XHsIB             DocNameI _ = NoExtField
-type instance XHsWC             DocNameI _ = NoExtField
-type instance XXHsImplicitBndrs DocNameI _ = NoExtCon
+type instance XHsWC DocNameI _ = NoExtField
+
+type instance XHsOuterExplicit    DocNameI _ = NoExtField
+type instance XHsOuterImplicit    DocNameI   = NoExtField
+type instance XXHsOuterTyVarBndrs DocNameI   = NoExtCon
+
+type instance XHsSig      DocNameI = NoExtField
+type instance XXHsSigType DocNameI = NoExtCon
 
 type instance XHsQTvs        DocNameI = NoExtField
 type instance XConDeclField  DocNameI = NoExtField
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 1177fb18..aec7f9ab 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -17,7 +17,8 @@ module Haddock.Utils (
   -- * Misc utilities
   restrictTo, emptyHsQTvs,
   toDescription, toInstalledDescription,
-  mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes,
+  mkEmptySigWcType, mkEmptySigType,
+  addClassContext, lHsQTyVarsToTypes,
 
   -- * Filename utilities
   moduleHtmlFile, moduleHtmlFile',
@@ -131,21 +132,38 @@ mkMeta x = emptyMetaDoc { _doc = x }
 mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn
 -- Dubious, because the implicit binders are empty even
 -- though the type might have free varaiables
-mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty)
+mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptySigType ty)
+
+mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn
+-- Dubious, because the implicit binders are empty even
+-- though the type might have free varaiables
+mkEmptySigType lty@(L loc ty) = L loc $ case ty of
+  HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }
+             , hst_body = body }
+    -> HsSig { sig_ext = noExtField
+             , sig_bndrs = HsOuterExplicit { hso_xexplicit = noExtField
+                                           , hso_bndrs     = bndrs }
+             , sig_body = body }
+  _ -> HsSig { sig_ext   = noExtField
+             , sig_bndrs = HsOuterImplicit{hso_ximplicit = []}
+             , sig_body = lty }
 
 addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn
 -- Add the class context to a class-op signature
 addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
-  = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype))))
-          -- The mkEmptySigWcType is suspicious
+  = L pos (TypeSig noExtField lname (mkEmptyWildCardBndrs (go_sig_ty ltype)))
   where
-    go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))
+    go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty }))
+       = L loc (HsSig { sig_ext = noExtField
+                      , sig_bndrs = bndrs, sig_body = go_ty ty })
+
+    go_ty (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))
        = L loc (HsForAllTy { hst_xforall = noExtField
-                           , hst_tele = tele, hst_body = go ty })
-    go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
+                           , hst_tele = tele, hst_body = go_ty ty })
+    go_ty (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))
        = L loc (HsQualTy { hst_xqual = noExtField
                          , hst_ctxt = add_ctxt ctxt, hst_body = ty })
-    go (L loc ty)
+    go_ty (L loc ty)
        = L loc (HsQualTy { hst_xqual = noExtField
                          , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
 
diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html
index 3477d89d..2a44be99 100644
--- a/hypsrc-test/ref/src/Classes.html
+++ b/hypsrc-test/ref/src/Classes.html
@@ -280,12 +280,12 @@ forall a. a -&gt; a
 </span
       ><span id="line-12"
       ></span
-      ><span id=""
       ><span class="hs-keyword"
-	>instance</span
-	><span
-	> </span
-	><span class="annot"
+      >instance</span
+      ><span
+      > </span
+      ><span id=""
+      ><span class="annot"
 	><a href="Classes.html#Foo"
 	  ><span class="hs-identifier hs-type"
 	    >Foo</span
@@ -303,93 +303,93 @@ forall a. a -&gt; a
 	  ></span
 	><span class="hs-special"
 	>]</span
-	><span
-	> </span
-	><span class="hs-keyword"
-	>where</span
-	><span
-	>
-</span
-	><span id="line-13"
 	></span
-	><span
-	>    </span
-	><span id=""
-	><span class="annot"
-	  ><span class="annottext"
-	    >bar :: [a] -&gt; Int
+      ><span
+      > </span
+      ><span class="hs-keyword"
+      >where</span
+      ><span
+      >
 </span
-	    ><a href="#"
-	    ><span class="hs-identifier hs-var hs-var hs-var hs-var"
-	      >bar</span
-	      ></a
-	    ></span
-	  ></span
-	><span
-	> </span
-	><span class="hs-glyph"
-	>=</span
-	><span
-	> </span
-	><span class="annot"
+      ><span id="line-13"
+      ></span
+      ><span
+      >    </span
+      ><span id=""
+      ><span class="annot"
 	><span class="annottext"
-	  >[a] -&gt; Int
-forall (t :: * -&gt; *) a. Foldable t =&gt; t a -&gt; Int
+	  >bar :: [a] -&gt; Int
 </span
-	  ><span class="hs-identifier hs-var"
-	  >length</span
+	  ><a href="#"
+	  ><span class="hs-identifier hs-var hs-var hs-var hs-var"
+	    >bar</span
+	    ></a
 	  ></span
-	><span
-	>
+	></span
+      ><span
+      > </span
+      ><span class="hs-glyph"
+      >=</span
+      ><span
+      > </span
+      ><span class="annot"
+      ><span class="annottext"
+	>[a] -&gt; Int
+forall (t :: * -&gt; *) a. Foldable t =&gt; t a -&gt; Int
 </span
-	><span id="line-14"
+	><span class="hs-identifier hs-var"
+	>length</span
 	></span
-	><span
-	>    </span
-	><span id=""
-	><span class="annot"
-	  ><span class="annottext"
-	    >baz :: Int -&gt; ([a], [a])
+      ><span
+      >
 </span
-	    ><a href="#"
-	    ><span class="hs-identifier hs-var hs-var hs-var hs-var"
-	      >baz</span
-	      ></a
-	    ></span
-	  ></span
-	><span
-	> </span
-	><span class="annot"
+      ><span id="line-14"
+      ></span
+      ><span
+      >    </span
+      ><span id=""
+      ><span class="annot"
 	><span class="annottext"
-	  >Int
+	  >baz :: Int -&gt; ([a], [a])
 </span
-	  ><span class="hs-identifier"
-	  >_</span
+	  ><a href="#"
+	  ><span class="hs-identifier hs-var hs-var hs-var hs-var"
+	    >baz</span
+	    ></a
 	  ></span
-	><span
-	> </span
-	><span class="hs-glyph"
-	>=</span
-	><span
-	> </span
-	><span class="hs-special"
-	>(</span
-	><span class="hs-special"
-	>[</span
-	><span class="hs-special"
-	>]</span
-	><span class="hs-special"
-	>,</span
-	><span
-	> </span
-	><span class="hs-special"
-	>[</span
-	><span class="hs-special"
-	>]</span
-	><span class="hs-special"
-	>)</span
 	></span
       ><span
+      > </span
+      ><span class="annot"
+      ><span class="annottext"
+	>Int
+</span
+	><span class="hs-identifier"
+	>_</span
+	></span
+      ><span
+      > </span
+      ><span class="hs-glyph"
+      >=</span
+      ><span
+      > </span
+      ><span class="hs-special"
+      >(</span
+      ><span class="hs-special"
+      >[</span
+      ><span class="hs-special"
+      >]</span
+      ><span class="hs-special"
+      >,</span
+      ><span
+      > </span
+      ><span class="hs-special"
+      >[</span
+      ><span class="hs-special"
+      >]</span
+      ><span class="hs-special"
+      >)</span
+      ><span
       >
 </span
       ><span id="line-15"
@@ -821,12 +821,12 @@ forall (t :: * -&gt; *) a. (Foldable t, Num a) =&gt; t a -&gt; a
 </span
       ><span id="line-27"
       ></span
-      ><span id=""
       ><span class="hs-keyword"
-	>instance</span
-	><span
-	> </span
-	><span id=""
+      >instance</span
+      ><span
+      > </span
+      ><span id=""
+      ><span id=""
 	><span class="annot"
 	  ><a href="Classes.html#Foo%27"
 	    ><span class="hs-identifier hs-type"
@@ -846,52 +846,52 @@ forall (t :: * -&gt; *) a. (Foldable t, Num a) =&gt; t a -&gt; a
 	  ><span class="hs-special"
 	  >]</span
 	  ></span
-	><span
-	> </span
-	><span class="hs-keyword"
-	>where</span
-	><span
-	>
-</span
-	><span id="line-28"
 	></span
-	><span
-	>    </span
-	><span id=""
-	><span class="annot"
-	  ><span class="annottext"
-	    >quux :: ([a], [a]) -&gt; [a]
+      ><span
+      > </span
+      ><span class="hs-keyword"
+      >where</span
+      ><span
+      >
 </span
-	    ><a href="#"
-	    ><span class="hs-identifier hs-var hs-var hs-var hs-var"
-	      >quux</span
-	      ></a
-	    ></span
-	  ></span
-	><span
-	> </span
-	><span class="hs-glyph"
-	>=</span
-	><span
-	> </span
-	><span class="annot"
+      ><span id="line-28"
+      ></span
+      ><span
+      >    </span
+      ><span id=""
+      ><span class="annot"
 	><span class="annottext"
-	  >([a] -&gt; [a] -&gt; [a]) -&gt; ([a], [a]) -&gt; [a]
-forall a b c. (a -&gt; b -&gt; c) -&gt; (a, b) -&gt; c
+	  >quux :: ([a], [a]) -&gt; [a]
 </span
-	  ><span class="hs-identifier hs-var"
-	  >uncurry</span
+	  ><a href="#"
+	  ><span class="hs-identifier hs-var hs-var hs-var hs-var"
+	    >quux</span
+	    ></a
 	  ></span
-	><span
-	> </span
-	><span class="annot"
-	><span class="annottext"
-	  >[a] -&gt; [a] -&gt; [a]
+	></span
+      ><span
+      > </span
+      ><span class="hs-glyph"
+      >=</span
+      ><span
+      > </span
+      ><span class="annot"
+      ><span class="annottext"
+	>([a] -&gt; [a] -&gt; [a]) -&gt; ([a], [a]) -&gt; [a]
+forall a b c. (a -&gt; b -&gt; c) -&gt; (a, b) -&gt; c
+</span
+	><span class="hs-identifier hs-var"
+	>uncurry</span
+	></span
+      ><span
+      > </span
+      ><span class="annot"
+      ><span class="annottext"
+	>[a] -&gt; [a] -&gt; [a]
 forall a. [a] -&gt; [a] -&gt; [a]
 </span
-	  ><span class="hs-operator hs-var"
-	  >(++)</span
-	  ></span
+	><span class="hs-operator hs-var"
+	>(++)</span
 	></span
       ><span
       >
@@ -941,23 +941,23 @@ forall a. [a] -&gt; [a] -&gt; [a]
       ></span
       ><span
       >    </span
+      ><span id="plugh"
+      ><span class="annot"
+	><a href="Classes.html#plugh"
+	  ><span class="hs-identifier hs-type"
+	    >plugh</span
+	    ></a
+	  ></span
+	></span
+      ><span
+      > </span
+      ><span class="hs-glyph"
+      >::</span
+      ><span
+      > </span
       ><span id=""
       ><span id=""
-	><span id="plugh"
-	  ><span class="annot"
-	    ><a href="Classes.html#plugh"
-	      ><span class="hs-identifier hs-type"
-		>plugh</span
-		></a
-	      ></span
-	    ></span
-	  ><span
-	  > </span
-	  ><span class="hs-glyph"
-	  >::</span
-	  ><span
-	  > </span
-	  ><span class="annot"
+	><span class="annot"
 	  ><a href="#"
 	    ><span class="hs-identifier hs-type"
 	      >p</span
-- 
cgit v1.2.3


From 4d0498d503bd51b7d7626497580232685a2691a1 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Fri, 13 Nov 2020 13:38:32 -0500
Subject: Adapt to splitPiTysInvisible being renamed to splitInvisPiTys

This is a part of !4434, a fix for GHC#18939.
---
 haddock-api/src/Haddock/Convert.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 2f342ba4..2a711e5c 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -230,7 +230,7 @@ synifyTyCon prr _coax tc
       | otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind)
 
     conKind = defaultType prr (tyConKind tc)
-    tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind
+    tyVarKinds = fst . splitFunTys . snd . splitInvisPiTys $ conKind
 
 synifyTyCon _prr _coax tc
   | Just flav <- famTyConFlav_maybe tc
-- 
cgit v1.2.3


From 25fa8fde84701c010fa466c2648f8f6d10265e8f Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Tue, 3 Nov 2020 12:04:17 +0100
Subject: Fix after Plugins moved into HscEnv

---
 haddock-api/src/Haddock.hs | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 662226a8..cb444844 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -67,6 +67,7 @@ import Text.ParserCombinators.ReadP (readP_to_S)
 import GHC hiding (verbosity)
 import GHC.Settings.Config
 import GHC.Driver.Session hiding (projectVersion, verbosity)
+import GHC.Driver.Env
 import GHC.Utils.Error
 import GHC.Unit
 import GHC.Utils.Panic (handleGhcException)
@@ -471,10 +472,10 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
   -- that may need to be re-linked: Haddock doesn't do any
   -- dynamic or static linking at all!
   _ <- setSessionDynFlags dynflags''
-  hscenv <- GHC.getSession
-  dynflags''' <- liftIO (GHC.Runtime.Loader.initializePlugins hscenv dynflags'')
-  _ <- setSessionDynFlags dynflags'''
-  ghcActs dynflags'''
+  hsc_env <- GHC.getSession
+  hsc_env'' <- liftIO (GHC.Runtime.Loader.initializePlugins hsc_env)
+  _ <- GHC.setSession hsc_env''
+  ghcActs (hsc_dflags hsc_env'')
   where
 
     -- ignore sublists of flags that start with "+RTS" and end in "-RTS"
-- 
cgit v1.2.3


From b2f1aef40cf50cf08eb28f34a9af2b1f9155c2df Mon Sep 17 00:00:00 2001
From: Andreas Klebinger <klebinger.andreas@gmx.at>
Date: Tue, 24 Nov 2020 20:51:59 +0100
Subject: Update for changes in GHC's Pretty

---
 haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 3a774ace..414b870d 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -172,7 +172,7 @@ ppLaTeXModule _title odir iface = do
 
       body = processExports exports
   --
-  writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex)
+  writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender (PageMode True) 80 1 txtPrinter "" tex)
 
 -- | Prints out an entry in a module export list.
 exportListItem :: ExportItem DocNameI -> LaTeX
-- 
cgit v1.2.3


From 8d260690b53f2fb6b54ba78bd13d1400d9ebd395 Mon Sep 17 00:00:00 2001
From: Richard Eisenberg <rae@richarde.dev>
Date: Sat, 7 Nov 2020 22:42:07 -0500
Subject: Avoid GHC#18932.

---
 haddock-api/src/Haddock/Convert.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 2a711e5c..5f9940fc 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -93,10 +93,11 @@ tyThingToLHsDecl prr t = case t of
            extractFamilyDecl _           =
              Left "tyThingToLHsDecl: impossible associated tycon"
 
+           cvt :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p)
+             -- Without this signature, we trigger GHC#18932
            cvt (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n
            cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noExtField
               (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind
-           cvt (XTyVarBndr nec) = noExtCon nec
 
            -- | Convert a LHsTyVarBndr to an equivalent LHsType.
            hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p)
-- 
cgit v1.2.3


From acf235d607879eb9542127eb0ddb42a250b5b850 Mon Sep 17 00:00:00 2001
From: Cale Gibbard <cgibbard@gmail.com>
Date: Thu, 30 Jul 2020 14:00:19 -0400
Subject: Add type arguments to PrefixCon

---
 haddock-api/src/Haddock/Backends/Hoogle.hs     | 6 +++---
 haddock-api/src/Haddock/Backends/LaTeX.hs      | 4 ++--
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 6 +++---
 haddock-api/src/Haddock/Convert.hs             | 2 +-
 haddock-api/src/Haddock/Interface/Create.hs    | 2 +-
 haddock-api/src/Haddock/Interface/Rename.hs    | 2 +-
 haddock-api/src/Haddock/Utils.hs               | 4 ++--
 7 files changed, 13 insertions(+), 13 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 44841bc5..1f55db10 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -244,9 +244,9 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
   -- AZ:TODO get rid of the concatMap
    = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args'
     where
-        f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
-        f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
-        f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
+        f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]
+        f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2]
+        f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat
                           [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++
                            [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
                           | r <- map unLoc recs]
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 3a774ace..f9480a47 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -784,7 +784,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
                          header_ = ppConstrHdr forall_ tyVars context unicode
                      in case det of
         -- Prefix constructor, e.g. 'Just a'
-        PrefixCon args
+        PrefixCon _ args
           | hasArgDocs -> header_ <+> ppOcc
           | otherwise -> hsep [ header_
                               , ppOcc
@@ -823,7 +823,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
           -- H98 record declarations
           RecCon (L _ fields)             -> doRecordFields fields
           -- H98 prefix data constructors
-          PrefixCon args | hasArgDocs     -> doConstrArgsWithDocs (map hsScaledThing args)
+          PrefixCon _ args | hasArgDocs   -> doConstrArgsWithDocs (map hsScaledThing args)
           -- H98 infix data constructor
           InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])
           _                               -> empty
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 8b9739f1..e9806471 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -845,7 +845,7 @@ ppShortConstrParts summary dataInst con unicode qual
                      in case det of
 
         -- Prefix constructor, e.g. 'Just a'
-        PrefixCon args ->
+        PrefixCon _ args ->
           ( header_ +++
               hsep (ppOcc : map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args)
           , noHtml
@@ -918,7 +918,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
                          header_ = ppConstrHdr forall_ tyVars context unicode qual
                      in case det of
         -- Prefix constructor, e.g. 'Just a'
-        PrefixCon args
+        PrefixCon _ args
           | hasArgDocs -> header_ +++ ppOcc <+> fixity
           | otherwise -> hsep [ header_ +++ ppOcc
                               , hsep (map ((ppLParendType unicode qual HideEmptyContexts) . hsScaledThing) args)
@@ -959,7 +959,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
           -- H98 record declarations
           RecCon (L _ fields)             -> [ doRecordFields fields ]
           -- H98 prefix data constructors
-          PrefixCon args | hasArgDocs     -> [ doConstrArgsWithDocs args ]
+          PrefixCon _ args | hasArgDocs   -> [ doConstrArgsWithDocs args ]
           -- H98 infix data constructor
           InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]
           _                               -> []
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 5f9940fc..b59602b6 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -398,7 +398,7 @@ synifyDataCon use_gadt_syntax dc =
   mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
     (True,True) -> Left "synifyDataCon: contradiction!"
     (True,False) -> return $ RecCon (noLoc field_tys)
-    (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys)
+    (False,False) -> return $ PrefixCon noTypeArgs (map hsUnrestricted linear_tys)
     (False,True) -> case linear_tys of
                      [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)
                      _ -> Left "synifyDataCon: infix with non-2 args?"
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index a0e56f07..8bc8d306 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -948,7 +948,7 @@ extractPatternSyn nm t tvs cons =
     let args =
           case con of
             ConDeclH98 { con_args = con_args' } -> case con_args' of
-              PrefixCon args' -> map hsScaledThing args'
+              PrefixCon _ args' -> map hsScaledThing args'
               RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields
               InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]
             ConDeclGADT { con_g_args = con_args' } -> case con_args' of
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index a1e712e0..5d7b4f1a 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -516,7 +516,7 @@ renameH98Details :: HsConDeclH98Details GhcRn
 renameH98Details (RecCon (L l fields)) = do
   fields' <- mapM renameConDeclFieldField fields
   return (RecCon (L l fields'))
-renameH98Details (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps
+renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps
 renameH98Details (InfixCon a b) = do
   a' <- renameHsScaled a
   b' <- renameHsScaled b
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index aec7f9ab..8186e3b7 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -210,10 +210,10 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
         ConDeclGADT { con_g_args = args } -> restrict_gadt_args args
       where
         restrict_h98_args :: HsConDeclH98Details GhcRn -> Maybe (ConDecl GhcRn)
-        restrict_h98_args (PrefixCon _) = Just d
+        restrict_h98_args (PrefixCon _ _) = Just d
         restrict_h98_args (RecCon (L _ fields))
           | all field_avail fields = Just d
-          | otherwise = Just (d { con_args = PrefixCon (field_types fields) })
+          | otherwise = Just (d { con_args = PrefixCon noTypeArgs (field_types fields) })
           -- if we have *all* the field names available, then
           -- keep the record declaration.  Otherwise degrade to
           -- a constructor declaration.  This isn't quite right, but
-- 
cgit v1.2.3


From 9b403b0f5f565674adce6c64b6942d36c3d6f7ec Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Wed, 18 Nov 2020 13:54:03 +0100
Subject: DynFlags's unit fields moved to HscEnv

---
 haddock-api/src/Haddock.hs                  | 26 +++++++++++++-------------
 haddock-api/src/Haddock/Backends/Hoogle.hs  | 19 ++++++++++---------
 haddock-api/src/Haddock/Interface.hs        |  5 +++--
 haddock-api/src/Haddock/Interface/Create.hs |  9 +++++----
 haddock-api/src/Haddock/Options.hs          | 11 ++++++-----
 5 files changed, 37 insertions(+), 33 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index cb444844..3543d8e2 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -178,6 +178,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
 
   ghc flags' $ withDir $ do
     dflags <- getDynFlags
+    unit_state <- hsc_units <$> getSession
 
     forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
       mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
@@ -195,7 +196,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
           }
 
       -- Render the interfaces.
-      liftIO $ renderStep dflags flags sinceQual qual packages ifaces
+      liftIO $ renderStep dflags unit_state flags sinceQual qual packages ifaces
 
     else do
       when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
@@ -205,7 +206,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
       packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks
 
       -- Render even though there are no input files (usually contents/index).
-      liftIO $ renderStep dflags flags sinceQual qual packages []
+      liftIO $ renderStep dflags unit_state flags sinceQual qual packages []
 
 -- | Run the GHC action using a temporary output directory
 withTempOutputDir :: Ghc a -> Ghc a
@@ -254,9 +255,9 @@ readPackagesAndProcessModules flags files = do
     return (packages, ifaces, homeLinks)
 
 
-renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption
+renderStep :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption
            -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
-renderStep dflags flags sinceQual nameQual pkgs interfaces = do
+renderStep dflags unit_state flags sinceQual nameQual pkgs interfaces = do
   updateHTMLXRefs pkgs
   let
     ifaceFiles = map snd pkgs
@@ -265,12 +266,12 @@ renderStep dflags flags sinceQual nameQual pkgs interfaces = do
       ((_, Just path), ifile) <- pkgs
       iface <- ifInstalledIfaces ifile
       return (instMod iface, path)
-  render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap
+  render dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
 
 -- | Render the interfaces with whatever backend is specified in the flags.
-render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface]
+render :: DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
        -> [InstalledInterface] -> Map Module FilePath -> IO ()
-render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
+render dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
 
   let
     title                = fromMaybe "" (optTitle flags)
@@ -283,7 +284,6 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
     opt_latex_style      = optLaTeXStyle     flags
     opt_source_css       = optSourceCssFile  flags
     opt_mathjax          = optMathjax        flags
-    pkgs                 = unitState dflags
     dflags'
       | unicode          = gopt_set dflags Opt_PrintUnicodeSyntax
       | otherwise        = dflags
@@ -297,7 +297,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
     pkgMod           = fmap ifaceMod (listToMaybe ifaces)
     pkgKey           = fmap moduleUnit pkgMod
     pkgStr           = fmap unitString pkgKey
-    pkgNameVer       = modulePackageInfo dflags flags pkgMod
+    pkgNameVer       = modulePackageInfo unit_state flags pkgMod
     pkgName          = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer)
     sincePkg         = case sinceQual of
                          External -> pkgName
@@ -342,7 +342,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
     -- records the *wired in* identity base.  So untranslate it
     -- so that we can service the request.
     unwire :: Module -> Module
-    unwire m = m { moduleUnit = unwireUnit (unitState dflags) (moduleUnit m) }
+    unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) }
 
   reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do
     let warn = hPutStrLn stderr . ("Warning: " ++)
@@ -373,7 +373,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
   when (Flag_GenContents `elem` flags) $ do
     withTiming dflags' "ppHtmlContents" (const ()) $ do
       _ <- {-# SCC ppHtmlContents #-}
-           ppHtmlContents pkgs odir title pkgStr
+           ppHtmlContents unit_state odir title pkgStr
                      themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
                      allVisibleIfaces True prologue pretty
                      sincePkg (makeContentsQual qual)
@@ -383,7 +383,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
   when (Flag_Html `elem` flags) $ do
     withTiming dflags' "ppHtml" (const ()) $ do
       _ <- {-# SCC ppHtml #-}
-           ppHtml pkgs title pkgStr visibleIfaces reexportedIfaces odir
+           ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir
                   prologue
                   themes opt_mathjax sourceUrls' opt_wiki_urls
                   opt_contents_url opt_index_url unicode sincePkg qual
@@ -403,7 +403,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do
 
             pkgVer =
               fromMaybe (makeVersion []) mpkgVer
-          in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)
+          in ppHoogle dflags' unit_state pkgNameStr pkgVer title (fmap _doc prologue)
                visibleIfaces odir
       _ -> putStrLn . unlines $
           [ "haddock: Unable to find a package providing module "
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 1f55db10..2ef0c61b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -31,6 +31,7 @@ import GHC.Driver.Ppr
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
 import GHC.Parser.Annotation (IsUnicodeSyntax(..))
+import GHC.Unit.State
 
 import Data.Char
 import Data.List
@@ -46,8 +47,8 @@ prefix = ["-- Hoogle documentation, generated by Haddock"
          ,""]
 
 
-ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
-ppHoogle dflags package version synopsis prologue ifaces odir = do
+ppHoogle :: DynFlags -> UnitState -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
+ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do
     let -- Since Hoogle is line based, we want to avoid breaking long lines.
         dflags' = dflags{ pprCols = maxBound }
         filename = package ++ ".txt"
@@ -56,16 +57,16 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do
                    ["@package " ++ package] ++
                    ["@version " ++ showVersion version
                    | not (null (versionBranch version)) ] ++
-                   concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i]
+                   concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i]
     createDirectoryIfMissing True odir
     writeUtf8File (odir </> filename) (unlines contents)
 
-ppModule :: DynFlags -> Interface -> [String]
-ppModule dflags iface =
+ppModule :: DynFlags -> UnitState -> Interface -> [String]
+ppModule dflags unit_state iface =
   "" : ppDocumentation dflags (ifaceDoc iface) ++
   ["module " ++ moduleString (ifaceMod iface)] ++
   concatMap (ppExport dflags) (ifaceExportItems iface) ++
-  concatMap (ppInstance dflags) (ifaceInstances iface)
+  concatMap (ppInstance dflags unit_state) (ifaceInstances iface)
 
 
 ---------------------------------------------------------------------
@@ -204,9 +205,9 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info })
               ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily }
               _                  -> decl
 
-ppInstance :: DynFlags -> ClsInst -> [String]
-ppInstance dflags x =
-  [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls]
+ppInstance :: DynFlags -> UnitState -> ClsInst -> [String]
+ppInstance dflags unit_state x =
+  [dropComment $ outWith (showSDocForUser dflags unit_state alwaysQualify) cls]
   where
     -- As per #168, we don't want safety information about the class
     -- in Hoogle output. The easiest way to achieve this is to set the
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 583cacf8..be9bd09a 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -159,10 +159,11 @@ processModule verbosity modsum flags modMap instIfaceMap = do
     IsBoot ->
       return Nothing
     NotBoot -> do
+      unit_state <- hsc_units <$> getSession
       out verbosity verbose "Creating interface..."
       (interface, msgs) <- {-# SCC createIterface #-}
                           withTimingD "createInterface" (const ()) $ do
-                            runWriterGhc $ createInterface tm flags modMap instIfaceMap
+                            runWriterGhc $ createInterface tm unit_state flags modMap instIfaceMap
 
       -- We need to keep track of which modules were somehow in scope so that when
       -- Haddock later looks for instances, it also looks in these modules too.
@@ -170,7 +171,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do
       -- See https://github.com/haskell/haddock/issues/469.
       hsc_env <- getSession
       let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
-          home_unit = mkHomeUnitFromFlags (hsc_dflags hsc_env)
+          home_unit = hsc_home_unit hsc_env
           !mods = mkModuleSet [ nameModule name
                               | gre <- globalRdrEnvElts new_rdr_env
                               , let name = gre_name gre
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 8bc8d306..7ef64a94 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -47,6 +47,7 @@ import GHC.Types.SourceFile
 import GHC.Core.ConLike (ConLike(..))
 import GHC
 import GHC.Driver.Ppr
+import GHC.Driver.Env
 import GHC.Types.Name
 import GHC.Types.Name.Set
 import GHC.Types.Name.Env
@@ -67,11 +68,12 @@ import GHC.Unit.Module.Warnings
 -- To do this, we need access to already processed modules in the topological
 -- sort. That's what's in the 'IfaceMap'.
 createInterface :: TypecheckedModule
+                -> UnitState
                 -> [Flag]       -- Boolean flags
                 -> IfaceMap     -- Locally processed modules
                 -> InstIfaceMap -- External, already installed interfaces
                 -> ErrMsgGhc Interface
-createInterface tm flags modMap instIfaceMap = do
+createInterface tm unit_state flags modMap instIfaceMap = do
 
   let ms             = pm_mod_summary . tm_parsed_module $ tm
       mi             = moduleInfo tm
@@ -84,7 +86,7 @@ createInterface tm flags modMap instIfaceMap = do
       !instances     = modInfoInstances mi
       !fam_instances = md_fam_insts md
       !exportedNames = modInfoExportsWithSelectors mi
-      (pkgNameFS, _) = modulePackageInfo dflags flags (Just mdl)
+      (pkgNameFS, _) = modulePackageInfo unit_state flags (Just mdl)
       pkgName        = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS
 
       (TcGblEnv { tcg_rdr_env = gre
@@ -164,8 +166,7 @@ createInterface tm flags modMap instIfaceMap = do
         | otherwise = exportItems
       !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
 
-  let !aliases =
-        mkAliasMap (unitState dflags) $ tm_renamed_source tm
+  let !aliases = mkAliasMap unit_state $ tm_renamed_source tm
 
   modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
 
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 5c9bf448..eda40935 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -45,7 +45,8 @@ import           Data.Version
 import           Control.Applicative
 import           Distribution.Verbosity
 import           GHC.Data.FastString
-import           GHC ( DynFlags, Module, moduleUnit, unitState )
+import           GHC ( DynFlags, Module, moduleUnit )
+import           GHC.Unit.State
 import           Haddock.Types
 import           Haddock.Utils
 import           GHC.Unit.State
@@ -370,16 +371,16 @@ optLast xs = Just (last xs)
 --
 -- The @--package-name@ and @--package-version@ Haddock flags allow the user to
 -- specify this information manually and it is returned here if present.
-modulePackageInfo :: DynFlags
+modulePackageInfo :: UnitState
                   -> [Flag] -- ^ Haddock flags are checked as they may contain
                             -- the package name or version provided by the user
                             -- which we prioritise
                   -> Maybe Module
                   -> (Maybe PackageName, Maybe Data.Version.Version)
-modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing)
-modulePackageInfo dflags flags (Just modu) =
+modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing)
+modulePackageInfo unit_state flags (Just modu) =
   ( optPackageName flags    <|> fmap unitPackageName pkgDb
   , optPackageVersion flags <|> fmap unitPackageVersion pkgDb
   )
   where
-    pkgDb = lookupUnit (unitState dflags) (moduleUnit modu)
+    pkgDb = lookupUnit unit_state (moduleUnit modu)
-- 
cgit v1.2.3


From 7936692badfe38f23ae95b51fb7bd7c2ff7e9bce Mon Sep 17 00:00:00 2001
From: tomjaguarpaw <tom-github.com@jaguarpaw.co.uk>
Date: Thu, 10 Dec 2020 18:01:41 +0000
Subject: Enable two warnings (#1245) (#1268)

because they will be soon be added to -Wall.

See https://gitlab.haskell.org/ghc/ghc/-/issues/15656
---
 haddock-api/haddock-api.cabal                          | 3 ++-
 haddock-api/src/Haddock/Backends/Hoogle.hs             | 1 +
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 +
 haddock-api/src/Haddock/GhcUtils.hs                    | 1 +
 haddock-api/src/Haddock/Interface/AttachInstances.hs   | 2 ++
 haddock-api/src/Haddock/Interface/Rename.hs            | 1 +
 haddock-api/src/Haddock/Interface/Specialize.hs        | 1 +
 haddock.cabal                                          | 2 +-
 8 files changed, 10 insertions(+), 2 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 801fbb0f..cea9c4bd 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -65,7 +65,8 @@ library
 
   hs-source-dirs: src
 
-  ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2
+  ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -Wincomplete-uni-patterns -Wincomplete-record-updates -O2
+
   ghc-options: -Wall
   if impl(ghc >= 8.0)
     ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 2ef0c61b..947ce51b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Backends.Hoogle
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 1de62a2e..cae00dd6 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 module Haddock.Backends.Hyperlinker.Parser (parse) where
 
 import Control.Applicative ( Alternative(..) )
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 39d6d3fd..42dc7f4f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 {-# OPTIONS_HADDOCK hide #-}
 -----------------------------------------------------------------------------
 -- |
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index d5fe878b..0d3f1ab5 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE MagicHash, BangPatterns #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.AttachInstances
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 5d7b4f1a..92247f90 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 ----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.Rename
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index b19f52d0..8eea5eaa 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
 module Haddock.Interface.Specialize
     ( specializeInstHead
diff --git a/haddock.cabal b/haddock.cabal
index 424a255b..7f2b5ee5 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -60,7 +60,7 @@ executable haddock
   default-language:     Haskell2010
   main-is:              Main.hs
   hs-source-dirs:       driver
-  ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded
+  ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs -Wincomplete-uni-patterns -Wincomplete-record-updates -O2 -threaded
 
   -- haddock typically only supports a single GHC major version
   build-depends:
-- 
cgit v1.2.3


From 4ffb30d8b637ccebecc81ce610f0af451ac8088d Mon Sep 17 00:00:00 2001
From: Andrew Martin <andrew.thaddeus@gmail.com>
Date: Sun, 11 Oct 2020 15:59:22 -0400
Subject: Update for boxed rep

---
 haddock-api/src/Haddock/Convert.hs  | 7 ++++---
 haddock-api/src/Haddock/GhcUtils.hs | 4 ++--
 2 files changed, 6 insertions(+), 5 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index b59602b6..f01a54bf 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -45,7 +45,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
 import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName
                   , unitTy, promotedNilDataCon, promotedConsDataCon )
 import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
-                 , liftedRepDataConKey )
+                 , liftedDataConKey, boxedRepDataConKey )
 import GHC.Types.Unique ( getUnique )
 import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength
                       , filterByList, filterOut )
@@ -568,8 +568,9 @@ synifyType _ vs (TyConApp tc tys)
     res_ty
       -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)
       | tc `hasKey` tYPETyConKey
-      , [TyConApp lev []] <- tys
-      , lev `hasKey` liftedRepDataConKey
+      , [TyConApp rep [TyConApp lev []]] <- tys
+      , rep `hasKey` boxedRepDataConKey
+      , lev `hasKey` liftedDataConKey
       = noLoc (HsTyVar noExtField NotPromoted (noLoc liftedTypeKindTyConName))
       -- Use non-prefix tuple syntax where possible, because it looks nicer.
       | Just sort <- tyConTuple_maybe tc
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 42dc7f4f..1f63b2a7 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -43,8 +43,8 @@ import GHC.Types.Var.Set ( VarSet, emptyVarSet )
 import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
 import GHC.Core.TyCo.Rep ( Type(..) )
 import GHC.Core.Type     ( isRuntimeRepVar )
-import GHC.Builtin.Types( liftedRepDataConTyCon )
 import GHC.Parser.Annotation (IsUnicodeSyntax(..))
+import GHC.Builtin.Types( liftedRepTy )
 
 import           GHC.Data.StringBuffer ( StringBuffer )
 import qualified GHC.Data.StringBuffer             as S
@@ -656,7 +656,7 @@ defaultRuntimeRepVars = go emptyVarEnv
 
     go subs (TyVarTy tv)
       | tv `elemVarEnv` subs
-      = TyConApp liftedRepDataConTyCon []
+      = liftedRepTy
       | otherwise
       = TyVarTy (updateTyVarKind (go subs) tv)
 
-- 
cgit v1.2.3


From 46c3db2460cea396fae525f4b9d8f40c34c0680e Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Tue, 15 Dec 2020 15:13:30 -0500
Subject: Revert "Enable two warnings (#1245) (#1268)"

As this does not build on GHC `master`.

This reverts commit 7936692badfe38f23ae95b51fb7bd7c2ff7e9bce.
---
 haddock-api/haddock-api.cabal                          | 3 +--
 haddock-api/src/Haddock/Backends/Hoogle.hs             | 1 -
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 -
 haddock-api/src/Haddock/GhcUtils.hs                    | 1 -
 haddock-api/src/Haddock/Interface/AttachInstances.hs   | 2 --
 haddock-api/src/Haddock/Interface/Rename.hs            | 1 -
 haddock-api/src/Haddock/Interface/Specialize.hs        | 1 -
 haddock.cabal                                          | 2 +-
 8 files changed, 2 insertions(+), 10 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index cea9c4bd..801fbb0f 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -65,8 +65,7 @@ library
 
   hs-source-dirs: src
 
-  ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -Wincomplete-uni-patterns -Wincomplete-record-updates -O2
-
+  ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2
   ghc-options: -Wall
   if impl(ghc >= 8.0)
     ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 947ce51b..2ef0c61b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Backends.Hoogle
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index cae00dd6..1de62a2e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 module Haddock.Backends.Hyperlinker.Parser (parse) where
 
 import Control.Applicative ( Alternative(..) )
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 1f63b2a7..dac6088f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -5,7 +5,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 {-# OPTIONS_HADDOCK hide #-}
 -----------------------------------------------------------------------------
 -- |
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 0d3f1ab5..d5fe878b 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,7 +1,5 @@
 {-# LANGUAGE MagicHash, BangPatterns #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.AttachInstances
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 92247f90..5d7b4f1a 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 ----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.Rename
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 8eea5eaa..b19f52d0 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -4,7 +4,6 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE GADTs #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
 module Haddock.Interface.Specialize
     ( specializeInstHead
diff --git a/haddock.cabal b/haddock.cabal
index 7f2b5ee5..424a255b 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -60,7 +60,7 @@ executable haddock
   default-language:     Haskell2010
   main-is:              Main.hs
   hs-source-dirs:       driver
-  ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs -Wincomplete-uni-patterns -Wincomplete-record-updates -O2 -threaded
+  ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded
 
   -- haddock typically only supports a single GHC major version
   build-depends:
-- 
cgit v1.2.3


From 4c6b8d4bb722b6e51406aa0afc334cc437461424 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Tue, 15 Dec 2020 15:17:59 -0500
Subject: Revert "Update for boxed rep"

This reverts commit 4ffb30d8b637ccebecc81ce610f0af451ac8088d.
---
 haddock-api/src/Haddock/Convert.hs  | 7 +++----
 haddock-api/src/Haddock/GhcUtils.hs | 4 ++--
 2 files changed, 5 insertions(+), 6 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index f01a54bf..b59602b6 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -45,7 +45,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
 import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName
                   , unitTy, promotedNilDataCon, promotedConsDataCon )
 import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey
-                 , liftedDataConKey, boxedRepDataConKey )
+                 , liftedRepDataConKey )
 import GHC.Types.Unique ( getUnique )
 import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength
                       , filterByList, filterOut )
@@ -568,9 +568,8 @@ synifyType _ vs (TyConApp tc tys)
     res_ty
       -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)
       | tc `hasKey` tYPETyConKey
-      , [TyConApp rep [TyConApp lev []]] <- tys
-      , rep `hasKey` boxedRepDataConKey
-      , lev `hasKey` liftedDataConKey
+      , [TyConApp lev []] <- tys
+      , lev `hasKey` liftedRepDataConKey
       = noLoc (HsTyVar noExtField NotPromoted (noLoc liftedTypeKindTyConName))
       -- Use non-prefix tuple syntax where possible, because it looks nicer.
       | Just sort <- tyConTuple_maybe tc
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 1f63b2a7..42dc7f4f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -43,8 +43,8 @@ import GHC.Types.Var.Set ( VarSet, emptyVarSet )
 import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )
 import GHC.Core.TyCo.Rep ( Type(..) )
 import GHC.Core.Type     ( isRuntimeRepVar )
+import GHC.Builtin.Types( liftedRepDataConTyCon )
 import GHC.Parser.Annotation (IsUnicodeSyntax(..))
-import GHC.Builtin.Types( liftedRepTy )
 
 import           GHC.Data.StringBuffer ( StringBuffer )
 import qualified GHC.Data.StringBuffer             as S
@@ -656,7 +656,7 @@ defaultRuntimeRepVars = go emptyVarEnv
 
     go subs (TyVarTy tv)
       | tv `elemVarEnv` subs
-      = liftedRepTy
+      = TyConApp liftedRepDataConTyCon []
       | otherwise
       = TyVarTy (updateTyVarKind (go subs) tv)
 
-- 
cgit v1.2.3


From b4b4d896d2d68d6c48e7db7bfe95c185ca0709cb Mon Sep 17 00:00:00 2001
From: Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io>
Date: Wed, 16 Dec 2020 20:03:14 +0100
Subject: Display linear/multiplicity arrows correctly (#1238)

Previously we were ignoring multiplicity and displayed
a %1 -> b as a -> b.
---
 haddock-api/src/Haddock/Backends/LaTeX.hs       |  14 ++-
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs  |   9 +-
 haddock-api/src/Haddock/Backends/Xhtml/Utils.hs |   9 +-
 html-test/ref/LinearTypes.html                  | 108 ++++++++++++++++++++++++
 html-test/src/LinearTypes.hs                    |  14 +++
 latex-test/ref/LinearTypes/LinearTypes.tex      |  30 +++++++
 latex-test/ref/LinearTypes/haddock.sty          |  57 +++++++++++++
 latex-test/ref/LinearTypes/main.tex             |  11 +++
 latex-test/src/LinearTypes/LinearTypes.hs       |  14 +++
 9 files changed, 259 insertions(+), 7 deletions(-)
 create mode 100644 html-test/ref/LinearTypes.html
 create mode 100644 html-test/src/LinearTypes.hs
 create mode 100644 latex-test/ref/LinearTypes/LinearTypes.tex
 create mode 100644 latex-test/ref/LinearTypes/haddock.sty
 create mode 100644 latex-test/ref/LinearTypes/main.tex
 create mode 100644 latex-test/src/LinearTypes/LinearTypes.hs

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 52df9dc8..40607082 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1073,9 +1073,13 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode
 ppr_mono_ty (HsQualTy _ ctxt ty) unicode
   = sep [ ppLContext ctxt unicode
         , ppr_mono_lty ty unicode ]
-ppr_mono_ty (HsFunTy _ _ ty1 ty2)   u
+ppr_mono_ty (HsFunTy _ mult ty1 ty2)   u
   = sep [ ppr_mono_lty ty1 u
-        , arrow u <+> ppr_mono_lty ty2 u ]
+        , arr <+> ppr_mono_lty ty2 u ]
+   where arr = case mult of
+                 HsLinearArrow _ -> lollipop u
+                 HsUnrestrictedArrow _ -> arrow u
+                 HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u
 
 ppr_mono_ty (HsBangTy _ b ty)     u = ppBang b <> ppLParendType u ty
 ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
@@ -1367,14 +1371,18 @@ quote :: LaTeX -> LaTeX
 quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}"
 
 
-dcolon, arrow, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX
+dcolon, arrow, lollipop, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX
 dcolon unicode = text (if unicode then "∷" else "::")
 arrow  unicode = text (if unicode then "→" else "->")
+lollipop unicode = text (if unicode then "⊸" else "%1 ->")
 darrow unicode = text (if unicode then "⇒" else "=>")
 forallSymbol unicode = text (if unicode then "∀" else "forall")
 starSymbol unicode = text (if unicode then "★" else "*")
 atSign unicode = text (if unicode then "@" else "@")
 
+multAnnotation :: LaTeX
+multAnnotation = text "%"
+
 dot :: LaTeX
 dot = char '.'
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index e9806471..6f474bd9 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1226,10 +1226,15 @@ ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _
   | otherwise = ppDocName q Prefix True name
 ppr_mono_ty (HsStarTy _ isUni) u _ _ =
   toHtml (if u || isUni then "★" else "*")
-ppr_mono_ty (HsFunTy _ _ ty1 ty2) u q e =
+ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =
   hsep [ ppr_mono_lty ty1 u q HideEmptyContexts
-       , arrow u <+> ppr_mono_lty ty2 u q e
+       , arr <+> ppr_mono_lty ty2 u q e
        ]
+   where arr = case mult of
+                 HsLinearArrow _ -> lollipop u
+                 HsUnrestrictedArrow _ -> arrow u
+                 HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
+
 ppr_mono_ty (HsTupleTy _ con tys) u q _ =
   tupleParens con (map (ppLType u q HideEmptyContexts) tys)
 ppr_mono_ty (HsSumTy _ tys) u q _ =
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index f5f64f51..238f0046 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -21,7 +21,8 @@ module Haddock.Backends.Xhtml.Utils (
   keyword, punctuate,
 
   braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList,
-  arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
+  arrow, lollipop, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
+  multAnnotation,
   atSign,
 
   hsep, vcat,
@@ -187,13 +188,17 @@ ubxparens :: Html -> Html
 ubxparens h = toHtml "(#" <+> h <+> toHtml "#)"
 
 
-dcolon, arrow, darrow, forallSymbol, atSign :: Bool -> Html
+dcolon, arrow, lollipop, darrow, forallSymbol, atSign :: Bool -> Html
 dcolon unicode = toHtml (if unicode then "∷" else "::")
 arrow  unicode = toHtml (if unicode then "→" else "->")
+lollipop unicode = toHtml (if unicode then "⊸" else "%1 ->")
 darrow unicode = toHtml (if unicode then "⇒" else "=>")
 forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall"
 atSign unicode = toHtml (if unicode then "@" else "@")
 
+multAnnotation :: Html
+multAnnotation = toHtml "%"
+
 dot :: Html
 dot = toHtml "."
 
diff --git a/html-test/ref/LinearTypes.html b/html-test/ref/LinearTypes.html
new file mode 100644
index 00000000..18cd060a
--- /dev/null
+++ b/html-test/ref/LinearTypes.html
@@ -0,0 +1,108 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><meta name="viewport" content="width=device-width, initial-scale=1"
+     /><title
+    >LinearTypes</title
+    ><link href="#" rel="stylesheet" type="text/css" title="NewOcean"
+     /><link rel="stylesheet" type="text/css" href="#"
+     /><link rel="stylesheet" type="text/css" href="#"
+     /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+    ></script
+    ><script type="text/x-mathjax-config"
+    >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><span class="caption empty"
+      >&nbsp;</span
+      ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >Safe-Inferred</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>LinearTypes</p
+	></div
+      ><div id="synopsis"
+      ><details id="syn"
+	><summary
+	  >Synopsis</summary
+	  ><ul class="details-toggle" data-details-id="syn"
+	  ><li class="src short"
+	    ><a href="#"
+	      >unrestricted</a
+	      > :: a -&gt; b</li
+	    ><li class="src short"
+	    ><a href="#"
+	      >linear</a
+	      > :: a %1 -&gt; b</li
+	    ><li class="src short"
+	    ><a href="#"
+	      >poly</a
+	      > :: a %m -&gt; b</li
+	    ></ul
+	  ></details
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><a id="v:unrestricted" class="def"
+	    >unrestricted</a
+	    > :: a -&gt; b <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Does something unrestricted.</p
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><a id="v:linear" class="def"
+	    >linear</a
+	    > :: a %1 -&gt; b <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Does something linear.</p
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><a id="v:poly" class="def"
+	    >poly</a
+	    > :: a %m -&gt; b <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Does something polymorphic.</p
+	    ></div
+	  ></div
+	></div
+      ></div
+    ></body
+  ></html
+>
diff --git a/html-test/src/LinearTypes.hs b/html-test/src/LinearTypes.hs
new file mode 100644
index 00000000..cb4eb138
--- /dev/null
+++ b/html-test/src/LinearTypes.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE LinearTypes #-}
+module LinearTypes where
+
+-- | Does something unrestricted.
+unrestricted :: a -> b
+unrestricted = undefined
+
+-- | Does something linear.
+linear :: a %1 -> b
+linear = linear
+
+-- | Does something polymorphic.
+poly :: a %m -> b
+poly = poly
diff --git a/latex-test/ref/LinearTypes/LinearTypes.tex b/latex-test/ref/LinearTypes/LinearTypes.tex
new file mode 100644
index 00000000..d02b6aa7
--- /dev/null
+++ b/latex-test/ref/LinearTypes/LinearTypes.tex
@@ -0,0 +1,30 @@
+\haddockmoduleheading{LinearTypes}
+\label{module:LinearTypes}
+\haddockbeginheader
+{\haddockverb\begin{verbatim}
+module LinearTypes (
+    unrestricted,  linear,  poly
+  ) where\end{verbatim}}
+\haddockendheader
+
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+unrestricted\ ::\ a\ ->\ b
+\end{tabular}]\haddockbegindoc
+Does something unrestricted.\par
+
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+linear\ ::\ a\ {\char '45}1\ ->\ b
+\end{tabular}]\haddockbegindoc
+Does something linear.\par
+
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+poly\ ::\ a\ {\char '45}m\ ->\ b
+\end{tabular}]\haddockbegindoc
+Does something polymorphic.\par
+
+\end{haddockdesc}
\ No newline at end of file
diff --git a/latex-test/ref/LinearTypes/haddock.sty b/latex-test/ref/LinearTypes/haddock.sty
new file mode 100644
index 00000000..6e031a98
--- /dev/null
+++ b/latex-test/ref/LinearTypes/haddock.sty
@@ -0,0 +1,57 @@
+% Default Haddock style definitions.  To use your own style, invoke
+% Haddock with the option --latex-style=mystyle.
+
+\usepackage{tabulary} % see below
+
+% make hyperlinks in the PDF, and add an expandabale index
+\usepackage[pdftex,bookmarks=true]{hyperref}
+
+\newenvironment{haddocktitle}
+  {\begin{center}\bgroup\large\bfseries}
+  {\egroup\end{center}}
+\newenvironment{haddockprologue}{\vspace{1in}}{}
+
+\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}}
+
+\newcommand{\haddockbeginheader}{\hrulefill}
+\newcommand{\haddockendheader}{\noindent\hrulefill}
+
+% a little gap before the ``Methods'' header
+\newcommand{\haddockpremethods}{\vspace{2ex}}
+
+% inserted before \\begin{verbatim}
+\newcommand{\haddockverb}{\small}
+
+% an identifier: add an index entry
+\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}}
+
+% The tabulary environment lets us have a column that takes up ``the
+% rest of the space''.  Unfortunately it doesn't allow
+% the \end{tabulary} to be in the expansion of a macro, it must appear
+% literally in the document text, so Haddock inserts
+% the \end{tabulary} itself.
+\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}
+\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}
+
+\newcommand{\haddocktt}[1]{{\small \texttt{#1}}}
+\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}}
+
+\makeatletter
+\newenvironment{haddockdesc}
+               {\list{}{\labelwidth\z@ \itemindent-\leftmargin
+                        \let\makelabel\haddocklabel}}
+               {\endlist}
+\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}}
+\makeatother
+
+% after a declaration, start a new line for the documentation.
+% Otherwise, the documentation starts right after the declaration,
+% because we're using the list environment and the declaration is the
+% ``label''.  I tried making this newline part of the label, but
+% couldn't get that to work reliably (the space seemed to stretch
+% sometimes).
+\newcommand{\haddockbegindoc}{\hfill\\[1ex]}
+
+% spacing between paragraphs and no \parindent looks better
+\parskip=10pt plus2pt minus2pt
+\setlength{\parindent}{0cm}
diff --git a/latex-test/ref/LinearTypes/main.tex b/latex-test/ref/LinearTypes/main.tex
new file mode 100644
index 00000000..655261c3
--- /dev/null
+++ b/latex-test/ref/LinearTypes/main.tex
@@ -0,0 +1,11 @@
+\documentclass{book}
+\usepackage{haddock}
+\begin{document}
+\begin{titlepage}
+\begin{haddocktitle}
+
+\end{haddocktitle}
+\end{titlepage}
+\tableofcontents
+\input{LinearTypes}
+\end{document}
\ No newline at end of file
diff --git a/latex-test/src/LinearTypes/LinearTypes.hs b/latex-test/src/LinearTypes/LinearTypes.hs
new file mode 100644
index 00000000..cb4eb138
--- /dev/null
+++ b/latex-test/src/LinearTypes/LinearTypes.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE LinearTypes #-}
+module LinearTypes where
+
+-- | Does something unrestricted.
+unrestricted :: a -> b
+unrestricted = undefined
+
+-- | Does something linear.
+linear :: a %1 -> b
+linear = linear
+
+-- | Does something polymorphic.
+poly :: a %m -> b
+poly = poly
-- 
cgit v1.2.3


From c3b276d94e207717731512d1e1f8b59b729b653a Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Fri, 6 Nov 2020 10:40:03 -0500
Subject: Adapt to HsCoreTy (formerly NewHsTypeX) becoming a type synonym

Needed for !4417, the fix for GHC#15706 and GHC#18914.
---
 haddock-api/src/Haddock/Backends/LaTeX.hs       | 2 +-
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs  | 2 +-
 haddock-api/src/Haddock/Interface/Rename.hs     | 2 +-
 haddock-api/src/Haddock/Interface/Specialize.hs | 2 +-
 haddock-api/src/Haddock/Types.hs                | 2 +-
 5 files changed, 5 insertions(+), 5 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 40607082..2ba0bf52 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1091,7 +1091,7 @@ ppr_mono_ty (HsListTy _ ty)       u = brackets (ppr_mono_lty ty u)
 ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u
 ppr_mono_ty (HsSpliceTy {})     _ = error "ppr_mono_ty HsSpliceTy"
 ppr_mono_ty (HsRecTy {})        _ = text "{..}"
-ppr_mono_ty (XHsType (NHsCoreTy {}))  _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty (XHsType {})        _ = error "ppr_mono_ty HsCoreTy"
 ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
 ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
 ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 6f474bd9..cb5417b5 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1249,7 +1249,7 @@ ppr_mono_ty (HsRecTy {})        _ _ _ = toHtml "{..}"
        -- Can now legally occur in ConDeclGADT, the output here is to provide a
        -- placeholder in the signature, which is followed by the field
        -- declarations.
-ppr_mono_ty (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty (XHsType {})        _ _ _ = error "ppr_mono_ty HsCoreTy"
 ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
 ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
 ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 5d7b4f1a..21af7edc 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -288,7 +288,7 @@ renameType t = case t of
   HsTyLit _ x -> return (HsTyLit noExtField x)
 
   HsRecTy _ a               -> HsRecTy noExtField <$> mapM renameConDeclFieldField a
-  (XHsType (NHsCoreTy a))   -> pure (XHsType (NHsCoreTy a))
+  XHsType a                 -> pure (XHsType a)
   HsExplicitListTy i a b  -> HsExplicitListTy i a <$> mapM renameLType b
   HsExplicitTupleTy a b   -> HsExplicitTupleTy a <$> mapM renameLType b
   HsSpliceTy _ s          -> renameHsSpliceTy s
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index b19f52d0..16293290 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -305,7 +305,7 @@ renameType t@(HsSpliceTy _ _) = pure t
 renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc
 renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt
 renameType t@(HsRecTy _ _) = pure t
-renameType t@(XHsType (NHsCoreTy _)) = pure t
+renameType t@(XHsType _) = pure t
 renameType (HsExplicitListTy x ip ltys) =
     HsExplicitListTy x ip <$> renameLTypes ltys
 renameType (HsExplicitTupleTy x ltys) =
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 7b261f4e..53a91cf5 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -700,7 +700,7 @@ type instance XExplicitListTy  DocNameI = NoExtField
 type instance XExplicitTupleTy DocNameI = NoExtField
 type instance XTyLit           DocNameI = NoExtField
 type instance XWildCardTy      DocNameI = NoExtField
-type instance XXType           DocNameI = NewHsTypeX
+type instance XXType           DocNameI = HsCoreTy
 
 type instance XHsForAllVis        DocNameI = NoExtField
 type instance XHsForAllInvis      DocNameI = NoExtField
-- 
cgit v1.2.3


From beafcacfd0fc3d447d461a2be3378e50ef77d9c0 Mon Sep 17 00:00:00 2001
From: tomjaguarpaw <tom-github.com@jaguarpaw.co.uk>
Date: Thu, 10 Dec 2020 18:01:41 +0000
Subject: Enable two warnings (#1245) (#1268)

because they will be soon be added to -Wall.

See https://gitlab.haskell.org/ghc/ghc/-/issues/15656
---
 haddock-api/haddock-api.cabal                          | 3 ++-
 haddock-api/src/Haddock/Backends/Hoogle.hs             | 1 +
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 +
 haddock-api/src/Haddock/GhcUtils.hs                    | 1 +
 haddock-api/src/Haddock/Interface/AttachInstances.hs   | 2 ++
 haddock-api/src/Haddock/Interface/Rename.hs            | 1 +
 haddock-api/src/Haddock/Interface/Specialize.hs        | 1 +
 haddock-api/src/Haddock/Utils.hs                       | 2 ++
 haddock.cabal                                          | 2 +-
 9 files changed, 12 insertions(+), 2 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 801fbb0f..cea9c4bd 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -65,7 +65,8 @@ library
 
   hs-source-dirs: src
 
-  ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2
+  ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -Wincomplete-uni-patterns -Wincomplete-record-updates -O2
+
   ghc-options: -Wall
   if impl(ghc >= 8.0)
     ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 2ef0c61b..947ce51b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Backends.Hoogle
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 1de62a2e..cae00dd6 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 module Haddock.Backends.Hyperlinker.Parser (parse) where
 
 import Control.Applicative ( Alternative(..) )
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 39d6d3fd..42dc7f4f 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 {-# OPTIONS_HADDOCK hide #-}
 -----------------------------------------------------------------------------
 -- |
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index d5fe878b..0d3f1ab5 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE MagicHash, BangPatterns #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.AttachInstances
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 21af7edc..bfbdf392 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 ----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.Rename
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 16293290..85055bf4 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
 module Haddock.Interface.Specialize
     ( specializeInstHead
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 8186e3b7..8a6b6349 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE GADTs #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Utils
diff --git a/haddock.cabal b/haddock.cabal
index 424a255b..7f2b5ee5 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -60,7 +60,7 @@ executable haddock
   default-language:     Haskell2010
   main-is:              Main.hs
   hs-source-dirs:       driver
-  ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded
+  ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs -Wincomplete-uni-patterns -Wincomplete-record-updates -O2 -threaded
 
   -- haddock typically only supports a single GHC major version
   build-depends:
-- 
cgit v1.2.3


From 600e076140649cb392d063ad73eb015630f62ff1 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Wed, 2 Dec 2020 12:37:25 +0100
Subject: Fix after binder collect changes

---
 haddock-api/src/Haddock/GhcUtils.hs         | 2 +-
 haddock-api/src/Haddock/Interface/Create.hs | 2 +-
 haddock-api/src/Haddock/Types.hs            | 2 +-
 3 files changed, 3 insertions(+), 3 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 42dc7f4f..fe97dee0 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -165,7 +165,7 @@ getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
 getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI]
 getMainDeclBinderI (TyClD _ d) = [tcdNameI d]
 getMainDeclBinderI (ValD _ d) =
-  case collectHsBindBinders d of
+  case collectHsBindBinders CollNoDictBinders d of
     []       -> []
     (name:_) -> [name]
 getMainDeclBinderI (SigD _ d) = sigNameNoLoc d
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 7ef64a94..060bef91 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -842,7 +842,7 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam
         doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr)
         return [[ExportDoc doc]]
       (L _ (ValD _ valDecl))
-        | name:_ <- collectHsBindBinders valDecl
+        | name:_ <- collectHsBindBinders CollNoDictBinders valDecl
         , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap
         -> return []
       _ ->
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 53a91cf5..465d276e 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -301,7 +301,7 @@ data DocNameI
 type instance IdP DocNameI = DocName
 
 instance CollectPass DocNameI where
-  collectXXPat _ ext = noExtCon ext
+  collectXXPat _ _ ext = noExtCon ext
 
 instance NamedThing DocName where
   getName (Documented name _) = name
-- 
cgit v1.2.3


From 8a5ccf93c53a40abe42134c2282ac9b9d653224c Mon Sep 17 00:00:00 2001
From: Adam Gundry <adam@well-typed.com>
Date: Tue, 1 Dec 2020 09:17:04 +0000
Subject: Adapt to changes to GlobalRdrElt and AvailInfo

Needed for ghc/ghc!4467
---
 haddock-api/src/Haddock/Interface.hs            |  4 ++--
 haddock-api/src/Haddock/Interface/Create.hs     | 12 ++----------
 haddock-api/src/Haddock/Interface/LexParseRn.hs |  4 ++--
 3 files changed, 6 insertions(+), 14 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index be9bd09a..e9cd6e0d 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -61,7 +61,7 @@ import GHC.Data.FastString (unpackFS)
 import GHC.Tc.Types (tcg_rdr_env)
 import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)
 import GHC.Types.Name.Occurrence (isTcOcc)
-import GHC.Types.Name.Reader (unQualOK, gre_name, globalRdrEnvElts)
+import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts)
 import GHC.Utils.Error (withTimingD)
 import GHC.HsToCore.Docs
 
@@ -174,7 +174,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do
           home_unit = hsc_home_unit hsc_env
           !mods = mkModuleSet [ nameModule name
                               | gre <- globalRdrEnvElts new_rdr_env
-                              , let name = gre_name gre
+                              , let name = greMangledName gre
                               , nameIsFromExternalPackage home_unit name
                               , isTcOcc (nameOccName name)   -- Types and classes only
                               , unQualOK gre ]               -- In scope unqualified
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 7ef64a94..e3263f9d 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -293,7 +293,7 @@ mkWarningMap dflags warnings gre exps = case warnings of
     let ws' = [ (n, w)
               | (occ, w) <- ws
               , elt <- lookupGlobalRdrEnv gre occ
-              , let n = gre_name elt, n `elem` exps ]
+              , let n = greMangledName elt, n `elem` exps ]
     in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws'
 
 moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))
@@ -693,16 +693,8 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
         constructor_names =
           filter isDataConName (availSubordinates avail)
 
--- this heavily depends on the invariants stated in Avail
-availExportsDecl :: AvailInfo -> Bool
-availExportsDecl (AvailTC ty_name names _)
-  | n : _ <- names = ty_name == n
-  | otherwise      = False
-availExportsDecl _ = True
-
 availSubordinates :: AvailInfo -> [Name]
-availSubordinates avail =
-  filter (/= availName avail) (availNamesWithSelectors avail)
+availSubordinates = map greNameMangledName . availSubordinateGreNames
 
 availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)]
 availNoDocs avail =
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 2c06438f..44c02875 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -120,7 +120,7 @@ rename dflags gre = rn
 
           -- There is only one name in the environment that matches so
           -- use it.
-          [a] -> pure (DocIdentifier (gre_name a))
+          [a] -> pure (DocIdentifier (greMangledName a))
 
           -- There are multiple names available.
           gres -> ambiguous dflags x gres
@@ -182,7 +182,7 @@ ambiguous dflags x gres = do
   let noChildren = map availName (gresToAvailInfo gres)
       dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren
       msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++
-            concatMap (\n -> "    * " ++ defnLoc n ++ "\n") (map gre_name gres) ++
+            concatMap (\n -> "    * " ++ defnLoc n ++ "\n") (map greMangledName gres) ++
             "    You may be able to disambiguate the identifier by qualifying it or\n" ++
             "    by hiding some imports.\n" ++
             "    Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt
-- 
cgit v1.2.3


From e7ee7957a7ac746cfa05d7218fe0c2d1fd27f569 Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Fri, 20 Sep 2019 14:20:55 -0400
Subject: Support a new ghc --make node type for parallel backpack upsweep

---
 haddock-api/src/Haddock/Interface.hs | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index e9cd6e0d..81c79cdf 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -52,6 +52,7 @@ import Text.Printf
 
 import GHC.Unit.Module.Env (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)
 import GHC.Unit.Module.ModSummary
+import GHC.Unit.Module.Graph
 import GHC.Unit.Types
 import GHC.Data.Graph.Directed
 import GHC.Driver.Session hiding (verbosity)
@@ -137,10 +138,11 @@ createIfaces verbosity modules flags instIfaceMap = do
   (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods
   return (reverse ifaces, ms)
   where
-    f (ifaces, ifaceMap, !ms) modSummary = do
+    f state (InstantiationNode _) = pure state
+    f (ifaces, ifaceMap, !ms) (ModuleNode ems) = do
       x <- {-# SCC processModule #-}
            withTimingD "processModule" (const ()) $ do
-             processModule verbosity modSummary flags ifaceMap instIfaceMap
+             processModule verbosity (emsModSummary ems) flags ifaceMap instIfaceMap
       return $ case x of
         Just (iface, ms') -> ( iface:ifaces
                              , Map.insert (ifaceMod iface) iface ifaceMap
-- 
cgit v1.2.3


From 39a2def15c0d38bb1f7eef6db81676dd13785982 Mon Sep 17 00:00:00 2001
From: Vladislav Zavialov <vlad.z.4096@gmail.com>
Date: Mon, 28 Dec 2020 18:03:18 +0300
Subject: Inline and fix getGADTConTypeG

The getGADTConTypeG used HsRecTy, which is at odds with GHC issue #18782.

I noticed that getGADTConTypeG was only used in the Hoogle backend.
Interestingly, when handling H98 constructors, Hoogle converts RecCon to
PrefixCon (see Haddock.Backends.Hoogle.ppCtor).

So I changed getGADTConTypeG to handle RecConGADT in the same manner as
PrefixConGADT, and after this simplification moved it into the 'where'
clause of ppCtor, to the only place where it is used.

The practical effect of this change is as follows.
Consider this example:
	data TestH98 = T98 { bar::Int }
	data TestGADT where
	  TG :: { foo :: Int } -> TestGADT

Before this patch,  haddock --hoogle  used to produce:
	T98 :: Int -> TestH98
	[TG] :: {foo :: Int} -> TestGADT

Notice how the record syntax was discarded in T98 but not TG.
With this patch, we always produce signatures without record syntax:
	T98 :: Int -> TestH98
	[TG] :: Int -> TestGADT

I suspect this might also be a bugfix, as currently Hoogle doesn't seem
to render GADT record constructors properly.
---
 haddock-api/src/Haddock/Backends/Hoogle.hs | 22 ++++++++++++++++------
 haddock-api/src/Haddock/GhcUtils.hs        | 30 ------------------------------
 2 files changed, 16 insertions(+), 36 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 947ce51b..520b51f3 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -271,13 +271,23 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }
                         (HsTyVar noExtField NotPromoted (reL (tcdName dat))) :
                         map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)
 
-ppCtor dflags _dat subdocs con@(ConDeclGADT { })
-   = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f
+ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names
+                                        , con_bndrs = L _ outer_bndrs
+                                        , con_mb_cxt = mcxt
+                                        , con_g_args = args
+                                        , con_res_ty = res_ty })
+   = concatMap (lookupCon dflags subdocs) names ++ [typeSig]
     where
-        f = [typeSig name (getGADTConTypeG con)]
-
-        typeSig nm ty = operator nm ++ " :: " ++ outHsSigType dflags (unL ty)
-        name = out dflags $ map unL $ getConNames con
+        typeSig = operator name ++ " :: " ++ outHsSigType dflags con_sig_ty
+        name = out dflags $ map unL names
+        con_sig_ty = HsSig noExtField outer_bndrs theta_ty where
+          theta_ty = case mcxt of
+            Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
+            Nothing -> tau_ty
+          tau_ty = foldr mkFunTy res_ty $
+            case args of PrefixConGADT pos_args -> map hsScaledThing pos_args
+                         RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds
+          mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
 
 ppFixity :: DynFlags -> (Name, Fixity) -> [String]
 ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)]
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 42dc7f4f..452cb6f4 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -185,36 +185,6 @@ tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln
 tcdNameI :: TyClDecl DocNameI -> DocName
 tcdNameI = unLoc . tyClDeclLNameI
 
--- -------------------------------------
-
-getGADTConTypeG :: ConDecl GhcRn -> LHsSigType GhcRn
--- The full type of a GADT data constructor We really only get this in
--- order to pretty-print it, and currently only in Haddock's code.  So
--- we are cavalier about locations and extensions, hence the
--- 'undefined's
-getGADTConTypeG (ConDeclGADT { con_bndrs = L _ outer_bndrs
-                            , con_mb_cxt = mcxt, con_g_args = args
-                            , con_res_ty = res_ty })
- = noLoc (HsSig { sig_ext   = noExtField
-                , sig_bndrs = outer_bndrs
-                , sig_body  = theta_ty })
- where
-   theta_ty | Just theta <- mcxt
-            = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
-            | otherwise
-            = tau_ty
-
---   tau_ty :: LHsType DocNameI
-   tau_ty = case args of
-              RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty
-              PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)
-
-   -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
-   mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)
-
-getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
-  -- Should only be called on ConDeclGADT
-
 
 -------------------------------------------------------------------------------
 -- * Parenthesization
-- 
cgit v1.2.3


From d1e3e365cc4cdf086e1ad6c192db80d4e91563d2 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alex@groundcloud.com>
Date: Fri, 25 Dec 2020 13:57:56 +0100
Subject: Prepare Haddock for being a GHC Plugin

---
 haddock-api/src/Haddock/Interface.hs        |   8 +-
 haddock-api/src/Haddock/Interface/Create.hs | 247 ++++++++++++++++++++++++----
 2 files changed, 222 insertions(+), 33 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 81c79cdf..a0ba001f 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -163,9 +163,15 @@ processModule verbosity modsum flags modMap instIfaceMap = do
     NotBoot -> do
       unit_state <- hsc_units <$> getSession
       out verbosity verbose "Creating interface..."
+
+      let
+        mod_summary = pm_mod_summary (tm_parsed_module tm)
+        tcg_gbl_env = fst (tm_internals_ tm)
+
       (interface, msgs) <- {-# SCC createIterface #-}
                           withTimingD "createInterface" (const ()) $ do
-                            runWriterGhc $ createInterface tm unit_state flags modMap instIfaceMap
+                            runWriterGhc $ createInterface1 flags unit_state
+                              mod_summary tcg_gbl_env modMap instIfaceMap
 
       -- We need to keep track of which modules were somehow in scope so that when
       -- Haddock later looks for instances, it also looks in these modules too.
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index e3263f9d..8bf9d7d6 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}
+{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wwarn #-}
@@ -18,7 +18,7 @@
 -- which creates a Haddock 'Interface' from the typechecking
 -- results 'TypecheckedModule' from GHC.
 -----------------------------------------------------------------------------
-module Haddock.Interface.Create (createInterface) where
+module Haddock.Interface.Create (createInterface, createInterface1) where
 
 import Documentation.Haddock.Doc (metaDocAppend)
 import Haddock.Types
@@ -37,6 +37,7 @@ import Data.Maybe
 import Control.Monad
 import Data.Traversable
 
+import GHC.Tc.Utils.Monad (finalSafeMode)
 import GHC.Types.Avail hiding (avail)
 import qualified GHC.Types.Avail  as Avail
 import qualified GHC.Unit.Module as Module
@@ -64,6 +65,191 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..))
 import GHC.Unit.Module.Warnings
 
 
+createInterface1
+  :: [Flag]
+  -> UnitState
+  -> ModSummary
+  -> TcGblEnv
+  -> IfaceMap
+  -> InstIfaceMap
+  -> ErrMsgGhc Interface
+createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
+
+  let
+    ModSummary
+      {
+        -- Cached flags from OPTIONS, INCLUDE and LANGUAGE
+        -- pragmas in the modules source code. Used to infer
+        -- safety of module.
+        ms_hspp_opts
+      , ms_location = ModLocation
+        {
+          ml_hie_file
+        }
+      } = mod_sum
+
+    TcGblEnv
+      {
+        tcg_mod
+      , tcg_src
+      , tcg_semantic_mod
+      , tcg_rdr_env
+      , tcg_exports
+      , tcg_insts
+      , tcg_fam_insts
+      , tcg_warns
+
+      -- Renamed source
+      , tcg_rn_imports
+      , tcg_rn_exports
+      , tcg_rn_decls
+
+      , tcg_doc_hdr
+      } = tc_gbl_env
+
+    dflags = ms_hspp_opts
+
+    is_sig = tcg_src == HsigFile
+
+    (pkg_name_fs, _) =
+      modulePackageInfo unit_state flags (Just tcg_mod)
+
+    pkg_name :: Maybe Package
+    pkg_name =
+      let
+        unpack (PackageName name) = unpackFS name
+      in
+        fmap unpack pkg_name_fs
+
+    fixities :: FixMap
+    fixities = case tcg_rn_decls of
+      Nothing -> mempty
+      Just dx -> mkFixMap dx
+
+    -- Locations of all the TH splices
+    loc_splices :: [SrcSpan]
+    loc_splices = case tcg_rn_decls of
+      Nothing -> []
+      Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ]
+
+  decls <- case tcg_rn_decls of
+    Nothing -> do
+      liftErrMsg $ tell [ "Warning: Renamed source is not available" ]
+      pure []
+    Just dx ->
+      pure (topDecls dx)
+
+  -- Derive final options to use for haddocking this module
+  doc_opts <- liftErrMsg $ mkDocOpts (haddockOptions ms_hspp_opts) flags tcg_mod
+
+  let
+    -- All elements of an explicit export list, if present
+    export_list :: Maybe [(IE GhcRn, Avails)]
+    export_list
+      | OptIgnoreExports `elem` doc_opts  =
+          Nothing
+      | Just rn_exports <- tcg_rn_exports =
+          Just [ (ie, avail) | (L _ ie, avail) <- rn_exports ]
+      | otherwise =
+          Nothing
+
+    -- All the exported Names of this module.
+    exported_names :: [Name]
+    exported_names =
+      concatMap availNamesWithSelectors tcg_exports
+
+    -- Module imports of the form `import X`. Note that there is
+    -- a) no qualification and
+    -- b) no import list
+    imported_modules :: Map ModuleName [ModuleName]
+    imported_modules
+      | Just{} <- export_list =
+          unrestrictedModuleImports (map unLoc tcg_rn_imports)
+      | otherwise =
+          M.empty
+
+    -- TyThings that have instances defined in this module
+    local_instances :: [Name]
+    local_instances =
+      [ name
+      | name <- map getName tcg_insts ++ map getName tcg_fam_insts
+      , nameIsLocalOrFrom tcg_semantic_mod name
+      ]
+
+  -- Infer module safety
+  safety   <- liftIO (finalSafeMode ms_hspp_opts tc_gbl_env)
+
+  -- Process the top-level module header documentation.
+  (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name
+    tcg_rdr_env safety tcg_doc_hdr
+
+  -- Warnings on declarations in this module
+  decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names)
+
+  -- Warning on the module header
+  mod_warning <- liftErrMsg (moduleWarning dflags tcg_rdr_env tcg_warns)
+
+  let
+    -- Warnings in this module and transitive warnings from dependend modules
+    warnings :: Map Name (Doc Name)
+    warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces))
+
+  maps@(!docs, !arg_docs, !decl_map, _) <-
+    liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls)
+
+  export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod
+    warnings tcg_rdr_env exported_names (map fst decls) maps fixities
+    imported_modules loc_splices export_list tcg_exports inst_ifaces dflags
+
+  let
+    visible_names :: [Name]
+    visible_names = mkVisibleNames maps export_items doc_opts
+
+    -- Measure haddock documentation coverage.
+    pruned_export_items :: [ExportItem GhcRn]
+    pruned_export_items = pruneExportItems export_items
+
+    !haddockable = 1 + length export_items -- module + exports
+    !haddocked = (if isJust tcg_doc_hdr then 1 else 0) + length pruned_export_items
+
+    coverage :: (Int, Int)
+    !coverage = (haddockable, haddocked)
+
+    aliases :: Map Module ModuleName
+    aliases = mkAliasMap unit_state tcg_rn_imports
+
+  return $! Interface
+    {
+      ifaceMod               = tcg_mod
+    , ifaceIsSig             = is_sig
+    , ifaceOrigFilename      = msHsFilePath mod_sum
+    , ifaceHieFile           = Just ml_hie_file
+    , ifaceInfo              = info
+    , ifaceDoc               = Documentation header_doc mod_warning
+    , ifaceRnDoc             = Documentation Nothing Nothing
+    , ifaceOptions           = doc_opts
+    , ifaceDocMap            = docs
+    , ifaceArgMap            = arg_docs
+    , ifaceRnDocMap          = M.empty
+    , ifaceRnArgMap          = M.empty
+    , ifaceExportItems       = if OptPrune `elem` doc_opts then
+                                 pruned_export_items else export_items
+    , ifaceRnExportItems     = []
+    , ifaceExports           = exported_names
+    , ifaceVisibleExports    = visible_names
+    , ifaceDeclMap           = decl_map
+    , ifaceFixMap            = fixities
+    , ifaceModuleAliases     = aliases
+    , ifaceInstances         = tcg_insts
+    , ifaceFamInstances      = tcg_fam_insts
+    , ifaceOrphanInstances   = [] -- Filled in attachInstances
+    , ifaceRnOrphanInstances = [] -- Filled in attachInstances
+    , ifaceHaddockCoverage   = coverage
+    , ifaceWarningMap        = warnings
+    , ifaceDynFlags          = dflags
+    }
+
+
 -- | Use a 'TypecheckedModule' to produce an 'Interface'.
 -- To do this, we need access to already processed modules in the topological
 -- sort. That's what's in the 'IfaceMap'.
@@ -166,7 +352,7 @@ createInterface tm unit_state flags modMap instIfaceMap = do
         | otherwise = exportItems
       !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
 
-  let !aliases = mkAliasMap unit_state $ tm_renamed_source tm
+  let !aliases = mkAliasMap unit_state imports
 
   modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
 
@@ -204,35 +390,32 @@ createInterface tm unit_state flags modMap instIfaceMap = do
 -- create a mapping from the module identity of M, to an alias N
 -- (if there are multiple aliases, we pick the last one.)  This
 -- will go in 'ifaceModuleAliases'.
-mkAliasMap :: UnitState -> Maybe RenamedSource -> M.Map Module ModuleName
-mkAliasMap state mRenamedSource =
-  case mRenamedSource of
-    Nothing -> M.empty
-    Just (_,impDecls,_,_) ->
-      M.fromList $
-      mapMaybe (\(SrcLoc.L _ impDecl) -> do
-        SrcLoc.L _ alias <- ideclAs impDecl
-        return $
-          (lookupModuleDyn state
-             -- TODO: This is supremely dodgy, because in general the
-             -- UnitId isn't going to look anything like the package
-             -- qualifier (even with old versions of GHC, the
-             -- IPID would be p-0.1, but a package qualifier never
-             -- has a version number it.  (Is it possible that in
-             -- Haddock-land, the UnitIds never have version numbers?
-             -- I, ezyang, have not quite understand Haddock's package
-             -- identifier model.)
-             --
-             -- Additionally, this is simulating some logic GHC already
-             -- has for deciding how to qualify names when it outputs
-             -- them to the user.  We should reuse that information;
-             -- or at least reuse the renamed imports, which know what
-             -- they import!
-             (fmap Module.fsToUnit $
-              fmap sl_fs $ ideclPkgQual impDecl)
-             (case ideclName impDecl of SrcLoc.L _ name -> name),
-           alias))
-        impDecls
+mkAliasMap :: UnitState -> [LImportDecl GhcRn] -> M.Map Module ModuleName
+mkAliasMap state impDecls =
+  M.fromList $
+  mapMaybe (\(SrcLoc.L _ impDecl) -> do
+    SrcLoc.L _ alias <- ideclAs impDecl
+    return $
+      (lookupModuleDyn state
+         -- TODO: This is supremely dodgy, because in general the
+         -- UnitId isn't going to look anything like the package
+         -- qualifier (even with old versions of GHC, the
+         -- IPID would be p-0.1, but a package qualifier never
+         -- has a version number it.  (Is it possible that in
+         -- Haddock-land, the UnitIds never have version numbers?
+         -- I, ezyang, have not quite understand Haddock's package
+         -- identifier model.)
+         --
+         -- Additionally, this is simulating some logic GHC already
+         -- has for deciding how to qualify names when it outputs
+         -- them to the user.  We should reuse that information;
+         -- or at least reuse the renamed imports, which know what
+         -- they import!
+         (fmap Module.fsToUnit $
+          fmap sl_fs $ ideclPkgQual impDecl)
+         (case ideclName impDecl of SrcLoc.L _ name -> name),
+       alias))
+    impDecls
 
 -- We want to know which modules are imported without any qualification. This
 -- way we can display module reexports more compactly. This mapping also looks
-- 
cgit v1.2.3


From 409cc2c7d7c521f171ea3f7a533721d2101fbf8b Mon Sep 17 00:00:00 2001
From: Alex Biehl <alex@groundcloud.com>
Date: Sun, 27 Dec 2020 12:48:43 +0100
Subject: Make Haddock a GHC Plugin

---
 haddock-api/src/Haddock/Interface.hs | 308 ++++++++++++++++++++++++-----------
 1 file changed, 212 insertions(+), 96 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index a0ba001f..87ac4861 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-}
+{-# LANGUAGE CPP, OverloadedStrings, BangPatterns, NamedFieldPuns #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface
@@ -29,7 +29,8 @@
 -- using this environment.
 -----------------------------------------------------------------------------
 module Haddock.Interface (
-  processModules
+    plugin
+  , processModules
 ) where
 
 
@@ -43,7 +44,7 @@ import Haddock.Types
 import Haddock.Utils
 
 import Control.Monad
-import Control.Exception (evaluate)
+import Data.IORef
 import Data.List
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -58,13 +59,17 @@ import GHC.Data.Graph.Directed
 import GHC.Driver.Session hiding (verbosity)
 import GHC hiding (verbosity)
 import GHC.Driver.Env
+import GHC.Driver.Monad (Session(..), modifySession, reflectGhc)
 import GHC.Data.FastString (unpackFS)
-import GHC.Tc.Types (tcg_rdr_env)
+import GHC.Tc.Types (TcGblEnv(..))
+import GHC.Tc.Utils.Monad (getTopEnv)
 import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)
 import GHC.Types.Name.Occurrence (isTcOcc)
 import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts)
 import GHC.Utils.Error (withTimingD)
 import GHC.HsToCore.Docs
+import GHC.Plugins (Outputable, StaticPlugin(..), Plugin(..), PluginWithArgs(..),
+                     defaultPlugin, keepRenamedSource)
 
 #if defined(mingw32_HOST_OS)
 import System.IO
@@ -90,8 +95,14 @@ processModules verbosity modules flags extIfaces = do
 #endif
 
   out verbosity verbose "Creating interfaces..."
-  let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces
-                                   , iface <- ifInstalledIfaces ext ]
+  let
+    instIfaceMap :: InstIfaceMap
+    instIfaceMap = Map.fromList
+      [ (instMod iface, iface)
+      | ext <- extIfaces
+      , iface <- ifInstalledIfaces ext
+      ]
+
   (interfaces, ms) <- createIfaces verbosity modules flags instIfaceMap
 
   let exportedNames =
@@ -127,100 +138,206 @@ processModules verbosity modules flags extIfaces = do
 
 createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet)
 createIfaces verbosity modules flags instIfaceMap = do
-  -- Ask GHC to tell us what the module graph is
+  (haddockPlugin, getIfaces, getModules) <- liftIO $ plugin
+    verbosity flags instIfaceMap
+
+  let
+    installHaddockPlugin :: HscEnv -> HscEnv
+    installHaddockPlugin hsc_env = hsc_env
+      {
+        hsc_dflags =
+          gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy
+      , hsc_static_plugins =
+          haddockPlugin : hsc_static_plugins hsc_env
+      }
+
+  -- Note that we would rather use withTempSession but as long as we
+  -- have the separate attachInstances step we need to keep the session
+  -- alive to be able to find all the instances.
+  modifySession installHaddockPlugin
+
   targets <- mapM (\filePath -> guessTarget filePath Nothing) modules
   setTargets targets
-  modGraph <- depanal [] False
 
-  -- Visit modules in that order
-  let sortedMods = flattenSCCs $ topSortModuleGraph False modGraph Nothing
-  out verbosity normal "Haddock coverage:"
-  (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods
-  return (reverse ifaces, ms)
-  where
-    f state (InstantiationNode _) = pure state
-    f (ifaces, ifaceMap, !ms) (ModuleNode ems) = do
-      x <- {-# SCC processModule #-}
-           withTimingD "processModule" (const ()) $ do
-             processModule verbosity (emsModSummary ems) flags ifaceMap instIfaceMap
-      return $ case x of
-        Just (iface, ms') -> ( iface:ifaces
-                             , Map.insert (ifaceMod iface) iface ifaceMap
-                             , unionModuleSet ms ms' )
-        Nothing           -> ( ifaces
-                             , ifaceMap
-                             , ms ) -- Boot modules don't generate ifaces.
-
-
-processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet))
-processModule verbosity modsum flags modMap instIfaceMap = do
-  out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
-  tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum
-
-  case isBootSummary modsum of
-    IsBoot ->
-      return Nothing
-    NotBoot -> do
-      unit_state <- hsc_units <$> getSession
-      out verbosity verbose "Creating interface..."
+  loadOk <- withTimingD "load" (const ()) $
+    {-# SCC load #-} GHC.load LoadAllTargets
+
+  case loadOk of
+    Failed ->
+      throwE "Cannot typecheck modules"
+    Succeeded -> do
+      modGraph <- GHC.getModuleGraph
+      ifaceMap  <- liftIO getIfaces
+      moduleSet <- liftIO getModules
 
       let
-        mod_summary = pm_mod_summary (tm_parsed_module tm)
-        tcg_gbl_env = fst (tm_internals_ tm)
-
-      (interface, msgs) <- {-# SCC createIterface #-}
-                          withTimingD "createInterface" (const ()) $ do
-                            runWriterGhc $ createInterface1 flags unit_state
-                              mod_summary tcg_gbl_env modMap instIfaceMap
-
-      -- We need to keep track of which modules were somehow in scope so that when
-      -- Haddock later looks for instances, it also looks in these modules too.
-      --
-      -- See https://github.com/haskell/haddock/issues/469.
-      hsc_env <- getSession
-      let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
-          home_unit = hsc_home_unit hsc_env
-          !mods = mkModuleSet [ nameModule name
-                              | gre <- globalRdrEnvElts new_rdr_env
-                              , let name = greMangledName gre
-                              , nameIsFromExternalPackage home_unit name
-                              , isTcOcc (nameOccName name)   -- Types and classes only
-                              , unQualOK gre ]               -- In scope unqualified
-
-      liftIO $ mapM_ putStrLn (nub msgs)
-      dflags <- getDynFlags
-      let (haddockable, haddocked) = ifaceHaddockCoverage interface
-          percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int
-          modString = moduleString (ifaceMod interface)
-          coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString
-          header = case ifaceDoc interface of
-            Documentation Nothing _ -> False
-            _ -> True
-          undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n
-                                                              , expItemMbDoc = (Documentation Nothing _, _)
-                                                              } <- ifaceExportItems interface ]
-            where
-              formatName :: SrcSpan -> HsDecl GhcRn -> String
-              formatName loc n = p (getMainDeclBinder n) ++ case loc of
-                RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")"
-                _ -> ""
-
-              p [] = ""
-              p (x:_) = let n = pretty dflags x
-                            ms = modString ++ "."
-                        in if ms `isPrefixOf` n
-                           then drop (length ms) n
-                           else n
-
-      when (OptHide `notElem` ifaceOptions interface) $ do
-        out verbosity normal coverageMsg
-        when (Flag_NoPrintMissingDocs `notElem` flags
-              && not (null undocumentedExports && header)) $ do
-          out verbosity normal "  Missing documentation for:"
-          unless header $ out verbosity normal "    Module header"
-          mapM_ (out verbosity normal . ("    " ++)) undocumentedExports
-      interface' <- liftIO $ evaluate interface
-      return (Just (interface', mods))
+        ifaces :: [Interface]
+        ifaces =
+          [ Map.findWithDefault
+              (error "haddock:iface")
+              (ms_mod (emsModSummary ems))
+              ifaceMap
+          | ModuleNode ems <- flattenSCCs $ topSortModuleGraph True modGraph Nothing
+          ]
+
+      return (ifaces, moduleSet)
+
+
+-- | A `Plugin` that hooks into GHC's compilation pipeline to generate Haddock
+-- interfaces. Due to the plugin nature we benefit from GHC's capabilities to
+-- parallelize the compilation process.
+plugin
+  :: MonadIO m
+  => Verbosity
+  -> [Flag]
+  -> InstIfaceMap
+  -> m
+     (
+       StaticPlugin -- the plugin to install with GHC
+     , m IfaceMap  -- get the processed interfaces
+     , m ModuleSet -- get the loaded modules
+     )
+plugin verbosity flags instIfaceMap = liftIO $ do
+  ifaceMapRef  <- newIORef Map.empty
+  moduleSetRef <- newIORef emptyModuleSet
+
+  let
+    processTypeCheckedResult :: ModSummary -> TcGblEnv -> Ghc ()
+    processTypeCheckedResult mod_summary tc_gbl_env
+      -- Don't do anything for hs-boot modules
+      | IsBoot <- isBootSummary mod_summary =
+          pure ()
+      | otherwise = do
+          ifaces <- liftIO $ readIORef ifaceMapRef
+          (iface, modules) <- withTimingD "processModule" (const ()) $
+            processModule1 verbosity flags ifaces instIfaceMap mod_summary tc_gbl_env
+
+          liftIO $ do
+            atomicModifyIORef' ifaceMapRef $ \xs ->
+              (Map.insert (ms_mod mod_summary) iface xs, ())
+
+            atomicModifyIORef' moduleSetRef $ \xs ->
+              (modules `unionModuleSet` xs, ())
+
+    staticPlugin :: StaticPlugin
+    staticPlugin = StaticPlugin
+      {
+        spPlugin = PluginWithArgs
+        {
+          paPlugin = defaultPlugin
+          {
+            renamedResultAction = keepRenamedSource
+          , typeCheckResultAction = \_ mod_summary tc_gbl_env -> do
+              session <- getTopEnv >>= liftIO . newIORef
+              liftIO $ reflectGhc
+                (processTypeCheckedResult mod_summary tc_gbl_env)
+                (Session session)
+              pure tc_gbl_env
+
+          }
+        , paArguments = []
+        }
+      }
+
+  pure
+    ( staticPlugin
+    , liftIO (readIORef ifaceMapRef)
+    , liftIO (readIORef moduleSetRef)
+    )
+
+
+
+processModule1
+  :: Verbosity
+  -> [Flag]
+  -> IfaceMap
+  -> InstIfaceMap
+  -> ModSummary
+  -> TcGblEnv
+  -> Ghc (Interface, ModuleSet)
+processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do
+  out verbosity verbose "Creating interface..."
+
+  let
+    TcGblEnv { tcg_rdr_env } = tc_gbl_env
+
+  unit_state <- hsc_units <$> getSession
+
+  (!interface, messages) <- {-# SCC createInterface #-}
+    withTimingD "createInterface" (const ()) $
+      runWriterGhc $ createInterface1 flags unit_state
+        mod_summary tc_gbl_env ifaces inst_ifaces
+
+  -- We need to keep track of which modules were somehow in scope so that when
+  -- Haddock later looks for instances, it also looks in these modules too.
+  --
+  -- See https://github.com/haskell/haddock/issues/469.
+  hsc_env <- getSession
+  let
+    mods :: ModuleSet
+    !mods = mkModuleSet
+      [ nameModule name
+      | gre <- globalRdrEnvElts tcg_rdr_env
+      , let name = greMangledName gre
+      , nameIsFromExternalPackage (hsc_home_unit hsc_env) name
+      , isTcOcc (nameOccName name)   -- Types and classes only
+      , unQualOK gre -- In scope unqualified
+      ]
+
+  liftIO $ mapM_ putStrLn (nub messages)
+  dflags <- getDynFlags
+
+  let
+    (haddockable, haddocked) =
+      ifaceHaddockCoverage interface
+
+    percentage :: Int
+    percentage =
+      round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double)
+
+    modString :: String
+    modString = moduleString (ifaceMod interface)
+
+    coverageMsg :: String
+    coverageMsg =
+      printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString
+
+    header :: Bool
+    header = case ifaceDoc interface of
+      Documentation Nothing _ -> False
+      _ -> True
+
+    undocumentedExports :: [String]
+    undocumentedExports =
+      [ formatName s n
+      | ExportDecl { expItemDecl = L s n
+                   , expItemMbDoc = (Documentation Nothing _, _)
+                   } <- ifaceExportItems interface
+      ]
+        where
+          formatName :: SrcSpan -> HsDecl GhcRn -> String
+          formatName loc n = p (getMainDeclBinder n) ++ case loc of
+            RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++
+              show (srcSpanStartLine rss) ++ ")"
+            _ -> ""
+
+          p :: Outputable a => [a] -> String
+          p [] = ""
+          p (x:_) = let n = pretty dflags x
+                        ms = modString ++ "."
+                    in if ms `isPrefixOf` n
+                       then drop (length ms) n
+                       else n
+
+  when (OptHide `notElem` ifaceOptions interface) $ do
+    out verbosity normal coverageMsg
+    when (Flag_NoPrintMissingDocs `notElem` flags
+          && not (null undocumentedExports && header)) $ do
+      out verbosity normal "  Missing documentation for:"
+      unless header $ out verbosity normal "    Module header"
+      mapM_ (out verbosity normal . ("    " ++)) undocumentedExports
+
+  pure (interface, mods)
 
 
 --------------------------------------------------------------------------------
@@ -249,4 +366,3 @@ buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
         mdl            = ifaceMod iface
         keep_old env n = Map.insertWith (\_ old -> old) n mdl env
         keep_new env n = Map.insert n mdl env
-
-- 
cgit v1.2.3


From e81e024703ed8bba3c45a679e08003ccba68e046 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alex@groundcloud.com>
Date: Sun, 27 Dec 2020 12:49:08 +0100
Subject: Add -j[n] CLI param to Haddock executable

It translates to `--ghcopt=-j[n]`
---
 haddock-api/src/Haddock.hs         | 7 ++++++-
 haddock-api/src/Haddock/Options.hs | 9 +++++++--
 2 files changed, 13 insertions(+), 3 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 3543d8e2..8bf932df 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -151,12 +151,17 @@ haddockWithGhc ghc args = handleTopExceptions $ do
   sinceQual <- rightOrThrowE (sinceQualification flags)
 
   -- inject dynamic-too into flags before we proceed
-  flags' <- ghc flags $ do
+  flags'' <- ghc flags $ do
         df <- getDynFlags
         case lookup "GHC Dynamic" (compilerInfo df) of
           Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags
           _ -> return flags
 
+  flags' <- pure $ case optParCount flags'' of
+    Nothing       -> flags''
+    Just Nothing  -> Flag_OptGhc "-j" : flags''
+    Just (Just n) -> Flag_OptGhc ("-j" ++ show n) : flags''
+
   -- bypass the interface version check
   let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
 
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index eda40935..65aacc61 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -24,6 +24,7 @@ module Haddock.Options (
   optSourceCssFile,
   sourceUrls,
   wikiUrls,
+  optParCount,
   optDumpInterfaceFile,
   optShowInterfaceFile,
   optLaTeXStyle,
@@ -110,6 +111,7 @@ data Flag
   | Flag_PackageVersion String
   | Flag_Reexport String
   | Flag_SinceQualification String
+  | Flag_ParCount (Maybe Int)
   deriving (Eq, Show)
 
 
@@ -221,7 +223,9 @@ options backwardsCompat =
     Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION")
       "version of the package being documented in usual x.y.z.w format",
     Option []  ["since-qual"] (ReqArg Flag_SinceQualification "QUAL")
-      "package qualification of @since, one of\n'always' (default) or 'only-external'"
+      "package qualification of @since, one of\n'always' (default) or 'only-external'",
+    Option ['j'] [] (OptArg (\count -> Flag_ParCount (fmap read count)) "n")
+      "load modules in parallel"
   ]
 
 
@@ -304,10 +308,11 @@ optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ]
 optLaTeXStyle :: [Flag] -> Maybe String
 optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
 
-
 optMathjax :: [Flag] -> Maybe String
 optMathjax flags = optLast [ str | Flag_Mathjax str <- flags ]
 
+optParCount :: [Flag] -> Maybe (Maybe Int)
+optParCount flags = optLast [ n | Flag_ParCount n <- flags ]
 
 qualification :: [Flag] -> Either String QualOption
 qualification flags =
-- 
cgit v1.2.3


From 703e5f0263dfc7c3173cf8ae1348c14902b9bcd7 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alex@groundcloud.com>
Date: Thu, 7 Jan 2021 23:40:56 +0100
Subject: Abstract Monad for interface creation

I found that when running as a plugin the lookupName function (which
runs in Ghc monad) does not work correctly from the
typeCheckResultAction hook.

Instead, we abstracted the monad used when creating interfaces, so
that access to GHC session specific parts is explicit and so that the
TcM can provide their (correct) implementation of lookupName.
---
 haddock-api/haddock-api.cabal                   |   1 +
 haddock-api/src/Haddock/Backends/LaTeX.hs       |   2 +-
 haddock-api/src/Haddock/GhcUtils.hs             |   9 -
 haddock-api/src/Haddock/Interface.hs            |  32 ++-
 haddock-api/src/Haddock/Interface/Create.hs     | 335 ++++++++++--------------
 haddock-api/src/Haddock/Interface/LexParseRn.hs |   3 +-
 haddock-api/src/Haddock/Interface/Rename.hs     |   1 -
 haddock-api/src/Haddock/InterfaceFile.hs        |   2 +-
 haddock-api/src/Haddock/Options.hs              |   3 +-
 haddock-api/src/Haddock/Types.hs                |  67 ++---
 10 files changed, 180 insertions(+), 275 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index cea9c4bd..87761ff8 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -61,6 +61,7 @@ library
                , exceptions
                , filepath
                , ghc-boot
+               , mtl
                , transformers
 
   hs-source-dirs: src
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 2ba0bf52..d95c86b2 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -39,7 +39,7 @@ import System.FilePath
 import Data.Char
 import Control.Monad
 import Data.Maybe
-import Data.List
+import Data.List (sort)
 import Prelude hiding ((<>))
 
 import Haddock.Doc (combineDocumentation)
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 452cb6f4..0a0211c9 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -34,7 +34,6 @@ import GHC.Driver.Ppr (showPpr )
 import GHC.Types.Name
 import GHC.Unit.Module
 import GHC
-import GHC.Core.Class
 import GHC.Driver.Session
 import GHC.Types.SrcLoc  ( advanceSrcLoc )
 import GHC.Types.Var     ( Specificity, VarBndr(..), TyVarBinder
@@ -403,14 +402,6 @@ modifySessionDynFlags f = do
   return ()
 
 
--- Extract the minimal complete definition of a Name, if one exists
-minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef)
-minimalDef n = do
-  mty <- lookupGlobalName n
-  case mty of
-    Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c
-    _ -> return Nothing
-
 -------------------------------------------------------------------------------
 -- * DynFlags
 -------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index 87ac4861..c557968f 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -61,8 +61,9 @@ import GHC hiding (verbosity)
 import GHC.Driver.Env
 import GHC.Driver.Monad (Session(..), modifySession, reflectGhc)
 import GHC.Data.FastString (unpackFS)
-import GHC.Tc.Types (TcGblEnv(..))
-import GHC.Tc.Utils.Monad (getTopEnv)
+import GHC.Tc.Types (TcM, TcGblEnv(..))
+import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv)
+import GHC.Tc.Utils.Env (tcLookupGlobal)
 import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)
 import GHC.Types.Name.Occurrence (isTcOcc)
 import GHC.Types.Name.Reader (unQualOK, greMangledName, globalRdrEnvElts)
@@ -202,15 +203,16 @@ plugin verbosity flags instIfaceMap = liftIO $ do
   moduleSetRef <- newIORef emptyModuleSet
 
   let
-    processTypeCheckedResult :: ModSummary -> TcGblEnv -> Ghc ()
+    processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM ()
     processTypeCheckedResult mod_summary tc_gbl_env
       -- Don't do anything for hs-boot modules
       | IsBoot <- isBootSummary mod_summary =
           pure ()
       | otherwise = do
+          hsc_env <- getTopEnv
           ifaces <- liftIO $ readIORef ifaceMapRef
           (iface, modules) <- withTimingD "processModule" (const ()) $
-            processModule1 verbosity flags ifaces instIfaceMap mod_summary tc_gbl_env
+            processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env
 
           liftIO $ do
             atomicModifyIORef' ifaceMapRef $ \xs ->
@@ -227,11 +229,8 @@ plugin verbosity flags instIfaceMap = liftIO $ do
           paPlugin = defaultPlugin
           {
             renamedResultAction = keepRenamedSource
-          , typeCheckResultAction = \_ mod_summary tc_gbl_env -> do
-              session <- getTopEnv >>= liftIO . newIORef
-              liftIO $ reflectGhc
-                (processTypeCheckedResult mod_summary tc_gbl_env)
-                (Session session)
+          , typeCheckResultAction = \_ mod_summary tc_gbl_env -> setGblEnv tc_gbl_env $ do
+              processTypeCheckedResult mod_summary tc_gbl_env
               pure tc_gbl_env
 
           }
@@ -246,33 +245,32 @@ plugin verbosity flags instIfaceMap = liftIO $ do
     )
 
 
-
 processModule1
   :: Verbosity
   -> [Flag]
   -> IfaceMap
   -> InstIfaceMap
+  -> HscEnv
   -> ModSummary
   -> TcGblEnv
-  -> Ghc (Interface, ModuleSet)
-processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do
+  -> TcM (Interface, ModuleSet)
+processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do
   out verbosity verbose "Creating interface..."
 
   let
     TcGblEnv { tcg_rdr_env } = tc_gbl_env
 
-  unit_state <- hsc_units <$> getSession
+    unit_state = hsc_units hsc_env
 
   (!interface, messages) <- {-# SCC createInterface #-}
-    withTimingD "createInterface" (const ()) $
-      runWriterGhc $ createInterface1 flags unit_state
-        mod_summary tc_gbl_env ifaces inst_ifaces
+    withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $
+      createInterface1 flags unit_state mod_summary tc_gbl_env
+        ifaces inst_ifaces
 
   -- We need to keep track of which modules were somehow in scope so that when
   -- Haddock later looks for instances, it also looks in these modules too.
   --
   -- See https://github.com/haskell/haddock/issues/469.
-  hsc_env <- getSession
   let
     mods :: ModuleSet
     !mods = mkModuleSet
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 8bf9d7d6..30fb8b7e 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1,6 +1,8 @@
-{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns #-}
+{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -Wwarn #-}
 -----------------------------------------------------------------------------
 -- |
@@ -18,43 +20,42 @@
 -- which creates a Haddock 'Interface' from the typechecking
 -- results 'TypecheckedModule' from GHC.
 -----------------------------------------------------------------------------
-module Haddock.Interface.Create (createInterface, createInterface1) where
+module Haddock.Interface.Create (IfM, runIfM, createInterface1) where
 
 import Documentation.Haddock.Doc (metaDocAppend)
-import Haddock.Types
+import Haddock.Types hiding (liftErrMsg)
 import Haddock.Options
 import Haddock.GhcUtils
 import Haddock.Utils
 import Haddock.Convert
 import Haddock.Interface.LexParseRn
 
-import Data.Bifunctor
+import Control.Monad.Reader
+import Control.Monad.Writer.Strict hiding (tell)
 import Data.Bitraversable
 import qualified Data.Map as M
 import Data.Map (Map)
 import Data.List
 import Data.Maybe
-import Control.Monad
 import Data.Traversable
 
 import GHC.Tc.Utils.Monad (finalSafeMode)
 import GHC.Types.Avail hiding (avail)
 import qualified GHC.Types.Avail  as Avail
 import qualified GHC.Unit.Module as Module
-import GHC.Unit.Module.ModDetails
 import GHC.Unit.Module.ModSummary
 import qualified GHC.Types.SrcLoc as SrcLoc
 import GHC.Types.SourceFile
+import GHC.Core.Class
 import GHC.Core.ConLike (ConLike(..))
-import GHC
+import GHC hiding (lookupName)
 import GHC.Driver.Ppr
-import GHC.Driver.Env
 import GHC.Types.Name
 import GHC.Types.Name.Set
 import GHC.Types.Name.Env
 import GHC.Unit.State
 import GHC.Types.Name.Reader
-import GHC.Tc.Types
+import GHC.Tc.Types hiding (IfM)
 import GHC.Data.FastString ( unpackFS, bytesFS )
 import GHC.Types.Basic ( PromotionFlag(..) )
 import GHC.Types.SourceText
@@ -65,14 +66,68 @@ import GHC.Parser.Annotation (IsUnicodeSyntax(..))
 import GHC.Unit.Module.Warnings
 
 
+newtype IfEnv m = IfEnv
+  {
+    -- | Lookup names in the enviroment.
+    ife_lookup_name :: Name -> m (Maybe TyThing)
+  }
+
+
+-- | A monad in which we create Haddock interfaces. Not to be confused with
+-- `GHC.Tc.Types.IfM` which is used to write GHC interfaces.
+--
+-- In the past `createInterface` was running in the `Ghc` monad but proved hard
+-- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting
+-- over the Ghc specific clarifies where side effects happen.
+newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT [ErrMsg] m) a }
+
+
+deriving newtype instance Functor m => Functor (IfM m)
+deriving newtype instance Applicative m => Applicative (IfM m)
+deriving newtype instance Monad m => Monad (IfM m)
+deriving newtype instance MonadIO m => MonadIO (IfM m)
+deriving newtype instance Monad m => MonadReader (IfEnv m) (IfM m)
+deriving newtype instance Monad m => MonadWriter [ErrMsg] (IfM m)
+
+
+-- | Run an `IfM` action.
+runIfM
+  -- | Lookup a global name in the current session. Used in cases
+  -- where declarations don't
+  :: (Name -> m (Maybe TyThing))
+  -- | The action to run.
+  -> IfM m a
+  -- | Result and accumulated error/warning messages.
+  -> m (a, [ErrMsg])
+runIfM lookup_name action = do
+  let
+    if_env = IfEnv
+      {
+        ife_lookup_name = lookup_name
+      }
+  runWriterT (runReaderT (unIfM action) if_env)
+
+
+liftErrMsg :: Monad m => ErrMsgM a -> IfM m a
+liftErrMsg action = do
+  writer (runWriter action)
+
+
+lookupName :: Monad m => Name -> IfM m (Maybe TyThing)
+lookupName name = IfM $ do
+  lookup_name <- asks ife_lookup_name
+  lift $ lift (lookup_name name)
+
+
 createInterface1
-  :: [Flag]
+  :: MonadIO m
+  => [Flag]
   -> UnitState
   -> ModSummary
   -> TcGblEnv
   -> IfaceMap
   -> InstIfaceMap
-  -> ErrMsgGhc Interface
+  -> IfM m Interface
 createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
 
   let
@@ -134,7 +189,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
 
   decls <- case tcg_rn_decls of
     Nothing -> do
-      liftErrMsg $ tell [ "Warning: Renamed source is not available" ]
+      tell [ "Warning: Renamed source is not available" ]
       pure []
     Just dx ->
       pure (topDecls dx)
@@ -250,142 +305,6 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do
     }
 
 
--- | Use a 'TypecheckedModule' to produce an 'Interface'.
--- To do this, we need access to already processed modules in the topological
--- sort. That's what's in the 'IfaceMap'.
-createInterface :: TypecheckedModule
-                -> UnitState
-                -> [Flag]       -- Boolean flags
-                -> IfaceMap     -- Locally processed modules
-                -> InstIfaceMap -- External, already installed interfaces
-                -> ErrMsgGhc Interface
-createInterface tm unit_state flags modMap instIfaceMap = do
-
-  let ms             = pm_mod_summary . tm_parsed_module $ tm
-      mi             = moduleInfo tm
-      L _ hsm        = parsedSource tm
-      !safety        = modInfoSafe mi
-      mdl            = ms_mod ms
-      sem_mdl        = tcg_semantic_mod (fst (tm_internals_ tm))
-      is_sig         = ms_hsc_src ms == HsigFile
-      dflags         = ms_hspp_opts ms
-      !instances     = modInfoInstances mi
-      !fam_instances = md_fam_insts md
-      !exportedNames = modInfoExportsWithSelectors mi
-      (pkgNameFS, _) = modulePackageInfo unit_state flags (Just mdl)
-      pkgName        = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS
-
-      (TcGblEnv { tcg_rdr_env = gre
-                , tcg_warns   = warnings
-                , tcg_exports = all_exports
-                }, md) = tm_internals_ tm
-
-  -- The 'pkgName' is necessary to decide what package to mention in "@since"
-  -- annotations. Not having it is not fatal though.
-  --
-  -- Cabal can be trusted to pass the right flags, so this warning should be
-  -- mostly encountered when running Haddock outside of Cabal.
-  when (isNothing pkgName) $
-    liftErrMsg $ tell [ "Warning: Package name is not available." ]
-
-  -- The renamed source should always be available to us, but it's best
-  -- to be on the safe side.
-  (group_, imports, mayExports, mayDocHeader) <-
-    case renamedSource tm of
-      Nothing -> do
-        liftErrMsg $ tell [ "Warning: Renamed source is not available." ]
-        return (emptyRnGroup, [], Nothing, Nothing)
-      Just x -> return x
-
-  opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
-
-  -- Process the top-level module header documentation.
-  (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags pkgName gre safety mayDocHeader
-
-  let declsWithDocs = topDecls group_
-
-      exports0 = fmap (map (first unLoc)) mayExports
-      exports
-        | OptIgnoreExports `elem` opts = Nothing
-        | otherwise = exports0
-
-      unrestrictedImportedMods
-        -- module re-exports are only possible with
-        -- explicit export list
-        | Just{} <- exports
-        = unrestrictedModuleImports (map unLoc imports)
-        | otherwise = M.empty
-
-      fixMap = mkFixMap group_
-      (decls, _) = unzip declsWithDocs
-      localInsts = filter (nameIsLocalOrFrom sem_mdl)
-                        $  map getName instances
-                        ++ map getName fam_instances
-      -- Locations of all TH splices
-      splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ]
-
-  warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames)
-
-  maps@(!docMap, !argMap, !declMap, _) <-
-    liftErrMsg (mkMaps dflags pkgName gre localInsts declsWithDocs)
-
-  let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
-
-  -- The MAIN functionality: compute the export items which will
-  -- each be the actual documentation of this module.
-  exportItems <- mkExportItems is_sig modMap pkgName mdl sem_mdl allWarnings gre
-                   exportedNames decls maps fixMap unrestrictedImportedMods
-                   splices exports all_exports instIfaceMap dflags
-
-  let !visibleNames = mkVisibleNames maps exportItems opts
-
-  -- Measure haddock documentation coverage.
-  let prunedExportItems0 = pruneExportItems exportItems
-      !haddockable = 1 + length exportItems -- module + exports
-      !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
-      !coverage = (haddockable, haddocked)
-
-  -- Prune the export list to just those declarations that have
-  -- documentation, if the 'prune' option is on.
-  let prunedExportItems'
-        | OptPrune `elem` opts = prunedExportItems0
-        | otherwise = exportItems
-      !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
-
-  let !aliases = mkAliasMap unit_state imports
-
-  modWarn <- liftErrMsg (moduleWarning dflags gre warnings)
-
-  return $! Interface {
-    ifaceMod               = mdl
-  , ifaceIsSig             = is_sig
-  , ifaceOrigFilename      = msHsFilePath ms
-  , ifaceInfo              = info
-  , ifaceDoc               = Documentation mbDoc modWarn
-  , ifaceRnDoc             = Documentation Nothing Nothing
-  , ifaceOptions           = opts
-  , ifaceDocMap            = docMap
-  , ifaceArgMap            = argMap
-  , ifaceRnDocMap          = M.empty
-  , ifaceRnArgMap          = M.empty
-  , ifaceExportItems       = prunedExportItems
-  , ifaceRnExportItems     = []
-  , ifaceExports           = exportedNames
-  , ifaceVisibleExports    = visibleNames
-  , ifaceDeclMap           = declMap
-  , ifaceFixMap            = fixMap
-  , ifaceModuleAliases     = aliases
-  , ifaceInstances         = instances
-  , ifaceFamInstances      = fam_instances
-  , ifaceOrphanInstances   = [] -- Filled in `attachInstances`
-  , ifaceRnOrphanInstances = [] -- Filled in `renameInterface`
-  , ifaceHaddockCoverage   = coverage
-  , ifaceWarningMap        = warningMap
-  , ifaceHieFile           = Just $ ml_hie_file $ ms_location ms
-  , ifaceDynFlags          = dflags
-  }
-
-
 -- | Given all of the @import M as N@ declarations in a package,
 -- create a mapping from the module identity of M, to an alias N
 -- (if there are multiple aliases, we pick the last one.)  This
@@ -640,7 +559,8 @@ mkFixMap group_ =
 -- We create the export items even if the module is hidden, since they
 -- might be useful when creating the export items for other modules.
 mkExportItems
-  :: Bool               -- is it a signature
+  :: Monad m
+  => Bool               -- is it a signature
   -> IfaceMap
   -> Maybe Package      -- this package
   -> Module             -- this module
@@ -657,7 +577,7 @@ mkExportItems
   -> Avails             -- exported stuff from this module
   -> InstIfaceMap
   -> DynFlags
-  -> ErrMsgGhc [ExportItem GhcRn]
+  -> IfM m [ExportItem GhcRn]
 mkExportItems
   is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls
   maps fixMap unrestricted_imp_mods splices exportList allExports
@@ -699,24 +619,39 @@ mkExportItems
       availExportItem is_sig modMap thisMod semMod warnings exportedNames
         maps fixMap splices instIfaceMap dflags avail
 
-availExportItem :: Bool               -- is it a signature
-                -> IfaceMap
-                -> Module             -- this module
-                -> Module             -- semantic module
-                -> WarningMap
-                -> [Name]             -- exported names (orig)
-                -> Maps
-                -> FixMap
-                -> [SrcSpan]          -- splice locations
-                -> InstIfaceMap
-                -> DynFlags
-                -> AvailInfo
-                -> ErrMsgGhc [ExportItem GhcRn]
+
+-- Extract the minimal complete definition of a Name, if one exists
+minimalDef :: Monad m => Name -> IfM m (Maybe ClassMinimalDef)
+minimalDef n = do
+  mty <- lookupName n
+  case mty of
+    Just (ATyCon (tyConClass_maybe -> Just c)) ->
+      return . Just $ classMinimalDef c
+    _ ->
+      return Nothing
+
+
+availExportItem
+  :: forall m
+  .  Monad m
+  => Bool               -- is it a signature
+  -> IfaceMap
+  -> Module             -- this module
+  -> Module             -- semantic module
+  -> WarningMap
+  -> [Name]             -- exported names (orig)
+  -> Maps
+  -> FixMap
+  -> [SrcSpan]          -- splice locations
+  -> InstIfaceMap
+  -> DynFlags
+  -> AvailInfo
+  -> IfM m [ExportItem GhcRn]
 availExportItem is_sig modMap thisMod semMod warnings exportedNames
   (docMap, argMap, declMap, _) fixMap splices instIfaceMap
   dflags availInfo = declWith availInfo
   where
-    declWith :: AvailInfo -> ErrMsgGhc [ ExportItem GhcRn ]
+    declWith :: AvailInfo -> IfM m [ ExportItem GhcRn ]
     declWith avail = do
       let t = availName avail
       r    <- findDecl avail
@@ -753,7 +688,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
                     in availExportDecl avail newDecl docs_
 
                   L loc (TyClD _ cl@ClassDecl{}) -> do
-                    mdef <- liftGhcToErrMsgGhc $ minimalDef t
+                    mdef <- minimalDef t
                     let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef
                     availExportDecl avail
                       (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_
@@ -783,7 +718,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
 
     availExportDecl :: AvailInfo -> LHsDecl GhcRn
                     -> (DocForDecl Name, [(Name, DocForDecl Name)])
-                    -> ErrMsgGhc [ ExportItem GhcRn ]
+                    -> IfM m [ ExportItem GhcRn ]
     availExportDecl avail decl (doc, subs)
       | availExportsDecl avail = do
           -- bundled pattern synonyms only make sense if the declaration is
@@ -828,7 +763,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
     exportedNameSet = mkNameSet exportedNames
     isExported n = elemNameSet n exportedNameSet
 
-    findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))
+    findDecl :: AvailInfo -> IfM m ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))
     findDecl avail
       | m == semMod =
           case M.lookup n declMap of
@@ -857,10 +792,10 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
         n = availName avail
         m = nameModule n
 
-    findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)]
+    findBundledPatterns :: AvailInfo -> IfM m [(HsDecl GhcRn, DocForDecl Name)]
     findBundledPatterns avail = do
       patsyns <- for constructor_names $ \name -> do
-        mtyThing <- liftGhcToErrMsgGhc (lookupName name)
+        mtyThing <- lookupName name
         case mtyThing of
           Just (AConLike PatSynCon{}) -> do
             export_items <- declWith (Avail.avail name)
@@ -890,9 +825,9 @@ semToIdMod this_uid m
     | Module.isHoleModule m = mkModule this_uid (moduleName m)
     | otherwise             = m
 
-hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn))
+hiDecl :: Monad m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn))
 hiDecl dflags t = do
-  mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
+  mayTyThing <- lookupName t
   case mayTyThing of
     Nothing -> do
       liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
@@ -911,8 +846,9 @@ hiDecl dflags t = do
 -- It gets the type signature from GHC and that means it's not going to
 -- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the
 -- declaration and use it instead - 'nLoc' here.
-hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
-                -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn)
+hiValExportItem
+  :: Monad m => DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool
+  -> Maybe Fixity -> IfM m (ExportItem GhcRn)
 hiValExportItem dflags name nLoc doc splice fixity = do
   mayDecl <- hiDecl dflags name
   case mayDecl of
@@ -942,12 +878,14 @@ lookupDocs avail warnings docMap argMap =
 
 -- | Export the given module as `ExportModule`. We are not concerned with the
 -- single export items of the given module.
-moduleExport :: Module           -- ^ Module A (identity, NOT semantic)
-             -> DynFlags         -- ^ The flags used when typechecking A
-             -> IfaceMap         -- ^ Already created interfaces
-             -> InstIfaceMap     -- ^ Interfaces in other packages
-             -> ModuleName       -- ^ The exported module
-             -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items
+moduleExport
+  :: Monad m
+  => Module           -- ^ Module A (identity, NOT semantic)
+  -> DynFlags         -- ^ The flags used when typechecking A
+  -> IfaceMap         -- ^ Already created interfaces
+  -> InstIfaceMap     -- ^ Interfaces in other packages
+  -> ModuleName       -- ^ The exported module
+  -> IfM m [ExportItem GhcRn] -- ^ Resulting export items
 moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
     -- NB: we constructed the identity module when looking up in
     -- the IfaceMap.
@@ -961,9 +899,8 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
         case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of
           Just iface -> return [ ExportModule (instMod iface) ]
           Nothing -> do
-            liftErrMsg $
-              tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
-                    "documentation for exported module: " ++ pretty dflags expMod]
+            liftErrMsg $ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
+                               "documentation for exported module: " ++ pretty dflags expMod]
             return []
   where
     m = mkModule (moduleUnit thisMod) expMod -- Identity module!
@@ -989,22 +926,24 @@ moduleExport thisMod dflags ifaceMap instIfaceMap expMod =
 -- every locally defined declaration is exported; thus, we just
 -- zip through the renamed declarations.
 
-fullModuleContents :: Bool               -- is it a signature
-                   -> IfaceMap
-                   -> Maybe Package      -- this package
-                   -> Module             -- this module
-                   -> Module             -- semantic module
-                   -> WarningMap
-                   -> GlobalRdrEnv      -- ^ The renaming environment
-                   -> [Name]             -- exported names (orig)
-                   -> [LHsDecl GhcRn]    -- renamed source declarations
-                   -> Maps
-                   -> FixMap
-                   -> [SrcSpan]          -- splice locations
-                   -> InstIfaceMap
-                   -> DynFlags
-                   -> Avails
-                   -> ErrMsgGhc [ExportItem GhcRn]
+fullModuleContents
+  :: Monad m
+  => Bool               -- is it a signature
+  -> IfaceMap
+  -> Maybe Package      -- this package
+  -> Module             -- this module
+  -> Module             -- semantic module
+  -> WarningMap
+  -> GlobalRdrEnv      -- ^ The renaming environment
+  -> [Name]             -- exported names (orig)
+  -> [LHsDecl GhcRn]    -- renamed source declarations
+  -> Maps
+  -> FixMap
+  -> [SrcSpan]          -- splice locations
+  -> InstIfaceMap
+  -> DynFlags
+  -> Avails
+  -> IfM m [ExportItem GhcRn]
 fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames
   decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do
   let availEnv = availsToNameEnv (nubAvails avails)
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 44c02875..87064a0f 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -Wwarn #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ViewPatterns #-}
   -----------------------------------------------------------------------------
 -- |
@@ -22,7 +23,7 @@ module Haddock.Interface.LexParseRn
 import GHC.Types.Avail
 import Control.Arrow
 import Control.Monad
-import Data.List
+import Data.List ((\\), maximumBy)
 import Data.Ord
 import Documentation.Haddock.Doc (metaDocConcat)
 import GHC.Driver.Session (languageExtensions)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index bfbdf392..14032d15 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -29,7 +29,6 @@ import GHC.Builtin.Types (eqTyCon_RDR)
 import Control.Applicative
 import Control.Arrow ( first )
 import Control.Monad hiding (mapM)
-import Data.List
 import qualified Data.Map as Map hiding ( Map )
 import Prelude hiding (mapM)
 import GHC.HsToCore.Docs
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 72fcb79b..4455f0f8 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -27,7 +27,7 @@ import Haddock.Utils hiding (out)
 import Control.Monad
 import Data.Array
 import Data.IORef
-import Data.List
+import Data.List (mapAccumR)
 import qualified Data.Map as Map
 import Data.Map (Map)
 import Data.Word
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 65aacc61..04189b99 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -46,11 +46,10 @@ import           Data.Version
 import           Control.Applicative
 import           Distribution.Verbosity
 import           GHC.Data.FastString
-import           GHC ( DynFlags, Module, moduleUnit )
+import           GHC ( Module, moduleUnit )
 import           GHC.Unit.State
 import           Haddock.Types
 import           Haddock.Utils
-import           GHC.Unit.State
 import           System.Console.GetOpt
 import qualified Text.ParserCombinators.ReadP as RP
 
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 53a91cf5..32f14f74 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -3,6 +3,9 @@
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -----------------------------------------------------------------------------
@@ -25,13 +28,16 @@ module Haddock.Types (
   , HsDocString, LHsDocString
   , Fixity(..)
   , module Documentation.Haddock.Types
+
+  -- $ Reexports
+  , runWriter
+  , tell
  ) where
 
 import Control.Exception
-import Control.Arrow hiding ((<+>))
 import Control.DeepSeq
-import Control.Monad (ap)
 import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Writer.Strict (Writer, WriterT, MonadWriter(..), lift, runWriter, runWriterT)
 import Data.Typeable (Typeable)
 import Data.Map (Map)
 import Data.Data (Data)
@@ -595,26 +601,7 @@ data SinceQual
 
 
 type ErrMsg = String
-newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) }
-
-
-instance Functor ErrMsgM where
-        fmap f (Writer (a, msgs)) = Writer (f a, msgs)
-
-instance Applicative ErrMsgM where
-    pure a = Writer (a, [])
-    (<*>)  = ap
-
-instance Monad ErrMsgM where
-        return   = pure
-        m >>= k  = Writer $ let
-                (a, w)  = runWriter m
-                (b, w') = runWriter (k a)
-                in (b, w ++ w')
-
-
-tell :: [ErrMsg] -> ErrMsgM ()
-tell w = Writer ((), w)
+type ErrMsgM = Writer [ErrMsg]
 
 
 -- Exceptions
@@ -637,34 +624,24 @@ throwE str = throw (HaddockException str)
 -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
 -- but we can't just use @GhcT ErrMsgM@ because GhcT requires the
 -- transformed monad to be MonadIO.
-newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) }
---instance MonadIO ErrMsgGhc where
---  liftIO = WriterGhc . fmap (\a->(a,[])) liftIO
---er, implementing GhcMonad involves annoying ExceptionMonad and
---WarnLogMonad classes, so don't bother.
-liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
-liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[]))
-liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
-liftErrMsg = WriterGhc . return . runWriter
---  for now, use (liftErrMsg . tell) for this
---tell :: [ErrMsg] -> ErrMsgGhc ()
---tell msgs = WriterGhc $ return ( (), msgs )
+newtype ErrMsgGhc a = ErrMsgGhc { unErrMsgGhc :: WriterT [ErrMsg] Ghc a }
 
 
-instance Functor ErrMsgGhc where
-  fmap f (WriterGhc x) = WriterGhc (fmap (first f) x)
+deriving newtype instance Functor ErrMsgGhc
+deriving newtype instance Applicative ErrMsgGhc
+deriving newtype instance Monad ErrMsgGhc
+deriving newtype instance (MonadWriter [ErrMsg]) ErrMsgGhc
+deriving newtype instance MonadIO ErrMsgGhc
 
-instance Applicative ErrMsgGhc where
-    pure a = WriterGhc (return (a, []))
-    (<*>) = ap
 
-instance Monad ErrMsgGhc where
-  return = pure
-  m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->
-               fmap (second (msgs1 ++)) (runWriterGhc (k a))
+runWriterGhc :: ErrMsgGhc a -> Ghc (a, [ErrMsg])
+runWriterGhc = runWriterT . unErrMsgGhc
 
-instance MonadIO ErrMsgGhc where
-  liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m))
+liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
+liftGhcToErrMsgGhc = ErrMsgGhc . lift
+
+liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
+liftErrMsg = writer . runWriter
 
 -----------------------------------------------------------------------------
 -- * Pass sensitive types
-- 
cgit v1.2.3


From 0952d94a2e30a3e7cddbede811b15fa70f7b9462 Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Tue, 19 Jan 2021 11:39:38 +0100
Subject: Make haddock more robust to changes to the `Language` data type

With the introduction of GHC2021, the `Languages` data type in GHC will
grow. In preparation of that (and to avoid changing haddock with each
new language), this change makes the code handle extensions to that data
type gracefully.

(cherry picked from commit c341dd7c9c3fc5ebc83a2d577c5a726f3eb152a5)
---
 haddock-api/src/Haddock/Backends/Xhtml.hs | 5 +----
 1 file changed, 1 insertion(+), 4 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 24b565fc..3453bb0c 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -223,10 +223,7 @@ moduleInfo iface =
           ("Language", lg)
           ] ++ extsForm
         where
-          lg inf = case hmi_language inf of
-            Nothing -> Nothing
-            Just Haskell98 -> Just "Haskell98"
-            Just Haskell2010 -> Just "Haskell2010"
+          lg inf = fmap show (hmi_language inf)
 
           multilineRow :: String -> [String] -> HtmlTable
           multilineRow title xs = (th ! [valign "top"]) << title <-> td << (toLines xs)
-- 
cgit v1.2.3


From 7a79b5b7061333868bee5a3273fea5f47fe03350 Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Sun, 10 Jan 2021 19:41:22 +0000
Subject: Add `NoGhcTc` instance now that it's not closed

---
 haddock-api/src/Haddock/Types.hs | 2 ++
 1 file changed, 2 insertions(+)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index bb76a1e9..74a17fbb 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -304,6 +304,8 @@ data DocName
 
 data DocNameI
 
+type instance NoGhcTc DocNameI = DocNameI
+
 type instance IdP DocNameI = DocName
 
 instance CollectPass DocNameI where
-- 
cgit v1.2.3


From a917dfd29f3103b69378138477514cbfa38558a9 Mon Sep 17 00:00:00 2001
From: Alfredo Di Napoli <alfredo@well-typed.com>
Date: Tue, 19 Jan 2021 08:00:40 +0100
Subject: Rename pprLogErrMsg to new name

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index cae00dd6..5c2bdd4e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -12,7 +12,7 @@ import qualified Data.ByteString as BS
 
 import GHC.Types.SourceText
 import GHC.Driver.Session
-import GHC.Utils.Error     ( pprLocErrMsg )
+import GHC.Utils.Error     ( pprLocMsgEnvelope )
 import GHC.Data.FastString ( mkFastString )
 import GHC.Parser.Errors.Ppr ( pprError )
 import GHC.Parser.Lexer    as Lexer
@@ -43,7 +43,7 @@ parse dflags fpath bs = case unP (go False []) initState of
     PFailed pst ->
       let err:_ = bagToList (fmap pprError (getErrorMessages pst)) in
       panic $ showSDoc dflags $
-        text "Hyperlinker parse error:" $$ pprLocErrMsg err
+        text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err
   where
 
     initState = initParserState pflags buf start
-- 
cgit v1.2.3


From f311442cb18c1b380d342f4894f274a346bcb26c Mon Sep 17 00:00:00 2001
From: Daniel Rogozin <daniel.rogozin@serokell.io>
Date: Fri, 14 Aug 2020 14:59:57 +0300
Subject: type level characters support for haddock (required for #11342)

---
 haddock-api/src/Haddock/Backends/LaTeX.hs      | 1 +
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 +
 haddock-api/src/Haddock/Convert.hs             | 1 +
 3 files changed, 3 insertions(+)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index d95c86b2..03c1209a 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1124,6 +1124,7 @@ ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)
 ppr_tylit :: HsTyLit -> Bool -> LaTeX
 ppr_tylit (HsNumTy _ n) _ = integer n
 ppr_tylit (HsStrTy _ s) _ = text (show s)
+ppr_tylit (HsCharTy _ c) _ = text (show c)
   -- XXX: Ok in verbatim, but not otherwise
   -- XXX: Do something with Unicode parameter?
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index cb5417b5..6a879a0d 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1285,3 +1285,4 @@ ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n
 ppr_tylit :: HsTyLit -> Html
 ppr_tylit (HsNumTy _ n) = toHtml (show n)
 ppr_tylit (HsStrTy _ s) = toHtml (show s)
+ppr_tylit (HsCharTy _ c) = toHtml (show c)
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index b59602b6..b866218f 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -811,6 +811,7 @@ synifyPatSynType ps =
 synifyTyLit :: TyLit -> HsTyLit
 synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n
 synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
+synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c
 
 synifyKindSig :: Kind -> LHsKind GhcRn
 synifyKindSig k = synifyType WithinType [] k
-- 
cgit v1.2.3


From df96565cf1c6b7468f58d9173bbbcbefb7445b08 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Sat, 6 Feb 2021 11:39:30 -0500
Subject: Fix partial record selector warning

---
 haddock-api/src/Haddock/Interface/Create.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 272b8f02..72f1ab62 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables, RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE DerivingStrategies #-}
@@ -687,11 +687,11 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
                     let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig
                     in availExportDecl avail newDecl docs_
 
-                  L loc (TyClD _ cl@ClassDecl{}) -> do
+                  L loc (TyClD _ ClassDecl {..}) -> do
                     mdef <- minimalDef t
                     let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef
                     availExportDecl avail
-                      (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_
+                      (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_
 
                   _ -> availExportDecl avail decl docs_
 
-- 
cgit v1.2.3