Context becomes a Maybe in the GHC AST

This prevents noLoc's appearing in the ParsedSource.

Match the change in GHC.

8 files changed, 49 insertions, 34 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index f7e1c77b..1a0cccf7 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -281,7 +281,7 @@ ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names
         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 })
+            Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })
             Nothing -> tau_ty
           tau_ty = foldr mkFunTy res_ty $
             case args of PrefixConGADT pos_args -> map hsScaledThing pos_args
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index df1f94e6..e2e16947 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -25,7 +25,7 @@ import GHC.Utils.Ppr hiding (Doc, quote)
 import qualified GHC.Utils.Ppr as Pretty
 
 import GHC.Types.Basic        ( PromotionFlag(..) )
-import GHC
+import GHC hiding (fromMaybeContext )
 import GHC.Types.Name.Occurrence
 import GHC.Types.Name        ( nameOccName )
 import GHC.Types.Name.Reader ( rdrNameOcc )
@@ -597,12 +597,12 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
 -------------------------------------------------------------------------------
 
 
-ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName
+ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName
            -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]
            -> Bool -> LaTeX
 ppClassHdr summ lctxt n tvs fds unicode =
   keyword "class"
-  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)
+  <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode else empty)
   <+> ppAppDocNameNames summ n (tyvarNames tvs)
   <+> ppFds fds unicode
 
@@ -806,7 +806,7 @@ ppSideBySideConstr subdocs unicode leader (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
                      in case det of
         -- Prefix constructor, e.g. 'Just a'
@@ -980,9 +980,11 @@ ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
 -------------------------------------------------------------------------------
 
 
-ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Bool -> LaTeX
-ppLContext        = ppContext        . unLoc
-ppLContextNoArrow = ppContextNoArrow . unLoc
+ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX
+ppLContext        Nothing _ = empty
+ppLContext        (Just ctxt) unicode  = ppContext        (unLoc ctxt) unicode
+ppLContextNoArrow Nothing _ = empty
+ppLContextNoArrow (Just ctxt) unicode = ppContextNoArrow (unLoc ctxt) unicode
 
 ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX
 ppContextNoLocsMaybe [] _ = Nothing
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
 
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 10e13152..83711414 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -215,7 +215,7 @@ synifyTyCon prr _coax tc
            , tcdDataDefn = HsDataDefn { dd_ext = noExtField
                                       , dd_ND = DataType  -- arbitrary lie, they are neither
                                                     -- algebraic data nor newtype:
-                                      , dd_ctxt = noLoc []
+                                      , dd_ctxt = Nothing
                                       , dd_cType = Nothing
                                       , dd_kindSig = synifyDataTyConReturnKind tc
                                                -- we have their kind accurately:
@@ -377,7 +377,7 @@ synifyDataCon use_gadt_syntax dc =
 
   -- skip any EqTheta, use 'orig'inal syntax
   ctx | null theta = Nothing
-      | otherwise = Just $ synifyCtx theta
+      | otherwise = synifyCtx theta
 
   linear_tys =
     zipWith (\ty bang ->
@@ -461,8 +461,8 @@ synifyTcIdSig vs (i, dm) =
     mainSig t = synifySigType DeleteTopLevelQuantification vs t
     defSig t = synifySigType ImplicitizeForAll vs t
 
-synifyCtx :: [PredType] -> LHsContext GhcRn
-synifyCtx = noLoc . map (synifyType WithinType [])
+synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn)
+synifyCtx ts = Just (noLoc ( map (synifyType WithinType []) ts))
 
 
 synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 546e2941..6e21e094 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -24,7 +24,7 @@ module Haddock.GhcUtils where
 
 import Control.Arrow
 import Data.Char ( isSpace )
-import Data.Maybe ( mapMaybe )
+import Data.Maybe ( mapMaybe, fromMaybe )
 
 import Haddock.Types( DocName, DocNameI )
 
@@ -172,7 +172,7 @@ getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs
                 , sig_body  = theta_ty })
  where
    theta_ty | Just theta <- mcxt
-            = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
+            = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })
             | otherwise
             = tau_ty
 
@@ -226,10 +226,12 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
                          , hst_ctxt = add_ctxt ctxt, hst_body = ty })
     go_ty (L loc ty)
        = L loc (HsQualTy { hst_xqual = noExtField
-                         , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })
+                         , hst_ctxt = add_ctxt Nothing, hst_body = L loc ty })
 
     extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)
-    add_ctxt (L loc preds) = L loc (extra_pred : preds)
+
+    add_ctxt Nothing              = Just $ noLoc [extra_pred]
+    add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds)
 
 addClassContext _ _ sig = sig   -- E.g. a MinimalSig is fine
 
@@ -355,7 +357,9 @@ reparenTypePrec = go
   go p (HsQualTy x ctxt ty)
     = let p' [_] = PREC_CTX
           p' _   = PREC_TOP -- parens will get added anyways later...
-          ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt
+          ctxt' = case ctxt of
+            Nothing -> Nothing
+            Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c
       in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty)
   go p (HsFunTy x w ty1 ty2)
     = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)
@@ -758,3 +762,5 @@ defaultRuntimeRepVars = go emptyVarEnv
     go _ ty@(LitTy {}) = ty
     go _ ty@(CoercionTy {}) = ty
 
+fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI
+fromMaybeContext mctxt = unLoc $ fromMaybe (noLoc []) mctxt
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 9a773b6c..4357cb79 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -1098,9 +1098,9 @@ extractPatternSyn nm t tvs cons =
         typ = longArrow args (data_ty con)
         typ' =
           case con of
-            ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ)
+            ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField (Just cxt) typ)
             _ -> typ
-        typ'' = noLoc (HsQualTy noExtField (noLoc []) typ')
+        typ'' = noLoc (HsQualTy noExtField Nothing typ')
     in PatSynSig noExtField [noLoc nm] (mkEmptySigType typ'')
 
   longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index b212adce..b62f79ce 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -258,7 +258,7 @@ renameType t = case t of
                        , hst_tele = tele', hst_body = ltype' })
 
   HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
-    lcontext' <- renameLContext lcontext
+    lcontext' <- traverse renameLContext lcontext
     ltype'    <- renameLType ltype
     return (HsQualTy { hst_xqual = noExtField, hst_ctxt = lcontext', hst_body = ltype' })
 
@@ -432,7 +432,7 @@ renameTyClD d = case d of
 
   ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity
             , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
-    lcontext' <- renameLContext lcontext
+    lcontext' <- traverse renameLContext lcontext
     lname'    <- renameL lname
     ltyvars'  <- renameLHsQTyVars ltyvars
     lfundeps' <- mapM renameLFunDep lfundeps
@@ -490,7 +490,7 @@ renameFamilyInfo (ClosedTypeFamily eqns)
 renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI)
 renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
                            , dd_kindSig = k, dd_cons = cons }) = do
-    lcontext' <- renameLContext lcontext
+    lcontext' <- traverse renameLContext lcontext
     k'        <- renameMaybeLKind k
     cons'     <- mapM (mapM renameCon) cons
     -- I don't think we need the derivings, so we return Nothing
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index f37e1da9..5ef5d92d 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -284,7 +284,7 @@ renameType (HsForAllTy x tele lt) =
         <*> renameLType lt
 renameType (HsQualTy x lctxt lt) =
     HsQualTy x
-        <$> located renameContext lctxt
+        <$> renameMContext lctxt
         <*> renameLType lt
 renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name
 renameType t@(HsStarTy _ _) = pure t
@@ -325,6 +325,11 @@ renameLKind = renameLType
 renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
 renameLTypes = mapM renameLType
 
+renameMContext :: Maybe (LHsContext GhcRn) -> Rename (IdP GhcRn) (Maybe (LHsContext GhcRn))
+renameMContext Nothing = return Nothing
+renameMContext (Just (L l ctxt)) = do
+  ctxt' <- renameContext ctxt
+  return (Just (L l ctxt'))
 
 renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
 renameContext = renameLTypes