diff options
Diffstat (limited to 'compiler/rename/RnPat.hs')
| -rw-r--r-- | compiler/rename/RnPat.hs | 133 |
1 files changed, 75 insertions, 58 deletions
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index a80a6982eb..ba19c4ebff 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -10,9 +10,12 @@ general, all of these functions return a renamed thing, and a set of free variables. -} -{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} module RnPat (-- main entry points rnPat, rnPats, rnBindPat, rnPatAndThen, @@ -126,12 +129,13 @@ liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing ; (r,fvs2) <- k v ; return (r, fvs1 `plusFV` fvs2) }) -wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b) +wrapSrcSpanCps :: (HasSrcSpan a, HasSrcSpan b) => + (SrcSpanLess a -> CpsRn (SrcSpanLess b)) -> a -> CpsRn b -- Set the location, and also wrap it around the value returned -wrapSrcSpanCps fn (L loc a) +wrapSrcSpanCps fn (dL->L loc a) = CpsRn (\k -> setSrcSpan loc $ unCpsRn (fn a) $ \v -> - k (L loc v)) + k (cL loc v)) lookupConCps :: Located RdrName -> CpsRn (Located Name) lookupConCps con_rdr @@ -216,9 +220,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@(L loc _) +newPatLName name_maker rdr_name@(dL->L loc _) = do { name <- newPatName name_maker rdr_name - ; return (L loc name) } + ; return (cL loc name) } newPatName :: NameMaker -> Located RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name @@ -387,9 +391,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 (L l rdr)) = do { loc <- liftCps getSrcSpanM - ; name <- newPatName mk (L loc rdr) - ; return (VarPat x (L l name)) } +rnPatAndThen mk (VarPat x (dL->L l rdr)) + = do { loc <- liftCps getSrcSpanM + ; name <- newPatName mk (cL loc rdr) + ; return (VarPat x (cL 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) @@ -419,7 +424,7 @@ rnPatAndThen mk (LitPat x lit) where normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) } -rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) +rnPatAndThen _ (NPat x (dL->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 @@ -431,9 +436,9 @@ rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) (Nothing, Nothing) -> positive (Just _ , Just _ ) -> positive ; eq' <- liftCpsFV $ lookupSyntaxName eqName - ; return (NPat x (L l lit') mb_neg' eq') } + ; return (NPat x (cL l lit') mb_neg' eq') } -rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) +rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ ) = do { new_name <- newPatName mk rdr ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] -- We skip negateName as @@ -441,8 +446,8 @@ rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) -- sense in n + k patterns ; minus <- liftCpsFV $ lookupSyntaxName minusName ; ge <- liftCpsFV $ lookupSyntaxName geName - ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name) - (L l lit') lit' ge minus) } + ; return (NPlusKPat x (cL (nameSrcSpan new_name) new_name) + (cL l lit') lit' ge minus) } -- The Report says that n+k patterns must be in Integral rnPatAndThen mk (AsPat x rdr pat) @@ -529,16 +534,17 @@ rnHsRecPatsAndThen :: NameMaker -> Located Name -- Constructor -> HsRecFields GhcPs (LPat GhcPs) -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) -rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) +rnHsRecPatsAndThen mk (dL->L _ con) + hs_rec_fields@(HsRecFields { rec_dotdot = dd }) = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat hs_rec_fields ; flds' <- mapM rn_field (flds `zip` [1..]) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } where - mkVarPat l n = VarPat noExt (L l n) - rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') - (hsRecFieldArg fld) - ; return (L l (fld { hsRecFieldArg = arg' })) } + mkVarPat l n = VarPat noExt (cL l n) + rn_field (dL->L l fld, n') = + do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) + ; return (cL l (fld { hsRecFieldArg = arg' })) } -- Suppress unused-match reporting for fields introduced by ".." nested_mk Nothing mk _ = mk @@ -559,12 +565,12 @@ data HsRecFieldContext | HsRecFieldUpd rnHsRecFields - :: forall arg. + :: forall arg. HasSrcSpan arg => HsRecFieldContext - -> (SrcSpan -> RdrName -> arg) + -> (SrcSpan -> RdrName -> SrcSpanLess arg) -- When punning, use this to build a new field - -> HsRecFields GhcPs (Located arg) - -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars) + -> HsRecFields GhcPs arg + -> RnM ([LHsRecField GhcRn arg], FreeVars) -- This surprisingly complicated pass -- a) looks up the field name (possibly using disambiguation) @@ -590,31 +596,37 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) HsRecFieldPat con -> Just con _ {- update -} -> Nothing - rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg) - -> RnM (LHsRecField GhcRn (Located arg)) - rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl - = L loc (FieldOcc _ (L ll lbl)) - , hsRecFieldArg = arg - , hsRecPun = pun })) + rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs arg + -> RnM (LHsRecField GhcRn arg) + rn_fld pun_ok parent (dL->L l + (HsRecField + { hsRecFieldLbl = + (dL->L loc (FieldOcc _ (dL->L ll lbl))) + , hsRecFieldArg = arg + , hsRecPun = pun })) = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl ; arg' <- if pun - then do { checkErr pun_ok (badPun (L loc lbl)) + then do { checkErr pun_ok (badPun (cL loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L loc (mk_arg loc arg_rdr)) } + ; return (cL loc (mk_arg loc arg_rdr)) } else return arg - ; return (L l (HsRecField { hsRecFieldLbl - = L loc (FieldOcc sel (L ll lbl)) - , hsRecFieldArg = arg' - , hsRecPun = pun })) } - rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) + ; return (cL l (HsRecField + { hsRecFieldLbl = (cL loc (FieldOcc + sel (cL ll lbl))) + , hsRecFieldArg = arg' + , hsRecPun = pun })) } + rn_fld _ _ (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) = panic "rnHsRecFields" + rn_fld _ _ _ = panic "rn_fld: Impossible Match" + -- due to #15884 + rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat -> Maybe Name -- The constructor (Nothing for an -- out of scope constructor) - -> [LHsRecField GhcRn (Located arg)] -- Explicit fields - -> RnM [LHsRecField GhcRn (Located arg)] -- Filled in .. fields + -> [LHsRecField GhcRn arg] -- Explicit fields + -> RnM [LHsRecField GhcRn arg] -- Filled in .. fields rn_dotdot (Just 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 @@ -648,9 +660,9 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) _other -> True ] ; addUsedGREs dot_dot_gres - ; return [ L loc (HsRecField - { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr)) - , hsRecFieldArg = L loc (mk_arg loc arg_rdr) + ; return [ cL loc (HsRecField + { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr)) + , hsRecFieldArg = cL loc (mk_arg loc arg_rdr) , hsRecPun = False }) | fl <- dot_dot_fields , let sel = flSelector fl @@ -695,25 +707,28 @@ rnHsRecUpdFields flds rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs -> RnM (LHsRecUpdField GhcRn, FreeVars) - rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f - , hsRecFieldArg = arg - , hsRecPun = pun })) + rn_fld pun_ok overload_ok (dL->L l (HsRecField { hsRecFieldLbl = dL->L loc f + , hsRecFieldArg = arg + , hsRecPun = pun })) = do { let lbl = rdrNameAmbiguousFieldOcc f ; sel <- setSrcSpan loc $ -- Defer renaming of overloaded fields to the typechecker -- See Note [Disambiguating record fields] in TcExpr if overload_ok - then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl + then do { mb <- lookupGlobalOccRn_overloaded + overload_ok lbl ; case mb of - Nothing -> do { addErr (unknownSubordinateErr doc lbl) - ; return (Right []) } + Nothing -> + do { addErr + (unknownSubordinateErr doc lbl) + ; return (Right []) } Just r -> return r } else fmap Left $ lookupGlobalOccRn lbl ; arg' <- if pun - then do { checkErr pun_ok (badPun (L loc lbl)) + then do { checkErr pun_ok (badPun (cL loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L loc (HsVar noExt (L loc arg_rdr))) } + ; return (cL loc (HsVar noExt (cL loc arg_rdr))) } else return arg ; (arg'', fvs) <- rnLExpr arg' @@ -723,14 +738,14 @@ rnHsRecUpdFields flds Right _ -> fvs lbl' = case sel of Left sel_name -> - L loc (Unambiguous sel_name (L loc lbl)) + cL loc (Unambiguous sel_name (cL loc lbl)) Right [sel_name] -> - L loc (Unambiguous sel_name (L loc lbl)) - Right _ -> L loc (Ambiguous noExt (L loc lbl)) + cL loc (Unambiguous sel_name (cL loc lbl)) + Right _ -> cL loc (Ambiguous noExt (cL loc lbl)) - ; return (L l (HsRecField { hsRecFieldLbl = lbl' - , hsRecFieldArg = arg'' - , hsRecPun = pun }), fvs') } + ; return (cL l (HsRecField { hsRecFieldLbl = lbl' + , hsRecFieldArg = arg'' + , hsRecPun = pun }), fvs') } dup_flds :: [NE.NonEmpty RdrName] -- Each list represents a RdrName that occurred more than once @@ -797,7 +812,9 @@ rnLit _ = return () -- Integer-looking literal. generalizeOverLitVal :: OverLitVal -> OverLitVal generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val})) - | denominator val == 1 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val}) + | denominator val == 1 = HsIntegral (IL { il_text=src + , il_neg=neg + , il_value=numerator val}) generalizeOverLitVal lit = lit isNegativeZeroOverLit :: HsOverLit t -> Bool @@ -831,8 +848,8 @@ rnOverLit origLit ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1) <- lookupSyntaxName std_name ; let rebindable = case from_thing_name of - HsVar _ (L _ v) -> v /= std_name - _ -> panic "rnOverLit" + HsVar _ lv -> (unLoc lv) /= std_name + _ -> panic "rnOverLit" ; let lit' = lit { ol_witness = from_thing_name , ol_ext = rebindable } ; if isNegativeZeroOverLit lit' |