← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to compiler/deSugar/DsGRHSs.lhs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
compiler/deSugar/DsGRHSs.lhs
 
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
\begin{code}
 
9
{-# OPTIONS -fno-warn-incomplete-patterns #-}
 
10
-- The above warning supression flag is a temporary kludge.
 
11
-- While working on this module you are encouraged to remove it and fix
 
12
-- any warnings in the module. See
 
13
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 
14
-- for details
 
15
 
 
16
module DsGRHSs ( dsGuarded, dsGRHSs ) where
 
17
 
 
18
#include "HsVersions.h"
 
19
 
 
20
import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds )
 
21
import {-# SOURCE #-} Match   ( matchSinglePat )
 
22
 
 
23
import HsSyn
 
24
import MkCore
 
25
import CoreSyn
 
26
import Var
 
27
import Type
 
28
 
 
29
import DsMonad
 
30
import DsUtils
 
31
import TysWiredIn
 
32
import PrelNames
 
33
import Name
 
34
import SrcLoc
 
35
import Outputable
 
36
\end{code}
 
37
 
 
38
@dsGuarded@ is used for both @case@ expressions and pattern bindings.
 
39
It desugars:
 
40
\begin{verbatim}
 
41
        | g1 -> e1
 
42
        ...
 
43
        | gn -> en
 
44
        where binds
 
45
\end{verbatim}
 
46
producing an expression with a runtime error in the corner if
 
47
necessary.  The type argument gives the type of the @ei@.
 
48
 
 
49
\begin{code}
 
50
dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr
 
51
 
 
52
dsGuarded grhss rhs_ty = do
 
53
    match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty
 
54
    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
 
55
    extractMatchResult match_result error_expr
 
56
\end{code}
 
57
 
 
58
In contrast, @dsGRHSs@ produces a @MatchResult@.
 
59
 
 
60
\begin{code}
 
61
dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchContext from
 
62
        -> GRHSs Id                             -- Guarded RHSs
 
63
        -> Type                                 -- Type of RHS
 
64
        -> DsM MatchResult
 
65
dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = do
 
66
    match_results <- mapM (dsGRHS hs_ctx pats rhs_ty) grhss
 
67
    let 
 
68
        match_result1 = foldr1 combineMatchResults match_results
 
69
        match_result2 = adjustMatchResultDs 
 
70
                                 (\e -> dsLocalBinds binds e) 
 
71
                                 match_result1
 
72
                -- NB: nested dsLet inside matchResult
 
73
    --
 
74
    return match_result2
 
75
 
 
76
dsGRHS :: HsMatchContext Name -> [Pat Id] -> Type -> LGRHS Id -> DsM MatchResult
 
77
dsGRHS hs_ctx _ rhs_ty (L _ (GRHS guards rhs))
 
78
  = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty
 
79
\end{code}
 
80
 
 
81
 
 
82
%************************************************************************
 
83
%*                                                                      *
 
84
%*  matchGuard : make a MatchResult from a guarded RHS                  *
 
85
%*                                                                      *
 
86
%************************************************************************
 
87
 
 
88
\begin{code}
 
89
matchGuards :: [Stmt Id]                -- Guard
 
90
            -> HsMatchContext Name      -- Context
 
91
            -> LHsExpr Id               -- RHS
 
92
            -> Type                     -- Type of RHS of guard
 
93
            -> DsM MatchResult
 
94
 
 
95
-- See comments with HsExpr.Stmt re what an ExprStmt means
 
96
-- Here we must be in a guard context (not do-expression, nor list-comp)        
 
97
 
 
98
matchGuards [] _ rhs _
 
99
  = do  { core_rhs <- dsLExpr rhs
 
100
        ; return (cantFailMatchResult core_rhs) }
 
101
 
 
102
        -- ExprStmts must be guards
 
103
        -- Turn an "otherwise" guard is a no-op.  This ensures that 
 
104
        -- you don't get a "non-exhaustive eqns" message when the guards 
 
105
        -- finish in "otherwise".
 
106
        -- NB:  The success of this clause depends on the typechecker not
 
107
        --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
 
108
        --      If it does, you'll get bogus overlap warnings
 
109
matchGuards (ExprStmt e _ _ : stmts) ctx rhs rhs_ty
 
110
  | Just addTicks <- isTrueLHsExpr e = do
 
111
    match_result <- matchGuards stmts ctx rhs rhs_ty
 
112
    return (adjustMatchResultDs addTicks match_result)
 
113
matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty = do
 
114
    match_result <- matchGuards stmts ctx rhs rhs_ty
 
115
    pred_expr <- dsLExpr expr
 
116
    return (mkGuardedMatchResult pred_expr match_result)
 
117
 
 
118
matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do
 
119
    match_result <- matchGuards stmts ctx rhs rhs_ty
 
120
    return (adjustMatchResultDs (dsLocalBinds binds) match_result)
 
121
        -- NB the dsLet occurs inside the match_result
 
122
        -- Reason: dsLet takes the body expression as its argument
 
123
        --         so we can't desugar the bindings without the
 
124
        --         body expression in hand
 
125
 
 
126
matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
 
127
    match_result <- matchGuards stmts ctx rhs rhs_ty
 
128
    core_rhs <- dsLExpr bind_rhs
 
129
    matchSinglePat core_rhs ctx pat rhs_ty match_result
 
130
 
 
131
isTrueLHsExpr :: LHsExpr Id -> 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 aways evaluted.
 
139
isTrueLHsExpr (L _ (HsVar 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 _ (HsTick    ix frees e))
 
144
    | Just ticks <- isTrueLHsExpr e   = Just (\x -> ticks x >>= mkTickBox ix frees)
 
145
   -- This encodes that the result is constant True for Hpc tick purposes;
 
146
   -- which is specifically what isTrueLHsExpr is trying to find out.
 
147
isTrueLHsExpr (L _ (HsBinTick ixT _ e))
 
148
    | Just ticks <- isTrueLHsExpr e   = Just (\x -> ticks x >>= mkTickBox ixT [])
 
149
isTrueLHsExpr (L _ (HsPar e))         = isTrueLHsExpr e
 
150
isTrueLHsExpr _                       = Nothing
 
151
\end{code}
 
152
 
 
153
Should {\em fail} if @e@ returns @D@
 
154
\begin{verbatim}
 
155
f x | p <- e', let C y# = e, f y# = r1
 
156
    | otherwise          = r2 
 
157
\end{verbatim}