X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsGRHSs.lhs;h=d3fcf76d1c6a86664993f051b67d601f9a0f6a5c;hp=24086a27468c879d42e29969efd6a3ae4a884b49;hb=HEAD;hpb=79b22beb4d2eca1877d99d55838ba6ce69658405 diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index 24086a2..d3fcf76 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -21,13 +21,13 @@ import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) import {-# SOURCE #-} Match ( matchSinglePat ) import HsSyn +import MkCore import CoreSyn import Var import Type import DsMonad import DsUtils -import PrelInfo import TysWiredIn import PrelNames import Name @@ -75,7 +75,7 @@ dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = do dsGRHS :: HsMatchContext Name -> [Pat Id] -> Type -> LGRHS Id -> DsM MatchResult dsGRHS hs_ctx _ rhs_ty (L _ (GRHS guards rhs)) - = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty + = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty \end{code} @@ -87,7 +87,7 @@ dsGRHS hs_ctx _ rhs_ty (L _ (GRHS guards rhs)) \begin{code} matchGuards :: [Stmt Id] -- Guard - -> HsMatchContext Name -- Context + -> HsStmtContext Name -- Context -> LHsExpr Id -- RHS -> Type -- Type of RHS of guard -> DsM MatchResult @@ -106,11 +106,11 @@ 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 (ExprStmt e _ _ : stmts) ctx rhs rhs_ty +matchGuards (ExprStmt 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 (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty = do +matchGuards (ExprStmt 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) @@ -126,7 +126,7 @@ matchGuards (LetStmt binds : 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 ctx pat rhs_ty match_result + matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr)