diff options
author | Josh Meredith <joshmeredith2008@gmail.com> | 2019-12-04 23:39:28 +1100 |
---|---|---|
committer | Josh Meredith <joshmeredith2008@gmail.com> | 2019-12-04 23:39:28 +1100 |
commit | a8435165b84c32fd2ebdd1281dd6ee077e07ad5a (patch) | |
tree | 791936d014aeaa26174c2dcbef34c14f3329dd04 /compiler/rename | |
parent | 7805441b4d5e22eb63a501e1e40383d10380dc92 (diff) | |
parent | f03a41d4bf9418ee028ecb51654c928b2da74edd (diff) | |
download | haskell-wip/binary-readerT.tar.gz |
Merge branch 'master' into wip/binary-readerTwip/binary-readerT
Diffstat (limited to 'compiler/rename')
-rw-r--r-- | compiler/rename/RnEnv.hs | 10 | ||||
-rw-r--r-- | compiler/rename/RnExpr.hs | 19 | ||||
-rw-r--r-- | compiler/rename/RnHsDoc.hs | 4 | ||||
-rw-r--r-- | compiler/rename/RnNames.hs | 2 | ||||
-rw-r--r-- | compiler/rename/RnPat.hs | 99 | ||||
-rw-r--r-- | compiler/rename/RnSource.hs | 156 | ||||
-rw-r--r-- | compiler/rename/RnSplice.hs | 30 | ||||
-rw-r--r-- | compiler/rename/RnTypes.hs | 128 | ||||
-rw-r--r-- | compiler/rename/RnUtils.hs | 4 |
9 files changed, 223 insertions, 229 deletions
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index c84e7bd328..00a76df77a 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -1137,7 +1137,7 @@ constructor namespace before looking in the data constructor namespace to deal with `DataKinds`. There is however, as always, one exception to this scheme. If we find -an ambiguous occurence of a record selector and DuplicateRecordFields +an ambiguous occurrence of a record selector and DuplicateRecordFields is enabled then we defer the selection until the typechecker. -} @@ -1555,7 +1555,13 @@ dataTcOccs rdr_name = [rdr_name] where occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName + rdr_name_tc = + case rdr_name of + -- The (~) type operator is always in scope, so we need a special case + -- for it here, or else :info (~) fails in GHCi. + -- See Note [eqTyCon (~) is built-in syntax] + Unqual occ | occNameFS occ == fsLit "~" -> eqTyCon_RDR + _ -> setRdrNameSpace rdr_name tcName {- Note [dataTcOccs and Exact Names] diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index d3f72fff47..693d818f67 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -232,16 +232,15 @@ rnExpr expr@(SectionR {}) = do { addErr (sectionErr expr); rnSection expr } --------------------------------------------- -rnExpr (HsCoreAnn x src ann expr) +rnExpr (HsPragE x prag expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsCoreAnn x src ann expr', fvs_expr) } - -rnExpr (HsSCC x src lbl expr) - = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsSCC x src lbl expr', fvs_expr) } -rnExpr (HsTickPragma x src info srcInfo expr) - = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsTickPragma x src info srcInfo expr', fvs_expr) } + ; return (HsPragE x (rn_prag prag) expr', fvs_expr) } + where + rn_prag :: HsPragE GhcPs -> HsPragE GhcRn + rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann + rn_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl + rn_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo + rn_prag (XHsPragE x) = noExtCon x rnExpr (HsLam x matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches @@ -1369,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/RnNames.hs b/compiler/rename/RnNames.hs index 8d1083a547..7614fb1932 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -92,7 +92,7 @@ mode changes, this triggers a recompilation from that module in the dependcy graph. So we can just worry mostly about direct imports. There is one trust property that can change for a package though without -recompliation being triggered: package trust. So we must check that all +recompilation being triggered: package trust. So we must check that all packages a module tranitively depends on to be trusted are still trusted when we are compiling this module (as due to recompilation avoidance some modules below may not be considered trusted any more without recompilation being 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 791b6a4ceb..a166a65bfb 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 @@ -686,7 +685,7 @@ rnFamInstEqn doc atfi rhs_kvars ; tycon' <- lookupFamInstName mb_cls tycon ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats -- Use the "...Dups" form because it's needed - -- below to report unsed binder on the LHS + -- below to report unused binder on the LHS -- Implicitly bound variables, empty if we have an explicit 'forall' according -- to the "forall-or-nothing" rule. @@ -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) @@ -1232,7 +1231,7 @@ Why do the instance declarations participate? At least two reasons the type synonym S. While we know that S depends upon 'Q depends upon Closed, we have no idea that Closed depends upon Open! - To accomodate for these situations, we ensure that an instance is checked + To accommodate for these situations, we ensure that an instance is checked before every @TyClDecl@ on which it does not depend. That's to say, instances are checked as early as possible in @tcTyAndClassDecls@. @@ -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 3e6d64751d..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 @@ -753,7 +753,7 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src spliceDebugDoc loc = let code = case mb_src of Nothing -> ending - Just e -> nest 2 (ppr e) : ending + Just e -> nest 2 (ppr (stripParensHsExpr e)) : ending ending = [ text "======>", nest 2 gen ] in hang (ppr loc <> colon <+> text "Splicing" <+> text sd) 2 (sep code) diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 434ed496f1..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 $ @@ -1653,7 +1649,7 @@ extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups extractHsTysRdrTyVarsDups tys = extract_ltys tys [] --- Returns the free kind variables of any explictly-kinded binders, returning +-- Returns the free kind variables of any explicitly-kinded binders, returning -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. -- NB: Does /not/ delete the binders themselves. @@ -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 @@ -1758,7 +1754,7 @@ extract_hs_tv_bndrs tv_bndrs acc_vars body_vars tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName] --- Returns the free kind variables of any explictly-kinded binders, returning +-- Returns the free kind variables of any explicitly-kinded binders, returning -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. -- NB: Does /not/ delete the binders themselves. @@ -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 |