module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
#include "HsVersions.h"
import GhcPrelude
import DsExpr ( dsLExpr, dsLocalBinds )
import Match ( matchSinglePatVar )
import GHC.Hs
import MkCore
import CoreSyn
import CoreUtils (bindNonRec)
import BasicTypes (Origin(FromSource))
import DynFlags
import GHC.HsToCore.PmCheck (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs)
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 nec) _ = noExtCon nec
dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
-> DsM MatchResult
dsGRHS hs_ctx rhs_ty (dL->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"
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
dflags <- getDynFlags
match_result <-
applyWhen (needToRunPmCheck dflags FromSource)
(addTyCsDs dicts . addScrutTmCs (Just bind_rhs) [match_var] . addPatTmCs [upat] [match_var])
(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 nec : _) _ _ _ =
noExtCon nec