module Language.Haskell.Liquid.Desugar710.DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where
import Language.Haskell.Liquid.Desugar710.DsExpr ( dsLExpr, dsLocalBinds )
import Language.Haskell.Liquid.Desugar710.Match ( matchSinglePat )
import Prelude hiding (error)
import HsSyn
import MkCore
import CoreSyn
import Var
import Type
import DsMonad
import Language.Haskell.Liquid.Desugar710.DsUtils
import TysWiredIn
import PrelNames
import Module
import Name
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
=
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