From 8241d9e700e043b86b609c334494c4632848389f Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Mon, 22 Feb 2021 20:04:24 +0000
Subject: Context becomes a Maybe in the GHC AST

This prevents noLoc's appearing in the ParsedSource.

Match the change in GHC.
---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 24 +++++++++++++-----------
 1 file changed, 13 insertions(+), 11 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Xhtml')

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index de37e42a..e48f9bdd 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -37,7 +37,7 @@ import           Text.XHtml hiding     ( name, title, p, quote )
 
 import GHC.Core.Type ( Specificity(..) )
 import GHC.Types.Basic (PromotionFlag(..), isPromoted)
-import GHC hiding (LexicalFixity(..))
+import GHC hiding (LexicalFixity(..), fromMaybeContext)
 import GHC.Exts
 import GHC.Types.Name
 import GHC.Data.BooleanFormula
@@ -167,7 +167,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep
         leader' = leader <+> ppForAllPart unicode qual tele
 
     do_args n leader (HsQualTy _ lctxt ltype)
-      | null (unLoc lctxt)
+      | null (fromMaybeContext lctxt)
       = do_largs n leader ltype
       | otherwise
       = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
@@ -435,10 +435,12 @@ ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)
 -------------------------------------------------------------------------------
 
 
-ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode
+ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Unicode
                               -> Qualification -> HideEmptyContexts -> Html
-ppLContext        = ppContext        . unLoc
-ppLContextNoArrow = ppContextNoArrow . unLoc
+ppLContext        Nothing  u q h = ppContext        []        u q h
+ppLContext        (Just c) u q h = ppContext        (unLoc c) u q h
+ppLContextNoArrow Nothing  u q h = ppContextNoArrow []        u q h
+ppLContextNoArrow (Just c) u q h = ppContextNoArrow (unLoc c) u q h
 
 ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
 ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $
@@ -472,12 +474,12 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyCont
 -------------------------------------------------------------------------------
 
 
-ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName
+ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName
            -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]
            -> Unicode -> Qualification -> Html
 ppClassHdr summ lctxt n tvs fds unicode qual =
   keyword "class"
-  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)
+  <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)
   <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs)
   <+> ppFds fds unicode qual
 
@@ -855,7 +857,7 @@ ppShortConstrParts summary dataInst con unicode qual
                 , con_ex_tvs = tyVars
                 , con_forall = L _ forall_
                 , con_mb_cxt = cxt
-                } -> let context = unLoc (fromMaybe (noLoc []) cxt)
+                } -> let context = fromMaybeContext cxt
                          header_ = ppConstrHdr forall_ tyVars context unicode qual
                      in case det of
 
@@ -927,7 +929,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
                 , con_ex_tvs = tyVars
                 , con_forall = L _ forall_
                 , con_mb_cxt = cxt
-                } -> let context = unLoc (fromMaybe (noLoc []) cxt)
+                } -> let context = fromMaybeContext cxt
                          header_ = ppConstrHdr forall_ tyVars context unicode qual
                      in case det of
         -- Prefix constructor, e.g. 'Just a'
@@ -1181,13 +1183,13 @@ patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  Sho
     hasNonEmptyContext t =
       case unLoc t of
         HsForAllTy _ _ s -> hasNonEmptyContext s
-        HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
+        HsQualTy _ cxt s -> if null (fromMaybeContext cxt) then hasNonEmptyContext s else True
         HsFunTy _ _ _ s    -> hasNonEmptyContext s
         _ -> False
     isFirstContextEmpty t =
       case unLoc t of
         HsForAllTy _ _ s -> isFirstContextEmpty s
-        HsQualTy _ cxt _ -> null (unLoc cxt)
+        HsQualTy _ cxt _ -> null (fromMaybeContext cxt)
         HsFunTy _ _ _ s    -> isFirstContextEmpty s
         _ -> False
 
-- 
cgit v1.2.3