module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
#include "HsVersions.h"
import GhcPrelude
import DsExpr ( dsLExpr, dsLocalBinds )
import Match ( matchSinglePatVar )
import HsSyn
import MkCore
import CoreSyn
import CoreUtils (bindNonRec)
import Check (genCaseTmCs2)
import DsMonad
import DsUtils
import Type ( Type )
import Name
import Util
import SrcLoc
import Outputable
dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
dsGuarded grhss rhs_ty = do
match_result <- dsGRHSs PatBindRhs grhss rhs_ty
error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
extractMatchResult match_result error_expr
dsGRHSs :: HsMatchContext Name
-> GRHSs GhcTc (LHsExpr GhcTc)
-> Type
-> DsM MatchResult
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
; 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))
= matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
dsGRHS _ _ (L _ (XGRHS _)) = panic "dsGRHS"
matchGuards :: [GuardStmt GhcTc]
-> HsStmtContext Name
-> LHsExpr GhcTc
-> Type
-> DsM MatchResult
matchGuards [] _ rhs _
= do { core_rhs <- dsLExpr rhs
; return (cantFailMatchResult core_rhs) }
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
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
match_result <- matchGuards stmts ctx rhs rhs_ty
return (adjustMatchResultDs (dsLocalBinds binds) match_result)
matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
let upat = unLoc pat
dicts = collectEvVarsPat upat
match_var <- selectMatchVar upat
tm_cs <- genCaseTmCs2 (Just bind_rhs) [upat] [match_var]
match_result <- addDictsDs dicts $
addTmCsDs tm_cs $
matchGuards stmts ctx rhs rhs_ty
core_rhs <- dsLExpr bind_rhs
match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
match_result
pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result'
matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"
matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"
matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"
matchGuards (ApplicativeStmt {} : _) _ _ _ =
panic "matchGuards ApplicativeLastStmt"
matchGuards (XStmtLR {} : _) _ _ _ =
panic "matchGuards XStmtLR"