ghc/compiler/deSugar/MatchLit.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[MatchLit]{Pattern-matching literal patterns}
   5
   6 \begin{code}
   7 module MatchLit ( matchLiterals ) where
   8
   9 #include "HsVersions.h"
  10
  11 import {-# SOURCE #-} Match  ( match )
  12 import {-# SOURCE #-} DsExpr ( dsExpr )
  13
  14 import HsSyn            ( HsLit(..), OutPat(..), HsExpr(..), Fixity,
  15                           Match, HsBinds, DoOrListComp, HsType, ArithSeqInfo )
  16 import TcHsSyn          ( TypecheckedHsExpr, TypecheckedPat )
  17 import CoreSyn          ( CoreExpr, CoreBinding, GenCoreExpr(..), GenCoreBinding(..) )
  18 import Id               ( Id )
  19
  20 import DsMonad
  21 import DsUtils
  22
  23 import Literal          ( mkMachInt_safe, Literal(..) )
  24 import PrimRep          ( PrimRep(IntRep) )
  25 import Maybes           ( catMaybes )
  26 import Type             ( Type, isUnpointedType )
  27 import Util             ( panic, assertPanic )
  28 \end{code}
  29
  30 \begin{code}
  31 matchLiterals :: [Id]
  32               -> [EquationInfo]
  33               -> DsM MatchResult
  34 \end{code}
  35
  36 This first one is a {\em special case} where the literal patterns are
  37 unboxed numbers (NB: the fiddling introduced by @tidyEqnInfo@).  We
  38 want to avoid using the ``equality'' stuff provided by the
  39 typechecker, and do a real ``case'' instead.  In that sense, the code
  40 is much like @matchConFamily@, which uses @match_cons_used@ to create
  41 the alts---here we use @match_prims_used@.
  42
  43 \begin{code}
  44 matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_ty : ps1) _ : eqns)
  45   = -- GENERATE THE ALTS
  46     match_prims_used vars eqns_info `thenDs` \ prim_alts ->
  47
  48     -- MAKE THE PRIMITIVE CASE
  49     mkCoPrimCaseMatchResult var prim_alts
  50   where
  51     match_prims_used _ [{-no more eqns-}] = returnDs []
  52
  53     match_prims_used vars eqns_info@(EqnInfo n ctx ((LitPat literal lit_ty):ps1) _ : eqns)
  54       = let
  55             (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
  56               = partitionEqnsByLit Nothing literal eqns_info
  57         in
  58         -- recursive call to make other alts...
  59         match_prims_used vars eqns_not_for_this_lit       `thenDs` \ rest_of_alts ->
  60
  61         -- (prim pats have no args; no selectMatchVars as in match_cons_used)
  62         -- now do the business to make the alt for _this_ LitPat ...
  63         match vars shifted_eqns_for_this_lit    `thenDs` \ match_result ->
  64         returnDs (
  65             (mk_core_lit lit_ty literal, match_result)
  66             : rest_of_alts
  67         )
  68       where
  69         mk_core_lit :: Type -> HsLit -> Literal
  70
  71         mk_core_lit ty (HsIntPrim     i) = mkMachInt_safe i
  72         mk_core_lit ty (HsCharPrim    c) = MachChar   c
  73         mk_core_lit ty (HsStringPrim  s) = MachStr    s
  74         mk_core_lit ty (HsFloatPrim   f) = MachFloat  f
  75         mk_core_lit ty (HsDoublePrim  d) = MachDouble d
  76         mk_core_lit ty (HsLitLit      s) = ASSERT(isUnpointedType ty)
  77                                            MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???")
  78         mk_core_lit ty other             = panic "matchLiterals:mk_core_lit:unhandled"
  79 \end{code}
  80
  81 \begin{code}
  82 matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx ((NPat literal lit_ty eq_chk):ps1) _ : eqns)
  83   = let
  84         (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
  85           = partitionEqnsByLit Nothing literal eqns_info
  86     in
  87     dsExpr (HsApp eq_chk (HsVar var))                     `thenDs` \ pred_expr ->
  88     match vars shifted_eqns_for_this_lit                  `thenDs` \ inner_match_result ->
  89     mkGuardedMatchResult pred_expr inner_match_result     `thenDs` \ match_result1 ->
  90
  91     if (null eqns_not_for_this_lit)
  92     then
  93         returnDs match_result1
  94     else
  95         matchLiterals all_vars eqns_not_for_this_lit      `thenDs` \ match_result2 ->
  96         combineMatchResults match_result1 match_result2
  97 \end{code}
  98
  99 For an n+k pattern, we use the various magic expressions we've been given.
 100 We generate:
 101 \begin{verbatim}
 102     if ge var lit then
 103         let n = sub var lit
 104         in  <expr-for-a-successful-match>
 105     else
 106         <try-next-pattern-or-whatever>
 107 \end{verbatim}
 108
 109
 110 \begin{code}
 111 matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx ((NPlusKPat master_n k ty ge sub):ps1) _ : eqns)
 112   = let
 113         (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
 114           = partitionEqnsByLit (Just master_n) k eqns_info
 115     in
 116     match vars shifted_eqns_for_this_lit        `thenDs` \ inner_match_result ->
 117
 118     dsExpr (HsApp ge (HsVar var))               `thenDs` \ ge_expr ->
 119     dsExpr (HsApp sub (HsVar var))              `thenDs` \ nminusk_expr ->
 120
 121     mkGuardedMatchResult
 122         ge_expr
 123         (mkCoLetsMatchResult [NonRec master_n nminusk_expr] inner_match_result)
 124                                         `thenDs` \ match_result1 ->
 125
 126     if (null eqns_not_for_this_lit)
 127     then
 128         returnDs match_result1
 129     else
 130         matchLiterals all_vars eqns_not_for_this_lit    `thenDs` \ match_result2 ->
 131         combineMatchResults match_result1 match_result2
 132 \end{code}
 133
 134 Given a blob of LitPats/NPats, we want to split them into those
 135 that are ``same''/different as one we are looking at.  We need to know
 136 whether we're looking at a LitPat/NPat, and what literal we're after.
 137
 138 \begin{code}
 139 partitionEqnsByLit :: Maybe Id  -- (Just v) for N-plus-K patterns, where v
 140                                 -- is the "master" variable;
 141                                 -- Nothing for NPats and LitPats
 142                    -> HsLit
 143                    -> [EquationInfo]
 144                    -> ([EquationInfo],  -- These ones are for this lit, AND
 145                                         -- they've been "shifted" by stripping
 146                                         -- off the first pattern
 147                        [EquationInfo]   -- These are not for this lit; they
 148                                         -- are exactly as fed in.
 149                       )
 150
 151 partitionEqnsByLit nPlusK lit eqns
 152   = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys))
 153         (unzip (map (partition_eqn nPlusK lit) eqns))
 154   where
 155     partition_eqn :: Maybe Id -> HsLit -> EquationInfo ->
 156                 (Maybe EquationInfo, Maybe EquationInfo)
 157
 158     partition_eqn Nothing lit (EqnInfo n ctx (LitPat k _ : remaining_pats) match_result)
 159       | lit `eq_lit` k  = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
 160                           -- NB the pattern is stripped off the EquationInfo
 161
 162     partition_eqn Nothing lit (EqnInfo n ctx (NPat k _ _ : remaining_pats) match_result)
 163       | lit `eq_lit` k  = (Just (EqnInfo n ctx remaining_pats match_result), Nothing)
 164                           -- NB the pattern is stripped off the EquationInfo
 165
 166     partition_eqn (Just master_n) lit  (EqnInfo n ctx (NPlusKPat n' k _ _ _ : remaining_pats) match_result)
 167       | lit `eq_lit` k  = (Just (EqnInfo n ctx remaining_pats new_match_result), Nothing)
 168                           -- NB the pattern is stripped off the EquationInfo
 169       where
 170         new_match_result | master_n == n' = match_result
 171                          | otherwise      = mkCoLetsMatchResult [NonRec n' (Var master_n)] match_result
 172
 173         -- Wild-card patterns, which will only show up in the shadows, go into both groups
 174     partition_eqn nPlusK lit eqn@(EqnInfo n ctx (WildPat _ : remaining_pats) match_result)
 175                         = (Just (EqnInfo n ctx remaining_pats match_result), Just eqn)
 176
 177         -- Default case; not for this pattern
 178     partition_eqn nPlusK lit eqn = (Nothing, Just eqn)
 179
 180 -- ToDo: meditate about this equality business...
 181
 182 eq_lit (HsInt  i1)       (HsInt  i2)       = i1 == i2
 183 eq_lit (HsFrac f1)       (HsFrac f2)       = f1 == f2
 184
 185 eq_lit (HsIntPrim i1)    (HsIntPrim i2)    = i1 == i2
 186 eq_lit (HsFloatPrim f1)  (HsFloatPrim f2)  = f1 == f2
 187 eq_lit (HsDoublePrim d1) (HsDoublePrim d2) = d1 == d2
 188 eq_lit (HsChar c1)       (HsChar c2)       = c1 == c2
 189 eq_lit (HsCharPrim c1)   (HsCharPrim c2)   = c1 == c2
 190 eq_lit (HsString s1)     (HsString s2)     = s1 == s2
 191 eq_lit (HsStringPrim s1) (HsStringPrim s2) = s1 == s2
 192 eq_lit (HsLitLit s1)     (HsLitLit s2)     = s1 == s2 -- ToDo: ??? (dubious)
 193 eq_lit other1            other2            = panic "matchLiterals:eq_lit"
 194 \end{code}