summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Check.hs24
-rw-r--r--compiler/deSugar/Coverage.hs87
-rw-r--r--compiler/deSugar/Desugar.hs23
-rw-r--r--compiler/deSugar/DsArrows.hs44
-rw-r--r--compiler/deSugar/DsExpr.hs43
-rw-r--r--compiler/deSugar/DsForeign.hs5
-rw-r--r--compiler/deSugar/DsGRHSs.hs16
-rw-r--r--compiler/deSugar/DsListComp.hs52
-rw-r--r--compiler/deSugar/DsMeta.hs154
-rw-r--r--compiler/deSugar/Match.hs15
10 files changed, 278 insertions, 185 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 6372967cc0..545aacef51 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -347,15 +347,17 @@ checkSingle' locn var p = do
checkGuardMatches :: HsMatchContext Name -- Match context
-> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs
-> DsM ()
-checkGuardMatches hs_ctx guards@(GRHSs grhss _) = do
+checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
dflags <- getDynFlags
let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
dsMatchContext = DsMatchContext hs_ctx combinedLoc
match = L combinedLoc $
- Match { m_ctxt = hs_ctx
+ Match { m_ext = noExt
+ , m_ctxt = hs_ctx
, m_pats = []
, m_grhss = guards }
checkMatches dflags dsMatchContext [] [match]
+checkGuardMatches _ (XGRHSs _) = panic "checkGuardMatches"
-- | Check a matchgroup (case, functions, etc.)
checkMatches :: DynFlags -> DsMatchContext
@@ -416,6 +418,7 @@ checkMatches' vars matches
hsLMatchToLPats :: LMatch id body -> Located [LPat id]
hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats
+ hsLMatchToLPats (L _ (XMatch _)) = panic "checMatches'"
-- | Check an empty case expression. Since there are no clauses to process, we
-- only compute the uncovered set. See Note [Checking EmptyCase Expressions]
@@ -780,12 +783,12 @@ translatePat fam_insts pat = case pat of
False -> mkCanFailPmPat arg_ty
-- list
- ListPat _ ps ty Nothing -> do
+ ListPat (ListPatTc ty Nothing) ps -> do
foldr (mkListPatVec ty) [nilPattern ty]
<$> translatePatVec fam_insts (map unLoc ps)
-- overloaded list
- ListPat x lpats elem_ty (Just (pat_ty, _to_list))
+ ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats
| Just e_ty <- splitListTyConApp_maybe pat_ty
, (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty
-- elem_ty is frequently something like
@@ -794,7 +797,7 @@ translatePat fam_insts pat = case pat of
-- We have to ensure that the element types are exactly the same.
-- Otherwise, one may give an instance IsList [Int] (more specific than
-- the default IsList [a]) with a different implementation for `toList'
- translatePat fam_insts (ListPat x lpats e_ty Nothing)
+ translatePat fam_insts (ListPat (ListPatTc e_ty Nothing) lpats)
-- See Note [Guards and Approximation]
| otherwise -> mkCanFailPmPat pat_ty
@@ -939,10 +942,12 @@ translateMatch fam_insts (L _ (Match { m_pats = lpats, m_grhss = grhss })) = do
return (pats', guards')
where
extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]
- extractGuards (L _ (GRHS gs _)) = map unLoc gs
+ extractGuards (L _ (GRHS _ gs _)) = map unLoc gs
+ extractGuards (L _ (XGRHS _)) = panic "translateMatch"
pats = map unLoc lpats
guards = map extractGuards (grhssGRHSs grhss)
+translateMatch _ (L _ (XMatch _)) = panic "translateMatch"
-- -----------------------------------------------------------------------
-- * Transform source guards (GuardStmt Id) to PmPats (Pattern)
@@ -990,14 +995,15 @@ cantFailPattern _ = False
-- | Translate a guard statement to Pattern
translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec
translateGuard fam_insts guard = case guard of
- BodyStmt e _ _ _ -> translateBoolGuard e
- LetStmt binds -> translateLet (unLoc binds)
- BindStmt p e _ _ _ -> translateBind fam_insts p e
+ BodyStmt _ e _ _ -> translateBoolGuard e
+ LetStmt _ binds -> translateLet (unLoc binds)
+ BindStmt _ p e _ _ -> translateBind fam_insts p e
LastStmt {} -> panic "translateGuard LastStmt"
ParStmt {} -> panic "translateGuard ParStmt"
TransStmt {} -> panic "translateGuard TransStmt"
RecStmt {} -> panic "translateGuard RecStmt"
ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"
+ XStmtLR {} -> panic "translateGuard RecStmt"
-- | Translate let-bindings
translateLet :: HsLocalBinds GhcTc -> DsM PatVec
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index ab04ee472f..25b77f2cfe 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -644,6 +644,7 @@ 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 = L l matches' }
+addTickMatchGroup _ (XMatchGroup _) = panic "addTickMatchGroup"
addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
-> TM (Match GhcTc (LHsExpr GhcTc))
@@ -651,23 +652,26 @@ addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats, m_grhss = gRHSs
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
return $ match { m_grhss = gRHSs' }
+addTickMatch _ _ (XMatch _) = panic "addTickMatch"
addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
-addTickGRHSs isOneOfMany isLambda (GRHSs guarded (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 guarded' (L l local_binds')
+ return $ GRHSs x guarded' (L l local_binds')
where
binders = collectLocalBinders local_binds
+addTickGRHSs _ _ (XGRHSs _) = panic "addTickGRHSs"
addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
-> TM (GRHS GhcTc (LHsExpr GhcTc))
-addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
+addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
(stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
(addTickGRHSBody isOneOfMany isLambda expr)
- return $ GRHS stmts' expr'
+ return $ GRHS x stmts' expr'
+addTickGRHS _ _ (XGRHS _) = panic "addTickGRHS"
addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
@@ -697,36 +701,33 @@ addTickLStmts' isGuard lstmts res
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
-> TM (Stmt GhcTc (LHsExpr GhcTc))
-addTickStmt _isGuard (LastStmt e noret ret) = do
- liftM3 LastStmt
+addTickStmt _isGuard (LastStmt x e noret ret) = do
+ liftM3 (LastStmt x)
(addTickLHsExpr e)
(pure noret)
(addTickSyntaxExpr hpcSrcSpan ret)
-addTickStmt _isGuard (BindStmt pat e bind fail ty) = do
- liftM5 BindStmt
+addTickStmt _isGuard (BindStmt x pat e bind fail) = do
+ liftM4 (BindStmt x)
(addTickLPat pat)
(addTickLHsExprRHS e)
(addTickSyntaxExpr hpcSrcSpan bind)
(addTickSyntaxExpr hpcSrcSpan fail)
- (return ty)
-addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
- liftM4 BodyStmt
+addTickStmt isGuard (BodyStmt x e bind' guard') = do
+ liftM3 (BodyStmt x)
(addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
- (return ty)
-addTickStmt _isGuard (LetStmt (L l binds)) = do
- liftM (LetStmt . L l)
+addTickStmt _isGuard (LetStmt x (L l binds)) = do
+ liftM (LetStmt x . L l)
(addTickHsLocalBinds binds)
-addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do
- liftM4 ParStmt
+addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do
+ liftM3 (ParStmt x)
(mapM (addTickStmtAndBinders isGuard) pairs)
(unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
(addTickSyntaxExpr hpcSrcSpan bindExpr)
- (return ty)
-addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do
+addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
args' <- mapM (addTickApplicativeArg isGuard) args
- return (ApplicativeStmt args' mb_join body_ty)
+ return (ApplicativeStmt body_ty args' mb_join)
addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
, trS_by = by, trS_using = using
@@ -749,6 +750,8 @@ addTickStmt isGuard stmt@(RecStmt {})
; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
+addTickStmt _ (XStmtLR _) = panic "addTickStmt"
+
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprRHS e
@@ -759,16 +762,17 @@ addTickApplicativeArg
addTickApplicativeArg isGuard (op, arg) =
liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
where
- addTickArg (ApplicativeArgOne pat expr isBody) =
- ApplicativeArgOne
+ addTickArg (ApplicativeArgOne x pat expr isBody) =
+ (ApplicativeArgOne x)
<$> addTickLPat pat
<*> addTickLHsExpr expr
<*> pure isBody
- addTickArg (ApplicativeArgMany stmts ret pat) =
- ApplicativeArgMany
+ addTickArg (ApplicativeArgMany x stmts ret pat) =
+ (ApplicativeArgMany x)
<$> addTickLStmts isGuard stmts
<*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
<*> addTickLPat pat
+ addTickArg (XApplicativeArg _) = panic "addTickApplicativeArg"
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
-> TM (ParStmtBlock GhcTc GhcTc)
@@ -896,29 +900,33 @@ addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do
matches' <- mapM (liftL addTickCmdMatch) matches
return $ mg { mg_alts = L l matches' }
+addTickCmdMatchGroup (XMatchGroup _) = panic "addTickCmdMatchGroup"
addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickCmdGRHSs gRHSs
return $ match { m_grhss = gRHSs' }
+addTickCmdMatch (XMatch _) = panic "addTickCmdMatch"
addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
-addTickCmdGRHSs (GRHSs guarded (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 guarded' (L l local_binds')
+ return $ GRHSs x guarded' (L l local_binds')
where
binders = collectLocalBinders local_binds
+addTickCmdGRHSs (XGRHSs _) = panic "addTickCmdGRHSs"
addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
-- The *guards* are *not* Cmds, although the body is
-- C.f. addTickGRHS for the BinBox stuff
-addTickCmdGRHS (GRHS stmts cmd)
+addTickCmdGRHS (GRHS x stmts cmd)
= do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
stmts (addTickLHsCmd cmd)
- ; return $ GRHS stmts' expr' }
+ ; return $ GRHS x stmts' expr' }
+addTickCmdGRHS (XGRHS _) = panic "addTickCmdGRHS"
addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]
-> TM [LStmt GhcTc (LHsCmd GhcTc)]
@@ -937,26 +945,24 @@ addTickLCmdStmts' lstmts res
binders = collectLStmtsBinders lstmts
addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
-addTickCmdStmt (BindStmt pat c bind fail ty) = do
- liftM5 BindStmt
+addTickCmdStmt (BindStmt x pat c bind fail) = do
+ liftM4 (BindStmt x)
(addTickLPat pat)
(addTickLHsCmd c)
(return bind)
(return fail)
- (return ty)
-addTickCmdStmt (LastStmt c noret ret) = do
- liftM3 LastStmt
+addTickCmdStmt (LastStmt x c noret ret) = do
+ liftM3 (LastStmt x)
(addTickLHsCmd c)
(pure noret)
(addTickSyntaxExpr hpcSrcSpan ret)
-addTickCmdStmt (BodyStmt c bind' guard' ty) = do
- liftM4 BodyStmt
+addTickCmdStmt (BodyStmt x c bind' guard') = do
+ liftM3 (BodyStmt x)
(addTickLHsCmd c)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
- (return ty)
-addTickCmdStmt (LetStmt (L l binds)) = do
- liftM (LetStmt . L l)
+addTickCmdStmt (LetStmt x (L l binds)) = do
+ liftM (LetStmt x . L l)
(addTickHsLocalBinds binds)
addTickCmdStmt stmt@(RecStmt {})
= do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
@@ -967,6 +973,8 @@ addTickCmdStmt stmt@(RecStmt {})
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
addTickCmdStmt ApplicativeStmt{} =
panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
+addTickCmdStmt XStmtLR{} =
+ panic "addTickCmdStmt XStmtLR"
-- Others should never happen in a command context.
addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)
@@ -1282,7 +1290,10 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
matchesOneOfMany :: [LMatch GhcTc body] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
where
- matchCount (L _ (Match { m_grhss = GRHSs grhss _binds })) = length grhss
+ matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) = length grhss
+ matchCount (L _ (Match { m_grhss = XGRHSs _ }))
+ = panic "matchesOneOfMany"
+ matchCount (L _ (XMatch _)) = panic "matchesOneOfMany"
type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index 05d322680c..e8ce029b04 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -374,9 +374,9 @@ Reason
-}
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
-dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
+dsRule (L loc (HsRule _ name rule_act vars lhs rhs))
= putSrcSpanDs loc $
- do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]
+ do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
; lhs' <- unsetGOptM Opt_EnableRewriteRules $
unsetWOptM Opt_WarnIdentities $
@@ -413,6 +413,7 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
; return (Just rule)
} } }
+dsRule (L _ (XRuleDecl _)) = panic "dsRule"
warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
@@ -553,26 +554,22 @@ subsequent transformations could fire.
-}
dsVect :: LVectDecl GhcTc -> DsM CoreVect
-dsVect (L loc (HsVect _ (L _ v) rhs))
+dsVect (L loc (HsVect _ _ (L _ v) rhs))
= putSrcSpanDs loc $
do { rhs' <- dsLExpr rhs
; return $ Vect v rhs'
}
-dsVect (L _loc (HsNoVect _ (L _ v)))
+dsVect (L _loc (HsNoVect _ _ (L _ v)))
= return $ NoVect v
-dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
+dsVect (L _loc (HsVectType (VectTypeTc tycon rhs_tycon) isScalar))
= return $ VectType isScalar tycon' rhs_tycon
where
tycon' | Just ty <- coreView $ mkTyConTy tycon
, (tycon', []) <- splitTyConApp ty = tycon'
| otherwise = tycon
-dsVect vd@(L _ (HsVectTypeIn _ _ _ _))
- = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
-dsVect (L _loc (HsVectClassOut cls))
+dsVect (L _loc (HsVectClass cls))
= return $ VectClass (classTyCon cls)
-dsVect vc@(L _ (HsVectClassIn _ _))
- = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
-dsVect (L _loc (HsVectInstOut inst))
+dsVect (L _loc (HsVectInst inst))
= return $ VectInst (instanceDFunId inst)
-dsVect vi@(L _ (HsVectInstIn _))
- = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)
+dsVect vd@(L _ (XVectDecl {}))
+ = pprPanic "Desugar.dsVect: unexpected 'XVectDecl'" (ppr vd)
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
index 61dc7c5b5b..5e355f03f9 100644
--- a/compiler/deSugar/DsArrows.hs
+++ b/compiler/deSugar/DsArrows.hs
@@ -450,8 +450,9 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
dsCmd ids local_vars stack_ty res_ty
- (HsCmdLam _ (MG { mg_alts = L _ [L _ (Match { m_pats = pats
- , m_grhss = GRHSs [L _ (GRHS [] body)] _ })] }))
+ (HsCmdLam _ (MG { mg_alts
+ = L _ [L _ (Match { m_pats = pats
+ , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })] }))
env_ids = do
let pat_vars = mkVarSet (collectPatsBinders pats)
let
@@ -554,7 +555,8 @@ case bodies, containing the following fields:
-}
dsCmd ids local_vars stack_ty res_ty
- (HsCmdCase _ exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys
+ (HsCmdCase _ exp (MG { mg_alts = L l matches
+ , mg_ext = MatchGroupTc arg_tys _
, mg_origin = origin }))
env_ids = do
stack_id <- newSysLocalDs stack_ty
@@ -602,8 +604,8 @@ dsCmd ids local_vars stack_ty res_ty
core_body <- dsExpr (HsCase noExt exp
(MG { mg_alts = L l matches'
- , mg_arg_tys = arg_tys
- , mg_res_ty = sum_ty, mg_origin = origin }))
+ , mg_ext = MatchGroupTc arg_tys sum_ty
+ , mg_origin = origin }))
-- Note that we replace the HsCase result type by sum_ty,
-- which is the type of matches'
@@ -758,7 +760,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
--
-- ---> premap (\ (xs) -> ((xs), ())) c
-dsCmdDo ids local_vars res_ty [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
@@ -816,7 +818,7 @@ dsCmdStmt
-- ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
-- (first c >>> arr snd) >>> ss
-dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
+dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
core_mux <- matchEnv env_ids
(mkCorePairExpr
@@ -847,7 +849,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
-- It would be simpler and more consistent to do this using second,
-- but that's likely to be defined in terms of first.
-dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do
+dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
let pat_ty = hsLPatType pat
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
let pat_vars = mkVarSet (collectPatBinders pat)
@@ -898,7 +900,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do
--
-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
-dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
+dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do
-- build a new environment using the let bindings
core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
-- match the old environment against the input
@@ -926,7 +928,8 @@ dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
dsCmdStmt ids local_vars out_ids
(RecStmt { recS_stmts = stmts
, recS_later_ids = later_ids, recS_rec_ids = rec_ids
- , recS_later_rets = later_rets, recS_rec_rets = rec_rets })
+ , recS_ext = RecStmtTc { recS_later_rets = later_rets
+ , recS_rec_rets = rec_rets } })
env_ids = do
let
later_ids_set = mkVarSet later_ids
@@ -1116,7 +1119,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys"
leavesMatch :: LMatch GhcTc (Located (body GhcTc))
-> [(Located (body GhcTc), IdSet)]
-leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs grhss (L _ binds) }))
+leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs _ grhss (L _ binds) }))
= let
defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet`
@@ -1125,7 +1128,9 @@ leavesMatch (L _ (Match { m_pats = pats, m_grhss = GRHSs grhss (L _ binds) }))
[(body,
mkVarSet (collectLStmtsBinders stmts)
`unionVarSet` defined_vars)
- | L _ (GRHS stmts body) <- grhss]
+ | L _ (GRHS _ stmts body) <- grhss]
+leavesMatch (L _ (Match _ _ _ (XGRHSs _))) = panic "leavesMatch"
+leavesMatch (L _ (XMatch _)) = panic "leavesMatch"
-- Replace the leaf commands in a match
@@ -1135,19 +1140,24 @@ replaceLeavesMatch
-> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command
-> ([Located (body' GhcTc)], -- remaining leaf expressions
LMatch GhcTc (Located (body' GhcTc))) -- updated match
-replaceLeavesMatch _res_ty leaves (L loc match@(Match { m_grhss = GRHSs grhss binds }))
+replaceLeavesMatch _res_ty leaves
+ (L loc match@(Match { m_grhss = GRHSs x grhss binds }))
= let
(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in
- (leaves', L loc (match { m_grhss = GRHSs grhss' binds }))
+ (leaves', L loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds }))
+replaceLeavesMatch _ _ (L _ (Match _ _ _ (XGRHSs _)))
+ = panic "replaceLeavesMatch"
+replaceLeavesMatch _ _ (L _ (XMatch _)) = panic "replaceLeavesMatch"
replaceLeavesGRHS
:: [Located (body' GhcTc)] -- replacement leaf expressions of that type
-> 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) (L loc (GRHS stmts _))
- = (leaves, L loc (GRHS stmts leaf))
+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _))
+ = (leaves, L loc (GRHS x stmts leaf))
+replaceLeavesGRHS _ (L _ (XGRHS _)) = panic "replaceLeavesGRHS"
replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
-- Balanced fold of a non-empty list.
@@ -1202,7 +1212,7 @@ collectl (L _ pat) bndrs
go (AsPat _ (L _ a) pat) = a : collectl pat bndrs
go (ParPat _ pat) = collectl pat bndrs
- go (ListPat _ pats _ _) = foldr collectl bndrs pats
+ go (ListPat _ pats) = foldr collectl bndrs pats
go (PArrPat _ pats) = foldr collectl bndrs pats
go (TuplePat _ pats _) = foldr collectl bndrs pats
go (SumPat _ pat _ _) = collectl pat bndrs
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 6f7f66e6a4..7ee1857dfe 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -444,7 +444,7 @@ ds_expr _ (HsMultiIf res_ty alts)
| otherwise
= do { match_result <- liftM (foldr1 combineMatchResults)
(mapM (dsGRHS IfAlt res_ty) alts)
- ; checkGuardMatches IfAlt (GRHSs alts (noLoc emptyLocalBinds))
+ ; checkGuardMatches IfAlt (GRHSs noExt alts (noLoc emptyLocalBinds))
; error_expr <- mkErrorExpr
; extractMatchResult match_result error_expr }
where
@@ -627,11 +627,12 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
-- constructor arguments.
; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
; ([discrim_var], matching_code)
- <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts
- , mg_arg_tys = [in_ty]
- , mg_res_ty = out_ty, mg_origin = FromSource })
- -- FromSource is not strictly right, but we
- -- want incomplete pattern-match warnings
+ <- matchWrapper RecUpd Nothing
+ (MG { mg_alts = noLoc alts
+ , mg_ext = MatchGroupTc [in_ty] out_ty
+ , mg_origin = FromSource })
+ -- FromSource is not strictly right, but we
+ -- want incomplete pattern-match warnings
; return (add_field_binds field_binds' $
bindNonRec discrim_var record_expr' matching_code) }
@@ -909,21 +910,21 @@ dsDo stmts
goL [] = panic "dsDo"
goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
- go _ (LastStmt body _ _) stmts
+ go _ (LastStmt _ body _ _) stmts
= ASSERT( null stmts ) dsLExpr body
-- The 'return' op isn't used for 'do' expressions
- go _ (BodyStmt rhs then_expr _ _) stmts
+ go _ (BodyStmt _ rhs then_expr _) stmts
= do { rhs2 <- dsLExpr rhs
; warnDiscardedDoBindings rhs (exprType rhs2)
; rest <- goL stmts
; dsSyntaxExpr then_expr [rhs2, rest] }
- go _ (LetStmt binds) stmts
+ go _ (LetStmt _ binds) stmts
= do { rest <- goL stmts
; dsLocalBinds binds rest }
- go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts
+ go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts
= do { body <- goL stmts
; rhs' <- dsLExpr rhs
; var <- selectSimpleMatchVarL pat
@@ -932,15 +933,16 @@ dsDo stmts
; match_code <- handle_failure pat match fail_op
; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
- go _ (ApplicativeStmt args mb_join body_ty) stmts
+ go _ (ApplicativeStmt body_ty args mb_join) stmts
= do {
let
(pats, rhss) = unzip (map (do_arg . snd) args)
- do_arg (ApplicativeArgOne pat expr _) =
+ do_arg (ApplicativeArgOne _ pat expr _) =
(pat, dsLExpr expr)
- do_arg (ApplicativeArgMany stmts ret pat) =
+ do_arg (ApplicativeArgMany _ stmts ret pat) =
(pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
+ do_arg (XApplicativeArg _) = panic "dsDo"
arg_tys = map hsLPatType pats
@@ -951,8 +953,7 @@ dsDo stmts
; let fun = L noSrcSpan $ HsLam noExt $
MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
body']
- , mg_arg_tys = arg_tys
- , mg_res_ty = body_ty
+ , mg_ext = MatchGroupTc arg_tys body_ty
, mg_origin = Generated }
; fun' <- dsLExpr fun
@@ -965,14 +966,15 @@ dsDo stmts
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = return_op
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
- , recS_bind_ty = bind_ty
- , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
+ , recS_ext = RecStmtTc
+ { recS_bind_ty = bind_ty
+ , recS_rec_rets = rec_rets
+ , recS_ret_ty = body_ty} }) stmts
= goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
where
- new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats)
+ new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
mfix_app bind_op
noSyntaxExpr -- Tuple cannot fail
- bind_ty
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
@@ -984,7 +986,7 @@ dsDo stmts
(MG { mg_alts = noLoc [mkSimpleMatch
LambdaExpr
[mfix_pat] body]
- , mg_arg_tys = [tup_ty], mg_res_ty = body_ty
+ , mg_ext = MatchGroupTc [tup_ty] body_ty
, mg_origin = Generated })
mfix_pat = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats
body = noLoc $ HsDo body_ty
@@ -997,6 +999,7 @@ dsDo stmts
go _ (ParStmt {}) _ = panic "dsDo ParStmt"
go _ (TransStmt {}) _ = panic "dsDo TransStmt"
+ go _ (XStmtLR {}) _ = panic "dsDo XStmtLR"
handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs
index a23c51b943..401ed876cc 100644
--- a/compiler/deSugar/DsForeign.hs
+++ b/compiler/deSugar/DsForeign.hs
@@ -99,17 +99,18 @@ dsForeigns' fos = do
where
do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
- do_decl (ForeignImport { fd_name = id, fd_co = co, fd_fi = spec }) = do
+ do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
traceIf (text "fi start" <+> ppr id)
let id' = unLoc id
(bs, h, c) <- dsFImport id' co spec
traceIf (text "fi end" <+> ppr id)
return (h, c, [], bs)
- do_decl (ForeignExport { fd_name = L _ id, fd_co = co
+ do_decl (ForeignExport { fd_name = L _ id, fd_e_ext = co
, fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], [])
+ do_decl (XForeignDecl _) = panic "dsForeigns'"
{-
************************************************************************
diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs
index b0470ef487..0fe4828dc3 100644
--- a/compiler/deSugar/DsGRHSs.hs
+++ b/compiler/deSugar/DsGRHSs.hs
@@ -57,18 +57,20 @@ dsGRHSs :: HsMatchContext Name
-> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs
-> Type -- Type of RHS
-> DsM MatchResult
-dsGRHSs hs_ctx (GRHSs grhss binds) rhs_ty
+dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty
= ASSERT( notNull grhss )
do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
; let match_result1 = foldr1 combineMatchResults match_results
match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
-- NB: nested dsLet inside matchResult
; return match_result2 }
+dsGRHSs _ (XGRHSs _) _ = panic "dsGRHSs"
dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
-> DsM MatchResult
-dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
+dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs))
= matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
+dsGRHS _ _ (L _ (XGRHS _)) = panic "dsGRHS"
{-
************************************************************************
@@ -98,16 +100,16 @@ matchGuards [] _ rhs _
-- NB: The success of this clause depends on the typechecker not
-- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
-- If it does, you'll get bogus overlap warnings
-matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty
+matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty
| Just addTicks <- isTrueLHsExpr e = do
match_result <- matchGuards stmts ctx rhs rhs_ty
return (adjustMatchResultDs addTicks match_result)
-matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
+matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do
match_result <- matchGuards stmts ctx rhs rhs_ty
pred_expr <- dsLExpr expr
return (mkGuardedMatchResult pred_expr match_result)
-matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do
+matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
match_result <- matchGuards stmts ctx rhs rhs_ty
return (adjustMatchResultDs (dsLocalBinds binds) match_result)
-- NB the dsLet occurs inside the match_result
@@ -115,7 +117,7 @@ matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do
-- so we can't desugar the bindings without the
-- body expression in hand
-matchGuards (BindStmt pat bind_rhs _ _ _ : stmts) ctx rhs rhs_ty = do
+matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
match_result <- matchGuards stmts ctx rhs rhs_ty
core_rhs <- dsLExpr bind_rhs
matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result
@@ -126,6 +128,8 @@ matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"
matchGuards (ApplicativeStmt {} : _) _ _ _ =
panic "matchGuards ApplicativeLastStmt"
+matchGuards (XStmtLR {} : _) _ _ _ =
+ panic "matchGuards XStmtLR"
isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs
index 36c2730aff..8c9fa72e03 100644
--- a/compiler/deSugar/DsListComp.hs
+++ b/compiler/deSugar/DsListComp.hs
@@ -220,20 +220,20 @@ deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr
deListComp [] _ = panic "deListComp"
-deListComp (LastStmt body _ _ : quals) list
+deListComp (LastStmt _ body _ _ : quals) list
= -- Figure 7.4, SLPJ, p 135, rule C above
ASSERT( null quals )
do { core_body <- dsLExpr body
; return (mkConsExpr (exprType core_body) core_body list) }
-- Non-last: must be a guard
-deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above
+deListComp (BodyStmt _ guard _ _ : quals) list = do -- rule B above
core_guard <- dsLExpr guard
core_rest <- deListComp quals list
return (mkIfThenElse core_guard core_rest list)
-- [e | let B, qs] = let B in [e | qs]
-deListComp (LetStmt binds : quals) list = do
+deListComp (LetStmt _ binds : quals) list = do
core_rest <- deListComp quals list
dsLocalBinds binds core_rest
@@ -241,11 +241,11 @@ deListComp (stmt@(TransStmt {}) : quals) list = do
(inner_list_expr, pat) <- dsTransStmt stmt
deBindComp pat inner_list_expr quals list
-deListComp (BindStmt pat list1 _ _ _ : quals) core_list2 = do -- rule A' above
+deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above
core_list1 <- dsLExprNoLP list1
deBindComp pat core_list1 quals core_list2
-deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
+deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
= do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
; let (exps, qual_tys) = unzip exps_and_qual_tys
@@ -266,6 +266,9 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
deListComp (ApplicativeStmt {} : _) _ =
panic "deListComp ApplicativeStmt"
+deListComp (XStmtLR {} : _) _ =
+ panic "deListComp XStmtLR"
+
deBindComp :: OutPat GhcTc
-> CoreExpr
-> [ExprStmt GhcTc]
@@ -328,18 +331,18 @@ dfListComp :: Id -> Id -- 'c' and 'n'
dfListComp _ _ [] = panic "dfListComp"
-dfListComp c_id n_id (LastStmt body _ _ : quals)
+dfListComp c_id n_id (LastStmt _ body _ _ : quals)
= ASSERT( null quals )
do { core_body <- dsLExprNoLP body
; return (mkApps (Var c_id) [core_body, Var n_id]) }
-- Non-last: must be a guard
-dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do
+dfListComp c_id n_id (BodyStmt _ guard _ _ : quals) = do
core_guard <- dsLExpr guard
core_rest <- dfListComp c_id n_id quals
return (mkIfThenElse core_guard core_rest (Var n_id))
-dfListComp c_id n_id (LetStmt binds : quals) = do
+dfListComp c_id n_id (LetStmt _ binds : quals) = do
-- new in 1.3, local bindings
core_rest <- dfListComp c_id n_id quals
dsLocalBinds binds core_rest
@@ -349,7 +352,7 @@ dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
-- Anyway, we bind the newly grouped list via the generic binding function
dfBindComp c_id n_id (pat, inner_list_expr) quals
-dfListComp c_id n_id (BindStmt pat list1 _ _ _ : quals) = do
+dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do
-- evaluate the two lists
core_list1 <- dsLExpr list1
@@ -360,6 +363,8 @@ dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
dfListComp _ _ (ApplicativeStmt {} : _) =
panic "dfListComp ApplicativeStmt"
+dfListComp _ _ (XStmtLR {} : _) =
+ panic "dfListComp XStmtLR"
dfBindComp :: Id -> Id -- 'c' and 'n'
-> (LPat GhcTc, CoreExpr)
@@ -487,7 +492,7 @@ dsPArrComp :: [ExprStmt GhcTc]
-> DsM CoreExpr
-- Special case for parallel comprehension
-dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
+dsPArrComp (ParStmt _ qss _ _ : quals) = dePArrParComp qss quals
-- Special case for simple generators:
--
@@ -498,7 +503,7 @@ dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
-- <<[:e' | p <- e, qs:]>> =
-- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
--
-dsPArrComp (BindStmt p e _ _ _ : qs) = do
+dsPArrComp (BindStmt _ p e _ _ : qs) = do
filterP <- dsDPHBuiltin filterPVar
ce <- dsLExprNoLP e
let ety'ce = parrElemType ce
@@ -529,7 +534,7 @@ dePArrComp [] _ _ = panic "dePArrComp"
--
-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
-dePArrComp (LastStmt e' _ _ : quals) pa cea
+dePArrComp (LastStmt _ e' _ _ : quals) pa cea
= ASSERT( null quals )
do { mapP <- dsDPHBuiltin mapPVar
; let ty = parrElemType cea
@@ -538,7 +543,7 @@ dePArrComp (LastStmt e' _ _ : quals) pa cea
--
-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
-dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do
+dePArrComp (BodyStmt _ b _ _ : qs) pa cea = do
filterP <- dsDPHBuiltin filterPVar
let ty = parrElemType cea
(clam,_) <- deLambda ty pa b
@@ -557,7 +562,7 @@ dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do
-- in
-- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
--
-dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do
+dePArrComp (BindStmt _ p e _ _ : qs) pa cea = do
filterP <- dsDPHBuiltin filterPVar
crossMapP <- dsDPHBuiltin crossMapPVar
ce <- dsLExpr e
@@ -582,7 +587,7 @@ dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do
-- where
-- {x_1, ..., x_n} = DV (ds) -- Defined Variables
--
-dePArrComp (LetStmt lds@(L _ ds) : qs) pa cea = do
+dePArrComp (LetStmt _ lds@(L _ ds) : qs) pa cea = do
mapP <- dsDPHBuiltin mapPVar
let xs = collectLocalBinders ds
ty'cea = parrElemType cea
@@ -610,6 +615,8 @@ dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt"
dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"
dePArrComp (ApplicativeStmt {} : _) _ _ =
panic "DsListComp.dePArrComp: ApplicativeStmt"
+dePArrComp (XStmtLR {} : _) _ _ =
+ panic "DsListComp.dePArrComp: XStmtLR"
-- <<[:e' | qs | qss:]>> pa ea =
-- <<[:e' | qss:]>> (pa, (x_1, ..., x_n))
@@ -690,18 +697,18 @@ dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
---------------
dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
-dsMcStmt (LastStmt body _ ret_op) stmts
+dsMcStmt (LastStmt _ body _ ret_op) stmts
= ASSERT( null stmts )
do { body' <- dsLExpr body
; dsSyntaxExpr ret_op [body'] }
-- [ .. | let binds, stmts ]
-dsMcStmt (LetStmt binds) stmts
+dsMcStmt (LetStmt _ binds) stmts
= do { rest <- dsMcStmts stmts
; dsLocalBinds binds rest }
-- [ .. | a <- m, stmts ]
-dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts
+dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts
= do { rhs' <- dsLExpr rhs
; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
@@ -709,7 +716,7 @@ dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts
--
-- [ .. | exp, stmts ]
--
-dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts
+dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts
= do { exp' <- dsLExpr exp
; rest <- dsMcStmts stmts
; guard_exp' <- dsSyntaxExpr guard_exp [exp']
@@ -732,7 +739,7 @@ dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts
dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
, trS_by = by, trS_using = using
, trS_ret = return_op, trS_bind = bind_op
- , trS_bind_arg_ty = n_tup_ty' -- n (a,b,c)
+ , trS_ext = n_tup_ty' -- n (a,b,c)
, trS_fmap = fmap_op, trS_form = form }) stmts_rest
= do { let (from_bndrs, to_bndrs) = unzip bndrs
@@ -777,7 +784,7 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
-- mzip :: forall a b. m a -> m b -> m (a,b)
-- NB: we need a polymorphic mzip because we call it several times
-dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
+dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
= do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty)
; mzip_op' <- dsExpr mzip_op
@@ -854,7 +861,8 @@ dsInnerMonadComp :: [ExprLStmt GhcTc]
-> SyntaxExpr GhcTc -- The monomorphic "return" operator
-> DsM CoreExpr
dsInnerMonadComp stmts bndrs ret_op
- = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)])
+ = dsMcStmts (stmts ++
+ [noLoc (LastStmt noExt (mkBigLHsVarTupId bndrs) False ret_op)])
-- The `unzip` function for `GroupStmt` in a monad comprehensions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 976f3c3d12..6bff89774d 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -174,13 +174,15 @@ repTopDs group@(HsGroup { hs_valds = valds
= notHandledL loc "Splices within declaration brackets" empty
no_default_decl (L loc decl)
= notHandledL loc "Default declarations" (ppr decl)
- no_warn (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 (L _ (XWarnDecl _)) = panic "repTopDs"
no_vect (L loc decl)
= notHandledL loc "Vectorisation pragmas" (ppr decl)
no_doc (L loc _)
= notHandledL loc "Haddock documentation" empty
+repTopDs (XHsGroup _) = panic "repTopDs"
hsSigTvBinders :: HsValBinds GhcRn -> [Name]
-- See Note [Scoped type variables in bindings]
@@ -206,10 +208,12 @@ get_scoped_tvs (L _ signature)
-- Both implicit and explicit quantified variables
-- We need the implicit ones for f :: forall (a::k). blah
-- here 'k' scopes too
- | HsIB { hsib_vars = implicit_vars
+ | HsIB { hsib_ext = HsIBRn { hsib_vars = implicit_vars }
, hsib_body = hs_ty } <- sig
, (explicit_vars, _) <- splitLHsForAllTy hs_ty
= implicit_vars ++ map hsLTyVarName explicit_vars
+ get_scoped_tvs_from_sig (XHsImplicitBndrs _)
+ = panic "get_scoped_tvs_from_sig"
{- Notes
@@ -334,14 +338,17 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
; return $ Just (loc, dec)
}
+repTyClD (L _ (XTyClDecl _)) = panic "repTyClD"
+
-------------------------
repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repRoleD (L loc (RoleAnnotDecl tycon roles))
+repRoleD (L loc (RoleAnnotDecl _ tycon roles))
= do { tycon1 <- lookupLOcc tycon
; roles1 <- mapM repRole roles
; roles2 <- coreList roleTyConName roles1
; dec <- repRoleAnnotD tycon1 roles2
; return (loc, dec) }
+repRoleD (L _ (XRoleAnnotDecl _)) = panic "repRoleD"
-------------------------
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ]
@@ -367,6 +374,7 @@ repDataDefn tc bndrs opt_tys
; repData cxt1 tc bndrs opt_tys ksig' cons1
derivs1 }
}
+repDataDefn _ _ _ (XHsDataDefn _) = panic "repDataDefn"
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
-> LHsType GhcRn
@@ -383,11 +391,13 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info,
fdInjectivityAnn = injectivity }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
- mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs
- , hsq_dependent = emptyNameSet }
+ mkHsQTvs tvs = HsQTvs { hsq_ext = HsQTvsRn
+ { hsq_implicit = []
+ , hsq_dependent = emptyNameSet }
+ , hsq_explicit = tvs }
resTyVar = case resultSig of
- TyVarSig bndr -> mkHsQTvs [bndr]
- _ -> mkHsQTvs []
+ TyVarSig _ bndr -> mkHsQTvs [bndr]
+ _ -> mkHsQTvs []
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
addTyClTyVarBinds resTyVar $ \_ ->
case info of
@@ -408,23 +418,25 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info,
; repDataFamilyD tc1 bndrs kind }
; return (loc, dec)
}
+repFamilyDecl (L _ (XFamilyDecl _)) = panic "repFamilyDecl"
-- | Represent result signature of a type family
repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)
-repFamilyResultSig NoSig = repNoSig
-repFamilyResultSig (KindSig ki) = do { ki' <- repLTy ki
- ; repKindSig ki' }
-repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr
- ; repTyVarSig bndr' }
+repFamilyResultSig (NoSig _) = repNoSig
+repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki
+ ; repKindSig ki' }
+repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
+ ; repTyVarSig bndr' }
+repFamilyResultSig (XFamilyResultSig _) = panic "repFamilyResultSig"
-- | Represent result signature using a Maybe Kind. Used with data families,
-- where the result signature can be either missing or a kind but never a named
-- result variable.
repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
-> DsM (Core (Maybe TH.KindQ))
-repFamilyResultSigToMaybeKind NoSig =
+repFamilyResultSigToMaybeKind (NoSig _) =
do { coreNothing kindQTyConName }
-repFamilyResultSigToMaybeKind (KindSig ki) =
+repFamilyResultSigToMaybeKind (KindSig _ ki) =
do { ki' <- repLTy ki
; coreJust kindQTyConName ki' }
repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"
@@ -459,6 +471,7 @@ repAssocTyFamDefaults = mapM rep_deflt
; rhs1 <- repLTy rhs
; eqn1 <- repTySynEqn tys2 rhs1
; repTySynInst tc1 eqn1 }
+ rep_deflt (L _ (XFamEqn _)) = panic "repAssocTyFamDefaults"
-------------------------
-- represent fundeps
@@ -484,6 +497,7 @@ repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
= do { dec <- repClsInstD cls_decl
; return (loc, dec) }
+repInstD (L _ (XInstDecl _)) = panic "repInstD"
repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ)
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
@@ -513,6 +527,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
; wrapGenSyms ss decls2 }
where
(tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
+repClsInstD (XClsInstDecl _) = panic "repClsInstD"
repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
@@ -525,6 +540,7 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
; return (loc, dec) }
where
(tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
+repStandaloneDerivD (L _ (XDerivDecl _)) = panic "repStandaloneDerivD"
repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
@@ -534,31 +550,39 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
; repTySynInst tc eqn1 }
repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
-repTyFamEqn (HsIB { hsib_vars = var_names
+repTyFamEqn (HsIB { hsib_ext = HsIBRn { hsib_vars = var_names }
, hsib_body = FamEqn { feqn_pats = tys
, feqn_rhs = rhs }})
- = do { let hs_tvs = HsQTvs { hsq_implicit = var_names
- , hsq_explicit = []
- , hsq_dependent = emptyNameSet } -- Yuk
+ = do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
+ { hsq_implicit = var_names
+ , hsq_dependent = emptyNameSet } -- Yuk
+ , hsq_explicit = [] }
; addTyClTyVarBinds hs_tvs $ \ _ ->
do { tys1 <- repLTys tys
; tys2 <- coreList typeQTyConName tys1
; rhs1 <- repLTy rhs
; repTySynEqn tys2 rhs1 } }
+repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"
+repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
repDataFamInstD (DataFamInstDecl { dfid_eqn =
- (HsIB { hsib_vars = var_names
+ (HsIB { hsib_ext = HsIBRn { hsib_vars = var_names }
, hsib_body = FamEqn { feqn_tycon = tc_name
, feqn_pats = tys
, feqn_rhs = defn }})})
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
- ; let hs_tvs = HsQTvs { hsq_implicit = var_names
- , hsq_explicit = []
- , hsq_dependent = emptyNameSet } -- Yuk
+ ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
+ { hsq_implicit = var_names
+ , hsq_dependent = emptyNameSet } -- Yuk
+ , hsq_explicit = [] }
; addTyClTyVarBinds hs_tvs $ \ bndrs ->
do { tys1 <- repList typeQTyConName repLTy tys
; repDataDefn tc bndrs (Just tys1) defn } }
+repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))
+ = panic "repDataFamInstD"
+repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
+ = panic "repDataFamInstD"
repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)
repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
@@ -616,7 +640,7 @@ repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
repFixD (L _ (XFixitySig _)) = panic "repFixD"
repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
+repRuleD (L loc (HsRule _ n act bndrs lhs rhs))
= do { let bndr_names = concatMap ruleBndrNames bndrs
; ss <- mkGenSyms bndr_names
; rule1 <- addBinds ss $
@@ -628,28 +652,36 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
; repPragRule n' bndrs' lhs' rhs' act' }
; rule2 <- wrapGenSyms ss rule1
; return (loc, rule2) }
+repRuleD (L _ (XRuleDecl _)) = panic "repRuleD"
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
-ruleBndrNames (L _ (RuleBndr n)) = [unLoc n]
-ruleBndrNames (L _ (RuleBndrSig n sig))
- | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig
+ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n]
+ruleBndrNames (L _ (RuleBndrSig _ n sig))
+ | HsWC { hswc_body = HsIB { hsib_ext = HsIBRn { hsib_vars = vars } }} <- sig
= unLoc n : vars
+ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
+ = panic "ruleBndrNames"
+ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
+ = panic "ruleBndrNames"
+ruleBndrNames (L _ (XRuleBndr _)) = panic "ruleBndrNames"
repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
-repRuleBndr (L _ (RuleBndr n))
+repRuleBndr (L _ (RuleBndr _ n))
= do { MkC n' <- lookupLBinder n
; rep2 ruleVarName [n'] }
-repRuleBndr (L _ (RuleBndrSig n sig))
+repRuleBndr (L _ (RuleBndrSig _ n sig))
= do { MkC n' <- lookupLBinder n
; MkC ty' <- repLTy (hsSigWcType sig)
; rep2 typedRuleVarName [n', ty'] }
+repRuleBndr (L _ (XRuleBndr _)) = panic "repRuleBndr"
repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
-repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
+repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
= do { target <- repAnnProv ann_prov
; exp' <- repE exp
; dec <- repPragAnn target exp'
; return (loc, dec) }
+repAnnD (L _ (XAnnDecl _)) = panic "repAnnD"
repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
repAnnProv (ValueAnnProvenance (L _ n))
@@ -703,6 +735,9 @@ repC (L _ (ConDeclGADT { con_names = cons
then return c'
else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
+repC (L _ (XConDecl _)) = panic "repC"
+
+
repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
repMbContext Nothing = repContext []
repMbContext (Just (L _ cxt)) = repContext cxt
@@ -746,6 +781,7 @@ repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs
where
rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)
rep_deriv_ty (L _ ty) = repTy ty
+repDerivClause (L _ (XHsDerivingClause _)) = panic "repDerivClause"
rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
-> DsM ([GenSymBind], [Core TH.DecQ])
@@ -812,6 +848,7 @@ rep_ty_sig mk_sig loc sig_ty nm
else repTForall th_explicit_tvs th_ctxt th_ty
; sig <- repProto mk_sig nm1 ty1
; return (loc, sig) }
+rep_ty_sig _ _ (XHsImplicitBndrs _) _ = panic "rep_ty_sig"
rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
-> DsM (SrcSpan, Core TH.DecQ)
@@ -840,6 +877,7 @@ rep_patsyn_ty_sig loc sig_ty nm
repTForall th_exis th_provs th_ty
; sig <- repProto patSynSigDName nm1 ty1
; return (loc, sig) }
+rep_patsyn_ty_sig _ (XHsImplicitBndrs _) _ = panic "rep_patsyn_ty_sig"
rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
-> DsM (SrcSpan, Core TH.DecQ)
@@ -946,11 +984,13 @@ addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
-- gensym a list of type variables and enter them into the meta environment;
-- the computations passed as the second argument is executed in that extended
-- meta environment and gets the *new* names on Core-level as an argument
-addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs })
+addTyVarBinds (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_tvs}
+ , hsq_explicit = exp_tvs })
thing_inside
= addSimpleTyVarBinds imp_tvs $
addHsTyVarBinds exp_tvs $
thing_inside
+addTyVarBinds (XLHsQTyVars _) _ = panic "addTyVarBinds"
addTyClTyVarBinds :: LHsQTyVars GhcRn
-> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
@@ -1008,7 +1048,7 @@ repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
repCtxt preds
repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
-repHsSigType (HsIB { hsib_vars = implicit_tvs
+repHsSigType (HsIB { hsib_ext = HsIBRn { hsib_vars = implicit_tvs }
, hsib_body = body })
| (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
= addSimpleTyVarBinds implicit_tvs $
@@ -1019,10 +1059,12 @@ repHsSigType (HsIB { hsib_vars = implicit_tvs
; if null explicit_tvs && null (unLoc ctxt)
then return th_ty
else repTForall th_explicit_tvs th_ctxt th_ty }
+repHsSigType (XHsImplicitBndrs _) = panic "repHsSigType"
repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ)
repHsSigWcType (HsWC { hswc_body = sig1 })
= repHsSigType sig1
+repHsSigWcType (XHsWildCardBndrs _) = panic "repHsSigWcType"
-- yield the representation of a list of types
repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ]
@@ -1308,7 +1350,8 @@ repE e = notHandled "Expression form" (ppr e)
-- Building representations of auxillary structures like Match, Clause, Stmt,
repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)
-repMatchTup (L _ (Match { m_pats = [p], m_grhss = GRHSs guards (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
@@ -1320,7 +1363,8 @@ repMatchTup (L _ (Match { m_pats = [p], m_grhss = GRHSs guards (L _ wheres) }))
repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)
-repClauseTup (L _ (Match { m_pats = ps, m_grhss = GRHSs guards (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
@@ -1329,9 +1373,11 @@ repClauseTup (L _ (Match { m_pats = ps, m_grhss = GRHSs guards (L _ wheres) }))
gs <- repGuards guards
; clause <- repClause ps1 gs ds
; wrapGenSyms (ss1++ss2) clause }}}
+repClauseTup (L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup"
+repClauseTup (L _ (XMatch _)) = panic "repClauseTup"
repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ)
-repGuards [L _ (GRHS [] e)]
+repGuards [L _ (GRHS _ [] e)]
= do {a <- repLE e; repNormal a }
repGuards other
= do { zs <- mapM repLGRHS other
@@ -1341,14 +1387,15 @@ repGuards other
repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
-> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
-repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))
+repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))
= do { guarded <- repLNormalGE e1 e2
; return ([], guarded) }
-repLGRHS (L _ (GRHS ss rhs))
+repLGRHS (L _ (GRHS _ ss rhs))
= do { (gs, ss') <- repLSts ss
; rhs' <- addBinds gs $ repLE rhs
; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
; return (gs, guarded) }
+repLGRHS (L _ (XGRHS _)) = panic "repLGRHS"
repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp])
repFields (HsRecFields { rec_flds = flds })
@@ -1401,7 +1448,7 @@ repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
repLSts stmts = repSts (map unLoc stmts)
repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
-repSts (BindStmt p e _ _ _ : ss) =
+repSts (BindStmt _ p e _ _ : ss) =
do { e2 <- repLE e
; ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
@@ -1409,17 +1456,17 @@ repSts (BindStmt p e _ _ _ : ss) =
; (ss2,zs) <- repSts ss
; z <- repBindSt p1 e2
; return (ss1++ss2, z : zs) }}
-repSts (LetStmt (L _ bs) : ss) =
+repSts (LetStmt _ (L _ bs) : ss) =
do { (ss1,ds) <- repBinds bs
; z <- repLetSt ds
; (ss2,zs) <- addBinds ss1 (repSts ss)
; return (ss1++ss2, z : zs) }
-repSts (BodyStmt e _ _ _ : ss) =
+repSts (BodyStmt _ e _ _ : ss) =
do { e2 <- repLE e
; z <- repNoBindSt e2
; (ss2,zs) <- repSts ss
; return (ss2, z : zs) }
-repSts (ParStmt stmt_blocks _ _ _ : ss) =
+repSts (ParStmt _ stmt_blocks _ _ : ss) =
do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
ss1 = concat ss_s
@@ -1434,7 +1481,7 @@ repSts (ParStmt stmt_blocks _ _ _ : ss) =
; zs1 <- coreList stmtQTyConName zs
; return (ss1, zs1) }
rep_stmt_block (XParStmtBlock{}) = panic "repSts"
-repSts [LastStmt e _ _]
+repSts [LastStmt _ e _ _]
= do { e2 <- repLE e
; z <- repNoBindSt e2
; return ([], [z]) }
@@ -1488,8 +1535,10 @@ rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
rep_bind (L loc (FunBind
{ fun_id = fn,
fun_matches = MG { mg_alts
- = L _ [L _ (Match { m_pats = []
- , m_grhss = GRHSs guards (L _ wheres) })] } }))
+ = L _ [L _ (Match
+ { m_pats = []
+ , m_grhss = GRHSs _ guards (L _ wheres) }
+ )] } }))
= do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; fn' <- lookupLBinder fn
@@ -1505,14 +1554,17 @@ rep_bind (L loc (FunBind { fun_id = fn
; ans <- repFun fn' (nonEmptyCoreList ms1)
; return (loc, ans) }
+rep_bind (L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind"
+
rep_bind (L loc (PatBind { pat_lhs = pat
- , pat_rhs = GRHSs guards (L _ wheres) }))
+ , 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 (L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind"
rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
= do { v' <- lookupBinder v
@@ -1525,7 +1577,6 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
- , psb_fvs = _fvs
, psb_args = args
, psb_def = pat
, psb_dir = dir })))
@@ -1603,6 +1654,7 @@ repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses }))
= do { clauses' <- mapM repClauseTup clauses
; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
+repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir"
repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)
repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
@@ -1634,8 +1686,8 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
repLambda (L _ (Match { m_pats = ps
- , m_grhss = GRHSs [L _ (GRHS [] e)]
- (L _ (EmptyLocalBinds _)) } ))
+ , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
+ (L _ (EmptyLocalBinds _)) } ))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
@@ -1668,10 +1720,10 @@ repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 }
repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p
; repPaspat x' p1 }
repP (ParPat _ p) = repLP p
-repP (ListPat _ ps _ Nothing) = do { qs <- repLPs ps; repPlist qs }
-repP (ListPat x ps ty1 (Just (_,e))) = do { p <- repP (ListPat x ps ty1 Nothing)
- ; e' <- repE (syn_expr e)
- ; repPview e' p}
+repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs }
+repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps)
+ ; e' <- repE (syn_expr e)
+ ; repPview e' p}
repP (TuplePat _ ps boxed)
| isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
| otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index c4fb7e7f30..0044cbe49f 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -284,7 +284,7 @@ matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
-- Since overloaded list patterns are treated as view patterns,
-- the code is roughly the same as for matchView
- = do { let ListPat _ _ elt_ty (Just (_,e)) = firstPat eqn1
+ = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1
; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand
; match_result <- match (var':vars) ty $
map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
@@ -305,7 +305,8 @@ getBangPat (BangPat _ pat ) = unLoc pat
getBangPat _ = panic "getBangPat"
getViewPat (ViewPat _ _ pat) = unLoc pat
getViewPat _ = panic "getViewPat"
-getOLPat (ListPat x pats ty (Just _)) = ListPat x pats ty Nothing
+getOLPat (ListPat (ListPatTc ty (Just _)) pats)
+ = ListPat (ListPatTc ty Nothing) pats
getOLPat _ = panic "getOLPat"
{-
@@ -441,7 +442,7 @@ tidy1 v (LazyPat _ pat)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
; return (mkCoreLets sel_binds, WildPat (idType v)) }
-tidy1 _ (ListPat _ pats ty Nothing)
+tidy1 _ (ListPat (ListPatTc ty Nothing) pats )
= return (idDsWrapper, unLoc list_ConPat)
where
list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
@@ -707,8 +708,7 @@ JJQC 30-Nov-1997
-}
matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
- , mg_arg_tys = arg_tys
- , mg_res_ty = rhs_ty
+ , mg_ext = MatchGroupTc arg_tys rhs_ty
, mg_origin = origin })
= do { dflags <- getDynFlags
; locn <- getSrcSpanDs
@@ -739,11 +739,12 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
addTmCsDs tm_cs $ -- See Note [Type and Term Equality Propagation]
dsGRHSs ctxt grhss rhs_ty
; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) }
+ mk_eqn_info _ (L _ (XMatch _)) = panic "matchWrapper"
handleWarnings = if isGenerated origin
then discardWarningsDs
else id
-
+matchWrapper _ _ (XMatchGroup _) = panic "matchWrapper"
matchEquations :: HsMatchContext Name
-> [MatchId] -> [EquationInfo] -> Type
@@ -1088,7 +1089,7 @@ patGroup _ (NPlusKPat _ _ (L _ OverLit {ol_val=oval}) _ _ _) =
patGroup _ (CoPat _ _ p _) = PgCo (hsPatType p)
-- Type of innelexp pattern
patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p))
-patGroup _ (ListPat _ _ _ (Just _)) = PgOverloadedList
+patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList
patGroup dflags (LitPat _ lit) = PgLit (hsLitKey dflags lit)
patGroup _ pat = pprPanic "patGroup" (ppr pat)
View Lorry Controller Status