ghc/compiler/deSugar/MatchLit.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[MatchLit]{Pattern-matching literal and n+k patterns}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module MatchLit (
  10         matchLiterals
  11     ) where
  12
  13 import AbsSyn           -- the stuff being desugared
  14 import PlainCore        -- the output of desugaring;
  15                         -- importing this module also gets all the
  16                         -- CoreSyn utility functions
  17 import DsMonad          -- the monadery used in the desugarer
  18
  19 import AbsUniType       ( isPrimType, getUniDataTyCon, kindFromType )
  20 import BasicLit         ( mkMachInt, BasicLit(..), PrimKind )
  21 import DsExpr           ( dsExpr )
  22 import DsUtils
  23 import Maybes           ( Maybe(..), catMaybes )
  24 import Match            ( match )
  25 import Id               ( getIdUniType, eqId )
  26 import Util
  27 \end{code}
  28
  29 \begin{code}
  30 matchLiterals :: [Id]
  31               -> [EquationInfo]
  32               -> [EquationInfo]         -- Shadows
  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 (LitPat literal lit_ty : ps1) _ : eqns) shadows
  45   = -- GENERATE THE ALTS
  46     match_prims_used vars eqns_info shadows `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 ((LitPat literal _):ps1) _ : eqns) shadows
  54       = let
  55             (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
  56               = partitionEqnsByLit Nothing literal eqns_info
  57             (shifted_shadows_for_this_lit, shadows_not_for_this_lit)
  58               = partitionEqnsByLit Nothing literal shadows
  59         in
  60         -- recursive call to make other alts...
  61         match_prims_used vars eqns_not_for_this_lit shadows_not_for_this_lit    `thenDs` \ rest_of_alts ->
  62
  63         -- (prim pats have no args; no selectMatchVars as in match_cons_used)
  64         -- now do the business to make the alt for _this_ LitPat ...
  65         match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit       `thenDs` \ match_result ->
  66         returnDs (
  67             (mk_core_lit literal, match_result)
  68             : rest_of_alts
  69         )
  70       where
  71         mk_core_lit :: Literal -> BasicLit
  72
  73         mk_core_lit (IntPrimLit     i) = mkMachInt  i
  74         mk_core_lit (CharPrimLit    c) = MachChar   c
  75         mk_core_lit (StringPrimLit  s) = MachStr    s
  76         mk_core_lit (FloatPrimLit   f) = MachFloat  f
  77         mk_core_lit (DoublePrimLit  d) = MachDouble d
  78         mk_core_lit (LitLitLit    s t) = ASSERT(isPrimType t)
  79                                          MachLitLit s (kindFromType t)
  80         mk_core_lit other              = panic "matchLiterals:mk_core_lit:unhandled"
  81 \end{code}
  82
  83 \begin{code}
  84 matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPat literal lit_ty eq_chk):ps1) _ : eqns) shadows
  85   = let
  86         (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
  87           = partitionEqnsByLit Nothing literal eqns_info
  88         (shifted_shadows_for_this_lit, shadows_not_for_this_lit)
  89               = partitionEqnsByLit Nothing literal shadows
  90     in
  91     dsExpr (App eq_chk (Var var))                                       `thenDs` \ pred_expr ->
  92     match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit   `thenDs` \ inner_match_result ->
  93     mkGuardedMatchResult pred_expr inner_match_result                   `thenDs` \ match_result1 ->
  94
  95     if (null eqns_not_for_this_lit)
  96     then
  97         returnDs match_result1
  98     else
  99         matchLiterals all_vars eqns_not_for_this_lit shadows_not_for_this_lit   `thenDs` \ match_result2 ->
 100         combineMatchResults match_result1 match_result2
 101 \end{code}
 102
 103 For an n+k pattern, we use the various magic expressions we've been given.
 104 We generate:
 105 \begin{verbatim}
 106     if ge var lit then
 107         let n = sub var lit
 108         in  <expr-for-a-successful-match>
 109     else
 110         <try-next-pattern-or-whatever>
 111 \end{verbatim}
 112
 113 \begin{code}
 114 matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPlusKPat master_n k ty from_lit ge sub):ps1) _ : eqns) shadows
 115   = let
 116         (shifted_eqns_for_this_lit, eqns_not_for_this_lit)
 117           = partitionEqnsByLit (Just master_n) k eqns_info
 118         (shifted_shadows_for_this_lit, shadows_not_for_this_lit)
 119           = partitionEqnsByLit (Just master_n) k shadows
 120     in
 121     match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit   `thenDs` \ inner_match_result ->
 122
 123     dsExpr from_lit                     `thenDs` \ core_lit ->
 124     dsExpr (App ge (Var var))           `thenDs` \ var_ge ->
 125     dsExpr (App sub (Var var))          `thenDs` \ var_sub ->
 126     mkCoAppDs var_ge  core_lit          `thenDs` \ var_ge_lit ->
 127     mkCoAppDs var_sub core_lit          `thenDs` \ var_sub_lit ->
 128
 129     mkGuardedMatchResult
 130         var_ge_lit
 131         (mkCoLetsMatchResult [CoNonRec master_n var_sub_lit] inner_match_result)
 132                                         `thenDs` \ match_result1 ->
 133
 134     if (null eqns_not_for_this_lit)
 135     then
 136         returnDs match_result1
 137     else
 138         matchLiterals all_vars eqns_not_for_this_lit shadows_not_for_this_lit   `thenDs` \ match_result2 ->
 139         combineMatchResults match_result1 match_result2
 140 \end{code}
 141
 142 Given a blob of LitPats/NPats/NPlusKPats, we want to split them into those
 143 that are ``same''/different as one we are looking at.  We need to know
 144 whether we're looking at a LitPat/NPat or NPlusKPat (initial Bool arg is
 145 @True@ for the latter), and what literal we're after.
 146
 147 \begin{code}
 148 partitionEqnsByLit :: Maybe Id  -- (Just v) for N-plus-K patterns, where v
 149                                 -- is the "master" variable;
 150                                 -- Nothing for NPats and LitPats
 151                    -> Literal
 152                    -> [EquationInfo]
 153                    -> ([EquationInfo],  -- These ones are for this lit, AND
 154                                         -- they've been "shifted" by stripping
 155                                         -- off the first pattern
 156                        [EquationInfo]   -- These are not for this lit; they
 157                                         -- are exactly as fed in.
 158                       )
 159
 160 partitionEqnsByLit want_NPlusK lit eqns
 161   = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys))
 162         (unzip (map (partition_eqn want_NPlusK lit) eqns))
 163   where
 164     partition_eqn :: Maybe Id -> Literal -> EquationInfo ->
 165                 (Maybe EquationInfo, Maybe EquationInfo)
 166
 167     partition_eqn Nothing lit (EqnInfo (LitPat k _ : remaining_pats) match_result)
 168       | lit `eq_lit` k  = (Just (EqnInfo remaining_pats match_result), Nothing)
 169                           -- NB the pattern is stripped off thhe EquationInfo
 170
 171     partition_eqn Nothing lit (EqnInfo (NPat k _ _ : remaining_pats) match_result)
 172       | lit `eq_lit` k  = (Just (EqnInfo remaining_pats match_result), Nothing)
 173                           -- NB the pattern is stripped off thhe EquationInfo
 174
 175     partition_eqn (Just master_n) lit  (EqnInfo (NPlusKPat n k _ _ _ _ : remaining_pats) match_result)
 176       | lit `eq_lit` k  = (Just (EqnInfo remaining_pats new_match_result), Nothing)
 177                           -- NB the pattern is stripped off thhe EquationInfo
 178       where
 179         new_match_result = if master_n `eqId` n then
 180                                 match_result
 181                            else
 182                                 mkCoLetsMatchResult [CoNonRec n (CoVar master_n)] match_result
 183
 184         -- Wild-card patterns, which will only show up in the shadows, go into both groups
 185     partition_eqn wantNPlusK lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result)
 186                         = (Just (EqnInfo remaining_pats match_result), Just eqn)
 187
 188         -- Default case; not for this pattern
 189     partition_eqn wantNPlusK lit eqn = (Nothing, Just eqn)
 190
 191 -- ToDo: meditate about this equality business...
 192
 193 eq_lit (IntLit  i1)       (IntLit  i2)       = i1 == i2
 194 eq_lit (FracLit f1)       (FracLit f2)       = f1 == f2
 195
 196 eq_lit (IntPrimLit i1)    (IntPrimLit i2)    = i1 == i2
 197 eq_lit (FloatPrimLit f1)  (FloatPrimLit f2)  = f1 == f2
 198 eq_lit (DoublePrimLit d1) (DoublePrimLit d2) = d1 == d2
 199 eq_lit (CharLit c1)       (CharLit c2)       = c1 == c2
 200 eq_lit (CharPrimLit c1)   (CharPrimLit c2)   = c1 == c2
 201 eq_lit (StringLit s1)     (StringLit s2)     = s1 == s2
 202 eq_lit (StringPrimLit s1) (StringPrimLit s2) = s1 == s2
 203 eq_lit (LitLitLit s1 _)   (LitLitLit s2 _)   = s1 == s2 -- ToDo: ??? (dubious)
 204 eq_lit other1             other2             = panic "matchLiterals:eq_lit"
 205 \end{code}