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