Match changes in GHC AST for in-tree API Annotations

As landed via https://gitlab.haskell.org/ghc/ghc/-/merge_requests/2418

1 files changed, 38 insertions, 46 deletions

diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index 41801710..b8db6dfd 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -26,7 +26,7 @@ import Control.Arrow
 import Data.Char ( isSpace )
 import Data.Maybe ( mapMaybe, fromMaybe )
 
-import Haddock.Types( DocName, DocNameI )
+import Haddock.Types( DocName, DocNameI, XRecCond )
 
 import GHC.Utils.FV as FV
 import GHC.Utils.Outputable ( Outputable )
@@ -44,7 +44,6 @@ 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.Parser.Annotation (IsUnicodeSyntax(..))
 import GHC.Builtin.Types( liftedRepTy )
 
 import           GHC.Data.StringBuffer ( StringBuffer )
@@ -75,20 +74,20 @@ filterSigNames p orig@(InlineSig _ n _)          = ifTrueJust (p $ unLoc n) orig
 filterSigNames p (FixSig _ (FixitySig _ ns ty)) =
   case filter (p . unLoc) ns of
     []       -> Nothing
-    filtered -> Just (FixSig noExtField (FixitySig noExtField filtered ty))
+    filtered -> Just (FixSig noAnn (FixitySig noExtField filtered ty))
 filterSigNames _ orig@(MinimalSig _ _ _)      = Just orig
 filterSigNames p (TypeSig _ ns ty) =
   case filter (p . unLoc) ns of
     []       -> Nothing
-    filtered -> Just (TypeSig noExtField filtered ty)
+    filtered -> Just (TypeSig noAnn filtered ty)
 filterSigNames p (ClassOpSig _ is_default ns ty) =
   case filter (p . unLoc) ns of
     []       -> Nothing
-    filtered -> Just (ClassOpSig noExtField is_default filtered ty)
+    filtered -> Just (ClassOpSig noAnn is_default filtered ty)
 filterSigNames p (PatSynSig _ ns ty) =
   case filter (p . unLoc) ns of
     []       -> Nothing
-    filtered -> Just (PatSynSig noExtField filtered ty)
+    filtered -> Just (PatSynSig noAnn filtered ty)
 filterSigNames _ _                             = Nothing
 
 ifTrueJust :: Bool -> name -> Maybe name
@@ -127,7 +126,7 @@ hsTyVarNameI (KindedTyVar _ _ (L _ n) _) = n
 hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName
 hsLTyVarNameI = hsTyVarNameI . unLoc
 
-getConNamesI :: ConDecl DocNameI -> [Located DocName]
+getConNamesI :: ConDecl DocNameI -> [LocatedN DocName]
 getConNamesI ConDeclH98  {con_name  = name}  = [name]
 getConNamesI ConDeclGADT {con_names = names} = names
 
@@ -167,21 +166,22 @@ getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI
 getGADTConType (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 })
+ = noLocA (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 = Just theta, hst_body = tau_ty })
+            = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = Just 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
+              RecConGADT flds -> mkFunTy (noLocA (HsRecTy noAnn (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)
+   mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI
+   mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)
 
 getGADTConType (ConDeclH98 {}) = panic "getGADTConType"
   -- Should only be called on ConDeclGADT
@@ -197,10 +197,10 @@ getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
 getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = []
 getMainDeclBinderI _ = []
 
-familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName
+familyDeclLNameI :: FamilyDecl DocNameI -> LocatedN DocName
 familyDeclLNameI (FamilyDecl { fdLName = n }) = n
 
-tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName
+tyClDeclLNameI :: TyClDecl DocNameI -> LocatedN DocName
 tyClDeclLNameI (FamDecl { tcdFam = fd })     = familyDeclLNameI fd
 tyClDeclLNameI (SynDecl { tcdLName = ln })   = ln
 tyClDeclLNameI (DataDecl { tcdLName = ln })  = ln
@@ -212,7 +212,7 @@ tcdNameI = unLoc . tyClDeclLNameI
 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 (mkEmptyWildCardBndrs (go_sig_ty ltype)))
+  = L pos (TypeSig noAnn lname (mkEmptyWildCardBndrs (go_sig_ty ltype)))
   where
     go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty }))
        = L loc (HsSig { sig_ext = noExtField
@@ -230,14 +230,14 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))
 
     extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)
 
-    add_ctxt Nothing              = Just $ noLoc [extra_pred]
+    add_ctxt Nothing              = Just $ noLocA [extra_pred]
     add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds)
 
 addClassContext _ _ sig = sig   -- E.g. a MinimalSig is fine
 
 lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]
 lHsQTyVarsToTypes tvs
-  = [ HsValArg $ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))
+  = [ HsValArg $ noLocA (HsTyVar noAnn NotPromoted (noLocA (hsLTyVarName tv)))
     | tv <- hsQTvExplicit tvs ]
 
 
@@ -332,14 +332,13 @@ 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, NoGhcTc a ~ a
-                             , MapXRec a, UnXRec a, WrapXRec a )
+reparenTypePrec :: forall a. (XRecCond a)
                 => Precedence -> HsType a -> HsType a
 reparenTypePrec = go
   where
 
   -- Shorter name for 'reparenType'
-  go :: Precedence -> HsType a -> HsType a
+  go :: XParTy a ~ ApiAnn' AnnParen => 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)
@@ -361,6 +360,7 @@ reparenTypePrec = go
             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)
+    -- = paren p PREC_FUN $ HsQualTy x (fmap (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)
@@ -378,40 +378,35 @@ reparenTypePrec = go
   go _ t@XHsType{} = t
 
   -- Located variant of 'go'
-  goL :: Precedence -> LHsType a -> LHsType a
+  goL :: XParTy a ~ ApiAnn' AnnParen => Precedence -> LHsType a -> LHsType a
   goL ctxt_prec = mapXRec @a (go ctxt_prec)
 
   -- Optionally wrap a type in parens
-  paren :: Precedence            -- Precedence of context
+  paren :: XParTy a ~ ApiAnn' AnnParen
+        => 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 . wrapXRec @a
+  paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noAnn . wrapXRec @a
                           | otherwise            = id
 
 
 -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')
-reparenType :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
-               , MapXRec a, UnXRec a, WrapXRec a )
-            => HsType a -> HsType a
+reparenType :: XRecCond 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, NoGhcTc a ~ a
-                          , MapXRec a, UnXRec a, WrapXRec a )
-             => LHsType a -> LHsType a
+reparenLType :: forall a. (XRecCond 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 )
+reparenSigType :: forall a. ( XRecCond 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 )
+reparenOuterTyVarBndrs :: forall flag a. ( XRecCond a )
                        => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a
 reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp
 reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
@@ -419,8 +414,7 @@ reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =
 reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v
 
 -- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
-reparenHsForAllTelescope :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a
-                                      , MapXRec a, UnXRec a, WrapXRec a )
+reparenHsForAllTelescope :: forall a. (XRecCond a )
                          => HsForAllTelescope a -> HsForAllTelescope a
 reparenHsForAllTelescope (HsForAllVis x bndrs) =
   HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs)
@@ -429,17 +423,13 @@ reparenHsForAllTelescope (HsForAllInvis x bndrs) =
 reparenHsForAllTelescope v@XHsForAllTelescope{} = v
 
 -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
-reparenTyVar :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a
-                , MapXRec a, UnXRec a, WrapXRec a )
-             => HsTyVarBndr flag a -> HsTyVarBndr flag a
+reparenTyVar :: (XRecCond 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, NoGhcTc a ~ a
-                       , MapXRec a, UnXRec a, WrapXRec a )
-                    => ConDeclField a -> ConDeclField a
+reparenConDeclField :: (XRecCond a) => ConDeclField a -> ConDeclField a
 reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d
 reparenConDeclField c@XConDeclField{} = c
 
@@ -449,13 +439,15 @@ reparenConDeclField c@XConDeclField{} = c
 -------------------------------------------------------------------------------
 
 
-unL :: Located a -> a
+unL :: GenLocated l a -> a
 unL (L _ x) = x
 
-
-reL :: a -> Located a
+reL :: a -> GenLocated l a
 reL = L undefined
 
+mapMA :: Monad m => (a -> m b) -> LocatedAn an a -> m (Located b)
+mapMA f (L al a) = L (locA al) <$> f a
+
 -------------------------------------------------------------------------------
 -- * NamedThing instances
 -------------------------------------------------------------------------------
@@ -763,4 +755,4 @@ defaultRuntimeRepVars = go emptyVarEnv
     go _ ty@(CoercionTy {}) = ty
 
 fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI
-fromMaybeContext mctxt = unLoc $ fromMaybe (noLoc []) mctxt
+fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt