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