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 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 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}