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   = resultWrapper ty `thenDs` \ (maybe_ty, wrap_fn) ->
  69     ASSERT( isJust maybe_ty )
  70       let (Just rep_ty) = maybe_ty in
  71       returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
  72
  73 dsLit (HsRat r ty)
  74   = mkIntegerExpr (numerator r)         `thenDs` \ num ->
  75     mkIntegerExpr (denominator r)       `thenDs` \ denom ->
  76     returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
  77   where
  78     (ratio_data_con, integer_ty)
  79         = case tcSplitTyConApp ty of
  80                 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
  81                                    (head (tyConDataCons tycon), i_ty)
  82 \end{code}
  83
  84 %************************************************************************
  85 %*                                                                      *
  86                 Pattern matching on literals
  87 %*                                                                      *
  88 %************************************************************************
  89
  90 \begin{code}
  91 matchLiterals :: [Id]
  92               -> [EquationInfo]
  93               -> DsM MatchResult
  94 \end{code}
  95
  96 This first one is a {\em special case} where the literal patterns are
  97 unboxed numbers (NB: the fiddling introduced by @tidyEqnInfo@).  We
  98 want to avoid using the ``equality'' stuff provided by the
  99 typechecker, and do a real ``case'' instead.  In that sense, the code
 100 is much like @matchConFamily@, which uses @match_cons_used@ to create
 101 the alts---here we use @match_prims_used@.
 102
 103 \begin{code}
 104 matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal : ps1) _ : eqns)
 105   = -- GENERATE THE ALTS
 106     match_prims_used vars eqns_info `thenDs` \ prim_alts ->
 107
 108     -- MAKE THE PRIMITIVE CASE
 109     returnDs (mkCoPrimCaseMatchResult var prim_alts)
 110   where
 111     match_prims_used _ [{-no more eqns-}] = returnDs []
 112
 113     match_prims_used vars eqns_info@(EqnInfo n ctx (pat@(LitPat literal):ps1) _ : eqns)
 114       = let
 115             (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
 116               = partitionEqnsByLit pat eqns_info
 117         in
 118         -- recursive call to make other alts...
 119         match_prims_used vars eqns_not_for_this_lit       `thenDs` \ rest_of_alts ->
 120
 121         -- (prim pats have no args; no selectMatchVars as in match_cons_used)
 122         -- now do the business to make the alt for _this_ LitPat ...
 123         match vars shifted_eqns_for_this_lit    `thenDs` \ match_result ->
 124         returnDs (
 125             (mk_core_lit literal, match_result)
 126             : rest_of_alts
 127         )
 128       where
 129         mk_core_lit :: HsLit -> Literal
 130
 131         mk_core_lit (HsIntPrim     i)    = mkMachInt  i
 132         mk_core_lit (HsCharPrim    c)    = MachChar   c
 133         mk_core_lit (HsStringPrim  s)    = MachStr    s
 134         mk_core_lit (HsFloatPrim   f)    = MachFloat  f
 135         mk_core_lit (HsDoublePrim  d)    = MachDouble d
 136         mk_core_lit (HsLitLit      s ty) = ASSERT(isUnLiftedType ty)
 137                                            MachLitLit s ty
 138         mk_core_lit other                = panic "matchLiterals:mk_core_lit:unhandled"
 139 \end{code}
 140
 141 \begin{code}
 142 matchLiterals all_vars@(var:vars)
 143   eqns_info@(EqnInfo n ctx (pat@(NPatOut literal lit_ty eq_chk):ps1) _ : eqns)
 144   = let
 145         (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
 146           = partitionEqnsByLit pat eqns_info
 147     in
 148     dsExpr (HsApp eq_chk (HsVar var))           `thenDs` \ pred_expr ->
 149     match vars shifted_eqns_for_this_lit        `thenDs` \ inner_match_result ->
 150     let
 151         match_result1 = mkGuardedMatchResult pred_expr inner_match_result
 152     in
 153     if (null eqns_not_for_this_lit)
 154     then
 155         returnDs match_result1
 156     else
 157         matchLiterals all_vars eqns_not_for_this_lit      `thenDs` \ match_result2 ->
 158         returnDs (combineMatchResults match_result1 match_result2)
 159 \end{code}
 160
 161 For an n+k pattern, we use the various magic expressions we've been given.
 162 We generate:
 163 \begin{verbatim}
 164     if ge var lit then
 165         let n = sub var lit
 166         in  <expr-for-a-successful-match>
 167     else
 168         <try-next-pattern-or-whatever>
 169 \end{verbatim}
 170
 171
 172 \begin{code}
 173 matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (pat@(NPlusKPatOut master_n k ge sub):ps1) _ : eqns)
 174   = let
 175         (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
 176           = partitionEqnsByLit pat eqns_info
 177     in
 178     match vars shifted_eqns_for_this_lit        `thenDs` \ inner_match_result ->
 179
 180     dsExpr (HsApp ge (HsVar var))               `thenDs` \ ge_expr ->
 181     dsExpr (HsApp sub (HsVar var))              `thenDs` \ nminusk_expr ->
 182
 183     let
 184         match_result1 = mkGuardedMatchResult ge_expr $
 185                         mkCoLetsMatchResult [NonRec master_n nminusk_expr] $
 186                         inner_match_result
 187     in
 188     if (null eqns_not_for_this_lit)
 189     then
 190         returnDs match_result1
 191     else
 192         matchLiterals all_vars eqns_not_for_this_lit    `thenDs` \ match_result2 ->
 193         returnDs (combineMatchResults match_result1 match_result2)
 194 \end{code}
 195
 196 Given a blob of @LitPat@s/@NPat@s, we want to split them into those
 197 that are ``same''/different as one we are looking at.  We need to know
 198 whether we're looking at a @LitPat@/@NPat@, and what literal we're after.
 199
 200 \begin{code}
 201 partitionEqnsByLit :: TypecheckedPat
 202                    -> [EquationInfo]
 203                    -> ([EquationInfo],  -- These ones are for this lit, AND
 204                                         -- they've been "shifted" by stripping
 205                                         -- off the first pattern
 206                        [EquationInfo]   -- These are not for this lit; they
 207                                         -- are exactly as fed in.
 208                       )
 209
 210 partitionEqnsByLit master_pat eqns
 211   = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys))
 212         (unzip (map (partition_eqn master_pat) eqns))
 213   where
 214     partition_eqn :: TypecheckedPat -> EquationInfo -> (Maybe EquationInfo, Maybe EquationInfo)
 215
 216     partition_eqn (LitPat k1) (EqnInfo n ctx (LitPat k2 : remaining_pats) match_result)
 217       | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
 218                           -- NB the pattern is stripped off the EquationInfo
 219
 220     partition_eqn (NPatOut k1 _ _) (EqnInfo n ctx (NPatOut k2 _ _ : remaining_pats) match_result)
 221       | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
 222                           -- NB the pattern is stripped off the EquationInfo
 223
 224     partition_eqn (NPlusKPatOut master_n k1 _ _)
 225                   (EqnInfo n ctx (NPlusKPatOut n' k2 _ _ : remaining_pats) match_result)
 226       | k1 == k2 = (Just (EqnInfo n ctx remaining_pats new_match_result), Nothing)
 227                           -- NB the pattern is stripped off the EquationInfo
 228       where
 229         new_match_result | master_n == n' = match_result
 230                          | otherwise      = mkCoLetsMatchResult
 231                                                [NonRec n' (Var master_n)] match_result
 232
 233         -- Wild-card patterns, which will only show up in the shadows,
 234         -- go into both groups
 235     partition_eqn master_pat eqn@(EqnInfo n ctx (WildPat _ : remaining_pats) match_result)
 236                         = (Just (EqnInfo n ctx remaining_pats match_result), Just eqn)
 237
 238         -- Default case; not for this pattern
 239     partition_eqn master_pat eqn = (Nothing, Just eqn)
 240 \end{code}
 241