module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where
#include "HsVersions.h"
import DsExpr ( dsLExpr, dsLocalBinds )
import Match ( matchSinglePat )
import HsSyn
import MkCore
import CoreSyn
import Var
import Type
import DsMonad
import DsUtils
import TysWiredIn
import PrelNames
import Module
import Name
import Util
import SrcLoc
import Outputable
dsGuarded :: GRHSs Id (LHsExpr Id) -> 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 -> [Pat Id]
-> GRHSs Id (LHsExpr Id)
-> 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 }
dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult
dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
= matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
matchGuards :: [GuardStmt Id]
-> HsStmtContext Name
-> LHsExpr Id
-> 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
match_result <- matchGuards stmts ctx rhs rhs_ty
core_rhs <- dsLExpr bind_rhs
matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result
matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"
matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"
matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"
isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr)
isTrueLHsExpr (L _ (HsVar v)) | v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
= Just return
isTrueLHsExpr (L _ (HsTick tickish e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> ticks x >>= return . (Tick tickish))
isTrueLHsExpr (L _ (HsBinTick ixT _ e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do e <- ticks x
this_mod <- getModule
return (Tick (HpcTick this_mod ixT) e))
isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e
isTrueLHsExpr _ = Nothing