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