DsGRHSs.lhs 3.31 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 4 5 6 7 8
%
\section[DsGRHSs]{Matching guarded right-hand-sides (GRHSs)}

\begin{code}
module DsGRHSs ( dsGuarded, dsGRHSs ) where

9 10
#include "HsVersions.h"

11 12
import {-# SOURCE #-} DsExpr  ( dsExpr, dsLet )
import {-# SOURCE #-} Match   ( matchSinglePat )
13

14 15
import HsSyn		( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..) )
import TcHsSyn		( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt )
16
import CoreSyn		( CoreExpr, Bind(..) )
17
import Type		( Type )
18 19

import DsMonad
20
import DsUtils
21
import PrelInfo		( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
22
import Unique		( otherwiseIdKey, trueDataConKey, Uniquable(..) )
23
import Outputable
24 25 26 27 28 29 30 31 32 33 34
\end{code}

@dsGuarded@ is used for both @case@ expressions and pattern bindings.
It desugars:
\begin{verbatim}
	| g1 -> e1
	...
	| gn -> en
	where binds
\end{verbatim}
producing an expression with a runtime error in the corner if
35
necessary.  The type argument gives the type of the @ei@.
36 37

\begin{code}
38
dsGuarded :: TypecheckedGRHSs -> DsM CoreExpr
39

40 41
dsGuarded grhss
  = dsGRHSs PatBindMatch [] grhss 				`thenDs` \ (err_ty, match_result) ->
42
    mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty ""	`thenDs` \ error_expr ->
43
    extractMatchResult match_result error_expr
44 45
\end{code}

46
In contrast, @dsGRHSs@ produces a @MatchResult@.
47 48

\begin{code}
49
dsGRHSs :: DsMatchKind -> [TypecheckedPat]	-- These are to build a MatchContext from
50 51 52 53 54 55 56 57 58 59 60
	-> TypecheckedGRHSs			-- Guarded RHSs
	-> DsM (Type, MatchResult)

dsGRHSs kind pats (GRHSs grhss binds (Just ty))
  = mapDs (dsGRHS kind pats) grhss		`thenDs` \ match_results ->
    let 
	match_result1 = foldr1 combineMatchResults match_results
	match_result2 = adjustMatchResultDs (dsLet binds) match_result1
		-- NB: nested dsLet inside matchResult
    in
    returnDs (ty, match_result2)
61

62 63
dsGRHS kind pats (GRHS guard locn)
  = matchGuard guard (DsMatchContext kind pats locn)
64 65 66
\end{code}


sof's avatar
sof committed
67 68 69 70 71 72 73 74
%************************************************************************
%*									*
%*  matchGuard : make a MatchResult from a guarded RHS			*
%*									*
%************************************************************************

\begin{code}
matchGuard :: [TypecheckedStmt] 	-- Guard
75
           -> DsMatchContext            -- Context
sof's avatar
sof committed
76 77
	   -> DsM MatchResult

78 79 80
matchGuard (ExprStmt expr locn : should_be_null) ctx 
  = putSrcLocDs locn (dsExpr expr) 	`thenDs` \ core_expr ->
    returnDs (cantFailMatchResult core_expr)
sof's avatar
sof committed
81 82

	-- Turn an "otherwise" guard is a no-op
83
matchGuard (GuardStmt (HsVar v) _ : stmts) ctx
84 85
  |  uniq == otherwiseIdKey
  || uniq == trueDataConKey
86
  = matchGuard stmts ctx
87
  where
88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103
    uniq = getUnique v

matchGuard (GuardStmt expr locn : stmts) ctx
  = matchGuard stmts ctx 		`thenDs` \ match_result ->
    putSrcLocDs locn (dsExpr expr)	`thenDs` \ pred_expr ->
    returnDs (mkGuardedMatchResult pred_expr match_result)

matchGuard (LetStmt binds : stmts) ctx
  = matchGuard stmts ctx 	`thenDs` \ match_result ->
    returnDs (adjustMatchResultDs (dsLet binds) match_result)
	-- NB the dsLet occurs inside the match_result

matchGuard (BindStmt pat rhs locn : stmts) ctx
  = matchGuard stmts ctx 		`thenDs` \ match_result ->
    putSrcLocDs locn (dsExpr rhs)	`thenDs` \ core_rhs ->
    matchSinglePat core_rhs ctx pat match_result
sof's avatar
sof committed
104
\end{code}
105

106 107
Should {\em fail} if @e@ returns @D@
\begin{verbatim}
108 109
f x | p <- e', let C y# = e, f y# = r1
    | otherwise 	 = r2 
110
\end{verbatim}