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