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