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 -- XXX This define is a bit of a hack, and should be done more nicely
  19 #define FAST_STRING_NOT_NEEDED 1
  20 #include "HsVersions.h"
  21
  22 import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds )
  23 import {-# SOURCE #-} Match   ( matchSinglePat )
  24
  25 import HsSyn
  26 import CoreSyn
  27 import Var
  28 import Type
  29
  30 import DsMonad
  31 import DsUtils
  32 import PrelInfo
  33 import TysWiredIn
  34 import PrelNames
  35 import Name
  36 import SrcLoc
  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 (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 :: HsMatchContext Name -> [Pat Id] -> Type -> LGRHS Id -> DsM MatchResult
  79 dsGRHS hs_ctx _ rhs_ty (L _ (GRHS guards rhs))
  80   = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty
  81 \end{code}
  82
  83
  84 %************************************************************************
  85 %*                                                                      *
  86 %*  matchGuard : make a MatchResult from a guarded RHS                  *
  87 %*                                                                      *
  88 %************************************************************************
  89
  90 \begin{code}
  91 matchGuards :: [Stmt Id]                -- Guard
  92             -> HsMatchContext Name      -- Context
  93             -> LHsExpr Id               -- RHS
  94             -> Type                     -- Type of RHS of guard
  95             -> DsM MatchResult
  96
  97 -- See comments with HsExpr.Stmt re what an ExprStmt means
  98 -- Here we must be in a guard context (not do-expression, nor list-comp)
  99
 100 matchGuards [] _ rhs _
 101   = do  { core_rhs <- dsLExpr rhs
 102         ; return (cantFailMatchResult core_rhs) }
 103
 104         -- ExprStmts must be guards
 105         -- Turn an "otherwise" guard is a no-op.  This ensures that
 106         -- you don't get a "non-exhaustive eqns" message when the guards
 107         -- finish in "otherwise".
 108         -- NB:  The success of this clause depends on the typechecker not
 109         --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
 110         --      If it does, you'll get bogus overlap warnings
 111 matchGuards (ExprStmt e _ _ : stmts) ctx rhs rhs_ty
 112   | Just addTicks <- isTrueLHsExpr e = do
 113     match_result <- matchGuards stmts ctx rhs rhs_ty
 114     return (adjustMatchResultDs addTicks match_result)
 115 matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty = do
 116     match_result <- matchGuards stmts ctx rhs rhs_ty
 117     pred_expr <- dsLExpr expr
 118     return (mkGuardedMatchResult pred_expr match_result)
 119
 120 matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do
 121     match_result <- matchGuards stmts ctx rhs rhs_ty
 122     return (adjustMatchResultDs (dsLocalBinds binds) match_result)
 123         -- NB the dsLet occurs inside the match_result
 124         -- Reason: dsLet takes the body expression as its argument
 125         --         so we can't desugar the bindings without the
 126         --         body expression in hand
 127
 128 matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
 129     match_result <- matchGuards stmts ctx rhs rhs_ty
 130     core_rhs <- dsLExpr bind_rhs
 131     matchSinglePat core_rhs ctx pat rhs_ty match_result
 132
 133 isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr)
 134
 135 -- Returns Just {..} if we're sure that the expression is True
 136 -- I.e.   * 'True' datacon
 137 --        * 'otherwise' Id
 138 --        * Trivial wappings of these
 139 -- The arguments to Just are any HsTicks that we have found,
 140 -- because we still want to tick then, even it they are aways evaluted.
 141 isTrueLHsExpr (L _ (HsVar v)) |  v `hasKey` otherwiseIdKey
 142                               || v `hasKey` getUnique trueDataConId
 143                                       = Just return
 144         -- trueDataConId doesn't have the same unique as trueDataCon
 145 isTrueLHsExpr (L _ (HsTick    ix frees e))
 146     | Just ticks <- isTrueLHsExpr e   = Just (\x -> ticks x >>= mkTickBox ix frees)
 147    -- This encodes that the result is constant True for Hpc tick purposes;
 148    -- which is specifically what isTrueLHsExpr is trying to find out.
 149 isTrueLHsExpr (L _ (HsBinTick ixT _ e))
 150     | Just ticks <- isTrueLHsExpr e   = Just (\x -> ticks x >>= mkTickBox ixT [])
 151 isTrueLHsExpr (L _ (HsPar e))         = isTrueLHsExpr e
 152 isTrueLHsExpr _                       = Nothing
 153 \end{code}
 154
 155 Should {\em fail} if @e@ returns @D@
 156 \begin{verbatim}
 157 f x | p <- e', let C y# = e, f y# = r1
 158     | otherwise          = r2
 159 \end{verbatim}