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)
ppr_expr (ExplicitTuple _ exprs boxity)
-- Special-case unary boxed tuples so that they are pretty-printed as
-- `Unit x`, not `(x)`
| [dL -> L _ (Present _ expr)] <- exprs
| [L _ (Present _ expr)] <- exprs
, Boxed <- boxity
= hsep [text (mkTupleStr Boxed 1), ppr expr]
| otherwise
......
......@@ -710,7 +710,7 @@ isIrrefutableHsPat
go (ConPatIn {}) = False -- Conservative
go (ConPatOut
{ pat_con = (dL->L _ (RealDataCon con))
{ pat_con = L _ (RealDataCon con)
, pat_args = details })
=
isJust (tyConSingleDataCon_maybe (dataConTyCon con))
......@@ -718,9 +718,8 @@ isIrrefutableHsPat
-- the latter is false of existentials. See #4439
&& all goL (hsConPatArgs details)
go (ConPatOut
{ pat_con = (dL->L _ (PatSynCon _pat)) })
{ pat_con = L _ (PatSynCon _pat) })
= False -- Conservative
go (ConPatOut{}) = panic "ConPatOut:Impossible Match" -- due to #15884
go (LitPat {}) = False
go (NPat {}) = False
go (NPlusKPat {}) = False
......@@ -790,8 +789,8 @@ conPatNeedsParens p = go
-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat p lpat@(dL->L loc pat)
| patNeedsParens p pat = cL loc (ParPat noExtField lpat)
parenthesizePat p lpat@(L loc pat)
| patNeedsParens p pat = L loc (ParPat noExtField lpat)
| otherwise = lpat
{-
......
......@@ -1063,14 +1063,14 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs
hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec
hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p))
hsLTyVarLocName = onHasSrcSpan hsTyVarName
hsLTyVarLocName = mapLoc hsTyVarName
hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
-- | Convert a LHsTyVarBndr to an equivalent LHsType.
hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
hsLTyVarBndrToType = onHasSrcSpan cvt
hsLTyVarBndrToType = mapLoc cvt
where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
cvt (KindedTyVar _ (L name_loc n) kind)
= HsKindSig noExtField
......
This diff is collapsed.
......@@ -282,7 +282,7 @@ checkSingle' locn var p = do
(Covered , _ ) -> plain -- useful
(NotCovered, NotDiverged) -> plain { pmresultRedundant = m } -- redundant
(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
-- in @MultiIf@ expressions.
......@@ -293,7 +293,7 @@ checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
dflags <- getDynFlags
let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
dsMatchContext = DsMatchContext hs_ctx combinedLoc
match = cL combinedLoc $
match = L combinedLoc $
Match { m_ext = noExtField
, m_ctxt = hs_ctx
, m_pats = []
......@@ -360,7 +360,7 @@ checkMatches' vars matches = do
(NotCovered, Diverged ) -> (rs, final_u, m:is, pc1 Semi.<> pc2)
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'"
getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta]
......@@ -465,7 +465,7 @@ translatePat fam_insts x pat = case pat of
-- (x@pat) ==> Translate pat with x as match var and handle impedance
-- 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
......@@ -481,7 +481,7 @@ translatePat fam_insts x pat = case pat of
pure (PmLet y (wrap_rhs_y (Var x)) : grds)
-- (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
let grd_b = vanillaConGrd b trueDataCon []
[ke1, ke2] <- traverse dsOverLit [unLoc k1, k2]
......@@ -527,14 +527,14 @@ translatePat fam_insts x pat = case pat of
--
-- 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_tvs = ex_tvs
, pat_dicts = dicts
, pat_args = ps } -> do
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
-- 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
......@@ -657,7 +657,7 @@ translateConPatOut fam_insts x con univ_tys ex_tvs dicts = \case
-- Translate a single match
translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc)
-> 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
pats' <- concat <$> zipWithM (translateLPat fam_insts) vars pats
guards' <- mapM (translateGuards fam_insts) guards
......@@ -665,7 +665,7 @@ translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }
return (pats', guards')
where
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"
guards = map extractGuards (grhssGRHSs grhss)
......@@ -1247,10 +1247,10 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) vars pm_result
when (approx && (exists_u || exists_i)) $
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)
(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)
(pprEqn q "has inaccessible right hand side"))
when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $
......@@ -1366,7 +1366,7 @@ pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun
(ppr_match, pref)
= case kind of
FunRhs { mc_fun = (dL->L _ fun) }
FunRhs { mc_fun = L _ fun }
-> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
_ -> (pprMatchContext kind, \ pp -> pp)
......
This diff is collapsed.
......@@ -205,12 +205,6 @@ nameOccName name = n_occ name
nameSrcLoc name = srcSpanStart (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 (
leftmost_smallest, leftmost_largest, rightmost,
spans, isSubspanOf, sortLocated,
-- ** HasSrcSpan
HasSrcSpan(..), SrcSpanLess, dL, cL,
pattern LL, onHasSrcSpan, liftL
liftL
) where
import GhcPrelude
......@@ -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
instance Outputable RealSrcLoc where
......@@ -533,36 +531,35 @@ type RealLocated = GenLocated RealSrcSpan
mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc = fmap
unLoc :: HasSrcSpan a => a -> SrcSpanLess a
unLoc (dL->L _ e) = e
unLoc :: GenLocated l e -> e
unLoc (L _ e) = e
getLoc :: HasSrcSpan a => a -> SrcSpan
getLoc (dL->L l _) = l
getLoc :: GenLocated l e -> l
getLoc (L l _) = l
noLoc :: HasSrcSpan a => SrcSpanLess a -> a
noLoc e = cL noSrcSpan e
noLoc :: e -> Located e
noLoc e = L noSrcSpan e
mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e
mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e
mkGeneralLocated :: String -> e -> Located 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)
-- | Combine locations from two 'Located' things and add them to a third thing
addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
a -> b -> SrcSpanLess c -> c
addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c
addCLoc :: Located a -> Located b -> c -> Located c
addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c
-- not clear whether to add a general Eq instance, but this is useful sometimes:
-- | 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
-- not clear whether to add a general Ord instance, but this is useful sometimes:
-- | 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
instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
......@@ -604,90 +601,10 @@ isSubspanOf src parent
| otherwise = srcSpanStart parent <= srcSpanStart src &&
srcSpanEnd parent >= srcSpanEnd src
{-
************************************************************************
* *
\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
liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL f (L loc a) = do
a' <- f a
return $ cL loc a'
return $ L loc a'
getRealSrcSpan :: RealLocated a -> RealSrcSpan
getRealSrcSpan (L l _) = l
......
This diff is collapsed.
......@@ -369,13 +369,13 @@ Reason
-}
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_tmvs = vars
, rd_lhs = lhs
, rd_rhs = rhs }))
= 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 $
unsetWOptM Opt_WarnIdentities $
......@@ -412,8 +412,7 @@ dsRule (dL->L loc (HsRule { rd_name = name
; return (Just rule)
} } }
dsRule (dL->L _ (XRuleDecl nec)) = noExtCon nec
dsRule _ = panic "dsRule: Impossible Match" -- due to #15884
dsRule (L _ (XRuleDecl nec)) = noExtCon nec
warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
-- See Note [Rules and inlining/other rules]
......
......@@ -316,7 +316,7 @@ dsProcExpr
:: LPat GhcTc
-> LHsCmdTop GhcTc
-> 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
let locals = mkVarSet (collectPatBinders pat)
(core_cmd, _free_vars, env_ids)
......@@ -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
(HsCmdLam _ (MG { mg_alts
= (dL->L _ [dL->L _ (Match { m_pats = pats
, m_grhss = GRHSs _ [dL->L _ (GRHS _ [] body)] _ })]) }))
= (L _ [L _ (Match { m_pats = pats
, m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) }))
env_ids = do
let pat_vars = mkVarSet (collectPatsBinders pats)
let
......@@ -567,7 +567,7 @@ case bodies, containing the following fields:
-}
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_origin = origin }))
env_ids = do
......@@ -616,7 +616,7 @@ dsCmd ids local_vars stack_ty res_ty
in_ty = envStackType env_ids stack_ty
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_origin = origin }))
-- Note that we replace the HsCase result type by sum_ty,
......@@ -632,7 +632,7 @@ dsCmd ids local_vars stack_ty res_ty
--
-- ---> 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
let
defined_vars = mkVarSet (collectLocalBinders binds)
......@@ -660,7 +660,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body)
-- ---> premap (\ (env,stk) -> env) c
dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty
(dL->L loc stmts))
(L loc stmts))
env_ids = do
putSrcSpanDs loc $
dsNoLevPoly stmts_ty
......@@ -706,7 +706,7 @@ dsTrimCmdArg
-> DsM (CoreExpr, -- desugared expression
DIdSet) -- subset of local vars that occur free
dsTrimCmdArg local_vars env_ids
(dL->L _ (HsCmdTop
(L _ (HsCmdTop
(CmdTopTc stack_ty cmd_ty ids) cmd )) = do
(meth_binds, meth_ids) <- mkCmdEnv ids
(core_cmd, free_vars, env_ids')
......@@ -778,7 +778,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
--
-- ---> 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
(text "In the command:" <+> ppr body)
(core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
......@@ -1139,8 +1139,8 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys"
leavesMatch :: LMatch GhcTc (Located (body GhcTc))
-> [(Located (body GhcTc), IdSet)]
leavesMatch (dL->L _ (Match { m_pats = pats
, m_grhss = GRHSs _ grhss (dL->L _ binds) }))
leavesMatch (L _ (Match { m_pats = pats
, m_grhss = GRHSs _ grhss (L _ binds) }))
= let
defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet`
......@@ -1149,7 +1149,7 @@ leavesMatch (dL->L _ (Match { m_pats = pats
[(body,
mkVarSet (collectLStmtsBinders stmts)
`unionVarSet` defined_vars)
| (dL->L _ (GRHS _ stmts body)) <- grhss]
| L _ (GRHS _ stmts body) <- grhss]
leavesMatch _ = panic "leavesMatch"
-- Replace the leaf commands in a match
......@@ -1161,12 +1161,12 @@ replaceLeavesMatch
-> ([Located (body' GhcTc)], -- remaining leaf expressions
LMatch GhcTc (Located (body' GhcTc))) -- updated match
replaceLeavesMatch _res_ty leaves
(dL->L loc
(L loc
match@(Match { m_grhss = GRHSs x grhss binds }))
= let
(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
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"
replaceLeavesGRHS
......@@ -1174,8 +1174,8 @@ replaceLeavesGRHS
-> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command
-> ([Located (body' GhcTc)], -- remaining leaf expressions
LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS
replaceLeavesGRHS (leaf:leaves) (dL->L loc (GRHS x stmts _))
= (leaves, cL loc (GRHS x stmts leaf))
replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _))
= (leaves, L loc (GRHS x stmts leaf))
replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS"
......@@ -1221,14 +1221,14 @@ collectPatsBinders pats = foldr collectl [] pats
---------------------
collectl :: LPat GhcTc -> [Id] -> [Id]
-- See Note [Dictionary binders in ConPatOut]
collectl (dL->L _ pat) bndrs
collectl (L _ pat) bndrs
= go pat
where
go (VarPat _ (dL->L _ var)) = var : bndrs
go (VarPat _ (L _ var)) = var : bndrs
go (WildPat _) = bndrs
go (LazyPat _ pat) = collectl pat bndrs
go (BangPat _ pat) = collectl pat bndrs
go (AsPat _ (dL->L _ a) pat) = a : collectl pat bndrs
go (AsPat _ (L _ a) pat) = a : collectl pat bndrs
go (ParPat _ pat) = collectl pat bndrs
go (ListPat _ pats) = foldr collectl bndrs pats
......@@ -1241,7 +1241,7 @@ collectl (dL->L _ pat) bndrs
++ foldr collectl bndrs (hsConPatArgs ps)
go (LitPat _ _) = bndrs
go (NPat {}) = bndrs
go (NPlusKPat _ (dL->L _ n) _ _ _ _) = n : bndrs
go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
go (SigPat _ pat _) = collectl pat bndrs
go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
......
......@@ -101,7 +101,7 @@ dsTopLHsBinds binds
unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
bang_binds = filterBag (isBangedHsBind . unLoc) binds
top_level_err desc (dL->L loc bind)
top_level_err desc (L loc bind)
= putSrcSpanDs loc $
errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")
2 (ppr bind))
......@@ -118,7 +118,7 @@ dsLHsBinds binds
------------------------
dsLHsBind :: LHsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
dsLHsBind (dL->L loc bind) = do dflags <- getDynFlags
dsLHsBind (L loc bind) = do dflags <- getDynFlags
putSrcSpanDs loc $ dsHsBind dflags bind
-- | Desugar a single binding (or group of recursive binds).
......@@ -143,7 +143,7 @@ dsHsBind dflags (VarBind { var_id = var
else []
; return (force_var, [core_bind]) }
dsHsBind dflags b@(FunBind { fun_id = (dL->L _ fun)
dsHsBind dflags b@(FunBind { fun_id = L _ fun
, fun_matches = matches
, fun_co_fn = co_fn
, fun_tick = tick })
......@@ -657,7 +657,7 @@ dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
-- rhs is in the Id's unfolding
-> Located TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl))
dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
| isJust (isClassOpId_maybe poly_id)
= putSrcSpanDs loc $
do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"
......
......@@ -72,10 +72,10 @@ import Control.Monad
-}
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds (dL->L _ (EmptyLocalBinds _)) body = return body
dsLocalBinds (dL->L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body
dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
dsValBinds binds body
dsLocalBinds (dL->L _ (HsIPBinds _ binds)) body = dsIPBinds binds body
dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body
dsLocalBinds _ _ = panic "dsLocalBinds"
-------------------------
......@@ -94,7 +94,7 @@ dsIPBinds (IPBinds ev_binds ip_binds) body
-- dependency order; hence Rec
; foldrM ds_ip_bind inner ip_binds }
where
ds_ip_bind (dL->L _ (IPBind _ ~(Right n) e)) body
ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body
= do e' <- dsLExpr e
return (Let (NonRec n e') body)
ds_ip_bind _ _ = panic "dsIPBinds"
......@@ -108,7 +108,7 @@ ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
-- a tuple and doing selections.
-- Silently ignore INLINE and SPECIALISE pragmas...
ds_val_bind (NonRecursive, hsbinds) body
| [dL->L loc bind] <- bagToList hsbinds
| [L loc bind] <- bagToList hsbinds
-- Non-recursive, non-overloaded bindings only come in ones
-- ToDo: in some bizarre case it's conceivable that there
-- could be dict binds in the 'binds'. (See the notes
......@@ -192,13 +192,13 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
; ds_binds <- dsTcEvBinds_s ev_binds
; return (mkCoreLets ds_binds body2) }
dsUnliftedBind (FunBind { fun_id = (dL->L l fun)
dsUnliftedBind (FunBind { fun_id = L l fun
, fun_matches = matches
, fun_co_fn = co_fn
, fun_tick = tick }) body
-- Can't be a bang pattern (that looks like a PatBind)
-- so must be simply unboxed
= do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (cL l $ idName fun))
= do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))
Nothing matches
; MASSERT( null args ) -- Functions aren't lifted
; MASSERT( isIdHsWrapper co_fn )
......@@ -231,7 +231,7 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (dL->L loc e)
dsLExpr (L loc e)
= putSrcSpanDs loc $
do { core_expr <- dsExpr e
-- uncomment this check to test the hsExprType function in TcHsSyn
......@@ -246,7 +246,7 @@ dsLExpr (dL->L loc e)
-- See Note [Levity polymorphism checking] in DsMonad
-- See Note [Levity polymorphism invariants] in CoreSyn
dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP (dL->L loc e)
dsLExprNoLP (L loc e)
= putSrcSpanDs loc $
do { e' <- dsExpr e
; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
......@@ -260,7 +260,7 @@ ds_expr :: Bool -- are we directly inside an HsWrap?
-> HsExpr GhcTc -> DsM CoreExpr
ds_expr _ (HsPar _ e) = dsLExpr e
ds_expr _ (ExprWithTySig _ e _) = dsLExpr e
ds_expr w (HsVar _ (dL->L _ var)) = dsHsVar w var
ds_expr w (HsVar _ (L _ var)) = dsHsVar w var
ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
ds_expr w (HsConLikeOut _ con) = dsConLike w con
ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar"
......@@ -285,7 +285,7 @@ ds_expr _ (HsWrap _ co_fn e)
; warnAboutIdentities dflags e' wrapped_ty
; return wrapped_e }
ds_expr _ (NegApp _ (dL->L loc
ds_expr _ (NegApp _ (L loc
(HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
neg_expr)
= do { expr' <- putSrcSpanDs loc $ do
......@@ -377,12 +377,12 @@ ds_expr _ e@(SectionR _ op expr) = do
core_op [Var x_id, Var y_id]))
ds_expr _ (ExplicitTuple _ tup_args boxity)
= do { let go (lam_vars, args) (dL->L _ (Missing ty))
= do { let go (lam_vars, args) (L _ (Missing ty))
-- For every missing expression, we need
-- another lambda in the desugaring.
= do { lam_var <- newSysLocalDsNoLP ty
; return (lam_var : lam_vars, Var lam_var : args) }
go (lam_vars, args) (dL->L _ (Present _ expr))
go (lam_vars, args) (L _ (Present _ expr))
-- Expressions that are present don't generate
-- lambdas, just arguments.
= do { core_expr <- dsLExprNoLP expr
......@@ -419,11 +419,11 @@ ds_expr _ (HsLet _ binds body) = do
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
ds_expr _ (HsDo res_ty ListComp (dL->L _ stmts)) = dsListComp stmts res_ty
ds_expr _ (HsDo _ DoExpr (dL->L _ stmts)) = dsDo stmts
ds_expr _ (HsDo _ GhciStmtCtxt (dL->L _ stmts)) = dsDo stmts
ds_expr _ (HsDo _ MDoExpr (dL->L _ stmts)) = dsDo stmts
ds_expr _ (HsDo _ MonadComp (dL->L _ stmts)) = dsMonadComp stmts
ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
ds_expr _ (HsDo _ DoExpr (L _ stmts)) = dsDo stmts
ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts
ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts
ds_expr _ (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
......@@ -473,7 +473,7 @@ See Note [Grand plan for static forms] in StaticPtrTable for an overview.
g = ... makeStatic loc f ...
-}
ds_expr _ (HsStatic _ expr@(dL->L loc _)) = do
ds_expr _ (HsStatic _ expr@(L loc _)) = do
expr_ds <- dsLExprNoLP expr
let ty = exprType expr_ds
makeStaticId <- dsLookupGlobalId makeStaticName
......@@ -612,7 +612,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
-- of the record selector, and we must not make that a local binder
-- else we shadow other uses of the record selector
-- Hence 'lcl_id'. Cf #2735
ds_field (dL->L _ rec_field)
ds_field (L _ rec_field)
= do { rhs <- dsLExpr (hsRecFieldArg rec_field)
; let fld_id = unLoc (hsRecUpdFieldId rec_field)
; lcl_id <- newSysLocalDs (idType fld_id)
......@@ -777,7 +777,7 @@ dsSyntaxExpr (SyntaxExpr { syn_expr = expr
findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
findField rbinds sel
= [hsRecFieldArg fld | (dL->L _ fld) <- rbinds