ghc/compiler/deSugar/MatchLit.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[MatchLit]{Pattern-matching literal patterns}
   5
   6 \begin{code}
   7 module MatchLit ( dsLit, matchLiterals ) where
   8
   9 #include "HsVersions.h"
  10
  11 import {-# SOURCE #-} Match  ( match )
  12 import {-# SOURCE #-} DsExpr ( dsExpr )
  13
  14 import DsMonad
  15 import DsCCall          ( resultWrapper )
  16 import DsUtils
  17
  18 import HsSyn            ( HsLit(..), Pat(..), HsExpr(..) )
  19 import TcHsSyn          ( TypecheckedPat )
  20 import Id               ( Id )
  21 import CoreSyn
  22 import TyCon            ( tyConDataCons )
  23 import TcType           ( tcSplitTyConApp, isIntegerTy  )
  24
  25 import PrelNames        ( ratioTyConKey )
  26 import Unique           ( hasKey )
  27 import Literal          ( mkMachInt, Literal(..) )
  28 import Maybes           ( catMaybes )
  29 import Type             ( isUnLiftedType )
  30 import Panic            ( panic, assertPanic )
  31 import Maybe            ( isJust )
  32 import Ratio            ( numerator, denominator )
  33 \end{code}
  34
  35 %************************************************************************
  36 %*                                                                      *
  37                 Desugaring literals
  38         [used to be in DsExpr, but DsMeta needs it,
  39          and it's nice to avoid a loop]
  40 %*                                                                      *
  41 %************************************************************************
  42
  43 We give int/float literals type @Integer@ and @Rational@, respectively.
  44 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
  45 around them.
  46
  47 ToDo: put in range checks for when converting ``@i@''
  48 (or should that be in the typechecker?)
  49
  50 For numeric literals, we try to detect there use at a standard type
  51 (@Int@, @Float@, etc.) are directly put in the right constructor.
  52 [NB: down with the @App@ conversion.]
  53
  54 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
  55
  56 \begin{code}
  57 dsLit :: HsLit -> DsM CoreExpr
  58 dsLit (HsChar c)       = returnDs (mkCharExpr c)
  59 dsLit (HsCharPrim c)   = returnDs (mkLit (MachChar c))
  60 dsLit (HsString str)   = mkStringLitFS str
  61 dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
  62 dsLit (HsInteger i)    = mkIntegerExpr i
  63 dsLit (HsInt i)        = returnDs (mkIntExpr i)
  64 dsLit (HsIntPrim i)    = returnDs (mkIntLit i)
  65 dsLit (HsFloatPrim f)  = returnDs (mkLit (MachFloat f))
  66 dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
  67 dsLit (HsLitLit str ty)
  68   = ASSERT( isJust maybe_ty )
  69     returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
  70   where
  71     (maybe_ty, wrap_fn) = resultWrapper ty
  72     Just rep_ty         = maybe_ty
  73
  74 dsLit (HsRat r ty)
  75   = mkIntegerExpr (numerator r)         `thenDs` \ num ->
  76     mkIntegerExpr (denominator r)       `thenDs` \ denom ->
  77     returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
  78   where
  79     (ratio_data_con, integer_ty)
  80         = case tcSplitTyConApp ty of
  81                 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
  82                                    (head (tyConDataCons tycon), i_ty)
  83 \end{code}
  84
  85 %************************************************************************
  86 %*                                                                      *
  87                 Pattern matching on literals
  88 %*                                                                      *
  89 %************************************************************************
  90
  91 \begin{code}
  92 matchLiterals :: [Id]
  93               -> [EquationInfo]
  94               -> DsM MatchResult
  95 \end{code}
  96
  97 This first one is a {\em special case} where the literal patterns are
  98 unboxed numbers (NB: the fiddling introduced by @tidyEqnInfo@).  We
  99 want to avoid using the ``equality'' stuff provided by the
 100 typechecker, and do a real ``case'' instead.  In that sense, the code
 101 is much like @matchConFamily@, which uses @match_cons_used@ to create
 102 the alts---here we use @match_prims_used@.
 103
 104 \begin{code}
 105 matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal : ps1) _ : eqns)
 106   = -- GENERATE THE ALTS
 107     match_prims_used vars eqns_info `thenDs` \ prim_alts ->
 108
 109     -- MAKE THE PRIMITIVE CASE
 110     returnDs (mkCoPrimCaseMatchResult var prim_alts)
 111   where
 112     match_prims_used _ [{-no more eqns-}] = returnDs []
 113
 114     match_prims_used vars eqns_info@(EqnInfo n ctx (pat@(LitPat literal):ps1) _ : eqns)
 115       = let
 116             (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
 117               = partitionEqnsByLit pat eqns_info
 118         in
 119         -- recursive call to make other alts...
 120         match_prims_used vars eqns_not_for_this_lit       `thenDs` \ rest_of_alts ->
 121
 122         -- (prim pats have no args; no selectMatchVars as in match_cons_used)
 123         -- now do the business to make the alt for _this_ LitPat ...
 124         match vars shifted_eqns_for_this_lit    `thenDs` \ match_result ->
 125         returnDs (
 126             (mk_core_lit literal, match_result)
 127             : rest_of_alts
 128         )
 129       where
 130         mk_core_lit :: HsLit -> Literal
 131
 132         mk_core_lit (HsIntPrim     i)    = mkMachInt  i
 133         mk_core_lit (HsCharPrim    c)    = MachChar   c
 134         mk_core_lit (HsStringPrim  s)    = MachStr    s
 135         mk_core_lit (HsFloatPrim   f)    = MachFloat  f
 136         mk_core_lit (HsDoublePrim  d)    = MachDouble d
 137         mk_core_lit (HsLitLit      s ty) = ASSERT(isUnLiftedType ty)
 138                                            MachLitLit s ty
 139         mk_core_lit other                = panic "matchLiterals:mk_core_lit:unhandled"
 140 \end{code}
 141
 142 \begin{code}
 143 matchLiterals all_vars@(var:vars)
 144   eqns_info@(EqnInfo n ctx (pat@(NPatOut literal lit_ty eq_chk):ps1) _ : eqns)
 145   = let
 146         (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
 147           = partitionEqnsByLit pat eqns_info
 148     in
 149     dsExpr (HsApp eq_chk (HsVar var))           `thenDs` \ pred_expr ->
 150     match vars shifted_eqns_for_this_lit        `thenDs` \ inner_match_result ->
 151     let
 152         match_result1 = mkGuardedMatchResult pred_expr inner_match_result
 153     in
 154     if (null eqns_not_for_this_lit)
 155     then
 156         returnDs match_result1
 157     else
 158         matchLiterals all_vars eqns_not_for_this_lit      `thenDs` \ match_result2 ->
 159         returnDs (combineMatchResults match_result1 match_result2)
 160 \end{code}
 161
 162 For an n+k pattern, we use the various magic expressions we've been given.
 163 We generate:
 164 \begin{verbatim}
 165     if ge var lit then
 166         let n = sub var lit
 167         in  <expr-for-a-successful-match>
 168     else
 169         <try-next-pattern-or-whatever>
 170 \end{verbatim}
 171
 172
 173 \begin{code}
 174 matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (pat@(NPlusKPatOut master_n k ge sub):ps1) _ : eqns)
 175   = let
 176         (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
 177           = partitionEqnsByLit pat eqns_info
 178     in
 179     match vars shifted_eqns_for_this_lit        `thenDs` \ inner_match_result ->
 180
 181     dsExpr (HsApp ge (HsVar var))               `thenDs` \ ge_expr ->
 182     dsExpr (HsApp sub (HsVar var))              `thenDs` \ nminusk_expr ->
 183
 184     let
 185         match_result1 = mkGuardedMatchResult ge_expr $
 186                         mkCoLetsMatchResult [NonRec master_n nminusk_expr] $
 187                         inner_match_result
 188     in
 189     if (null eqns_not_for_this_lit)
 190     then
 191         returnDs match_result1
 192     else
 193         matchLiterals all_vars eqns_not_for_this_lit    `thenDs` \ match_result2 ->
 194         returnDs (combineMatchResults match_result1 match_result2)
 195 \end{code}
 196
 197 Given a blob of @LitPat@s/@NPat@s, we want to split them into those
 198 that are ``same''/different as one we are looking at.  We need to know
 199 whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
 200
 201 \begin{code}
 202 partitionEqnsByLit :: TypecheckedPat
 203                    -> [EquationInfo]
 204                    -> ([EquationInfo],  -- These ones are for this lit, AND
 205                                         -- they've been "shifted" by stripping
 206                                         -- off the first pattern
 207                        [EquationInfo]   -- These are not for this lit; they
 208                                         -- are exactly as fed in.
 209                       )
 210
 211 partitionEqnsByLit master_pat eqns
 212   = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys))
 213         (unzip (map (partition_eqn master_pat) eqns))
 214   where
 215     partition_eqn :: TypecheckedPat -> EquationInfo -> (Maybe EquationInfo, Maybe EquationInfo)
 216
 217     partition_eqn (LitPat k1) (EqnInfo n ctx (LitPat k2 : remaining_pats) match_result)
 218       | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
 219                           -- NB the pattern is stripped off the EquationInfo
 220
 221     partition_eqn (NPatOut k1 _ _) (EqnInfo n ctx (NPatOut k2 _ _ : remaining_pats) match_result)
 222       | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
 223                           -- NB the pattern is stripped off the EquationInfo
 224
 225     partition_eqn (NPlusKPatOut master_n k1 _ _)
 226                   (EqnInfo n ctx (NPlusKPatOut n' k2 _ _ : remaining_pats) match_result)
 227       | k1 == k2 = (Just (EqnInfo n ctx remaining_pats new_match_result), Nothing)
 228                           -- NB the pattern is stripped off the EquationInfo
 229       where
 230         new_match_result | master_n == n' = match_result
 231                          | otherwise      = mkCoLetsMatchResult
 232                                                [NonRec n' (Var master_n)] match_result
 233
 234         -- Wild-card patterns, which will only show up in the shadows,
 235         -- go into both groups
 236     partition_eqn master_pat eqn@(EqnInfo n ctx (WildPat _ : remaining_pats) match_result)
 237                         = (Just (EqnInfo n ctx remaining_pats match_result), Just eqn)
 238
 239         -- Default case; not for this pattern
 240     partition_eqn master_pat eqn = (Nothing, Just eqn)
 241 \end{code}
 242