Commit 5aba5d32 authored by Vladislav Zavialov's avatar Vladislav Zavialov Committed by Marge Bot

Remove HasSrcSpan (#17494)

Metric Decrease:
    haddock.compiler
parent 316f2431
Pipeline #13331 failed with stages
in 44 seconds
...@@ -920,7 +920,7 @@ ppr_expr (SectionR _ op expr) ...@@ -920,7 +920,7 @@ ppr_expr (SectionR _ op expr)
ppr_expr (ExplicitTuple _ exprs boxity) ppr_expr (ExplicitTuple _ exprs boxity)
-- Special-case unary boxed tuples so that they are pretty-printed as -- Special-case unary boxed tuples so that they are pretty-printed as
-- `Unit x`, not `(x)` -- `Unit x`, not `(x)`
| [dL -> L _ (Present _ expr)] <- exprs | [L _ (Present _ expr)] <- exprs
, Boxed <- boxity , Boxed <- boxity
= hsep [text (mkTupleStr Boxed 1), ppr expr] = hsep [text (mkTupleStr Boxed 1), ppr expr]
| otherwise | otherwise
......
...@@ -710,7 +710,7 @@ isIrrefutableHsPat ...@@ -710,7 +710,7 @@ isIrrefutableHsPat
go (ConPatIn {}) = False -- Conservative go (ConPatIn {}) = False -- Conservative
go (ConPatOut go (ConPatOut
{ pat_con = (dL->L _ (RealDataCon con)) { pat_con = L _ (RealDataCon con)
, pat_args = details }) , pat_args = details })
= =
isJust (tyConSingleDataCon_maybe (dataConTyCon con)) isJust (tyConSingleDataCon_maybe (dataConTyCon con))
...@@ -718,9 +718,8 @@ isIrrefutableHsPat ...@@ -718,9 +718,8 @@ isIrrefutableHsPat
-- the latter is false of existentials. See #4439 -- the latter is false of existentials. See #4439
&& all goL (hsConPatArgs details) && all goL (hsConPatArgs details)
go (ConPatOut go (ConPatOut
{ pat_con = (dL->L _ (PatSynCon _pat)) }) { pat_con = L _ (PatSynCon _pat) })
= False -- Conservative = False -- Conservative
go (ConPatOut{}) = panic "ConPatOut:Impossible Match" -- due to #15884
go (LitPat {}) = False go (LitPat {}) = False
go (NPat {}) = False go (NPat {}) = False
go (NPlusKPat {}) = False go (NPlusKPat {}) = False
...@@ -790,8 +789,8 @@ conPatNeedsParens p = go ...@@ -790,8 +789,8 @@ conPatNeedsParens p = go
-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p) parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat p lpat@(dL->L loc pat) parenthesizePat p lpat@(L loc pat)
| patNeedsParens p pat = cL loc (ParPat noExtField lpat) | patNeedsParens p pat = L loc (ParPat noExtField lpat)
| otherwise = lpat | otherwise = lpat
{- {-
......
...@@ -1063,14 +1063,14 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs ...@@ -1063,14 +1063,14 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs
hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec
hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p)) hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p))
hsLTyVarLocName = onHasSrcSpan hsTyVarName hsLTyVarLocName = mapLoc hsTyVarName
hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))] hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
-- | Convert a LHsTyVarBndr to an equivalent LHsType. -- | Convert a LHsTyVarBndr to an equivalent LHsType.
hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
hsLTyVarBndrToType = onHasSrcSpan cvt hsLTyVarBndrToType = mapLoc cvt
where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
cvt (KindedTyVar _ (L name_loc n) kind) cvt (KindedTyVar _ (L name_loc n) kind)
= HsKindSig noExtField = HsKindSig noExtField
......
This diff is collapsed.
...@@ -282,7 +282,7 @@ checkSingle' locn var p = do ...@@ -282,7 +282,7 @@ checkSingle' locn var p = do
(Covered , _ ) -> plain -- useful (Covered , _ ) -> plain -- useful
(NotCovered, NotDiverged) -> plain { pmresultRedundant = m } -- redundant (NotCovered, NotDiverged) -> plain { pmresultRedundant = m } -- redundant
(NotCovered, Diverged ) -> plain { pmresultInaccessible = m } -- inaccessible rhs (NotCovered, Diverged ) -> plain { pmresultInaccessible = m } -- inaccessible rhs
where m = [cL locn [cL locn p]] where m = [L locn [L locn p]]
-- | Exhaustive for guard matches, is used for guards in pattern bindings and -- | Exhaustive for guard matches, is used for guards in pattern bindings and
-- in @MultiIf@ expressions. -- in @MultiIf@ expressions.
...@@ -293,7 +293,7 @@ checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do ...@@ -293,7 +293,7 @@ checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
dflags <- getDynFlags dflags <- getDynFlags
let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss) let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
dsMatchContext = DsMatchContext hs_ctx combinedLoc dsMatchContext = DsMatchContext hs_ctx combinedLoc
match = cL combinedLoc $ match = L combinedLoc $
Match { m_ext = noExtField Match { m_ext = noExtField
, m_ctxt = hs_ctx , m_ctxt = hs_ctx
, m_pats = [] , m_pats = []
...@@ -360,8 +360,8 @@ checkMatches' vars matches = do ...@@ -360,8 +360,8 @@ checkMatches' vars matches = do
(NotCovered, Diverged ) -> (rs, final_u, m:is, pc1 Semi.<> pc2) (NotCovered, Diverged ) -> (rs, final_u, m:is, pc1 Semi.<> pc2)
hsLMatchToLPats :: LMatch id body -> Located [LPat id] hsLMatchToLPats :: LMatch id body -> Located [LPat id]
hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats
hsLMatchToLPats _ = panic "checkMatches'" hsLMatchToLPats _ = panic "checkMatches'"
getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta] getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta]
getNFirstUncovered _ 0 _ = pure [] getNFirstUncovered _ 0 _ = pure []
...@@ -465,7 +465,7 @@ translatePat fam_insts x pat = case pat of ...@@ -465,7 +465,7 @@ translatePat fam_insts x pat = case pat of
-- (x@pat) ==> Translate pat with x as match var and handle impedance -- (x@pat) ==> Translate pat with x as match var and handle impedance
-- mismatch with incoming match var -- mismatch with incoming match var
AsPat _ (dL->L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p
SigPat _ p _ty -> translateLPat fam_insts x p SigPat _ p _ty -> translateLPat fam_insts x p
...@@ -481,7 +481,7 @@ translatePat fam_insts x pat = case pat of ...@@ -481,7 +481,7 @@ translatePat fam_insts x pat = case pat of
pure (PmLet y (wrap_rhs_y (Var x)) : grds) pure (PmLet y (wrap_rhs_y (Var x)) : grds)
-- (n + k) ===> let b = x >= k, True <- b, let n = x-k -- (n + k) ===> let b = x >= k, True <- b, let n = x-k
NPlusKPat _pat_ty (dL->L _ n) k1 k2 ge minus -> do NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do
b <- mkPmId boolTy b <- mkPmId boolTy
let grd_b = vanillaConGrd b trueDataCon [] let grd_b = vanillaConGrd b trueDataCon []
[ke1, ke2] <- traverse dsOverLit [unLoc k1, k2] [ke1, ke2] <- traverse dsOverLit [unLoc k1, k2]
...@@ -527,14 +527,14 @@ translatePat fam_insts x pat = case pat of ...@@ -527,14 +527,14 @@ translatePat fam_insts x pat = case pat of
-- --
-- See #14547, especially comment#9 and comment#10. -- See #14547, especially comment#9 and comment#10.
ConPatOut { pat_con = (dL->L _ con) ConPatOut { pat_con = L _ con
, pat_arg_tys = arg_tys , pat_arg_tys = arg_tys
, pat_tvs = ex_tvs , pat_tvs = ex_tvs
, pat_dicts = dicts , pat_dicts = dicts
, pat_args = ps } -> do , pat_args = ps } -> do
translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps
NPat ty (dL->L _ olit) mb_neg _ -> do NPat ty (L _ olit) mb_neg _ -> do
-- See Note [Literal short cut] in MatchLit.hs -- See Note [Literal short cut] in MatchLit.hs
-- We inline the Literal short cut for @ty@ here, because @ty@ is more -- We inline the Literal short cut for @ty@ here, because @ty@ is more
-- precise than the field of OverLitTc, which is all that dsOverLit (which -- precise than the field of OverLitTc, which is all that dsOverLit (which
...@@ -657,7 +657,7 @@ translateConPatOut fam_insts x con univ_tys ex_tvs dicts = \case ...@@ -657,7 +657,7 @@ translateConPatOut fam_insts x con univ_tys ex_tvs dicts = \case
-- Translate a single match -- Translate a single match
translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc) translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc)
-> DsM (GrdVec, [GrdVec]) -> DsM (GrdVec, [GrdVec])
translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss })) translateMatch fam_insts vars (L _ (Match { m_pats = pats, m_grhss = grhss }))
= do = do
pats' <- concat <$> zipWithM (translateLPat fam_insts) vars pats pats' <- concat <$> zipWithM (translateLPat fam_insts) vars pats
guards' <- mapM (translateGuards fam_insts) guards guards' <- mapM (translateGuards fam_insts) guards
...@@ -665,8 +665,8 @@ translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss } ...@@ -665,8 +665,8 @@ translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }
return (pats', guards') return (pats', guards')
where where
extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc] extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]
extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs extractGuards (L _ (GRHS _ gs _)) = map unLoc gs
extractGuards _ = panic "translateMatch" extractGuards _ = panic "translateMatch"
guards = map extractGuards (grhssGRHSs grhss) guards = map extractGuards (grhssGRHSs grhss)
translateMatch _ _ _ = panic "translateMatch" translateMatch _ _ _ = panic "translateMatch"
...@@ -1247,10 +1247,10 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) vars pm_result ...@@ -1247,10 +1247,10 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) vars pm_result
when (approx && (exists_u || exists_i)) $ when (approx && (exists_u || exists_i)) $
putSrcSpanDs loc (warnDs NoReason approx_msg) putSrcSpanDs loc (warnDs NoReason approx_msg)
when exists_r $ forM_ redundant $ \(dL->L l q) -> do when exists_r $ forM_ redundant $ \(L l q) -> do
putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
(pprEqn q "is redundant")) (pprEqn q "is redundant"))
when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do when exists_i $ forM_ inaccessible $ \(L l q) -> do
putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
(pprEqn q "has inaccessible right hand side")) (pprEqn q "has inaccessible right hand side"))
when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $ when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $
...@@ -1366,7 +1366,7 @@ pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun ...@@ -1366,7 +1366,7 @@ pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun
(ppr_match, pref) (ppr_match, pref)
= case kind of = case kind of
FunRhs { mc_fun = (dL->L _ fun) } FunRhs { mc_fun = L _ fun }
-> (pprMatchContext kind, \ pp -> ppr fun <+> pp) -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
_ -> (pprMatchContext kind, \ pp -> pp) _ -> (pprMatchContext kind, \ pp -> pp)
......
This diff is collapsed.
...@@ -205,12 +205,6 @@ nameOccName name = n_occ name ...@@ -205,12 +205,6 @@ nameOccName name = n_occ name
nameSrcLoc name = srcSpanStart (n_loc name) nameSrcLoc name = srcSpanStart (n_loc name)
nameSrcSpan name = n_loc name nameSrcSpan name = n_loc name
type instance SrcSpanLess Name = Name
instance HasSrcSpan Name where
composeSrcSpan (L sp n) = n {n_loc = sp}
decomposeSrcSpan n = L (n_loc n) n
{- {-
************************************************************************ ************************************************************************
* * * *
......
...@@ -85,9 +85,7 @@ module SrcLoc ( ...@@ -85,9 +85,7 @@ module SrcLoc (
leftmost_smallest, leftmost_largest, rightmost, leftmost_smallest, leftmost_largest, rightmost,
spans, isSubspanOf, sortLocated, spans, isSubspanOf, sortLocated,
-- ** HasSrcSpan liftL
HasSrcSpan(..), SrcSpanLess, dL, cL,
pattern LL, onHasSrcSpan, liftL
) where ) where
import GhcPrelude import GhcPrelude
...@@ -182,7 +180,7 @@ advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) ...@@ -182,7 +180,7 @@ advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1)
************************************************************************ ************************************************************************
-} -}
sortLocated :: HasSrcSpan a => [a] -> [a] sortLocated :: [Located a] -> [Located a]
sortLocated things = sortBy (comparing getLoc) things sortLocated things = sortBy (comparing getLoc) things
instance Outputable RealSrcLoc where instance Outputable RealSrcLoc where
...@@ -533,36 +531,35 @@ type RealLocated = GenLocated RealSrcSpan ...@@ -533,36 +531,35 @@ type RealLocated = GenLocated RealSrcSpan
mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc = fmap mapLoc = fmap
unLoc :: HasSrcSpan a => a -> SrcSpanLess a unLoc :: GenLocated l e -> e
unLoc (dL->L _ e) = e unLoc (L _ e) = e
getLoc :: HasSrcSpan a => a -> SrcSpan getLoc :: GenLocated l e -> l
getLoc (dL->L l _) = l getLoc (L l _) = l
noLoc :: HasSrcSpan a => SrcSpanLess a -> a noLoc :: e -> Located e
noLoc e = cL noSrcSpan e noLoc e = L noSrcSpan e
mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e mkGeneralLocated :: String -> e -> Located e
mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e
combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan combineLocs :: Located a -> Located b -> SrcSpan
combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)
-- | Combine locations from two 'Located' things and add them to a third thing -- | Combine locations from two 'Located' things and add them to a third thing
addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => addCLoc :: Located a -> Located b -> c -> Located c
a -> b -> SrcSpanLess c -> c addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c
addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c
-- not clear whether to add a general Eq instance, but this is useful sometimes: -- not clear whether to add a general Eq instance, but this is useful sometimes:
-- | Tests whether the two located things are equal -- | Tests whether the two located things are equal
eqLocated :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> a -> Bool eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool
eqLocated a b = unLoc a == unLoc b eqLocated a b = unLoc a == unLoc b
-- not clear whether to add a general Ord instance, but this is useful sometimes: -- not clear whether to add a general Ord instance, but this is useful sometimes:
-- | Tests the ordering of the two located things -- | Tests the ordering of the two located things
cmpLocated :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> a -> Ordering cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering
cmpLocated a b = unLoc a `compare` unLoc b cmpLocated a b = unLoc a `compare` unLoc b
instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
...@@ -604,90 +601,10 @@ isSubspanOf src parent ...@@ -604,90 +601,10 @@ isSubspanOf src parent
| otherwise = srcSpanStart parent <= srcSpanStart src && | otherwise = srcSpanStart parent <= srcSpanStart src &&
srcSpanEnd parent >= srcSpanEnd src srcSpanEnd parent >= srcSpanEnd src
liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b)
{- liftL f (L loc a) = do
************************************************************************
* *
\subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans}
* *
************************************************************************
-}
{-
Note [HasSrcSpan Typeclass]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To be able to uniformly set/get source location spans (of `SrcSpan`) in
syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`.
More details can be found at the following wiki page
ImplementingTreesThatGrow/HandlingSourceLocations
For most syntactic entities, the source location spans are stored in
a syntactic entity by a wapper constuctor (introduced by TTG's
new constructor extension), e.g., by `NewPat (WrapperPat sp pat)`
for a source location span `sp` and a pattern `pat`.
-}
-- | Determines the type of undecorated syntactic entities
-- For most syntactic entities `E`, where source location spans are
-- introduced by a wrapper construtor of the same syntactic entity,
-- we have `SrcSpanLess E = E`.
-- However, some syntactic entities have a different type compared to
-- a syntactic entity `e :: E` may have the type `Located E` when
-- decorated by wrapping it with `L sp e` for a source span `sp`.
type family SrcSpanLess a
-- | A typeclass to set/get SrcSpans
class HasSrcSpan a where
-- | Composes a `SrcSpan` decoration with an undecorated syntactic
-- entity to form its decorated variant
composeSrcSpan :: Located (SrcSpanLess a) -> a
-- | Decomposes a decorated syntactic entity into its `SrcSpan`
-- decoration and its undecorated variant
decomposeSrcSpan :: a -> Located (SrcSpanLess a)
{- laws:
composeSrcSpan . decomposeSrcSpan = id
decomposeSrcSpan . composeSrcSpan = id
in other words, `HasSrcSpan` defines an iso relation between
a `SrcSpan`-decorated syntactic entity and its undecorated variant
(together with the `SrcSpan`).
-}
type instance SrcSpanLess (GenLocated l e) = e
instance HasSrcSpan (Located a) where
composeSrcSpan = id
decomposeSrcSpan = id
-- | An abbreviated form of decomposeSrcSpan,
-- mainly to be used in ViewPatterns
dL :: HasSrcSpan a => a -> Located (SrcSpanLess a)
dL = decomposeSrcSpan
-- | An abbreviated form of composeSrcSpan,
-- mainly to replace the hardcoded `L`
cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL sp e = composeSrcSpan (L sp e)
-- | A Pattern Synonym to Set/Get SrcSpans
pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
pattern LL sp e <- (dL->L sp e)
where
LL sp e = cL sp e
-- | Lifts a function of undecorated entities to one of decorated ones
onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) =>
(SrcSpanLess a -> SrcSpanLess b) -> a -> b
onHasSrcSpan f (dL->L l e) = cL l (f e)
liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) =>
(SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
liftL f (dL->L loc a) = do
a' <- f a a' <- f a
return $ cL loc a' return $ L loc a'
getRealSrcSpan :: RealLocated a -> RealSrcSpan getRealSrcSpan :: RealLocated a -> RealSrcSpan
getRealSrcSpan (L l _) = l getRealSrcSpan (L l _) = l
......
This diff is collapsed.
...@@ -369,13 +369,13 @@ Reason ...@@ -369,13 +369,13 @@ Reason
-} -}
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
dsRule (dL->L loc (HsRule { rd_name = name dsRule (L loc (HsRule { rd_name = name
, rd_act = rule_act , rd_act = rule_act
, rd_tmvs = vars , rd_tmvs = vars
, rd_lhs = lhs , rd_lhs = lhs
, rd_rhs = rhs })) , rd_rhs = rhs }))
= putSrcSpanDs loc $ = putSrcSpanDs loc $
do { let bndrs' = [var | (dL->L _ (RuleBndr _ (dL->L _ var))) <- vars] do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
; lhs' <- unsetGOptM Opt_EnableRewriteRules $ ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
unsetWOptM Opt_WarnIdentities $ unsetWOptM Opt_WarnIdentities $
...@@ -412,8 +412,7 @@ dsRule (dL->L loc (HsRule { rd_name = name ...@@ -412,8 +412,7 @@ dsRule (dL->L loc (HsRule { rd_name = name
; return (Just rule) ; return (Just rule)
} } } } } }
dsRule (dL->L _ (XRuleDecl nec)) = noExtCon nec dsRule (L _ (XRuleDecl nec)) = noExtCon nec
dsRule _ = panic "dsRule: Impossible Match" -- due to #15884
warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
-- See Note [Rules and inlining/other rules] -- See Note [Rules and inlining/other rules]
......
...@@ -316,7 +316,7 @@ dsProcExpr ...@@ -316,7 +316,7 @@ dsProcExpr
:: LPat GhcTc :: LPat GhcTc
-> LHsCmdTop GhcTc -> LHsCmdTop GhcTc
-> DsM CoreExpr -> DsM CoreExpr
dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
(meth_binds, meth_ids) <- mkCmdEnv ids (meth_binds, meth_ids) <- mkCmdEnv ids
let locals = mkVarSet (collectPatBinders pat) let locals = mkVarSet (collectPatBinders pat)
(core_cmd, _free_vars, env_ids) (core_cmd, _free_vars, env_ids)
...@@ -455,8 +455,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do ...@@ -455,8 +455,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
dsCmd ids local_vars stack_ty res_ty dsCmd ids local_vars stack_ty res_ty
(HsCmdLam _ (MG { mg_alts (HsCmdLam _ (MG { mg_alts
= (dL->L _ [dL->L _ (Match { m_pats = pats = (L _ [L _ (Match { m_pats = pats
, m_grhss = GRHSs _ [dL->L _ (GRHS _ [] body)] _ })]) })) , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) }))
env_ids = do env_ids = do
let pat_vars = mkVarSet (collectPatsBinders pats) let pat_vars = mkVarSet (collectPatsBinders pats)
let let
...@@ -567,7 +567,7 @@ case bodies, containing the following fields: ...@@ -567,7 +567,7 @@ case bodies, containing the following fields:
-} -}
dsCmd ids local_vars stack_ty res_ty dsCmd ids local_vars stack_ty res_ty
(HsCmdCase _ exp (MG { mg_alts = (dL->L l matches) (HsCmdCase _ exp (MG { mg_alts = L l matches
, mg_ext = MatchGroupTc arg_tys _ , mg_ext = MatchGroupTc arg_tys _
, mg_origin = origin })) , mg_origin = origin }))
env_ids = do env_ids = do
...@@ -616,7 +616,7 @@ dsCmd ids local_vars stack_ty res_ty ...@@ -616,7 +616,7 @@ dsCmd ids local_vars stack_ty res_ty
in_ty = envStackType env_ids stack_ty in_ty = envStackType env_ids stack_ty
core_body <- dsExpr (HsCase noExtField exp core_body <- dsExpr (HsCase noExtField exp
(MG { mg_alts = cL l matches' (MG { mg_alts = L l matches'
, mg_ext = MatchGroupTc arg_tys sum_ty , mg_ext = MatchGroupTc arg_tys sum_ty
, mg_origin = origin })) , mg_origin = origin }))
-- Note that we replace the HsCase result type by sum_ty, -- Note that we replace the HsCase result type by sum_ty,
...@@ -632,7 +632,7 @@ dsCmd ids local_vars stack_ty res_ty ...@@ -632,7 +632,7 @@ dsCmd ids local_vars stack_ty res_ty
-- --
-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body) dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)
env_ids = do env_ids = do
let let
defined_vars = mkVarSet (collectLocalBinders binds) defined_vars = mkVarSet (collectLocalBinders binds)
...@@ -660,7 +660,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body) ...@@ -660,7 +660,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body)
-- ---> premap (\ (env,stk) -> env) c -- ---> premap (\ (env,stk) -> env) c
dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty
(dL->L loc stmts)) (L loc stmts))
env_ids = do env_ids = do
putSrcSpanDs loc $ putSrcSpanDs loc $
dsNoLevPoly stmts_ty dsNoLevPoly stmts_ty
...@@ -706,7 +706,7 @@ dsTrimCmdArg ...@@ -706,7 +706,7 @@ dsTrimCmdArg
-> DsM (CoreExpr, -- desugared expression -> DsM (CoreExpr, -- desugared expression
DIdSet) -- subset of local vars that occur free DIdSet) -- subset of local vars that occur free
dsTrimCmdArg local_vars env_ids dsTrimCmdArg local_vars env_ids
(dL->L _ (HsCmdTop (L _ (HsCmdTop
(CmdTopTc stack_ty cmd_ty ids) cmd )) = do (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
(meth_binds, meth_ids) <- mkCmdEnv ids (meth_binds, meth_ids) <- mkCmdEnv ids
(core_cmd, free_vars, env_ids') (core_cmd, free_vars, env_ids')
...@@ -778,7 +778,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo" ...@@ -778,7 +778,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
-- --
-- ---> premap (\ (xs) -> ((xs), ())) c -- ---> premap (\ (xs) -> ((xs), ())) c
dsCmdDo ids local_vars res_ty [dL->L loc (LastStmt _ body _ _)] env_ids = do dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do
putSrcSpanDs loc $ dsNoLevPoly res_ty putSrcSpanDs loc $ dsNoLevPoly res_ty
(text "In the command:" <+> ppr body) (text "In the command:" <+> ppr body)
(core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
...@@ -1139,8 +1139,8 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" ...@@ -1139,8 +1139,8 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys"
leavesMatch :: LMatch GhcTc (Located (body GhcTc)) leavesMatch :: LMatch GhcTc (Located (body GhcTc))
-> [(Located (body GhcTc), IdSet)] -> [(Located (body GhcTc), IdSet)]
leavesMatch (dL->L _ (Match { m_pats = pats leavesMatch (L _ (Match { m_pats = pats
, m_grhss = GRHSs _ grhss (dL->L _ binds) })) , m_grhss = GRHSs _ grhss (L _ binds) }))
= let = let
defined_vars = mkVarSet (collectPatsBinders pats) defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet` `unionVarSet`
...@@ -1149,7 +1149,7 @@ leavesMatch (dL->L _ (Match { m_pats = pats ...@@ -1149,7 +1149,7 @@ leavesMatch (dL->L _ (Match { m_pats = pats
[(body, [(body,
mkVarSet (collectLStmtsBinders stmts) mkVarSet (collectLStmtsBinders stmts)
`unionVarSet` defined_vars) `unionVarSet` defined_vars)
| (dL->L _ (GRHS _ stmts body)) <- grhss] | L _ (GRHS _ stmts body) <- grhss]
leavesMatch _ = panic "leavesMatch" leavesMatch _ = panic "leavesMatch"
-- Replace the leaf commands in a match -- Replace the leaf commands in a match
...@@ -1161,12 +1161,12 @@ replaceLeavesMatch ...@@ -1161,12 +1161,12 @@ replaceLeavesMatch
-> ([Located (body' GhcTc)], -- remaining leaf expressions -> ([Located (body' GhcTc)], -- remaining leaf expressions
LMatch GhcTc (Located (body' GhcTc))) -- updated match LMatch GhcTc (Located (body' GhcTc))) -- updated match
replaceLeavesMatch _res_ty leaves replaceLeavesMatch _res_ty leaves
(dL->L loc (L loc
match@(Match { m_grhss = GRHSs x grhss binds })) match@(Match { m_grhss = GRHSs x grhss binds }))
= let = let
(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in in
(leaves', cL loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds }))
replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch" replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch"
replaceLeavesGRHS replaceLeavesGRHS
...@@ -1174,8 +1174,8 @@ replaceLeavesGRHS ...@@ -1174,8 +1174,8 @@ replaceLeavesGRHS
-> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command
-> ([Located (body' GhcTc)], -- remaining leaf expressions -> ([Located (body' GhcTc)], -- remaining leaf expressions
LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS
replaceLeavesGRHS (leaf:leaves) (dL->L loc (GRHS x stmts _)) replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _))