From 5aba5d3218330f8ce127aa7767efcbb6f63a2db1 Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Wed, 20 Nov 2019 15:44:49 +0300 Subject: Remove HasSrcSpan (#17494) Metric Decrease: haddock.compiler --- compiler/rename/RnExpr.hs | 2 +- compiler/rename/RnHsDoc.hs | 4 +- compiler/rename/RnPat.hs | 99 ++++++++++++++--------------- compiler/rename/RnSource.hs | 152 +++++++++++++++++++++----------------------- compiler/rename/RnSplice.hs | 28 ++++---- compiler/rename/RnTypes.hs | 124 +++++++++++++++++------------------- compiler/rename/RnUtils.hs | 4 +- 7 files changed, 201 insertions(+), 212 deletions(-) (limited to 'compiler/rename') diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 59ca753ae4..693d818f67 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -1368,7 +1368,7 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later where (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later new_stmt | non_rec = head ss - | otherwise = cL (getLoc (head ss)) rec_stmt + | otherwise = L (getLoc (head ss)) rec_stmt rec_stmt = empty_rec_stmt { recS_stmts = ss , recS_later_ids = nameSetElemsStable used_later , recS_rec_ids = nameSetElemsStable fwds } diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs index deaedb8bca..6af59a0210 100644 --- a/compiler/rename/RnHsDoc.hs +++ b/compiler/rename/RnHsDoc.hs @@ -17,9 +17,9 @@ rnMbLHsDoc mb_doc = case mb_doc of Nothing -> return Nothing rnLHsDoc :: LHsDocString -> RnM LHsDocString -rnLHsDoc (dL->L pos doc) = do +rnLHsDoc (L pos doc) = do doc' <- rnHsDoc doc - return (cL pos doc') + return (L pos doc') rnHsDoc :: HsDocString -> RnM HsDocString rnHsDoc = pure diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 61cdc140bf..59ab5446cd 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -129,13 +129,12 @@ liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing ; (r,fvs2) <- k v ; return (r, fvs1 `plusFV` fvs2) }) -wrapSrcSpanCps :: (HasSrcSpan a, HasSrcSpan b) => - (SrcSpanLess a -> CpsRn (SrcSpanLess b)) -> a -> CpsRn b +wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b) -- Set the location, and also wrap it around the value returned -wrapSrcSpanCps fn (dL->L loc a) +wrapSrcSpanCps fn (L loc a) = CpsRn (\k -> setSrcSpan loc $ unCpsRn (fn a) $ \v -> - k (cL loc v)) + k (L loc v)) lookupConCps :: Located RdrName -> CpsRn (Located Name) lookupConCps con_rdr @@ -220,9 +219,9 @@ rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn) rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig) newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) -newPatLName name_maker rdr_name@(dL->L loc _) +newPatLName name_maker rdr_name@(L loc _) = do { name <- newPatName name_maker rdr_name - ; return (cL loc name) } + ; return (L loc name) } newPatName :: NameMaker -> Located RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name @@ -391,10 +390,10 @@ rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat ; return (LazyPat x pat') } rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat ; return (BangPat x pat') } -rnPatAndThen mk (VarPat x (dL->L l rdr)) +rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM - ; name <- newPatName mk (cL loc rdr) - ; return (VarPat x (cL l name)) } + ; name <- newPatName mk (L loc rdr) + ; return (VarPat x (L l name)) } -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) @@ -424,7 +423,7 @@ rnPatAndThen mk (LitPat x lit) where normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) } -rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq) +rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit ; mb_neg' -- See Note [Negative zero] <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName @@ -436,9 +435,9 @@ rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq) (Nothing, Nothing) -> positive (Just _ , Just _ ) -> positive ; eq' <- liftCpsFV $ lookupSyntaxName eqName - ; return (NPat x (cL l lit') mb_neg' eq') } + ; return (NPat x (L l lit') mb_neg' eq') } -rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ ) +rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) = do { new_name <- newPatName mk rdr ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] -- We skip negateName as @@ -446,8 +445,8 @@ rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ ) -- sense in n + k patterns ; minus <- liftCpsFV $ lookupSyntaxName minusName ; ge <- liftCpsFV $ lookupSyntaxName geName - ; return (NPlusKPat x (cL (nameSrcSpan new_name) new_name) - (cL l lit') lit' ge minus) } + ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name) + (L l lit') lit' ge minus) } -- The Report says that n+k patterns must be in Integral rnPatAndThen mk (AsPat x rdr pat) @@ -540,7 +539,7 @@ rnHsRecPatsAndThen :: NameMaker -> Located Name -- Constructor -> HsRecFields GhcPs (LPat GhcPs) -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) -rnHsRecPatsAndThen mk (dL->L _ con) +rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat hs_rec_fields @@ -548,10 +547,10 @@ rnHsRecPatsAndThen mk (dL->L _ con) ; check_unused_wildcard (implicit_binders flds' <$> dd) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } where - mkVarPat l n = VarPat noExtField (cL l n) - rn_field (dL->L l fld, n') = + mkVarPat l n = VarPat noExtField (L l n) + rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) - ; return (cL l (fld { hsRecFieldArg = arg' })) } + ; return (L l (fld { hsRecFieldArg = arg' })) } loc = maybe noSrcSpan getLoc dd @@ -585,12 +584,12 @@ data HsRecFieldContext | HsRecFieldUpd rnHsRecFields - :: forall arg. HasSrcSpan arg => + :: forall arg. HsRecFieldContext - -> (SrcSpan -> RdrName -> SrcSpanLess arg) + -> (SrcSpan -> RdrName -> arg) -- When punning, use this to build a new field - -> HsRecFields GhcPs arg - -> RnM ([LHsRecField GhcRn arg], FreeVars) + -> HsRecFields GhcPs (Located arg) + -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars) -- This surprisingly complicated pass -- a) looks up the field name (possibly using disambiguation) @@ -616,38 +615,36 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) HsRecFieldPat con -> Just con _ {- update -} -> Nothing - rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs arg - -> RnM (LHsRecField GhcRn arg) - rn_fld pun_ok parent (dL->L l + rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg) + -> RnM (LHsRecField GhcRn (Located arg)) + rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl = - (dL->L loc (FieldOcc _ (dL->L ll lbl))) + (L loc (FieldOcc _ (L ll lbl))) , hsRecFieldArg = arg , hsRecPun = pun })) = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl ; arg' <- if pun - then do { checkErr pun_ok (badPun (cL loc lbl)) + then do { checkErr pun_ok (badPun (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (cL loc (mk_arg loc arg_rdr)) } + ; return (L loc (mk_arg loc arg_rdr)) } else return arg - ; return (cL l (HsRecField - { hsRecFieldLbl = (cL loc (FieldOcc - sel (cL ll lbl))) + ; return (L l (HsRecField + { hsRecFieldLbl = (L loc (FieldOcc + sel (L ll lbl))) , hsRecFieldArg = arg' , hsRecPun = pun })) } - rn_fld _ _ (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) + rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) = panic "rnHsRecFields" - rn_fld _ _ _ = panic "rn_fld: Impossible Match" - -- due to #15884 rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat -> Maybe Name -- The constructor (Nothing for an -- out of scope constructor) - -> [LHsRecField GhcRn arg] -- Explicit fields - -> RnM ([LHsRecField GhcRn arg]) -- Field Labels we need to fill in - rn_dotdot (Just (dL -> L loc n)) (Just con) flds -- ".." on record construction / pat match + -> [LHsRecField GhcRn (Located arg)] -- Explicit fields + -> RnM ([LHsRecField GhcRn (Located arg)]) -- Field Labels we need to fill in + rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match | not (isUnboundName con) -- This test is because if the constructor -- isn't in scope the constructor lookup will add -- an error but still return an unbound name. We @@ -679,9 +676,9 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) _other -> True ] ; addUsedGREs dot_dot_gres - ; return [ cL loc (HsRecField - { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr)) - , hsRecFieldArg = cL loc (mk_arg loc arg_rdr) + ; return [ L loc (HsRecField + { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr)) + , hsRecFieldArg = L loc (mk_arg loc arg_rdr) , hsRecPun = False }) | fl <- dot_dot_fields , let sel = flSelector fl @@ -726,9 +723,9 @@ rnHsRecUpdFields flds rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs -> RnM (LHsRecUpdField GhcRn, FreeVars) - rn_fld pun_ok overload_ok (dL->L l (HsRecField { hsRecFieldLbl = dL->L loc f - , hsRecFieldArg = arg - , hsRecPun = pun })) + rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f + , hsRecFieldArg = arg + , hsRecPun = pun })) = do { let lbl = rdrNameAmbiguousFieldOcc f ; sel <- setSrcSpan loc $ -- Defer renaming of overloaded fields to the typechecker @@ -744,10 +741,10 @@ rnHsRecUpdFields flds Just r -> return r } else fmap Left $ lookupGlobalOccRn lbl ; arg' <- if pun - then do { checkErr pun_ok (badPun (cL loc lbl)) + then do { checkErr pun_ok (badPun (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (cL loc (HsVar noExtField (cL loc arg_rdr))) } + ; return (L loc (HsVar noExtField (L loc arg_rdr))) } else return arg ; (arg'', fvs) <- rnLExpr arg' @@ -757,14 +754,14 @@ rnHsRecUpdFields flds Right _ -> fvs lbl' = case sel of Left sel_name -> - cL loc (Unambiguous sel_name (cL loc lbl)) + L loc (Unambiguous sel_name (L loc lbl)) Right [sel_name] -> - cL loc (Unambiguous sel_name (cL loc lbl)) - Right _ -> cL loc (Ambiguous noExtField (cL loc lbl)) + L loc (Unambiguous sel_name (L loc lbl)) + Right _ -> L loc (Ambiguous noExtField (L loc lbl)) - ; return (cL l (HsRecField { hsRecFieldLbl = lbl' - , hsRecFieldArg = arg'' - , hsRecPun = pun }), fvs') } + ; return (L l (HsRecField { hsRecFieldLbl = lbl' + , hsRecFieldArg = arg'' + , hsRecPun = pun }), fvs') } dup_flds :: [NE.NonEmpty RdrName] -- Each list represents a RdrName that occurred more than once diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 966e027fe2..88fe10b493 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -284,7 +284,7 @@ rnSrcWarnDecls _ [] rnSrcWarnDecls bndr_set decls' = do { -- check for duplicates - ; mapM_ (\ dups -> let ((dL->L loc rdr) :| (lrdr':_)) = dups + ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups in addErrAt loc (dupWarnDecl lrdr' rdr)) warn_rdr_dups ; pairs_s <- mapM (addLocM rn_deprec) decls @@ -304,7 +304,7 @@ rnSrcWarnDecls bndr_set decls' what = text "deprecation" warn_rdr_dups = findDupRdrNames - $ concatMap (\(dL->L _ (Warning _ ns _)) -> ns) decls + $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) @@ -477,9 +477,9 @@ checkCanonicalInstances cls poly_ty mbinds = do -- checkCanonicalMonadInstances | cls == applicativeClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = (dL->L _ name) + FunBind { fun_id = L _ name , fun_matches = mg } | name == pureAName, isAliasMG mg == Just returnMName -> addWarnNonCanonicalMethod1 @@ -492,9 +492,9 @@ checkCanonicalInstances cls poly_ty mbinds = do _ -> return () | cls == monadClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = (dL->L _ name) + FunBind { fun_id = L _ name , fun_matches = mg } | name == returnMName, isAliasMG mg /= Just pureAName -> addWarnNonCanonicalMethod2 @@ -523,9 +523,9 @@ checkCanonicalInstances cls poly_ty mbinds = do -- checkCanonicalMonoidInstances | cls == semigroupClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = (dL->L _ name) + FunBind { fun_id = L _ name , fun_matches = mg } | name == sappendName, isAliasMG mg == Just mappendName -> addWarnNonCanonicalMethod1 @@ -534,9 +534,9 @@ checkCanonicalInstances cls poly_ty mbinds = do _ -> return () | cls == monoidClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = (dL->L _ name) + FunBind { fun_id = L _ name , fun_matches = mg } | name == mappendName, isAliasMG mg /= Just sappendName -> addWarnNonCanonicalMethod2NoDefault @@ -549,10 +549,9 @@ checkCanonicalInstances cls poly_ty mbinds = do -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\" -- binding, and return @Just rhsName@ if this is the case isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name - isAliasMG MG {mg_alts = (dL->L _ - [dL->L _ (Match { m_pats = [] + isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = [] , m_grhss = grhss })])} - | GRHSs _ [dL->L _ (GRHS _ [] body)] lbinds <- grhss + | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss , EmptyLocalBinds _ <- unLoc lbinds , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) isAliasMG _ = Nothing @@ -612,7 +611,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' ; cls <- case hsTyGetAppHead_maybe head_ty' of - Just (dL->L _ cls) -> pure cls + Just (L _ cls) -> pure cls Nothing -> do -- The instance is malformed. We'd still like -- to make *some* progress (rather than failing outright), so @@ -794,7 +793,7 @@ rnTyFamInstEqn atfi ctf_info , feqn_rhs = rhs }}) = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs ; (eqn'@(HsIB { hsib_body = - FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs) + FamEqn { feqn_tycon = L _ tycon' }}), fvs) <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn ; case ctf_info of NotClosedTyFam -> pure () @@ -1041,15 +1040,15 @@ bindRuleTmVars doc tyvs vars names thing_inside = go vars names $ \ vars' -> bindLocalNamesFV names (thing_inside vars') where - go ((dL->L l (RuleBndr _ (dL->L loc _))) : vars) (n : ns) thing_inside + go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside = go vars ns $ \ vars' -> - thing_inside (cL l (RuleBndr noExtField (cL loc n)) : vars') + thing_inside (L l (RuleBndr noExtField (L loc n)) : vars') - go ((dL->L l (RuleBndrSig _ (dL->L loc _) bsig)) : vars) + go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) (n : ns) thing_inside = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' -> go vars ns $ \ vars' -> - thing_inside (cL l (RuleBndrSig noExtField (cL loc n) bsig') : vars') + thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars') go [] [] thing_inside = thing_inside [] go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) @@ -1474,12 +1473,12 @@ dupRoleAnnotErr list 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) where sorted_list = NE.sortBy cmp_annot list - ((dL->L loc first_decl) :| _) = sorted_list + ((L loc first_decl) :| _) = sorted_list - pp_role_annot (dL->L loc decl) = hang (ppr decl) + pp_role_annot (L loc decl) = hang (ppr decl) 4 (text "-- written at" <+> ppr loc) - cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 + cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2 dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () dupKindSig_Err list @@ -1489,12 +1488,12 @@ dupKindSig_Err list 2 (vcat $ map pp_kisig $ NE.toList sorted_list) where sorted_list = NE.sortBy cmp_loc list - ((dL->L loc first_decl) :| _) = sorted_list + ((L loc first_decl) :| _) = sorted_list - pp_kisig (dL->L loc decl) = + pp_kisig (L loc decl) = hang (ppr decl) 4 (text "-- written at" <+> ppr loc) - cmp_loc (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 + cmp_loc (L loc1 _) (L loc2 _) = loc1 `compare` loc2 {- Note [Role annotations in the renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1640,7 +1639,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). ; let sig_rdr_names_w_locs = - [op | (dL->L _ (ClassOpSig _ False ops _)) <- sigs + [op | L _ (ClassOpSig _ False ops _) <- sigs , op <- ops] ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only @@ -1750,15 +1749,15 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType } where h98_style = case condecls of -- Note [Stupid theta] - (dL->L _ (ConDeclGADT {})) : _ -> False - _ -> True + (L _ (ConDeclGADT {})) : _ -> False + _ -> True - rn_derivs (dL->L loc ds) + rn_derivs (L loc ds) = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) multipleDerivClausesErr ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds - ; return (cL loc ds', fvs) } + ; return (L loc ds', fvs) } rnDataDefn _ (XHsDataDefn nec) = noExtCon nec warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) @@ -1787,21 +1786,19 @@ warnNoDerivStrat mds loc rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs -> RnM (LHsDerivingClause GhcRn, FreeVars) rnLHsDerivingClause doc - (dL->L loc (HsDerivingClause + (L loc (HsDerivingClause { deriv_clause_ext = noExtField , deriv_clause_strategy = dcs - , deriv_clause_tys = (dL->L loc' dct) })) + , deriv_clause_tys = L loc' dct })) = do { (dcs', dct', fvs) <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct ; warnNoDerivStrat dcs' loc - ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExtField - , deriv_clause_strategy = dcs' - , deriv_clause_tys = cL loc' dct' }) + ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField + , deriv_clause_strategy = dcs' + , deriv_clause_tys = L loc' dct' }) , fvs ) } -rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause nec)) +rnLHsDerivingClause _ (L _ (XHsDerivingClause nec)) = noExtCon nec -rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match" - -- due to #15884 rnLDerivStrategy :: forall a. HsDocContext @@ -1811,10 +1808,10 @@ rnLDerivStrategy :: forall a. rnLDerivStrategy doc mds thing_inside = case mds of Nothing -> boring_case Nothing - Just (dL->L loc ds) -> + Just (L loc ds) -> setSrcSpan loc $ do (ds', thing, fvs) <- rn_deriv_strat ds - pure (Just (cL loc ds'), thing, fvs) + pure (Just (L loc ds'), thing, fvs) where rn_deriv_strat :: DerivStrategy GhcPs -> RnM (DerivStrategy GhcRn, a, FreeVars) @@ -1902,7 +1899,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars ---------------------- rn_info :: Located Name -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars) - rn_info (dL->L _ fam_name) (ClosedTypeFamily (Just eqns)) + rn_info (L _ fam_name) (ClosedTypeFamily (Just eqns)) = do { (eqns', fvs) <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name)) -- no class context @@ -1985,17 +1982,17 @@ rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in -> LFamilyResultSig GhcRn -- ^ Result signature -> LInjectivityAnn GhcPs -- ^ Injectivity annotation -> RnM (LInjectivityAnn GhcRn) -rnInjectivityAnn tvBndrs (dL->L _ (TyVarSig _ resTv)) - (dL->L srcSpan (InjectivityAnn injFrom injTo)) +rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) + (L srcSpan (InjectivityAnn injFrom injTo)) = do - { (injDecl'@(dL->L _ (InjectivityAnn injFrom' injTo')), noRnErrors) + { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors) <- askNoErrs $ bindLocalNames [hsLTyVarName resTv] $ -- The return type variable scopes over the injectivity annotation -- e.g. type family F a = (r::*) | r -> a do { injFrom' <- rnLTyVar injFrom ; injTo' <- mapM rnLTyVar injTo - ; return $ cL srcSpan (InjectivityAnn injFrom' injTo') } + ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs resName = hsLTyVarName resTv @@ -2031,12 +2028,12 @@ rnInjectivityAnn tvBndrs (dL->L _ (TyVarSig _ resTv)) -- -- So we rename injectivity annotation like we normally would except that -- this time we expect "result" to be reported not in scope by rnLTyVar. -rnInjectivityAnn _ _ (dL->L srcSpan (InjectivityAnn injFrom injTo)) = +rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) = setSrcSpan srcSpan $ do (injDecl', _) <- askNoErrs $ do injFrom' <- rnLTyVar injFrom injTo' <- mapM rnLTyVar injTo - return $ cL srcSpan (InjectivityAnn injFrom' injTo') + return $ L srcSpan (InjectivityAnn injFrom' injTo') return $ injDecl' {- @@ -2102,7 +2099,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs all_fvs) }} rnConDecl decl@(ConDeclGADT { con_names = names - , con_forall = (dL->L _ explicit_forall) + , con_forall = L _ explicit_forall , con_qvars = qtvs , con_mb_cxt = mcxt , con_args = args @@ -2178,12 +2175,12 @@ rnConDeclDetails _ doc (InfixCon ty1 ty2) ; (new_ty2, fvs2) <- rnLHsType doc ty2 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } -rnConDeclDetails con doc (RecCon (dL->L l fields)) +rnConDeclDetails con doc (RecCon (L l fields)) = do { fls <- lookupConstructorFields con ; (new_fields, fvs) <- rnConDeclFields doc fls fields -- No need to check for duplicate fields -- since that is done by RnNames.extendGlobalRdrEnvRn - ; return (RecCon (cL l new_fields), fvs) } + ; return (RecCon (L l new_fields), fvs) } ------------------------------------------------- @@ -2210,20 +2207,19 @@ extendPatSynEnv val_decls local_fix_env thing = do { -> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])] new_ps' bind names - | (dL->L bind_loc (PatSynBind _ (PSB { psb_id = (dL->L _ n) - , psb_args = RecCon as }))) <- bind + | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n + , psb_args = RecCon as }))) <- bind = do - bnd_name <- newTopSrcBinder (cL bind_loc n) + bnd_name <- newTopSrcBinder (L bind_loc n) let rnames = map recordPatSynSelectorId as mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs - mkFieldOcc (dL->L l name) = cL l (FieldOcc noExtField (cL l name)) + mkFieldOcc (L l name) = L l (FieldOcc noExtField (L l name)) field_occs = map mkFieldOcc rnames flds <- mapM (newRecordSelector False [bnd_name]) field_occs return ((bnd_name, flds): names) - | (dL->L bind_loc (PatSynBind _ - (PSB { psb_id = (dL->L _ n)}))) <- bind + | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind = do - bnd_name <- newTopSrcBinder (cL bind_loc n) + bnd_name <- newTopSrcBinder (L bind_loc n) return ((bnd_name, []): names) | otherwise = return names @@ -2249,9 +2245,9 @@ rnHsTyVars :: [Located RdrName] -> RnM [Located Name] rnHsTyVars tvs = mapM rnHsTyVar tvs rnHsTyVar :: Located RdrName -> RnM (Located Name) -rnHsTyVar (dL->L l tyvar) = do +rnHsTyVar (L l tyvar) = do tyvar' <- lookupOccRn tyvar - return (cL l tyvar') + return (L l tyvar') {- ********************************************************* @@ -2274,7 +2270,7 @@ addl :: HsGroup GhcPs -> [LHsDecl GhcPs] -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) -- This stuff reverses the declarations (again) but it doesn't matter addl gp [] = return (gp, Nothing) -addl gp ((dL->L l d) : ds) = add gp l d ds +addl gp (L l d : ds) = add gp l d ds add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] @@ -2282,7 +2278,7 @@ add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] -- #10047: Declaration QuasiQuoters are expanded immediately, without -- causing a group split -add gp _ (SpliceD _ (SpliceDecl _ (dL->L _ qq@HsQuasiQuote{}) _)) ds +add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds = do { (ds', _) <- rnTopSpliceDecls qq ; addl gp (ds' ++ ds) } @@ -2308,52 +2304,52 @@ add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds -- Class declarations: pull out the fixity signatures to the top add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds | isClassDecl d - = let fsigs = [ cL l f - | (dL->L l (FixSig _ f)) <- tcdSigs d ] in - addl (gp { hs_tyclds = add_tycld (cL l d) ts, hs_fixds = fsigs ++ fs}) ds + = let fsigs = [ L l f + | L l (FixSig _ f) <- tcdSigs d ] in + addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds | otherwise - = addl (gp { hs_tyclds = add_tycld (cL l d) ts }) ds + = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds -- Signatures: fixity sigs go a different place than all others add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds - = addl (gp {hs_fixds = cL l f : ts}) ds + = addl (gp {hs_fixds = L l f : ts}) ds -- Standalone kind signatures: added to the TyClGroup add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds - = addl (gp {hs_tyclds = add_kisig (cL l s) ts}) ds + = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds - = addl (gp {hs_valds = add_sig (cL l d) ts}) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds -- Value declarations: use add_bind add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds - = addl (gp { hs_valds = add_bind (cL l d) ts }) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds -- Role annotations: added to the TyClGroup add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds - = addl (gp { hs_tyclds = add_role_annot (cL l d) ts }) ds + = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds -- NB instance declarations go into TyClGroups. We throw them into the first -- group, just as we do for the TyClD case. The renamer will go on to group -- and order them later. add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds - = addl (gp { hs_tyclds = add_instd (cL l d) ts }) ds + = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds -- The rest are routine add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds - = addl (gp { hs_derivds = cL l d : ts }) ds + = addl (gp { hs_derivds = L l d : ts }) ds add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds - = addl (gp { hs_defds = cL l d : ts }) ds + = addl (gp { hs_defds = L l d : ts }) ds add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds - = addl (gp { hs_fords = cL l d : ts }) ds + = addl (gp { hs_fords = L l d : ts }) ds add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds - = addl (gp { hs_warnds = cL l d : ts }) ds + = addl (gp { hs_warnds = L l d : ts }) ds add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds - = addl (gp { hs_annds = cL l d : ts }) ds + = addl (gp { hs_annds = L l d : ts }) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds - = addl (gp { hs_ruleds = cL l d : ts }) ds + = addl (gp { hs_ruleds = L l d : ts }) ds add gp l (DocD _ d) ds - = addl (gp { hs_docs = (cL l d) : (hs_docs gp) }) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec add (HsGroup {}) _ (XHsDecl nec) _ = noExtCon nec add (XHsGroup nec) _ _ _ = noExtCon nec diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index d9cc28ee7b..6319a8ce10 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -361,13 +361,13 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter q_span quote - = cL q_span $ HsApp noExtField (cL q_span - $ HsApp noExtField (cL q_span (HsVar noExtField (cL q_span quote_selector))) - quoterExpr) - quoteExpr + = L q_span $ HsApp noExtField (L q_span + $ HsApp noExtField (L q_span (HsVar noExtField (L q_span quote_selector))) + quoterExpr) + quoteExpr where - quoterExpr = cL q_span $! HsVar noExtField $! (cL q_span quoter) - quoteExpr = cL q_span $! HsLit noExtField $! HsString NoSourceText quote + quoterExpr = L q_span $! HsVar noExtField $! (L q_span quoter) + quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName UntypedPatSplice -> quotePatName @@ -379,19 +379,19 @@ rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) -- Not exported...used for all rnSplice (HsTypedSplice x hasParen splice_name expr) = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (cL loc splice_name) + ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsTypedSplice x hasParen n' expr', fvs) } rnSplice (HsUntypedSplice x hasParen splice_name expr) = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (cL loc splice_name) + ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsUntypedSplice x hasParen n' expr', fvs) } rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) = do { loc <- getSrcSpanM - ; splice_name' <- newLocalBndrRn (cL loc splice_name) + ; splice_name' <- newLocalBndrRn (L loc splice_name) -- Rename the quoter; akin to the HsVar case of rnExpr ; quoter' <- lookupOccRn quoter @@ -620,7 +620,7 @@ rnSplicePat splice -- See Note [Delaying modFinalizers in untyped splices]. ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField) . HsSpliced noExtField (ThModFinalizers mod_finalizers) - . HsSplicedPat) `onHasSrcSpan` + . HsSplicedPat) `mapLoc` pat , emptyFVs ) } @@ -629,12 +629,12 @@ rnSplicePat splice ---------------------- rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) -rnSpliceDecl (SpliceDecl _ (dL->L loc splice) flg) +rnSpliceDecl (SpliceDecl _ (L loc splice) flg) = rnSpliceGen run_decl_splice pend_decl_splice splice where pend_decl_splice rn_splice = ( makePending UntypedDeclSplice rn_splice - , SpliceDecl noExtField (cL loc rn_splice) flg) + , SpliceDecl noExtField (L loc rn_splice) flg) run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) rnSpliceDecl (XSpliceDecl nec) = noExtCon nec @@ -739,8 +739,8 @@ traceSplice :: SpliceInfo -> TcM () traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src , spliceGenerated = gen, spliceIsDecl = is_decl }) = do { loc <- case mb_src of - Nothing -> getSrcSpanM - Just (dL->L loc _) -> return loc + Nothing -> getSrcSpanM + Just (L loc _) -> return loc ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) ; when is_decl $ -- Raw material for -dth-dec-file diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 1e7d101089..724dea866d 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -164,10 +164,10 @@ rnWcBody ctxt nwc_rdrs hs_ty rn_lty env hs_ty ; return (nwcs, hs_ty', fvs) } where - rn_lty env (dL->L loc hs_ty) + rn_lty env (L loc hs_ty) = setSrcSpan loc $ do { (hs_ty', fvs) <- rn_ty env hs_ty - ; return (cL loc hs_ty', fvs) } + ; return (L loc hs_ty', fvs) } rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -- A lot of faff just to allow the extra-constraints wildcard to appear @@ -179,23 +179,23 @@ rnWcBody ctxt nwc_rdrs hs_ty , hst_bndrs = tvs', hst_body = hs_body' } , fvs) } - rn_ty env (HsQualTy { hst_ctxt = dL->L cx hs_ctxt + rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt , hst_body = hs_ty }) | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt - , (dL->L lx (HsWildCardTy _)) <- ignoreParens hs_ctxt_last + , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1 - ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExtField)] + ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)] ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty ; return (HsQualTy { hst_xqual = noExtField - , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' } + , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } | otherwise = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty ; return (HsQualTy { hst_xqual = noExtField - , hst_ctxt = cL cx hs_ctxt' + , hst_ctxt = L cx hs_ctxt' , hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } @@ -336,7 +336,7 @@ rnImplicitBndrs bind_free_tvs vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ] ; loc <- getSrcSpanM - ; vars <- mapM (newLocalBndrRn . cL loc . unLoc) real_fvs + ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_fvs ; bindLocalNamesFV vars $ thing_inside vars } @@ -467,11 +467,11 @@ rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args -------------- rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars) -rnTyKiContext env (dL->L loc cxt) +rnTyKiContext env (L loc cxt) = do { traceRn "rncontext" (ppr cxt) ; let env' = env { rtke_what = RnConstraint } ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt - ; return (cL loc cxt', fvs) } + ; return (L loc cxt', fvs) } rnContext :: HsDocContext -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars) @@ -479,10 +479,10 @@ rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta -------------- rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) -rnLHsTyKi env (dL->L loc ty) +rnLHsTyKi env (L loc ty) = setSrcSpan loc $ do { (ty', fvs) <- rnHsTyKi env ty - ; return (cL loc ty', fvs) } + ; return (L loc ty', fvs) } rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) @@ -504,7 +504,7 @@ rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) , hst_body = tau' } , fvs1 `plusFV` fvs2) } -rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name)) +rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ unlessXOptM LangExt.PolyKinds $ addErr $ withHsDocContext (rtke_ctxt env) $ @@ -513,7 +513,7 @@ rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name)) -- Any type variable at the kind level is illegal without the use -- of PolyKinds (see #14710) ; name <- rnTyVar env rdr_name - ; return (HsTyVar noExtField ip (cL loc name), unitFV name) } + ; return (HsTyVar noExtField ip (L loc name), unitFV name) } rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) = setSrcSpan (getLoc l_op) $ @@ -660,20 +660,20 @@ rnTyVar env rdr_name rnLTyVar :: Located RdrName -> RnM (Located Name) -- Called externally; does not deal with wildards -rnLTyVar (dL->L loc rdr_name) +rnLTyVar (L loc rdr_name) = do { tyvar <- lookupTypeOccRn rdr_name - ; return (cL loc tyvar) } + ; return (L loc tyvar) } -------------- rnHsTyOp :: Outputable a => RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars) -rnHsTyOp env overall_ty (dL->L loc op) +rnHsTyOp env overall_ty (L loc op) = do { ops_ok <- xoptM LangExt.TypeOperators ; op' <- rnTyVar env op ; unless (ops_ok || op' `hasKey` eqTyConKey) $ addErr (opTyErr op overall_ty) - ; let l_op' = cL loc op' + ; let l_op' = L loc op' ; return (l_op', unitFV op') } -------------- @@ -989,35 +989,33 @@ bindLHsTyVarBndr :: HsDocContext -> LHsTyVarBndr GhcPs -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) -> RnM (b, FreeVars) -bindLHsTyVarBndr _doc mb_assoc (dL->L loc +bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar x - lrdr@(dL->L lv _))) thing_inside + lrdr@(L lv _))) thing_inside = do { nm <- newTyVarNameRn mb_assoc lrdr ; bindLocalNamesFV [nm] $ - thing_inside (cL loc (UserTyVar x (cL lv nm))) } + thing_inside (L loc (UserTyVar x (L lv nm))) } -bindLHsTyVarBndr doc mb_assoc (dL->L loc (KindedTyVar x lrdr@(dL->L lv _) kind)) +bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind)) thing_inside = do { sig_ok <- xoptM LangExt.KindSignatures ; unless sig_ok (badKindSigErr doc kind) ; (kind', fvs1) <- rnLHsKind doc kind ; tv_nm <- newTyVarNameRn mb_assoc lrdr ; (b, fvs2) <- bindLocalNamesFV [tv_nm] - $ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind')) + $ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind')) ; return (b, fvs1 `plusFV` fvs2) } -bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr nec)) _ = noExtCon nec -bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match" - -- due to #15884 +bindLHsTyVarBndr _ _ (L _ (XTyVarBndr nec)) _ = noExtCon nec newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name -newTyVarNameRn mb_assoc (dL->L loc rdr) +newTyVarNameRn mb_assoc (L loc rdr) = do { rdr_env <- getLocalRdrEnv ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of (Just _, Just n) -> return n -- Use the same Name as the parent class decl - _ -> newLocalBndrRn (cL loc rdr) } + _ -> newLocalBndrRn (L loc rdr) } {- ********************************************************* * * @@ -1044,23 +1042,21 @@ rnConDeclFields ctxt fls fields rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs -> RnM (LConDeclField GhcRn, FreeVars) -rnField fl_env env (dL->L l (ConDeclField _ names ty haddock_doc)) +rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) = do { let new_names = map (fmap lookupField) names ; (new_ty, fvs) <- rnLHsTyKi env ty ; new_haddock_doc <- rnMbLHsDoc haddock_doc - ; return (cL l (ConDeclField noExtField new_names new_ty new_haddock_doc) + ; return (L l (ConDeclField noExtField new_names new_ty new_haddock_doc) , fvs) } where lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn - lookupField (FieldOcc _ (dL->L lr rdr)) = - FieldOcc (flSelector fl) (cL lr rdr) + lookupField (FieldOcc _ (L lr rdr)) = + FieldOcc (flSelector fl) (L lr rdr) where lbl = occNameFS $ rdrNameOcc rdr fl = expectJust "rnField" $ lookupFsEnv fl_env lbl lookupField (XFieldOcc nec) = noExtCon nec -rnField _ _ (dL->L _ (XConDeclField nec)) = noExtCon nec -rnField _ _ _ = panic "rnField: Impossible Match" - -- due to #15884 +rnField _ _ (L _ (XConDeclField nec)) = noExtCon nec {- ************************************************************************ @@ -1094,13 +1090,13 @@ mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn) -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExtField ty21 op2 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExtField ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 (\t1 t2 -> HsOpTy noExtField t1 op2 t2) (unLoc op2) fix2 ty21 ty22 loc2 } -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsFunTy _ ty21 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22)) = mk_hs_op_ty mk1 pp_op1 fix1 ty1 (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2 @@ -1116,8 +1112,8 @@ mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) mk_hs_op_ty mk1 op1 fix1 ty1 mk2 op2 fix2 ty21 ty22 loc2 | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2) - ; return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) } - | associate_right = return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) + ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } + | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 ; return (mk2 (noLoc new_ty) ty22) } @@ -1133,35 +1129,35 @@ mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged -> RnM (HsExpr GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpAppRn e1@(dL->L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 +mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) return (OpApp fix2 e1 op2 e2) | associate_right = do new_e <- mkOpAppRn e12 op2 fix2 e2 - return (OpApp fix1 e11 op1 (cL loc' new_e)) + return (OpApp fix1 e11 op1 (L loc' new_e)) where loc'= combineLocs e12 e2 (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- -- (- neg_arg) `op` e2 -mkOpAppRn e1@(dL->L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 +mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 | nofix_error = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) return (OpApp fix2 e1 op2 e2) | associate_right = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 - return (NegApp noExtField (cL loc' new_e) neg_name) + return (NegApp noExtField (L loc' new_e) neg_name) where loc' = combineLocs neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- -- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(dL->L _ (NegApp {})) -- NegApp can occur on the right +mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right | not associate_right -- We *want* right association = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) return (OpApp fix1 e1 op1 e2) @@ -1194,10 +1190,10 @@ instance Outputable OpName where get_op :: LHsExpr GhcRn -> OpName -- An unbound name could be either HsVar or HsUnboundVar -- See RnExpr.rnUnboundVar -get_op (dL->L _ (HsVar _ n)) = NormalOp (unLoc n) -get_op (dL->L _ (HsUnboundVar _ uv)) = UnboundOp uv -get_op (dL->L _ (HsRecFld _ fld)) = RecFldOp fld -get_op other = pprPanic "get_op" (ppr other) +get_op (L _ (HsVar _ n)) = NormalOp (unLoc n) +get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv +get_op (L _ (HsRecFld _ fld)) = RecFldOp fld +get_op other = pprPanic "get_op" (ppr other) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to @@ -1229,9 +1225,9 @@ mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged -> RnM (HsCmd GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(dL->L loc +mkOpFormRn a1@(L loc (HsCmdTop _ - (dL->L _ (HsCmdArrForm x op1 f (Just fix1) + (L _ (HsCmdArrForm x op1 f (Just fix1) [a11,a12])))) op2 fix2 a2 | nofix_error @@ -1241,7 +1237,7 @@ mkOpFormRn a1@(dL->L loc | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 return (HsCmdArrForm noExtField op1 f (Just fix1) - [a11, cL loc (HsCmdTop [] (cL loc new_c))]) + [a11, L loc (HsCmdTop [] (L loc new_c))]) -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1255,7 +1251,7 @@ mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn) -mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2 +mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 = do { fix1 <- lookupFixityRn (unLoc op1) ; let (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1266,7 +1262,7 @@ mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2 else if associate_right then do { new_p <- mkConOpPatRn op2 fix2 p12 p2 - ; return (ConPatIn op1 (InfixCon p11 (cL loc new_p))) } + ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right? else return (ConPatIn op2 (InfixCon p1 p2)) } @@ -1284,12 +1280,12 @@ checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM () -- eg a `op` b `C` c = ... -- See comments with rnExpr (OpApp ...) about "deriving" -checkPrecMatch op (MG { mg_alts = (dL->L _ ms) }) +checkPrecMatch op (MG { mg_alts = (L _ ms) }) = mapM_ check ms where - check (dL->L _ (Match { m_pats = (dL->L l1 p1) - : (dL->L l2 p2) - : _ })) + check (L _ (Match { m_pats = (L l1 p1) + : (L l2 p2) + : _ })) = setSrcSpan (combineSrcSpans l1 l2) $ do checkPrec op p1 False checkPrec op p2 True @@ -1398,7 +1394,7 @@ unexpectedTypeSigErr ty 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () -badKindSigErr doc (dL->L loc ty) +badKindSigErr doc (L loc ty) = setSrcSpan loc $ addErr $ withHsDocContext doc $ hang (text "Illegal kind signature:" <+> quotes (ppr ty)) @@ -1416,7 +1412,7 @@ inTypeDoc :: HsType GhcPs -> SDoc inTypeDoc ty = text "In the type" <+> quotes (ppr ty) warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM () -warnUnusedForAll in_doc (dL->L loc tv) used_names +warnUnusedForAll in_doc (L loc tv) used_names = whenWOptM Opt_WarnUnusedForalls $ unless (hsTyVarName tv `elemNameSet` used_names) $ addWarnAt (Reason Opt_WarnUnusedForalls) loc $ @@ -1668,9 +1664,9 @@ extractHsTyVarBndrsKVs tv_bndrs -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName] -extractRdrKindSigVars (dL->L _ resultSig) - | KindSig _ k <- resultSig = extractHsTyRdrTyVars k - | TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k +extractRdrKindSigVars (L _ resultSig) + | KindSig _ k <- resultSig = extractHsTyRdrTyVars k + | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k | otherwise = [] -- Get type/kind variables mentioned in the kind signature, preserving @@ -1695,7 +1691,7 @@ extract_ltys tys acc = foldr extract_lty acc tys extract_lty :: LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_lty (dL->L _ ty) acc +extract_lty (L _ ty) acc = case ty of HsTyVar _ _ ltv -> extract_tv ltv acc HsBangTy _ _ ty -> extract_lty ty acc @@ -1767,7 +1763,7 @@ extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName] -- the function returns [k1,k2], even though k1 is bound here extract_hs_tv_bndrs_kvs tv_bndrs = foldr extract_lty [] - [k | (dL->L _ (KindedTyVar _ _ k)) <- tv_bndrs] + [k | L _ (KindedTyVar _ _ k) <- tv_bndrs] extract_tv :: Located RdrName -> [Located RdrName] -> [Located RdrName] diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs index 0da8e30f6a..88996e31b1 100644 --- a/compiler/rename/RnUtils.hs +++ b/compiler/rename/RnUtils.hs @@ -66,7 +66,7 @@ import qualified GHC.LanguageExtensions as LangExt newLocalBndrRn :: Located RdrName -> RnM Name -- Used for non-top-level binders. These should -- never be qualified. -newLocalBndrRn (dL->L loc rdr_name) +newLocalBndrRn (L loc rdr_name) | Just name <- isExact_maybe rdr_name = return name -- This happens in code generated by Template Haskell -- See Note [Binders in Template Haskell] in Convert.hs @@ -127,7 +127,7 @@ checkShadowedRdrNames loc_rdr_names where filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names -- See Note [Binders in Template Haskell] in Convert - get_loc_occ (dL->L loc rdr) = (loc,rdrNameOcc rdr) + get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () checkDupAndShadowedNames envs names -- cgit v1.2.1