Commit c3823cba authored by Alan Zimmerman's avatar Alan Zimmerman

TTG : complete for balance of hsSyn AST

Summary:
- remove PostRn/PostTc fields
- remove the HsVect In/Out distinction for Type, Class and Instance
- remove PlaceHolder in favour of NoExt
- Simplify OutputableX constraint

Updates haddock submodule

Test Plan: ./validate

Reviewers: goldfire, bgamari

Subscribers: goldfire, thomie, mpickering, carter

Differential Revision: https://phabricator.haskell.org/D4625
parent 313720a4
......@@ -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
......
......@@ -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)
......
......@@ -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)
......@@ -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
......
......@@ -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
......
......@@ -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'"
{-
************************************************************************
......
......@@ -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"