[Git][ghc/ghc][master] EPA: get rid of l2l and friends

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Tue Nov 7 07:21:58 UTC 2023



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
8217acb8 by Alan Zimmerman at 2023-11-07T02:21:12-05:00
EPA: get rid of l2l and friends

Replace them with

  l2l to convert the location
  la2la to convert a GenLocated thing

Updates haddock submodule

- - - - -


16 changed files:

- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- utils/haddock


Changes:

=====================================
compiler/GHC/Parser.y
=====================================
@@ -4332,6 +4332,9 @@ glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor
 glNRR :: LocatedN a -> EpaLocation
 glNRR = srcSpan2e . getLocA
 
+n2l :: LocatedN a -> LocatedA a
+n2l (L la a) = L (l2l la) a
+
 anc :: RealSrcSpan -> Anchor
 anc r = Anchor r UnchangedAnchor
 


=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -50,7 +50,7 @@ module GHC.Parser.Annotation (
 
   -- ** Utilities for converting between different 'GenLocated' when
   -- ** we do not care about the annotations.
-  la2na, na2la, n2l, l2n, l2l, la2la,
+  l2l, la2la,
   reLoc,
   HasLoc(..), getHasLocList,
 
@@ -991,31 +991,15 @@ knowing that in most cases the original list is empty.
 
 -- ---------------------------------------------------------------------
 
--- |Helper function (temporary) during transition of names
+-- |Helper function for converting annotation types.
 --  Discards any annotations
-l2n :: LocatedAn a1 a2 -> LocatedN a2
-l2n (L la a) = L (noAnnSrcSpan (locA la)) a
+l2l :: (HasLoc a, HasAnnotation b) => a -> b
+l2l a = noAnnSrcSpan (getHasLoc a)
 
-n2l :: LocatedN a -> LocatedA a
-n2l (L la a) = L (na2la la) a
-
--- |Helper function (temporary) during transition of names
---  Discards any annotations
-la2na :: SrcSpanAnn' a -> SrcSpanAnnN
-la2na l = noAnnSrcSpan (locA l)
-
--- |Helper function (temporary) during transition of names
---  Discards any annotations
-la2la :: (NoAnn ann2) => LocatedAn ann1 a2 -> LocatedAn ann2 a2
-la2la (L la a) = L (noAnnSrcSpan (locA la)) a
-
-l2l :: SrcSpanAnn' a -> SrcAnn ann
-l2l l = SrcSpanAnn EpAnnNotUsed (locA l)
-
--- |Helper function (temporary) during transition of names
+-- |Helper function for converting annotation types.
 --  Discards any annotations
-na2la :: (NoAnn ann) => SrcSpanAnn' a -> SrcAnn ann
-na2la l = noAnnSrcSpan (locA l)
+la2la :: (HasLoc l, HasAnnotation l2) => GenLocated l a -> GenLocated l2 a
+la2la (L la a) = L (noAnnSrcSpan (getHasLoc la)) a
 
 locA :: (HasLoc a) => a -> SrcSpan
 locA = getHasLoc


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1837,7 +1837,7 @@ instance DisambECP (HsExpr GhcPs) where
   mkHsParPV l lpar e rpar = do
     cs <- getCommentsFor l
     return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar e rpar)
-  mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v)
+  mkHsVarPV v@(L l _) = return $ L (l2l l) (HsVar noExtField v)
   mkHsLitPV (L l a) = do
     cs <- getCommentsFor l
     return $ L l (HsLit (comment (realSrcSpan l) cs) a)
@@ -1912,7 +1912,7 @@ instance DisambECP (PatBuilder GhcPs) where
   mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
   mkHsDoPV l _ _ _       = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
   mkHsParPV l lpar p rpar   = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
-  mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v)
+  mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v)
   mkHsLitPV lit@(L l a) = do
     checkUnboxedLitPat lit
     return $ L l (PatBuilderPat (LitPat noExtField a))


=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -244,7 +244,7 @@ finishHsVar (L l name)
  = do { this_mod <- getModule
       ; when (nameIsLocalOrFrom this_mod name) $
         checkThLocalName name
-      ; return (HsVar noExtField (L (la2na l) name), unitFV name) }
+      ; return (HsVar noExtField (L (l2l l) name), unitFV name) }
 
 rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
 rnUnboundVar v = do
@@ -280,7 +280,7 @@ rnExpr (HsVar _ (L l v))
             -> rnExpr (ExplicitList noAnn [])
 
             | otherwise
-            -> finishHsVar (L (na2la l) nm)
+            -> finishHsVar (L (l2l l) nm)
         }}}
 
 rnExpr (HsIPVar x v)


=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -2539,7 +2539,7 @@ extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do {
           return ((PatSynName bnd_name, con_info) : names)
       | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n, psb_args = as })) <- bind
       = do
-        bnd_name <- newTopSrcBinder (L (la2na bind_loc) n)
+        bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)
         let con_info = mkConInfo (conDetailsArity length as) []
         return ((PatSynName bnd_name, con_info) : names)
       | otherwise


=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -869,10 +869,10 @@ getLocalNonValBinders fixity_env
     new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances
         = do { let TyDeclBinders (main_bndr, tc_flav) at_bndrs sig_bndrs
                      (LConsWithFields cons_with_flds flds) = hsLTyClDeclBinders tc_decl
-             ; tycon_name          <- newTopSrcBinder $ l2n main_bndr
-             ; at_names            <- mapM (newTopSrcBinder . l2n . fst) at_bndrs
-             ; sig_names           <- mapM (newTopSrcBinder . l2n) sig_bndrs
-             ; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds
+             ; tycon_name          <- newTopSrcBinder $ la2la main_bndr
+             ; at_names            <- mapM (newTopSrcBinder . la2la . fst) at_bndrs
+             ; sig_names           <- mapM (newTopSrcBinder . la2la) sig_bndrs
+             ; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (la2la con)) cons_with_flds
              ; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst con_names_with_flds) flds
              ; mapM_ (add_dup_fld_errs flds') con_names_with_flds
              ; let tc_gre = mkLocalTyConGRE (fmap (const tycon_name) tc_flav) tycon_name
@@ -947,7 +947,7 @@ getLocalNonValBinders fixity_env
     new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl })
         = do { main_name <- unLoc <$> lookupFamInstName mb_cls (feqn_tycon ti_decl)
              ; let LConsWithFields cons_with_flds flds = hsDataFamInstBinders dfid
-             ; sub_names <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds
+             ; sub_names <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (la2la con)) cons_with_flds
              ; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst sub_names) flds
              ; mapM_ (add_dup_fld_errs flds') sub_names
              ; let fld_env  = mk_fld_env sub_names flds'
@@ -2133,14 +2133,14 @@ printMinimalImports hsc_src imports_w_usage
 
 to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
 to_ie_post_rn_var (L l n)
-  | isDataOcc $ occName n = L l (IEPattern (la2e l)   (L (la2na l) n))
-  | otherwise             = L l (IEName    noExtField (L (la2na l) n))
+  | isDataOcc $ occName n = L l (IEPattern (la2e l)   (L (l2l l) n))
+  | otherwise             = L l (IEName    noExtField (L (l2l l) n))
 
 
 to_ie_post_rn :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
 to_ie_post_rn (L l n)
-  | isTcOcc occ && isSymOcc occ = L l (IEType (la2e l)   (L (la2na l) n))
-  | otherwise                   = L l (IEName noExtField (L (la2na l) n))
+  | isTcOcc occ && isSymOcc occ = L l (IEType (la2e l)   (L (l2l l) n))
+  | otherwise                   = L l (IEName noExtField (L (l2l l) n))
   where occ = occName n
 
 {-


=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -558,7 +558,7 @@ rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
        ; return (NPat x (L l lit') mb_neg' eq') }
 
 rnPatAndThen mk (NPlusKPat _ rdr (L l lit) _ _ _ )
-  = do { new_name <- newPatName mk (l2n rdr)
+  = do { new_name <- newPatName mk (la2la rdr)
        ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
                                                 -- We skip negateName as
                                                 -- negative zero doesn't make


=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -391,12 +391,12 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name
 mkQuasiQuoteExpr flavour quoter (L q_span' quote)
   = L q_span $ HsApp noComments (L q_span
              $ HsApp noComments (L q_span
-                    (HsVar noExtField (L (la2na q_span) quote_selector)))
+                    (HsVar noExtField (L (l2l q_span) quote_selector)))
                                 quoterExpr)
                     quoteExpr
   where
     q_span = noAnnSrcSpan (locA q_span')
-    quoterExpr = L q_span $! HsVar noExtField $! (L (la2na q_span) quoter)
+    quoterExpr = L q_span $! HsVar noExtField $! (L (l2l q_span) quoter)
     quoteExpr  = L q_span $! HsLit noComments $! HsString NoSourceText quote
     quote_selector = case flavour of
                        UntypedExpSplice  -> quoteExpName


=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -1241,7 +1241,7 @@ dynCompileExpr expr = do
   parsed_expr <- parseExpr expr
   -- > Data.Dynamic.toDyn expr
   let loc = getLoc parsed_expr
-      to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L (la2na loc) $ getRdrName toDynName)
+      to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L (l2l loc) $ getRdrName toDynName)
                             parsed_expr
   hval <- compileParsedExpr to_dyn_expr
   return (unsafeCoerce hval :: Dynamic)


=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -2292,7 +2292,7 @@ mkFunBindSE arity loc fun pats_and_exprs
 mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
              -> LHsBind GhcPs
 mkRdrFunBind fun@(L loc _fun_rdr) matches
-  = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches)
+  = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches)
 
 -- | Make a function binding. If no equations are given, produce a function
 -- with the given arity that uses an empty case expression for the last
@@ -2320,7 +2320,7 @@ mkRdrFunBindEC :: Arity
                -> [LMatch GhcPs (LHsExpr GhcPs)]
                -> LHsBind GhcPs
 mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
-  = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches')
+  = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches')
  where
    -- Catch-all eqn looks like
    --     fmap _ z = case z of {}
@@ -2344,7 +2344,7 @@ mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
 mkRdrFunBindSE :: Arity -> LocatedN RdrName ->
                     [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
 mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
-  = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches')
+  = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches')
  where
    -- Catch-all eqn looks like
    --     compare _ _ = error "Void compare"


=====================================
compiler/GHC/Tc/Gen/Export.hs
=====================================
@@ -710,7 +710,7 @@ lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items
               do { ub <- reportUnboundName unboundName
                  ; let l = getLoc n
                        gre = mkLocalGRE UnboundGRE NoParent ub
-                 ; return (L l (IEName noExtField (L (la2na l) ub)), gre)}
+                 ; return (L l (IEName noExtField (L (l2l l) ub)), gre)}
             FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) ->
               do { checkPatSynParent spec_parent par child_nm
                  ; return (replaceLWrappedName n child_nm, child)


=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1542,7 +1542,7 @@ splitHsAppTys hs_ty
     go (L _  (HsAppKindTy _ ty at k)) as = go ty (HsTypeArg at k : as)
     go (L sp (HsParTy _ f))        as = go f (HsArgPar (locA sp) : as)
     go (L _  (HsOpTy _ prom l op@(L sp _) r)) as
-      = ( L (na2la sp) (HsTyVar noAnn prom op)
+      = ( L (l2l sp) (HsTyVar noAnn prom op)
         , HsValArg l : HsValArg r : as )
     go f as = (f, as)
 


=====================================
compiler/GHC/Tc/TyCl/Class.hs
=====================================
@@ -195,7 +195,7 @@ tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
                                 tcdMeths = default_binds}))
   = recoverM (return emptyLHsBinds) $
     setSrcSpan (getLocA class_name) $
-    do  { clas <- tcLookupLocatedClass (n2l class_name)
+    do  { clas <- tcLookupLocatedClass (la2la class_name)
 
         -- We make a separate binding for each default method.
         -- At one time I used a single AbsBinds for all of them, thus
@@ -281,7 +281,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
 
              local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)
 
-             lm_bind     = dm_bind { fun_id = L (la2na bind_loc) local_dm_name }
+             lm_bind     = dm_bind { fun_id = L (l2l bind_loc) local_dm_name }
                              -- Substitute the local_meth_name for the binder
                              -- NB: the binding is always a FunBind
 


=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -610,7 +610,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
          -- itself, so we make do with the location of family name
        ; (co_ax_branch, co_ax_validity_info)
           <- tcTyFamInstEqn fam_tc mb_clsinfo
-                (L (na2la $ getLoc fam_lname) eqn)
+                (L (l2l $ getLoc fam_lname) eqn)
 
          -- (2) check for validity
        ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch


=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -943,7 +943,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
     mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
     mk_mg body = mkMatchGroup (Generated SkipPmc) (noLocA [builder_match])
           where
-            builder_args  = [L (na2la loc) (VarPat noExtField (L loc n))
+            builder_args  = [L (l2l loc) (VarPat noExtField (L loc n))
                             | L loc n <- args]
             builder_match = mkMatch (mkPrefixFunRhs ps_lname)
                                     builder_args body


=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit b75ff8a88bbdd0d60032a4e304d37ec65526c06b
+Subproject commit 2cbf7f0a55898e0c2827ae9ad13727b34877e793



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8217acb8afe883659cdf6e9ccf7a3d6f943f8082

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8217acb8afe883659cdf6e9ccf7a3d6f943f8082
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231107/7c57c5d7/attachment-0001.html>


More information about the ghc-commits mailing list