GHC Exactprint main commit

Metric Increase:
       T10370
       parsing001

Updates haddock submodule

1 files changed, 30 insertions, 28 deletions

diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index ec8c2bb66e..bcb9fa084d 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -1286,7 +1286,7 @@ inferInitialKinds decls
        ; traceTc "inferInitialKinds done }" empty
        ; return tcs }
   where
-    infer_initial_kind = addLocM (getInitialKind InitialKindInfer)
+    infer_initial_kind = addLocMA (getInitialKind InitialKindInfer)
 
 -- Check type/class declarations against their standalone kind signatures or
 -- CUSKs, producing a generalized TcTyCon for each.
@@ -1298,7 +1298,7 @@ checkInitialKinds decls
        ; return tcs }
   where
     check_initial_kind (ldecl, msig) =
-      addLocM (getInitialKind (InitialKindCheck msig)) ldecl
+      addLocMA (getInitialKind (InitialKindCheck msig)) ldecl
 
 -- | Get the initial kind of a TyClDecl, either generalized or non-generalized,
 -- depending on the 'InitialKindStrategy'.
@@ -1327,7 +1327,7 @@ getInitialKind strategy
             -- See Note [Don't process associated types in getInitialKind]
        ; inner_tcs <-
            tcExtendNameTyVarEnv parent_tv_prs $
-           mapM (addLocM (getAssocFamInitialKind cls)) ats
+           mapM (addLocMA (getAssocFamInitialKind cls)) ats
        ; return (cls : inner_tcs) }
   where
     getAssocFamInitialKind cls =
@@ -1531,7 +1531,7 @@ kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
   -- See Note [Kind checking for type and class decls]
   -- Called only for declarations without a signature (no CUSKs or SAKs here)
 kcLTyClDecl (L loc decl)
-  = setSrcSpan loc $
+  = setSrcSpanA loc $
     do { tycon <- tcLookupTcTyCon tc_name
        ; traceTc "kcTyClDecl {" (ppr tc_name)
        ; addVDQNote tycon $   -- See Note [Inferring visible dependent quantification]
@@ -1569,7 +1569,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name
                       , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon
   = bindTyClTyVars name $ \ _ _ _ ->
     do  { _ <- tcHsContext ctxt
-        ; mapM_ (wrapLocM_ kc_sig) sigs }
+        ; mapM_ (wrapLocMA_ kc_sig) sigs }
   where
     kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType nms op_ty
     kc_sig _                          = return ()
@@ -1617,7 +1617,7 @@ kcConDecls :: NewOrData
            -> TcM ()
 -- See Note [kcConDecls: kind-checking data type decls]
 kcConDecls new_or_data tc_res_kind cons
-  = mapM_ (wrapLocM_ (kcConDecl new_or_data tc_res_kind)) cons
+  = mapM_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind)) cons
 
 -- Kind check a data constructor. In additional to the data constructor,
 -- we also need to know about whether or not its corresponding type was
@@ -2323,7 +2323,7 @@ tcTyClDecl roles_info (L loc decl)
       _ -> pprPanic "tcTyClDecl" (ppr thing)
 
   | otherwise
-  = setSrcSpan loc $ tcAddDeclCtxt decl $
+  = setSrcSpanA loc $ tcAddDeclCtxt decl $
     do { traceTc "---- tcTyClDecl ---- {" (ppr decl)
        ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl
        ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)
@@ -2341,7 +2341,7 @@ wiredInDerivInfo tycon decl
                     if isFunTyCon tycon || isPrimTyCon tycon
                        then []  -- no tyConTyVars
                        else mkTyVarNamePairs (tyConTyVars tycon)
-                , di_clauses = unLoc derivs
+                , di_clauses = derivs
                 , di_ctxt = tcMkDeclCtxt decl } ]
 wiredInDerivInfo _ _ = []
 
@@ -2404,7 +2404,7 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs
                -- The (binderVars binders) is needed bring into scope the
                -- skolems bound by the class decl header (#17841)
                do { ctxt <- tcHsContext hs_ctxt
-                  ; fds  <- mapM (addLocM tc_fundep) fundeps
+                  ; fds  <- mapM (addLocMA tc_fundep) fundeps
                   ; sig_stuff <- tcClassSigs class_name sigs meths
                   ; at_stuff  <- tcClassATs class_name clas ats at_defs
                   ; return (ctxt, fds, sig_stuff, at_stuff) }
@@ -2448,9 +2448,11 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs
        ; return clas }
   where
     skol_info = TyConSkol ClassFlavour class_name
-    tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;
+    tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var])
+    tc_fundep (FunDep _ tvs1 tvs2)
+                           = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;
                                 ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;
-                                ; return (tvs1', tvs2') }
+                                ; return (tvs1',tvs2') }
 
 
 {- Note [Associated type defaults]
@@ -2493,7 +2495,7 @@ tcClassATs class_name cls ats at_defs
                                           (at_def_tycon at_def) [at_def])
                         emptyNameEnv at_defs
 
-    tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at
+    tc_at at = do { fam_tc <- addLocMA (tcFamDecl1 (Just cls)) at
                   ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)
                                   `orElse` []
                   ; atd <- tcDefaultAssocDecl fam_tc at_defs
@@ -2518,7 +2520,7 @@ tcDefaultAssocDecl fam_tc
                                    , feqn_pats  = hs_pats
                                    , feqn_rhs   = hs_rhs_ty }})]
   = -- See Note [Type-checking default assoc decls]
-    setSrcSpan loc $
+    setSrcSpanA loc $
     tcAddFamInstCtxt (text "default type instance") tc_name $
     do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name)
        ; let fam_tc_name = tyConName fam_tc
@@ -2559,7 +2561,7 @@ tcDefaultAssocDecl fam_tc
                        -- simply create an empty substitution and let GHC fall
                        -- over later, in GHC.Tc.Validity.checkValidAssocTyFamDeflt.
                        -- See Note [Type-checking default assoc decls].
-       ; pure $ Just (substTyUnchecked subst rhs_ty, ATVI loc pats)
+       ; pure $ Just (substTyUnchecked subst rhs_ty, ATVI (locA loc) pats)
            -- We perform checks for well-formedness and validity later, in
            -- GHC.Tc.Validity.checkValidAssocTyFamDeflt.
      }
@@ -2789,7 +2791,7 @@ tcInjectivity _ Nothing
   -- therefore we can always infer the result kind if we know the result type.
   -- But this does not seem to be useful in any way so we don't do it.  (Another
   -- reason is that the implementation would not be straightforward.)
-tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames)))
+tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames)))
   = setSrcSpan loc $
     do { let tvs = binderVars tcbs
        ; dflags <- getDynFlags
@@ -2903,7 +2905,7 @@ tcDataDefn err_ctxt roles_info tc_name
                                   gadt_syntax) }
        ; let deriv_info = DerivInfo { di_rep_tc = tycon
                                     , di_scoped_tvs = tcTyConScopedTyVars tctc
-                                    , di_clauses = unLoc derivs
+                                    , di_clauses = derivs
                                     , di_ctxt = err_ctxt }
        ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs)
        ; return (tycon, [deriv_info]) }
@@ -2946,7 +2948,7 @@ kcTyFamInstEqn tc_fam_tc
                    , feqn_bndrs = outer_bndrs
                    , feqn_pats  = hs_pats
                    , feqn_rhs   = hs_rhs_ty }))
-  = setSrcSpan loc $
+  = setSrcSpanA loc $
     do { traceTc "kcTyFamInstEqn" (vcat
            [ text "tc_name ="    <+> ppr eqn_tc_name
            , text "fam_tc ="     <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)
@@ -2989,7 +2991,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo
     (L loc (FamEqn { feqn_bndrs  = outer_bndrs
                    , feqn_pats   = hs_pats
                    , feqn_rhs    = hs_rhs_ty }))
-  = setSrcSpan loc $
+  = setSrcSpanA loc $
     do { traceTc "tcTyFamInstEqn" $
          vcat [ ppr loc, ppr fam_tc <+> ppr hs_pats
               , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc)
@@ -3012,7 +3014,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo
        -- (tcFamInstEqnGuts zonks to Type)
        ; return (mkCoAxBranch qtvs [] [] pats rhs_ty
                               (map (const Nominal) qtvs)
-                              loc) }
+                              (locA loc)) }
 
 {- Note [Instantiating a family tycon]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3150,7 +3152,7 @@ checkFamTelescope tclvl hs_outer_bndrs outer_tvs
   , (b_first : _) <- bndrs
   , let b_last    = last bndrs
         skol_info = ForAllSkol (fsep (map ppr bndrs))
-  = setSrcSpan (combineSrcSpans (getLoc b_first) (getLoc b_last)) $
+  = setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $
     emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC
   | otherwise
   = return ()
@@ -3324,7 +3326,7 @@ tcConDecls :: NewOrData
            -> TcKind                    -- Result kind
            -> [LConDecl GhcRn] -> TcM [DataCon]
 tcConDecls new_or_data dd_info rep_tycon tmpl_bndrs res_kind
-  = concatMapM $ addLocM $
+  = concatMapM $ addLocMA $
     tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind
               (mkTyConTagMap rep_tycon)
     -- mkTyConTagMap: it's important that we pay for tag allocation here,
@@ -3664,7 +3666,7 @@ tcConArg exp_kind (HsScaled w bty)
         ; return (Scaled w' arg_ty, getBangStrictness bty) }
 
 tcRecConDeclFields :: ContextKind
-                   -> Located [LConDeclField GhcRn]
+                   -> LocatedL [LConDeclField GhcRn]
                    -> TcM [(Scaled TcType, HsSrcBang)]
 tcRecConDeclFields exp_kind fields
   = mapM (tcConArg exp_kind) btys
@@ -4292,7 +4294,7 @@ checkFieldCompat fld con1 con2 res1 res2 fty1 fty2
 checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()
 checkValidDataCon dflags existential_ok tc con
   = setSrcSpan con_loc $
-    addErrCtxt (dataConCtxt [L con_loc con_name]) $
+    addErrCtxt (dataConCtxt [L (noAnnSrcSpan con_loc) con_name]) $
     do  { let tc_tvs      = tyConTyVars tc
               res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
               orig_res_ty = dataConOrigResTy con
@@ -4891,7 +4893,7 @@ checkValidRoleAnnots role_annots tc
       = whenIsJust role_annot_decl_maybe $
           \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) ->
           addRoleAnnotCtxt name $
-          setSrcSpan loc $ do
+          setSrcSpanA loc $ do
           { role_annots_ok <- xoptM LangExt.RoleAnnotations
           ; checkTc role_annots_ok $ needXRoleAnnotations tc
           ; checkTc (vis_vars `equalLength` the_role_annots)
@@ -5087,15 +5089,15 @@ fieldTypeMisMatch field_name con1 con2
   = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,
          text "give different types for field", quotes (ppr field_name)]
 
-dataConCtxt :: [Located Name] -> SDoc
+dataConCtxt :: [LocatedN Name] -> SDoc
 dataConCtxt cons = text "In the definition of data constructor" <> plural cons
                    <+> ppr_cons cons
 
-dataConResCtxt :: [Located Name] -> SDoc
+dataConResCtxt :: [LocatedN Name] -> SDoc
 dataConResCtxt cons = text "In the result type of data constructor" <> plural cons
                       <+> ppr_cons cons
 
-ppr_cons :: [Located Name] -> SDoc
+ppr_cons :: [LocatedN Name] -> SDoc
 ppr_cons [con] = quotes (ppr con)
 ppr_cons cons  = interpp'SP cons
 
@@ -5217,7 +5219,7 @@ wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots))
 illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()
 illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _))
   = setErrCtxt [] $
-    setSrcSpan loc $
+    setSrcSpanA loc $
     addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$
               text "they are allowed only for datatypes and classes.")