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