Merge remote-tracking branch 'github/pr/83'
[ghc.git] / compiler / deSugar / DsGRHSs.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Matching guarded right-hand-sides (GRHSs)
7 -}
8
9 {-# LANGUAGE CPP #-}
10
11 module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
12
13 #include "HsVersions.h"
14
15 import GhcPrelude
16
17 import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
18 import {-# SOURCE #-} Match ( matchSinglePat )
19
20 import HsSyn
21 import MkCore
22 import CoreSyn
23
24 import DsMonad
25 import DsUtils
26 import TysWiredIn
27 import PrelNames
28 import Type ( Type )
29 import Module
30 import Name
31 import Util
32 import SrcLoc
33 import Outputable
34
35 {-
36 @dsGuarded@ is used for both @case@ expressions and pattern bindings.
37 It desugars:
38 \begin{verbatim}
39 | g1 -> e1
40 ...
41 | gn -> en
42 where binds
43 \end{verbatim}
44 producing an expression with a runtime error in the corner if
45 necessary. The type argument gives the type of the @ei@.
46 -}
47
48 dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
49
50 dsGuarded grhss rhs_ty = do
51 match_result <- dsGRHSs PatBindRhs grhss rhs_ty
52 error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
53 extractMatchResult match_result error_expr
54
55 -- In contrast, @dsGRHSs@ produces a @MatchResult@.
56
57 dsGRHSs :: HsMatchContext Name
58 -> GRHSs GhcTc (LHsExpr GhcTc) -- Guarded RHSs
59 -> Type -- Type of RHS
60 -> DsM MatchResult
61 dsGRHSs hs_ctx (GRHSs grhss binds) rhs_ty
62 = ASSERT( notNull grhss )
63 do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
64 ; let match_result1 = foldr1 combineMatchResults match_results
65 match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
66 -- NB: nested dsLet inside matchResult
67 ; return match_result2 }
68
69 dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
70 -> DsM MatchResult
71 dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
72 = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
73
74 {-
75 ************************************************************************
76 * *
77 * matchGuard : make a MatchResult from a guarded RHS *
78 * *
79 ************************************************************************
80 -}
81
82 matchGuards :: [GuardStmt GhcTc] -- Guard
83 -> HsStmtContext Name -- Context
84 -> LHsExpr GhcTc -- RHS
85 -> Type -- Type of RHS of guard
86 -> DsM MatchResult
87
88 -- See comments with HsExpr.Stmt re what a BodyStmt means
89 -- Here we must be in a guard context (not do-expression, nor list-comp)
90
91 matchGuards [] _ rhs _
92 = do { core_rhs <- dsLExpr rhs
93 ; return (cantFailMatchResult core_rhs) }
94
95 -- BodyStmts must be guards
96 -- Turn an "otherwise" guard is a no-op. This ensures that
97 -- you don't get a "non-exhaustive eqns" message when the guards
98 -- finish in "otherwise".
99 -- NB: The success of this clause depends on the typechecker not
100 -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
101 -- If it does, you'll get bogus overlap warnings
102 matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty
103 | Just addTicks <- isTrueLHsExpr e = do
104 match_result <- matchGuards stmts ctx rhs rhs_ty
105 return (adjustMatchResultDs addTicks match_result)
106 matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
107 match_result <- matchGuards stmts ctx rhs rhs_ty
108 pred_expr <- dsLExpr expr
109 return (mkGuardedMatchResult pred_expr match_result)
110
111 matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do
112 match_result <- matchGuards stmts ctx rhs rhs_ty
113 return (adjustMatchResultDs (dsLocalBinds binds) match_result)
114 -- NB the dsLet occurs inside the match_result
115 -- Reason: dsLet takes the body expression as its argument
116 -- so we can't desugar the bindings without the
117 -- body expression in hand
118
119 matchGuards (BindStmt pat bind_rhs _ _ _ : stmts) ctx rhs rhs_ty = do
120 match_result <- matchGuards stmts ctx rhs rhs_ty
121 core_rhs <- dsLExpr bind_rhs
122 matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result
123
124 matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"
125 matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"
126 matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
127 matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"
128 matchGuards (ApplicativeStmt {} : _) _ _ _ =
129 panic "matchGuards ApplicativeLastStmt"
130
131 isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
132
133 -- Returns Just {..} if we're sure that the expression is True
134 -- I.e. * 'True' datacon
135 -- * 'otherwise' Id
136 -- * Trivial wappings of these
137 -- The arguments to Just are any HsTicks that we have found,
138 -- because we still want to tick then, even it they are always evaluated.
139 isTrueLHsExpr (L _ (HsVar (L _ v))) | v `hasKey` otherwiseIdKey
140 || v `hasKey` getUnique trueDataConId
141 = Just return
142 -- trueDataConId doesn't have the same unique as trueDataCon
143 isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return
144 isTrueLHsExpr (L _ (HsTick tickish e))
145 | Just ticks <- isTrueLHsExpr e
146 = Just (\x -> do wrapped <- ticks x
147 return (Tick tickish wrapped))
148 -- This encodes that the result is constant True for Hpc tick purposes;
149 -- which is specifically what isTrueLHsExpr is trying to find out.
150 isTrueLHsExpr (L _ (HsBinTick ixT _ e))
151 | Just ticks <- isTrueLHsExpr e
152 = Just (\x -> do e <- ticks x
153 this_mod <- getModule
154 return (Tick (HpcTick this_mod ixT) e))
155
156 isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e
157 isTrueLHsExpr _ = Nothing
158
159 {-
160 Should {\em fail} if @e@ returns @D@
161 \begin{verbatim}
162 f x | p <- e', let C y# = e, f y# = r1
163 | otherwise = r2
164 \end{verbatim}
165 -}