summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Coverage.hs136
-rw-r--r--compiler/deSugar/Desugar.hs15
-rw-r--r--compiler/deSugar/DsArrows.hs40
-rw-r--r--compiler/deSugar/DsBinds.hs10
-rw-r--r--compiler/deSugar/DsExpr.hs54
-rw-r--r--compiler/deSugar/DsForeign.hs6
-rw-r--r--compiler/deSugar/DsGRHSs.hs5
-rw-r--r--compiler/deSugar/DsListComp.hs6
-rw-r--r--compiler/deSugar/DsMeta.hs287
-rw-r--r--compiler/deSugar/DsUtils.hs38
-rw-r--r--compiler/deSugar/ExtractDocs.hs30
-rw-r--r--compiler/deSugar/Match.hs55
-rw-r--r--compiler/deSugar/MatchCon.hs6
-rw-r--r--compiler/deSugar/MatchLit.hs16
14 files changed, 345 insertions, 359 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index cfff423037..8a823906af 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -121,7 +121,7 @@ guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
guessSourceFile binds orig_file =
-- Try look for a file generated from a .hsc file to a
-- .hs file, by peeking ahead.
- let top_pos = catMaybes $ foldr (\ (dL->L pos _) rest ->
+ let top_pos = catMaybes $ foldr (\ (L pos _) rest ->
srcSpanFileName_maybe pos : rest) [] binds
in
case top_pos of
@@ -255,12 +255,12 @@ addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
addTickLHsBinds = mapBagM addTickLHsBind
addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
-addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds = binds,
+addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
abs_exports = abs_exports })) = do
withEnv add_exports $ do
withEnv add_inlines $ do
binds' <- addTickLHsBinds binds
- return $ cL pos $ bind { abs_binds = binds' }
+ return $ L pos $ bind { abs_binds = binds' }
where
-- in AbsBinds, the Id on each binding is not the actual top-level
-- Id that we are defining, they are related by the abs_exports
@@ -280,7 +280,7 @@ addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds = binds,
| ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
, isInlinePragma (idInlinePragma pid) ] }
-addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do
+addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
let name = getOccString id
decl_path <- getPathEntry
density <- getDensity
@@ -292,7 +292,7 @@ addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do
-- See Note [inline sccs]
tickish <- tickishType `liftM` getEnv
- if inline && tickish == ProfNotes then return (cL pos funBind) else do
+ if inline && tickish == ProfNotes then return (L pos funBind) else do
(fvs, mg) <-
getFreeVars $
@@ -321,8 +321,8 @@ addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do
return Nothing
let mbCons = maybe Prelude.id (:)
- return $ cL pos $ funBind { fun_matches = mg
- , fun_tick = tick `mbCons` fun_tick funBind }
+ return $ L pos $ funBind { fun_matches = mg
+ , fun_tick = tick `mbCons` fun_tick funBind }
where
-- a binding is a simple pattern binding if it is a funbind with
@@ -331,8 +331,8 @@ addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do
isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
-- TODO: Revisit this
-addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs
- , pat_rhs = rhs }))) = do
+addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
+ , pat_rhs = rhs }))) = do
let name = "(...)"
(fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
let pat' = pat { pat_rhs = rhs'}
@@ -342,7 +342,7 @@ addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs
decl_path <- getPathEntry
let top_lev = null decl_path
if not (shouldTickPatBind density top_lev)
- then return (cL pos pat')
+ then return (L pos pat')
else do
-- Allocate the ticks
@@ -355,14 +355,12 @@ addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs
rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')
patvar_tickss = zipWith mbCons patvar_ticks
(snd (pat_ticks pat') ++ repeat [])
- return $ cL pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
+ return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
-addTickLHsBind var_bind@(dL->L _ (VarBind {})) = return var_bind
-addTickLHsBind patsyn_bind@(dL->L _ (PatSynBind {})) = return patsyn_bind
-addTickLHsBind bind@(dL->L _ (XHsBindsLR {})) = return bind
-addTickLHsBind _ = panic "addTickLHsBind: Impossible Match" -- due to #15884
-
+addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
+addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
+addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
bindTick
@@ -397,7 +395,7 @@ bindTick density name pos fvs = do
-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExpr e@(dL->L pos e0) = do
+addTickLHsExpr e@(L pos e0) = do
d <- getDensity
case d of
TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
@@ -413,7 +411,7 @@ addTickLHsExpr e@(dL->L pos e0) = do
-- (because the body will definitely have a tick somewhere). ToDo: perhaps
-- we should treat 'case' and 'if' the same way?
addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprRHS e@(dL->L pos e0) = do
+addTickLHsExprRHS e@(L pos e0) = do
d <- getDensity
case d of
TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
@@ -442,7 +440,7 @@ addTickLHsExprEvalInner e = do
-- break012. This gives the user the opportunity to inspect the
-- values of the let-bound variables.
addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprLetBody e@(dL->L pos e0) = do
+addTickLHsExprLetBody e@(L pos e0) = do
d <- getDensity
case d of
TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
@@ -456,9 +454,9 @@ addTickLHsExprLetBody e@(dL->L pos e0) = do
-- because the scope of this tick is completely subsumed by
-- another.
addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprNever (dL->L pos e0) = do
+addTickLHsExprNever (L pos e0) = do
e1 <- addTickHsExpr e0
- return $ cL pos e1
+ return $ L pos e1
-- general heuristic: expressions which do not denote values are good
-- break points
@@ -475,16 +473,16 @@ isCallSite OpApp{} = True
isCallSite _ = False
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprOptAlt oneOfMany (dL->L pos e0)
+addTickLHsExprOptAlt oneOfMany (L pos e0)
= ifDensity TickForCoverage
(allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
- (addTickLHsExpr (cL pos e0))
+ (addTickLHsExpr (L pos e0))
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addBinTickLHsExpr boxLabel (dL->L pos e0)
+addBinTickLHsExpr boxLabel (L pos e0)
= ifDensity TickForCoverage
(allocBinTickBox boxLabel pos $ addTickHsExpr e0)
- (addTickLHsExpr (cL pos e0))
+ (addTickLHsExpr (L pos e0))
-- -----------------------------------------------------------------------------
@@ -493,7 +491,7 @@ addBinTickLHsExpr boxLabel (dL->L pos e0)
-- in the addTickLHsExpr family of functions.)
addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpr e@(HsVar _ (dL->L _ id)) = do freeVar id; return e
+addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
addTickHsExpr e@(HsConLikeOut _ con)
| Just id <- conLikeWrapId_maybe con = do freeVar id; return e
@@ -552,14 +550,14 @@ addTickHsExpr (HsMultiIf ty alts)
= do { let isOneOfMany = case alts of [_] -> False; _ -> True
; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
; return $ HsMultiIf ty alts' }
-addTickHsExpr (HsLet x (dL->L l binds) e) =
+addTickHsExpr (HsLet x (L l binds) e) =
bindLocals (collectLocalBinders binds) $
- liftM2 (HsLet x . cL l)
+ liftM2 (HsLet x . L l)
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprLetBody e)
-addTickHsExpr (HsDo srcloc cxt (dL->L l stmts))
+addTickHsExpr (HsDo srcloc cxt (L l stmts))
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
- ; return (HsDo srcloc cxt (cL l stmts')) }
+ ; return (HsDo srcloc cxt (L l stmts')) }
where
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
@@ -606,7 +604,7 @@ addTickHsExpr (HsTick x t e) =
addTickHsExpr (HsBinTick x t0 t1 e) =
liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
-addTickHsExpr (HsPragE _ HsPragTick{} (dL->L pos e0)) = do
+addTickHsExpr (HsPragE _ HsPragTick{} (L pos e0)) = do
e2 <- allocTickBox (ExpBox False) False False pos $
addTickHsExpr e0
return $ unLoc e2
@@ -629,19 +627,18 @@ addTickHsExpr (HsWrap x w e) =
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
-addTickTupArg (dL->L l (Present x e)) = do { e' <- addTickLHsExpr e
- ; return (cL l (Present x e')) }
-addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty))
-addTickTupArg (dL->L _ (XTupArg nec)) = noExtCon nec
-addTickTupArg _ = panic "addTickTupArg: Impossible Match" -- due to #15884
+addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e
+ ; return (L l (Present x e')) }
+addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
+addTickTupArg (L _ (XTupArg nec)) = noExtCon nec
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
-> TM (MatchGroup GhcTc (LHsExpr GhcTc))
-addTickMatchGroup is_lam mg@(MG { mg_alts = dL->L l matches }) = do
+addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
let isOneOfMany = matchesOneOfMany matches
matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
- return $ mg { mg_alts = cL l matches' }
+ return $ mg { mg_alts = L l matches' }
addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec
addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
@@ -655,11 +652,11 @@ addTickMatch _ _ (XMatch nec) = noExtCon nec
addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
-addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (dL->L l local_binds)) = do
+addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
- return $ GRHSs x guarded' (cL l local_binds')
+ return $ GRHSs x guarded' (L l local_binds')
where
binders = collectLocalBinders local_binds
addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec
@@ -673,7 +670,7 @@ addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
addTickGRHS _ _ (XGRHS nec) = noExtCon nec
addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do
+addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
d <- getDensity
case d of
TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr
@@ -716,13 +713,13 @@ addTickStmt isGuard (BodyStmt x e bind' guard') = do
(addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
-addTickStmt _isGuard (LetStmt x (dL->L l binds)) = do
- liftM (LetStmt x . cL l)
+addTickStmt _isGuard (LetStmt x (L l binds)) = do
+ liftM (LetStmt x . L l)
(addTickHsLocalBinds binds)
addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do
liftM3 (ParStmt x)
(mapM (addTickStmtAndBinders isGuard) pairs)
- (unLoc <$> addTickLHsExpr (cL hpcSrcSpan mzipExpr))
+ (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
(addTickSyntaxExpr hpcSrcSpan bindExpr)
addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
args' <- mapM (addTickApplicativeArg isGuard) args
@@ -737,7 +734,7 @@ addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
t_u <- addTickLHsExprRHS using
t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
- t_m <- fmap unLoc (addTickLHsExpr (cL hpcSrcSpan liftMExpr))
+ t_m <- fmap unLoc (addTickLHsExpr (L hpcSrcSpan liftMExpr))
return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
, trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
@@ -770,7 +767,7 @@ addTickApplicativeArg isGuard (op, arg) =
addTickArg (ApplicativeArgMany x stmts ret pat) =
(ApplicativeArgMany x)
<$> addTickLStmts isGuard stmts
- <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret))
+ <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
<*> addTickLPat pat
addTickArg (XApplicativeArg nec) = noExtCon nec
@@ -823,7 +820,7 @@ addTickIPBind (XIPBind x) = return (XIPBind x)
-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do
- x' <- fmap unLoc (addTickLHsExpr (cL pos x))
+ x' <- fmap unLoc (addTickLHsExpr (L pos x))
return $ syn { syn_expr = x' }
-- we do not walk into patterns.
addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
@@ -837,9 +834,9 @@ addTickHsCmdTop (HsCmdTop x cmd) =
addTickHsCmdTop (XCmdTop nec) = noExtCon nec
addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
-addTickLHsCmd (dL->L pos c0) = do
+addTickLHsCmd (L pos c0) = do
c1 <- addTickHsCmd c0
- return $ cL pos c1
+ return $ L pos c1
addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
addTickHsCmd (HsCmdLam x matchgroup) =
@@ -864,14 +861,14 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2)
(addTickLHsCmd c3)
-addTickHsCmd (HsCmdLet x (dL->L l binds) c) =
+addTickHsCmd (HsCmdLet x (L l binds) c) =
bindLocals (collectLocalBinders binds) $
- liftM2 (HsCmdLet x . cL l)
+ liftM2 (HsCmdLet x . L l)
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
-addTickHsCmd (HsCmdDo srcloc (dL->L l stmts))
+addTickHsCmd (HsCmdDo srcloc (L l stmts))
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
- ; return (HsCmdDo srcloc (cL l stmts')) }
+ ; return (HsCmdDo srcloc (L l stmts')) }
addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) =
liftM5 HsCmdArrApp
@@ -897,9 +894,9 @@ addTickHsCmd (XCmd nec) = noExtCon nec
addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
-> TM (MatchGroup GhcTc (LHsCmd GhcTc))
-addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do
+addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do
matches' <- mapM (liftL addTickCmdMatch) matches
- return $ mg { mg_alts = cL l matches' }
+ return $ mg { mg_alts = L l matches' }
addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec
addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
@@ -910,11 +907,11 @@ addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
addTickCmdMatch (XMatch nec) = noExtCon nec
addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
-addTickCmdGRHSs (GRHSs x guarded (dL->L l local_binds)) = do
+addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
guarded' <- mapM (liftL addTickCmdGRHS) guarded
- return $ GRHSs x guarded' (cL l local_binds')
+ return $ GRHSs x guarded' (L l local_binds')
where
binders = collectLocalBinders local_binds
addTickCmdGRHSs (XGRHSs nec) = noExtCon nec
@@ -961,8 +958,8 @@ addTickCmdStmt (BodyStmt x c bind' guard') = do
(addTickLHsCmd c)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
-addTickCmdStmt (LetStmt x (dL->L l binds)) = do
- liftM (LetStmt x . cL l)
+addTickCmdStmt (LetStmt x (L l binds)) = do
+ liftM (LetStmt x . L l)
(addTickHsLocalBinds binds)
addTickCmdStmt stmt@(RecStmt {})
= do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
@@ -986,9 +983,9 @@ addTickHsRecordBinds (HsRecFields fields dd)
addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc)
-> TM (LHsRecField' id (LHsExpr GhcTc))
-addTickHsRecField (dL->L l (HsRecField id expr pun))
+addTickHsRecField (L l (HsRecField id expr pun))
= do { expr' <- addTickLHsExpr expr
- ; return (cL l (HsRecField id expr' pun)) }
+ ; return (L l (HsRecField id expr' pun)) }
addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
@@ -1168,10 +1165,10 @@ allocTickBox boxLabel countEntries topOnly pos m =
(fvs, e) <- getFreeVars m
env <- getEnv
tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
- return (cL pos (HsTick noExtField tickish (cL pos e)))
+ return (L pos (HsTick noExtField tickish (L pos e)))
) (do
e <- m
- return (cL pos e)
+ return (L pos e)
)
-- the tick application inherits the source position of its
@@ -1239,7 +1236,7 @@ allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)
allocBinTickBox boxLabel pos m = do
env <- getEnv
case tickishType env of
- HpcTicks -> do e <- liftM (cL pos) m
+ HpcTicks -> do e <- liftM (L pos) m
ifGoodTickSrcSpan pos
(mkBinTickBoxHpc boxLabel pos e)
(return e)
@@ -1255,8 +1252,8 @@ mkBinTickBoxHpc boxLabel pos e =
c = tickBoxCount st
mes = mixEntries st
in
- ( cL pos $ HsTick noExtField (HpcTick (this_mod env) c)
- $ cL pos $ HsBinTick noExtField (c+1) (c+2) e
+ ( L pos $ HsTick noExtField (HpcTick (this_mod env) c)
+ $ L pos $ HsBinTick noExtField (c+1) (c+2) e
-- notice that F and T are reversed,
-- because we are building the list in
-- reverse...
@@ -1283,12 +1280,11 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
matchesOneOfMany :: [LMatch GhcTc body] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
where
- matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ }))
+ matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))
= length grhss
- matchCount (dL->L _ (Match { m_grhss = XGRHSs nec }))
+ matchCount (L _ (Match { m_grhss = XGRHSs nec }))
= noExtCon nec
- matchCount (dL->L _ (XMatch nec)) = noExtCon nec
- matchCount _ = panic "matchCount: Impossible Match" -- due to #15884
+ matchCount (L _ (XMatch nec)) = noExtCon nec
type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index c2978d8774..f5aa6f0785 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -369,13 +369,13 @@ Reason
-}
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
-dsRule (dL->L loc (HsRule { rd_name = name
- , rd_act = rule_act
- , rd_tmvs = vars
- , rd_lhs = lhs
- , rd_rhs = rhs }))
+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]
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
index ade017208d..0cbf3dae39 100644
--- a/compiler/deSugar/DsArrows.hs
+++ b/compiler/deSugar/DsArrows.hs
@@ -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
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 20a3b23e96..dbfc6f52fd 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -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,8 +118,8 @@ dsLHsBinds binds
------------------------
dsLHsBind :: LHsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
-dsLHsBind (dL->L loc bind) = do dflags <- getDynFlags
- putSrcSpanDs loc $ dsHsBind dflags bind
+dsLHsBind (L loc bind) = do dflags <- getDynFlags
+ putSrcSpanDs loc $ dsHsBind dflags bind
-- | Desugar a single binding (or group of recursive binds).
dsHsBind :: DynFlags
@@ -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"
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index e0bb58bd49..e58bb341aa 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -72,11 +72,11 @@ 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 $
- dsValBinds binds body
-dsLocalBinds (dL->L _ (HsIPBinds _ binds)) body = dsIPBinds binds body
-dsLocalBinds _ _ = panic "dsLocalBinds"
+dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body
+dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
+ dsValBinds binds body
+dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body
+dsLocalBinds _ _ = panic "dsLocalBinds"
-------------------------
-- caller sets location
@@ -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
+ = [hsRecFieldArg fld | L _ fld <- rbinds
, sel == idName (unLoc $ hsRecFieldId fld) ]
{-
@@ -896,7 +896,7 @@ dsDo stmts
= goL stmts
where
goL [] = panic "dsDo"
- goL ((dL->L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
+ goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
go _ (LastStmt _ body _ _) stmts
= ASSERT( null stmts ) dsLExpr body
@@ -961,7 +961,7 @@ dsDo stmts
, recS_ret_ty = body_ty} }) stmts
= goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
where
- new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
+ new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
mfix_app bind_op
noSyntaxExpr -- Tuple cannot fail
@@ -1002,7 +1002,7 @@ handle_failure pat match fail_op
| otherwise
= extractMatchResult match (error "It can't fail")
-mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
+mk_fail_msg :: DynFlags -> Located e -> String
mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
showPpr dflags (getLoc pat)
@@ -1142,7 +1142,7 @@ we're not directly in an HsWrap, reject.
checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()
checkForcedEtaExpansion expr ty
| Just var <- case expr of
- HsVar _ (dL->L _ var) -> Just var
+ HsVar _ (L _ var) -> Just var
HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)
_ -> Nothing
, let bad_tys = badUseOfLevPolyPrimop var ty
diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs
index 43ef2327c5..49dab953bf 100644
--- a/compiler/deSugar/DsForeign.hs
+++ b/compiler/deSugar/DsForeign.hs
@@ -97,7 +97,7 @@ dsForeigns' fos = do
(vcat cs $$ vcat fe_init_code),
foldr (appOL . toOL) nilOL bindss)
where
- do_ldecl (dL->L loc decl) = putSrcSpanDs loc (do_decl decl)
+ do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
traceIf (text "fi start" <+> ppr id)
@@ -106,10 +106,10 @@ dsForeigns' fos = do
traceIf (text "fi end" <+> ppr id)
return (h, c, [], bs)
- do_decl (ForeignExport { fd_name = (dL->L _ id)
+ do_decl (ForeignExport { fd_name = L _ id
, fd_e_ext = co
, fd_fe = CExport
- (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do
+ (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], [])
do_decl (XForeignDecl nec) = noExtCon nec
diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs
index a6ef106c98..fe60cb8001 100644
--- a/compiler/deSugar/DsGRHSs.hs
+++ b/compiler/deSugar/DsGRHSs.hs
@@ -70,10 +70,9 @@ dsGRHSs _ (XGRHSs nec) _ = noExtCon nec
dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
-> DsM MatchResult
-dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs))
+dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs))
= matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
-dsGRHS _ _ (dL->L _ (XGRHS nec)) = noExtCon nec
-dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884
+dsGRHS _ _ (L _ (XGRHS nec)) = noExtCon nec
{-
************************************************************************
diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs
index e826045eb5..084a9dabff 100644
--- a/compiler/deSugar/DsListComp.hs
+++ b/compiler/deSugar/DsListComp.hs
@@ -484,8 +484,8 @@ dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr
dsMonadComp stmts = dsMcStmts stmts
dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr
-dsMcStmts [] = panic "dsMcStmts"
-dsMcStmts ((dL->L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
+dsMcStmts [] = panic "dsMcStmts"
+dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
---------------
dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
@@ -639,7 +639,7 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
| otherwise
= extractMatchResult match (error "It can't fail")
- mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
+ mk_fail_msg :: DynFlags -> Located e -> String
mk_fail_msg dflags pat
= "Pattern match failure in monad comprehension at " ++
showPpr dflags (getLoc pat)
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 4c38212648..0b0c7abdb4 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -170,15 +170,15 @@ repTopDs group@(HsGroup { hs_valds = valds
wrapGenSyms ss q_decs
}
where
- no_splice (dL->L loc _)
+ no_splice (L loc _)
= notHandledL loc "Splices within declaration brackets" empty
- no_default_decl (dL->L loc decl)
+ no_default_decl (L loc decl)
= notHandledL loc "Default declarations" (ppr decl)
- no_warn (dL->L loc (Warning _ thing _))
+ no_warn (L loc (Warning _ thing _))
= notHandledL loc "WARNING and DEPRECATION pragmas" $
text "Pragma for declaration of" <+> ppr thing
no_warn _ = panic "repTopDs"
- no_doc (dL->L loc _)
+ no_doc (L loc _)
= notHandledL loc "Haddock documentation" empty
repTopDs (XHsGroup nec) = noExtCon nec
@@ -192,7 +192,7 @@ hsScopedTvBinders binds
XValBindsLR (NValBinds _ sigs) -> sigs
get_scoped_tvs :: LSig GhcRn -> [Name]
-get_scoped_tvs (dL->L _ signature)
+get_scoped_tvs (L _ signature)
| TypeSig _ _ sig <- signature
= get_scoped_tvs_from_sig (hswc_body sig)
| ClassOpSig _ _ _ sig <- signature
@@ -302,24 +302,24 @@ them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
--
repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ))
-repTyClD (dL->L loc (FamDecl { tcdFam = fam })) = liftM Just $
- repFamilyDecl (L loc fam)
+repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $
+ repFamilyDecl (L loc fam)
-repTyClD (dL->L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
+repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
repSynDecl tc1 bndrs rhs
; return (Just (loc, dec)) }
-repTyClD (dL->L loc (DataDecl { tcdLName = tc
- , tcdTyVars = tvs
- , tcdDataDefn = defn }))
+repTyClD (L loc (DataDecl { tcdLName = tc
+ , tcdTyVars = tvs
+ , tcdDataDefn = defn }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
repDataDefn tc1 (Left bndrs) defn
; return (Just (loc, dec)) }
-repTyClD (dL->L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
+repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
tcdTyVars = tvs, tcdFDs = fds,
tcdSigs = sigs, tcdMeths = meth_binds,
tcdATs = ats, tcdATDefs = atds }))
@@ -341,7 +341,7 @@ repTyClD _ = panic "repTyClD"
-------------------------
repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repRoleD (dL->L loc (RoleAnnotDecl _ tycon roles))
+repRoleD (L loc (RoleAnnotDecl _ tycon roles))
= do { tycon1 <- lookupLOcc tycon
; roles1 <- mapM repRole roles
; roles2 <- coreList roleTyConName roles1
@@ -351,7 +351,7 @@ repRoleD _ = panic "repRoleD"
-------------------------
repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repKiSigD (dL->L loc kisig) =
+repKiSigD (L loc kisig) =
case kisig of
StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v
XStandaloneKindSig nec -> noExtCon nec
@@ -393,11 +393,11 @@ repSynDecl tc bndrs ty
; repTySyn tc bndrs ty1 }
repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repFamilyDecl decl@(dL->L loc (FamilyDecl { fdInfo = info
- , fdLName = tc
- , fdTyVars = tvs
- , fdResultSig = dL->L _ resultSig
- , fdInjectivityAnn = injectivity }))
+repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info
+ , fdLName = tc
+ , fdTyVars = tvs
+ , fdResultSig = L _ resultSig
+ , fdInjectivityAnn = injectivity }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
mkHsQTvs tvs = HsQTvs { hsq_ext = []
@@ -453,7 +453,7 @@ repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
-> DsM (Core (Maybe TH.InjectivityAnn))
repInjectivityAnn Nothing =
do { coreNothing injAnnTyConName }
-repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) =
+repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =
do { lhs' <- lookupBinder (unLoc lhs)
; rhs1 <- mapM (lookupBinder . unLoc) rhs
; rhs2 <- coreList nameTyConName rhs1
@@ -473,7 +473,7 @@ repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep])
repLFunDeps fds = repList funDepTyConName repLFunDep fds
repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)
-repLFunDep (dL->L _ (xs, ys))
+repLFunDep (L _ (xs, ys))
= do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
ys' <- repList nameTyConName (lookupBinder . unLoc) ys
repFunDep xs' ys'
@@ -481,13 +481,13 @@ repLFunDep (dL->L _ (xs, ys))
-- Represent instance declarations
--
repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl }))
+repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
= do { dec <- repTyFamInstD fi_decl
; return (loc, dec) }
-repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl }))
+repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
= do { dec <- repDataFamInstD fi_decl
; return (loc, dec) }
-repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl }))
+repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
= do { dec <- repClsInstD cls_decl
; return (loc, dec) }
repInstD _ = panic "repInstD"
@@ -523,8 +523,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
repClsInstD (XClsInstDecl nec) = noExtCon nec
repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat
- , deriv_type = ty }))
+repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
+ , deriv_type = ty }))
= do { dec <- addSimpleTyVarBinds tvs $
do { cxt' <- repLContext cxt
; strat' <- repDerivStrategy strat
@@ -611,9 +611,8 @@ repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec)))
= noExtCon nec
repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)
-repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
- , fd_fi = CImport (dL->L _ cc)
- (dL->L _ s) mch cis _ }))
+repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
+ , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))
= do MkC name' <- lookupLOcc name
MkC typ' <- repHsSigType typ
MkC cc' <- repCCallConv cc
@@ -654,7 +653,7 @@ repSafety PlayInterruptible = rep2 interruptibleName []
repSafety PlaySafe = rep2 safeName []
repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir)))
+repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
= do { MkC prec' <- coreIntLit prec
; let rep_fn = case dir of
InfixL -> infixLDName
@@ -668,12 +667,12 @@ repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir)))
repFixD _ = panic "repFixD"
repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repRuleD (dL->L loc (HsRule { rd_name = n
- , rd_act = act
- , rd_tyvs = ty_bndrs
- , rd_tmvs = tm_bndrs
- , rd_lhs = lhs
- , rd_rhs = rhs }))
+repRuleD (L loc (HsRule { rd_name = n
+ , rd_act = act
+ , rd_tyvs = ty_bndrs
+ , rd_tmvs = tm_bndrs
+ , rd_lhs = lhs
+ , rd_rhs = rhs }))
= do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
; ss <- mkGenSyms tm_bndr_names
@@ -695,29 +694,28 @@ repRuleD (dL->L loc (HsRule { rd_name = n
repRuleD _ = panic "repRuleD"
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
-ruleBndrNames (dL->L _ (RuleBndr _ n)) = [unLoc n]
-ruleBndrNames (dL->L _ (RuleBndrSig _ n sig))
+ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n]
+ruleBndrNames (L _ (RuleBndrSig _ n sig))
| HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
= unLoc n : vars
-ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
+ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
= panic "ruleBndrNames"
-ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
+ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
= panic "ruleBndrNames"
-ruleBndrNames (dL->L _ (XRuleBndr nec)) = noExtCon nec
-ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884
+ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec
repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
-repRuleBndr (dL->L _ (RuleBndr _ n))
+repRuleBndr (L _ (RuleBndr _ n))
= do { MkC n' <- lookupLBinder n
; rep2 ruleVarName [n'] }
-repRuleBndr (dL->L _ (RuleBndrSig _ n sig))
+repRuleBndr (L _ (RuleBndrSig _ n sig))
= do { MkC n' <- lookupLBinder n
; MkC ty' <- repLTy (hsSigWcType sig)
; rep2 typedRuleVarName [n', ty'] }
repRuleBndr _ = panic "repRuleBndr"
repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp)))
+repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
= do { target <- repAnnProv ann_prov
; exp' <- repE exp
; dec <- repPragAnn target exp'
@@ -725,10 +723,10 @@ repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp)))
repAnnD _ = panic "repAnnD"
repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
-repAnnProv (ValueAnnProvenance (dL->L _ n))
+repAnnProv (ValueAnnProvenance (L _ n))
= do { MkC n' <- globalVar n -- ANNs are allowed only at top-level
; rep2 valueAnnotationName [ n' ] }
-repAnnProv (TypeAnnProvenance (dL->L _ n))
+repAnnProv (TypeAnnProvenance (L _ n))
= do { MkC n' <- globalVar n
; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
@@ -739,17 +737,17 @@ repAnnProv ModuleAnnProvenance
-------------------------------------------------------
repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
-repC (dL->L _ (ConDeclH98 { con_name = con
- , con_forall = (dL->L _ False)
- , con_mb_cxt = Nothing
- , con_args = args }))
+repC (L _ (ConDeclH98 { con_name = con
+ , con_forall = L _ False
+ , con_mb_cxt = Nothing
+ , con_args = args }))
= repDataCon con args
-repC (dL->L _ (ConDeclH98 { con_name = con
- , con_forall = (dL->L _ is_existential)
- , con_ex_tvs = con_tvs
- , con_mb_cxt = mcxt
- , con_args = args }))
+repC (L _ (ConDeclH98 { con_name = con
+ , con_forall = L _ is_existential
+ , con_ex_tvs = con_tvs
+ , con_mb_cxt = mcxt
+ , con_args = args }))
= do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
do { c' <- repDataCon con args
; ctxt' <- repMbContext mcxt
@@ -759,11 +757,11 @@ repC (dL->L _ (ConDeclH98 { con_name = con
}
}
-repC (dL->L _ (ConDeclGADT { con_names = cons
- , con_qvars = qtvs
- , con_mb_cxt = mcxt
- , con_args = args
- , con_res_ty = res_ty }))
+repC (L _ (ConDeclGADT { con_names = cons
+ , con_qvars = qtvs
+ , con_mb_cxt = mcxt
+ , con_args = args
+ , con_res_ty = res_ty }))
| isEmptyLHsQTvs qtvs -- No implicit or explicit variables
, Nothing <- mcxt -- No context
-- ==> no need for a forall
@@ -783,7 +781,7 @@ repC _ = panic "repC"
repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
repMbContext Nothing = repContext []
-repMbContext (Just (dL->L _ cxt)) = repContext cxt
+repMbContext (Just (L _ cxt)) = repContext cxt
repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName []
@@ -812,14 +810,14 @@ repBangTy ty = do
-------------------------------------------------------
repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])
-repDerivs (dL->L _ clauses)
+repDerivs (L _ clauses)
= repList derivClauseQTyConName repDerivClause clauses
repDerivClause :: LHsDerivingClause GhcRn
-> DsM (Core TH.DerivClauseQ)
-repDerivClause (dL->L _ (HsDerivingClause
+repDerivClause (L _ (HsDerivingClause
{ deriv_clause_strategy = dcs
- , deriv_clause_tys = (dL->L _ dct) }))
+ , deriv_clause_tys = L _ dct }))
= do MkC dcs' <- repDerivStrategy dcs
MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
rep2 derivClauseName [dcs',dct']
@@ -853,22 +851,22 @@ rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
rep_sigs = concatMapM rep_sig
rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-rep_sig (dL->L loc (TypeSig _ nms ty))
+rep_sig (L loc (TypeSig _ nms ty))
= mapM (rep_wc_ty_sig sigDName loc ty) nms
-rep_sig (dL->L loc (PatSynSig _ nms ty))
+rep_sig (L loc (PatSynSig _ nms ty))
= mapM (rep_patsyn_ty_sig loc ty) nms
-rep_sig (dL->L loc (ClassOpSig _ is_deflt nms ty))
+rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
| is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
| otherwise = mapM (rep_ty_sig sigDName loc ty) nms
-rep_sig d@(dL->L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
-rep_sig (dL->L _ (FixSig {})) = return [] -- fixity sigs at top level
-rep_sig (dL->L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
-rep_sig (dL->L loc (SpecSig _ nm tys ispec))
+rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
+rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level
+rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
+rep_sig (L loc (SpecSig _ nm tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec loc) tys
-rep_sig (dL->L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc
-rep_sig (dL->L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
-rep_sig (dL->L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
-rep_sig (dL->L loc (CompleteMatchSig _ _st cls mty))
+rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc
+rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
+rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
+rep_sig (L loc (CompleteMatchSig _ _st cls mty))
= rep_complete_sig cls mty loc
rep_sig _ = panic "rep_sig"
@@ -990,7 +988,7 @@ rep_complete_sig :: Located [Located Name]
-> Maybe (Located Name)
-> SrcSpan
-> DsM [(SrcSpan, Core TH.DecQ)]
-rep_complete_sig (dL->L _ cls) mty loc
+rep_complete_sig (L _ cls) mty loc
= do { mty' <- repMaybe nameTyConName lookupLOcc mty
; cls' <- repList nameTyConName lookupLOcc cls
; sig <- repPragComplete cls' mty'
@@ -1066,18 +1064,18 @@ addTyClTyVarBinds tvs m
--
repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
-> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
-repTyVarBndrWithKind (dL->L _ (UserTyVar _ _)) nm
+repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm
= repPlainTV nm
-repTyVarBndrWithKind (dL->L _ (KindedTyVar _ _ ki)) nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm
= repLTy ki >>= repKindedTV nm
repTyVarBndrWithKind _ _ = panic "repTyVarBndrWithKind"
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
-repTyVarBndr (dL->L _ (UserTyVar _ (dL->L _ nm)) )
+repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )
= do { nm' <- lookupBinder nm
; repPlainTV nm' }
-repTyVarBndr (dL->L _ (KindedTyVar _ (dL->L _ nm) ki))
+repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki))
= do { nm' <- lookupBinder nm
; ki' <- repLTy ki
; repKindedTV nm' ki' }
@@ -1135,7 +1133,7 @@ repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
repTy ty@(HsForAllTy {hst_fvf = fvf}) = repForall fvf ty
repTy ty@(HsQualTy {}) = repForall ForallInvis ty
-repTy (HsTyVar _ _ (dL->L _ n))
+repTy (HsTyVar _ _ (L _ n))
| isLiftedTypeKindTyConName n = repTStar
| n `hasKey` constraintKindTyConKey = repTConstraint
| n `hasKey` funTyConKey = repArrowTyCon
@@ -1216,11 +1214,10 @@ repMaybeLTy :: Maybe (LHsKind GhcRn)
repMaybeLTy = repMaybe kindQTyConName repLTy
repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
-repRole (dL->L _ (Just Nominal)) = rep2 nominalRName []
-repRole (dL->L _ (Just Representational)) = rep2 representationalRName []
-repRole (dL->L _ (Just Phantom)) = rep2 phantomRName []
-repRole (dL->L _ Nothing) = rep2 inferRName []
-repRole _ = panic "repRole: Impossible Match" -- due to #15884
+repRole (L _ (Just Nominal)) = rep2 nominalRName []
+repRole (L _ (Just Representational)) = rep2 representationalRName []
+repRole (L _ (Just Phantom)) = rep2 phantomRName []
+repRole (L _ Nothing) = rep2 inferRName []
-----------------------------------------------------------------------------
-- Splices
@@ -1256,10 +1253,10 @@ repLEs es = repList expQTyConName repLE es
-- unless we can make sure that constructs, which are plainly not
-- supported in TH already lead to error messages at an earlier stage
repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
-repLE (dL->L loc e) = putSrcSpanDs loc (repE e)
+repLE (L loc e) = putSrcSpanDs loc (repE e)
repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
-repE (HsVar _ (dL->L _ x)) =
+repE (HsVar _ (L _ x)) =
do { mb_val <- dsLookupMetaEnv x
; case mb_val of
Nothing -> do { str <- globalVar x
@@ -1279,8 +1276,8 @@ repE e@(HsRecFld _ f) = case f of
-- HsOverlit can definitely occur
repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit _ l) = do { a <- repLiteral l; repLit a }
-repE (HsLam _ (MG { mg_alts = (dL->L _ [m]) })) = repLambda m
-repE (HsLamCase _ (MG { mg_alts = (dL->L _ ms) }))
+repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m
+repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))
= do { ms' <- mapM repMatchTup ms
; core_ms <- coreList matchQTyConName ms'
; repLamCase core_ms }
@@ -1301,7 +1298,7 @@ repE (NegApp _ x _) = do
repE (HsPar _ x) = repLE x
repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
-repE (HsCase _ e (MG { mg_alts = (dL->L _ ms) }))
+repE (HsCase _ e (MG { mg_alts = (L _ ms) }))
= do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
; core_ms2 <- coreList matchQTyConName ms2
@@ -1315,13 +1312,13 @@ repE (HsMultiIf _ alts)
= do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
; expr' <- repMultiIf (nonEmptyCoreList alts')
; wrapGenSyms (concat binds) expr' }
-repE (HsLet _ (dL->L _ bs) e) = do { (ss,ds) <- repBinds bs
+repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs
; e2 <- addBinds ss (repLE e)
; z <- repLetE ds e2
; wrapGenSyms ss z }
-- FIXME: I haven't got the types here right yet
-repE e@(HsDo _ ctxt (dL->L _ sts))
+repE e@(HsDo _ ctxt (L _ sts))
| case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
= do { (ss,zs) <- repLSts sts;
e' <- repDoE (nonEmptyCoreList zs);
@@ -1343,9 +1340,9 @@ repE e@(HsDo _ ctxt (dL->L _ sts))
repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
repE (ExplicitTuple _ es boxity) =
let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ))
- tupArgToCoreExp a
- | L _ (Present _ e) <- dL a = do { e' <- repLE e
- ; coreJust expQTyConName e' }
+ tupArgToCoreExp (L _ a)
+ | Present _ e <- a = do { e' <- repLE e
+ ; coreJust expQTyConName e' }
| otherwise = coreNothing expQTyConName
in do { args <- mapM tupArgToCoreExp es
@@ -1407,8 +1404,8 @@ repE e = notHandled "Expression form" (ppr e)
-- Building representations of auxiliary structures like Match, Clause, Stmt,
repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)
-repMatchTup (dL->L _ (Match { m_pats = [p]
- , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =
+repMatchTup (L _ (Match { m_pats = [p]
+ , m_grhss = GRHSs _ guards (L _ wheres) })) =
do { ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
; p1 <- repLP p
@@ -1420,8 +1417,8 @@ repMatchTup (dL->L _ (Match { m_pats = [p]
repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)
-repClauseTup (dL->L _ (Match { m_pats = ps
- , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =
+repClauseTup (L _ (Match { m_pats = ps
+ , m_grhss = GRHSs _ guards (L _ wheres) })) =
do { ss1 <- mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do {
ps1 <- repLPs ps
@@ -1430,11 +1427,11 @@ repClauseTup (dL->L _ (Match { m_pats = ps
gs <- repGuards guards
; clause <- repClause ps1 gs ds
; wrapGenSyms (ss1++ss2) clause }}}
-repClauseTup (dL->L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec
+repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec
repClauseTup _ = panic "repClauseTup"
repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ)
-repGuards [dL->L _ (GRHS _ [] e)]
+repGuards [L _ (GRHS _ [] e)]
= do {a <- repLE e; repNormal a }
repGuards other
= do { zs <- mapM repLGRHS other
@@ -1444,10 +1441,10 @@ repGuards other
repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
-> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
-repLGRHS (dL->L _ (GRHS _ [dL->L _ (BodyStmt _ e1 _ _)] e2))
+repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))
= do { guarded <- repLNormalGE e1 e2
; return ([], guarded) }
-repLGRHS (dL->L _ (GRHS _ ss rhs))
+repLGRHS (L _ (GRHS _ ss rhs))
= do { (gs, ss') <- repLSts ss
; rhs' <- addBinds gs $ repLE rhs
; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
@@ -1460,16 +1457,16 @@ repFields (HsRecFields { rec_flds = flds })
where
rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
-> DsM (Core (TH.Q TH.FieldExp))
- rep_fld (dL->L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
- ; e <- repLE (hsRecFieldArg fld)
- ; repFieldExp fn e }
+ rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
+ ; e <- repLE (hsRecFieldArg fld)
+ ; repFieldExp fn e }
repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp])
repUpdFields = repList fieldExpQTyConName rep_fld
where
rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
- rep_fld (dL->L l fld) = case unLoc (hsRecFieldLbl fld) of
- Unambiguous sel_name _ -> do { fn <- lookupLOcc (cL l sel_name)
+ rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
+ Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
; e <- repLE (hsRecFieldArg fld)
; repFieldExp fn e }
_ -> notHandled "Ambiguous record updates" (ppr fld)
@@ -1513,7 +1510,7 @@ repSts (BindStmt _ p e _ _ : ss) =
; (ss2,zs) <- repSts ss
; z <- repBindSt p1 e2
; return (ss1++ss2, z : zs) }}
-repSts (LetStmt _ (dL->L _ bs) : ss) =
+repSts (LetStmt _ (L _ bs) : ss) =
do { (ss1,ds) <- repBinds bs
; z <- repLetSt ds
; (ss2,zs) <- addBinds ss1 (repSts ss)
@@ -1590,18 +1587,16 @@ repBinds (HsValBinds _ decs)
repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-rep_implicit_param_bind (dL->L loc (IPBind _ ename (dL->L _ rhs)))
+rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
= do { name <- case ename of
- Left (dL->L _ n) -> rep_implicit_param_name n
+ Left (L _ n) -> rep_implicit_param_name n
Right _ ->
panic "rep_implicit_param_bind: post typechecking"
; rhs' <- repE rhs
; ipb <- repImplicitParamBind name rhs'
; return (loc, ipb) }
-rep_implicit_param_bind (dL->L _ b@(XIPBind _))
+rep_implicit_param_bind (L _ b@(XIPBind _))
= notHandled "Implicit parameter bind extension" (ppr b)
-rep_implicit_param_bind _ = panic "rep_implicit_param_bind: Impossible Match"
- -- due to #15884
rep_implicit_param_name :: HsIPName -> DsM (Core String)
rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
@@ -1624,13 +1619,12 @@ rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-- Note GHC treats declarations of a variable (not a pattern)
-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
-- with an empty list of patterns
-rep_bind (dL->L loc (FunBind
+rep_bind (L loc (FunBind
{ fun_id = fn,
fun_matches = MG { mg_alts
- = (dL->L _ [dL->L _ (Match
- { m_pats = []
- , m_grhss = GRHSs _ guards
- (dL->L _ wheres) }
+ = (L _ [L _ (Match
+ { m_pats = []
+ , m_grhss = GRHSs _ guards (L _ wheres) }
)]) } }))
= do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
@@ -1640,26 +1634,26 @@ rep_bind (dL->L loc (FunBind
; ans' <- wrapGenSyms ss ans
; return (loc, ans') }
-rep_bind (dL->L loc (FunBind { fun_id = fn
- , fun_matches = MG { mg_alts = (dL->L _ ms) } }))
+rep_bind (L loc (FunBind { fun_id = fn
+ , fun_matches = MG { mg_alts = L _ ms } }))
= do { ms1 <- mapM repClauseTup ms
; fn' <- lookupLBinder fn
; ans <- repFun fn' (nonEmptyCoreList ms1)
; return (loc, ans) }
-rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec
+rep_bind (L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec
-rep_bind (dL->L loc (PatBind { pat_lhs = pat
- , pat_rhs = GRHSs _ guards (dL->L _ wheres) }))
+rep_bind (L loc (PatBind { pat_lhs = pat
+ , pat_rhs = GRHSs _ guards (L _ wheres) }))
= do { patcore <- repLP pat
; (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; ans <- repVal patcore guardcore wherecore
; ans' <- wrapGenSyms ss ans
; return (loc, ans') }
-rep_bind (dL->L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec
+rep_bind (L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec
-rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e}))
+rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
= do { v' <- lookupBinder v
; e2 <- repLE e
; x <- repNormal e2
@@ -1668,11 +1662,11 @@ rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e}))
; ans <- repVal patcore x empty_decls
; return (srcLocSpan (getSrcLoc v), ans) }
-rep_bind (dL->L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
-rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id = syn
- , psb_args = args
- , psb_def = pat
- , psb_dir = dir })))
+rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
+rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
+ , psb_args = args
+ , psb_def = pat
+ , psb_dir = dir })))
= do { syn' <- lookupLBinder syn
; dir' <- repPatSynDir dir
; ss <- mkGenArgSyms args
@@ -1707,11 +1701,8 @@ rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id = syn
wrapGenArgSyms (RecCon _) _ dec = return dec
wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
-rep_bind (dL->L _ (PatSynBind _ (XPatSynBind nec)))
- = noExtCon nec
-rep_bind (dL->L _ (XHsBindsLR nec)) = noExtCon nec
-rep_bind _ = panic "rep_bind: Impossible match!"
- -- due to #15884
+rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec
+rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec
repPatSynD :: Core TH.Name
-> Core TH.PatSynArgsQ
@@ -1747,7 +1738,7 @@ repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ)
repPatSynDir Unidirectional = rep2 unidirPatSynName []
repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
-repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) }))
+repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) }))
= do { clauses' <- mapM repClauseTup clauses
; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec
@@ -1781,16 +1772,16 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
-- (\ p1 .. pn -> exp) by causing an error.
repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
-repLambda (dL->L _ (Match { m_pats = ps
- , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] e)]
- (dL->L _ (EmptyLocalBinds _)) } ))
+repLambda (L _ (Match { m_pats = ps
+ , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
+ (L _ (EmptyLocalBinds _)) } ))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
do { xs <- repLPs ps; body <- repLE e; repLam xs body })
; wrapGenSyms ss lam }
-repLambda (dL->L _ m) = notHandled "Guarded lambdas" (pprMatch m)
+repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m)
-----------------------------------------------------------------------------
@@ -1837,12 +1828,12 @@ repP (ConPatIn dc details)
}
where
rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ))
- rep_fld (dL->L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
- ; MkC p <- repLP (hsRecFieldArg fld)
- ; rep2 fieldPatName [v,p] }
+ rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
+ ; MkC p <- repLP (hsRecFieldArg fld)
+ ; rep2 fieldPatName [v,p] }
-repP (NPat _ (dL->L _ l) Nothing _) = do { a <- repOverloadedLiteral l
- ; repPlit a }
+repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l
+ ; repPlit a }
repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
repP (SigPat _ p t) = do { p' <- repLP p
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index b76c4f0592..c358c175c6 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -674,7 +674,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
-- and all the desugared binds
mkSelectorBinds ticks pat val_expr
- | (dL->L _ (VarPat _ (dL->L _ v))) <- pat' -- Special case (A)
+ | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A)
= return (v, [(v, val_expr)])
| is_flat_prod_lpat pat' -- Special case (B)
@@ -721,9 +721,9 @@ mkSelectorBinds ticks pat val_expr
strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)
-- Remove outermost bangs and parens
-strip_bangs (dL->L _ (ParPat _ p)) = strip_bangs p
-strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p
-strip_bangs lp = lp
+strip_bangs (L _ (ParPat _ p)) = strip_bangs p
+strip_bangs (L _ (BangPat _ p)) = strip_bangs p
+strip_bangs lp = lp
is_flat_prod_lpat :: LPat (GhcPass p) -> Bool
is_flat_prod_lpat = is_flat_prod_pat . unLoc
@@ -731,7 +731,7 @@ is_flat_prod_lpat = is_flat_prod_pat . unLoc
is_flat_prod_pat :: Pat (GhcPass p) -> Bool
is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p
is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
-is_flat_prod_pat (ConPatOut { pat_con = (dL->L _ pcon)
+is_flat_prod_pat (ConPatOut { pat_con = L _ pcon
, pat_args = ps})
| RealDataCon con <- pcon
, isProductTyCon (dataConTyCon con)
@@ -759,7 +759,7 @@ is_triv_pat _ = False
mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats = cL (getLoc (head lpats)) $
+mkLHsPatTup lpats = L (getLoc (head lpats)) $
mkVanillaTuplePat lpats Boxed
mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
@@ -952,25 +952,25 @@ decideBangHood dflags lpat
| otherwise -- -XStrict
= go lpat
where
- go lp@(dL->L l p)
+ go lp@(L l p)
= case p of
- ParPat x p -> cL l (ParPat x (go p))
+ ParPat x p -> L l (ParPat x (go p))
LazyPat _ lp' -> lp'
BangPat _ _ -> lp
- _ -> cL l (BangPat noExtField lp)
+ _ -> L l (BangPat noExtField lp)
-- | Unconditionally make a 'Pat' strict.
addBang :: LPat GhcTc -- ^ Original pattern
-> LPat GhcTc -- ^ Banged pattern
addBang = go
where
- go lp@(dL->L l p)
+ go lp@(L l p)
= case p of
- ParPat x p -> cL l (ParPat x (go p))
- LazyPat _ lp' -> cL l (BangPat noExtField lp')
+ ParPat x p -> L l (ParPat x (go p))
+ LazyPat _ lp' -> L l (BangPat noExtField lp')
-- Should we bring the extension value over?
BangPat _ _ -> lp
- _ -> cL l (BangPat noExtField lp)
+ _ -> L l (BangPat noExtField lp)
isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
@@ -980,24 +980,24 @@ isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-- * Trivial wappings of these
-- The arguments to Just are any HsTicks that we have found,
-- because we still want to tick then, even it they are always evaluated.
-isTrueLHsExpr (dL->L _ (HsVar _ (dL->L _ v)))
+isTrueLHsExpr (L _ (HsVar _ (L _ v)))
| v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
= Just return
-- trueDataConId doesn't have the same unique as trueDataCon
-isTrueLHsExpr (dL->L _ (HsConLikeOut _ con))
+isTrueLHsExpr (L _ (HsConLikeOut _ con))
| con `hasKey` getUnique trueDataCon = Just return
-isTrueLHsExpr (dL->L _ (HsTick _ tickish e))
+isTrueLHsExpr (L _ (HsTick _ tickish e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do wrapped <- ticks x
return (Tick tickish wrapped))
-- This encodes that the result is constant True for Hpc tick purposes;
-- which is specifically what isTrueLHsExpr is trying to find out.
-isTrueLHsExpr (dL->L _ (HsBinTick _ ixT _ e))
+isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do e <- ticks x
this_mod <- getModule
return (Tick (HpcTick this_mod ixT) e))
-isTrueLHsExpr (dL->L _ (HsPar _ e)) = isTrueLHsExpr e
-isTrueLHsExpr _ = Nothing
+isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e
+isTrueLHsExpr _ = Nothing
diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs
index 33bed3b3f5..ec5238ae4b 100644
--- a/compiler/deSugar/ExtractDocs.hs
+++ b/compiler/deSugar/ExtractDocs.hs
@@ -12,6 +12,7 @@ import GHC.Hs.Binds
import GHC.Hs.Doc
import GHC.Hs.Decls
import GHC.Hs.Extension
+import GHC.Hs.Pat
import GHC.Hs.Types
import GHC.Hs.Utils
import Name
@@ -114,7 +115,8 @@ user-written. This lets us relate Names (from ClsInsts) to comments
(associated with InstDecls and DerivDecls).
-}
-getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
+getMainDeclBinder :: XRec pass Pat ~ Located (Pat pass) =>
+ HsDecl pass -> [IdP pass]
getMainDeclBinder (TyClD _ d) = [tcdName d]
getMainDeclBinder (ValD _ d) =
case collectHsBindBinders d of
@@ -141,13 +143,13 @@ getInstLoc :: InstDecl (GhcPass p) -> SrcSpan
getInstLoc = \case
ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)
DataFamInstD _ (DataFamInstDecl
- { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->L l _) }}}) -> l
+ { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l
TyFamInstD _ (TyFamInstDecl
-- Since CoAxioms' Names refer to the whole line for type family instances
-- in particular, we need to dig a bit deeper to pull out the entire
-- equation. This does not happen for data family instances, for some
-- reason.
- { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = (dL->L l _) }}}) -> l
+ { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l
ClsInstD _ (XClsInstDecl _) -> error "getInstLoc"
DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
@@ -164,7 +166,7 @@ subordinates :: Map SrcSpan Name
subordinates instMap decl = case decl of
InstD _ (ClsInstD _ d) -> do
DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
- FamEqn { feqn_tycon = (dL->L l _)
+ FamEqn { feqn_tycon = L l _
, feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d
[ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
@@ -175,7 +177,7 @@ subordinates instMap decl = case decl of
_ -> []
where
classSubs dd = [ (name, doc, declTypeDocs d)
- | (dL->L _ d, doc) <- classDecls dd
+ | (L _ d, doc) <- classDecls dd
, name <- getMainDeclBinder d, not (isValD d)
]
dataSubs :: HsDataDefn GhcRn
@@ -189,8 +191,8 @@ subordinates instMap decl = case decl of
| c <- cons, cname <- getConNames c ]
fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
| RecCon flds <- map getConArgs cons
- , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
- , (dL->L _ n) <- ns ]
+ , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
+ , (L _ n) <- ns ]
derivs = [ (instName, [unLoc doc], M.empty)
| (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
concatMap (unLoc . deriv_clause_tys . unLoc) $
@@ -198,15 +200,15 @@ subordinates instMap decl = case decl of
, Just instName <- [M.lookup l instMap] ]
extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
- extract_deriv_ty ty =
- case dL ty of
+ extract_deriv_ty (L l ty) =
+ case ty of
-- deriving (forall a. C a {- ^ Doc comment -})
- L l (HsForAllTy{ hst_fvf = ForallInvis
- , hst_body = dL->L _ (HsDocTy _ _ doc) })
- -> Just (l, doc)
+ HsForAllTy{ hst_fvf = ForallInvis
+ , hst_body = L _ (HsDocTy _ _ doc) }
+ -> Just (l, doc)
-- deriving (C a {- ^ Doc comment -})
- L l (HsDocTy _ _ doc) -> Just (l, doc)
- _ -> Nothing
+ HsDocTy _ _ doc -> Just (l, doc)
+ _ -> Nothing
-- | Extract constructor argument docs from inside constructor decls.
conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 2e0aeb9877..b11a2e2f06 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -271,7 +271,7 @@ matchView (var:vars) ty (eqns@(eqn1:_))
= do { -- we could pass in the expr from the PgView,
-- but this needs to extract the pat anyway
-- to figure out the type of the fresh variable
- let ViewPat _ viewExpr (dL->L _ pat) = firstPat eqn1
+ let ViewPat _ viewExpr (L _ pat) = firstPat eqn1
-- do the rest of the compilation
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var pat_ty'
@@ -407,16 +407,16 @@ tidy1 :: Id -- The Id being scrutinised
tidy1 v o (ParPat _ pat) = tidy1 v o (unLoc pat)
tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat)
tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty)
-tidy1 v o (BangPat _ (dL->L l p)) = tidy_bang_pat v o l p
+tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
-tidy1 v _ (VarPat _ (dL->L _ var))
+tidy1 v _ (VarPat _ (L _ var))
= return (wrapBind var v, WildPat (idType var))
-- case v of { x@p -> mr[] }
-- = case v of { p -> let x=v in mr[] }
-tidy1 v o (AsPat _ (dL->L _ var) pat)
+tidy1 v o (AsPat _ (L _ var) pat)
= do { (wrap, pat') <- tidy1 v o (unLoc pat)
; return (wrapBind var v . wrap, pat') }
@@ -472,7 +472,7 @@ tidy1 _ o (LitPat _ lit)
; return (idDsWrapper, tidyLitPat lit) }
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (NPat ty (dL->L _ lit@OverLit { ol_val = v }) mb_neg eq)
+tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
= do { unless (isGenerated o) $
let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
| otherwise = lit
@@ -480,7 +480,7 @@ tidy1 _ o (NPat ty (dL->L _ lit@OverLit { ol_val = v }) mb_neg eq)
; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
-- NPlusKPat: we may want to warn about the literals
-tidy1 _ o n@(NPlusKPat _ _ (dL->L _ lit1) lit2 _ _)
+tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
= do { unless (isGenerated o) $ do
warnAboutOverflowedOverLit lit1
warnAboutOverflowedOverLit lit2
@@ -495,15 +495,15 @@ tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc
-> DsM (DsWrapper, Pat GhcTc)
-- Discard par/sig under a bang
-tidy_bang_pat v o _ (ParPat _ (dL->L l p)) = tidy_bang_pat v o l p
-tidy_bang_pat v o _ (SigPat _ (dL->L l p) _) = tidy_bang_pat v o l p
+tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p
+tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p
-- Push the bang-pattern inwards, in the hope that
-- it may disappear next time
tidy_bang_pat v o l (AsPat x v' p)
- = tidy1 v o (AsPat x v' (cL l (BangPat noExtField p)))
+ = tidy1 v o (AsPat x v' (L l (BangPat noExtField p)))
tidy_bang_pat v o l (CoPat x w p t)
- = tidy1 v o (CoPat x w (BangPat noExtField (cL l p)) t)
+ = tidy1 v o (CoPat x w (BangPat noExtField (L l p)) t)
-- Discard bang around strict pattern
tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p
@@ -512,7 +512,7 @@ tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p
tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p
-- Data/newtype constructors
-tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc))
+tidy_bang_pat v o l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
, pat_args = args
, pat_arg_tys = arg_tys })
-- Newtypes: push bang inwards (#9844)
@@ -538,7 +538,7 @@ tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc))
--
-- NB: SigPatIn, ConPatIn should not happen
-tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (cL l p))
+tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p))
-------------------
push_bang_into_newtype_arg :: SrcSpan
@@ -549,16 +549,16 @@ push_bang_into_newtype_arg :: SrcSpan
-- We are transforming !(N p) into (N !p)
push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
= ASSERT( null args)
- PrefixCon [cL l (BangPat noExtField arg)]
+ PrefixCon [L l (BangPat noExtField arg)]
push_bang_into_newtype_arg l _ty (RecCon rf)
- | HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf
+ | HsRecFields { rec_flds = L lf fld : flds } <- rf
, HsRecField { hsRecFieldArg = arg } <- fld
= ASSERT( null flds)
- RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg
- = cL l (BangPat noExtField arg) })] })
+ RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg
+ = L l (BangPat noExtField arg) })] })
push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
| HsRecFields { rec_flds = [] } <- rf
- = PrefixCon [cL l (BangPat noExtField (noLoc (WildPat ty)))]
+ = PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))]
push_bang_into_newtype_arg _ _ cd
= pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
@@ -724,7 +724,7 @@ one pattern, and match simply only accepts one pattern.
JJQC 30-Nov-1997
-}
-matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches)
+matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
, mg_ext = MatchGroupTc arg_tys rhs_ty
, mg_origin = origin })
= do { dflags <- getDynFlags
@@ -747,7 +747,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches)
; return (new_vars, result_expr) }
where
-- Called once per equation in the match, or alternative in the case
- mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))
+ mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss }))
= do { dflags <- getDynFlags
; let upats = map (unLoc . decideBangHood dflags) pats
dicts = collectEvVarsPats upats
@@ -763,8 +763,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches)
; return (EqnInfo { eqn_pats = upats
, eqn_orig = FromSource
, eqn_rhs = match_result }) }
- mk_eqn_info _ (dL->L _ (XMatch nec)) = noExtCon nec
- mk_eqn_info _ _ = panic "mk_eqn_info: Impossible Match" -- due to #15884
+ mk_eqn_info _ (L _ (XMatch nec)) = noExtCon nec
handleWarnings = if isGenerated origin
then discardWarningsDs
@@ -1004,8 +1003,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
-- real comparison is on HsExpr's
-- strip parens
- exp (HsPar _ (dL->L _ e)) e' = exp e e'
- exp e (HsPar _ (dL->L _ e')) = exp e e'
+ exp (HsPar _ (L _ e)) e' = exp e e'
+ exp e (HsPar _ (L _ e')) = exp e e'
-- because the expressions do not necessarily have the same type,
-- we have to compare the wrappers
exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'
@@ -1058,8 +1057,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
wrap res_wrap1 res_wrap2
---------
- tup_arg (dL->L _ (Present _ e1)) (dL->L _ (Present _ e2)) = lexp e1 e2
- tup_arg (dL->L _ (Missing t1)) (dL->L _ (Missing t2)) = eqType t1 t2
+ tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2
+ tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
tup_arg _ _ = False
---------
@@ -1094,13 +1093,13 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
patGroup :: DynFlags -> Pat GhcTc -> PatGroup
-patGroup _ (ConPatOut { pat_con = (dL->L _ con)
+patGroup _ (ConPatOut { pat_con = L _ con
, pat_arg_tys = tys })
| RealDataCon dcon <- con = PgCon dcon
| PatSynCon psyn <- con = PgSyn psyn tys
patGroup _ (WildPat {}) = PgAny
patGroup _ (BangPat {}) = PgBang
-patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) =
+patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) =
case (oval, isJust mb_neg) of
(HsIntegral i, False) -> PgN (fromInteger (il_value i))
(HsIntegral i, True ) -> PgN (-fromInteger (il_value i))
@@ -1108,7 +1107,7 @@ patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) =
(HsFractional r, True ) -> PgN (-fl_value r)
(HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
PgOverS s
-patGroup _ (NPlusKPat _ _ (dL->L _ (OverLit {ol_val=oval})) _ _ _) =
+patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
case oval of
HsIntegral i -> PgNpK (il_value i)
_ -> pprPanic "patGroup NPlusKPat" (ppr oval)
diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs
index be65433c3b..43d71acfdf 100644
--- a/compiler/deSugar/MatchCon.hs
+++ b/compiler/deSugar/MatchCon.hs
@@ -170,7 +170,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
alt_wrapper = wrapper1,
alt_result = foldr1 combineMatchResults match_results } }
where
- ConPatOut { pat_con = (dL->L _ con1)
+ ConPatOut { pat_con = L _ con1
, pat_arg_tys = arg_tys, pat_wrap = wrapper1,
pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
= firstPat eqn1
@@ -192,7 +192,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor
= arg_vars
where
fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
- lookup_fld (dL->L _ rpat) = lookupNameEnv_NF fld_var_env
+ lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env
(idName (unLoc (hsRecFieldId rpat)))
select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
matchOneConLike _ _ [] = panic "matchOneCon []"
@@ -209,7 +209,7 @@ compatible_pats _ _ = True -- Prefix or infix co
same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc)
-> Bool
same_fields flds1 flds2
- = all2 (\(dL->L _ f1) (dL->L _ f2)
+ = all2 (\(L _ f1) (L _ f2)
-> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
(rec_flds flds1) (rec_flds flds2)
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
index 126346b935..4f65362b2b 100644
--- a/compiler/deSugar/MatchLit.hs
+++ b/compiler/deSugar/MatchLit.hs
@@ -288,11 +288,11 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
-- ^ See if the expression is an 'Integral' literal.
-- Remember to look through automatically-added tick-boxes! (#8384)
-getLHsIntegralLit (dL->L _ (HsPar _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (dL->L _ (HsTick _ _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
-getLHsIntegralLit (dL->L _ (HsLit _ lit)) = getSimpleIntegralLit lit
+getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
+getLHsIntegralLit (L _ (HsLit _ lit)) = getSimpleIntegralLit lit
getLHsIntegralLit _ = Nothing
-- | If 'Integral', extract the value and type name of the overloaded literal.
@@ -469,7 +469,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal
- = do { let NPat _ (dL->L _ lit) mb_neg eq_chk = firstPat eqn1
+ = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
; lit_expr <- dsOverLit lit
; neg_lit <- case mb_neg of
Nothing -> return lit_expr
@@ -500,7 +500,7 @@ We generate:
matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- All NPlusKPats, for the *same* literal k
matchNPlusKPats (var:vars) ty (eqn1:eqns)
- = do { let NPlusKPat _ (dL->L _ n1) (dL->L _ lit1) lit2 ge minus
+ = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus
= firstPat eqn1
; lit1_expr <- dsOverLit lit1
; lit2_expr <- dsOverLit lit2
@@ -513,7 +513,7 @@ matchNPlusKPats (var:vars) ty (eqn1:eqns)
adjustMatchResult (foldr1 (.) wraps) $
match_result) }
where
- shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (dL->L _ n) _ _ _ _ : pats })
+ shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
= (wrapBind n n1, eqn { eqn_pats = pats })
-- The wrapBind is a no-op for the first equation
shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
View Lorry Controller Status