compiler/deSugar/MatchLit.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Pattern-matching literal patterns
   7
   8 \begin{code}
   9 module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
  10                   tidyLitPat, tidyNPat,
  11                   matchLiterals, matchNPlusKPats, matchNPats ) where
  12
  13 #include "HsVersions.h"
  14
  15 import {-# SOURCE #-} Match  ( match )
  16 import {-# SOURCE #-} DsExpr ( dsExpr )
  17
  18 import DsMonad
  19 import DsUtils
  20
  21 import HsSyn
  22 import Id
  23 import CoreSyn
  24 import TyCon
  25 import DataCon
  26 import TcType
  27 import Type
  28 import PrelNames
  29 import TysWiredIn
  30 import PrelNames
  31 import Unique
  32 import Literal
  33 import SrcLoc
  34 import Ratio
  35 import SrcLoc
  36 import Outputable
  37 import Util
  38 import FastString
  39 \end{code}
  40
  41 %************************************************************************
  42 %*                                                                      *
  43                 Desugaring literals
  44         [used to be in DsExpr, but DsMeta needs it,
  45          and it's nice to avoid a loop]
  46 %*                                                                      *
  47 %************************************************************************
  48
  49 We give int/float literals type @Integer@ and @Rational@, respectively.
  50 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
  51 around them.
  52
  53 ToDo: put in range checks for when converting ``@i@''
  54 (or should that be in the typechecker?)
  55
  56 For numeric literals, we try to detect there use at a standard type
  57 (@Int@, @Float@, etc.) are directly put in the right constructor.
  58 [NB: down with the @App@ conversion.]
  59
  60 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
  61
  62 \begin{code}
  63 dsLit :: HsLit -> DsM CoreExpr
  64 dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s))
  65 dsLit (HsCharPrim c)   = returnDs (mkLit (MachChar c))
  66 dsLit (HsIntPrim i)    = returnDs (mkLit (MachInt i))
  67 dsLit (HsFloatPrim f)  = returnDs (mkLit (MachFloat f))
  68 dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
  69
  70 dsLit (HsChar c)       = returnDs (mkCharExpr c)
  71 dsLit (HsString str)   = mkStringExprFS str
  72 dsLit (HsInteger i _)  = mkIntegerExpr i
  73 dsLit (HsInt i)        = returnDs (mkIntExpr i)
  74
  75 dsLit (HsRat r ty)
  76   = mkIntegerExpr (numerator r)         `thenDs` \ num ->
  77     mkIntegerExpr (denominator r)       `thenDs` \ denom ->
  78     returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
  79   where
  80     (ratio_data_con, integer_ty)
  81         = case tcSplitTyConApp ty of
  82                 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
  83                                    (head (tyConDataCons tycon), i_ty)
  84
  85 dsOverLit :: HsOverLit Id -> DsM CoreExpr
  86 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
  87 -- (an expression for) the literal value itself
  88 dsOverLit (HsIntegral   _ lit) = dsExpr lit
  89 dsOverLit (HsFractional _ lit) = dsExpr lit
  90 \end{code}
  91
  92 \begin{code}
  93 hsLitKey :: HsLit -> Literal
  94 -- Get a Core literal to use (only) a grouping key
  95 -- Hence its type doesn't need to match the type of the original literal
  96 --      (and doesn't for strings)
  97 -- It only works for primitive types and strings;
  98 -- others have been removed by tidy
  99 hsLitKey (HsIntPrim     i) = mkMachInt  i
 100 hsLitKey (HsCharPrim    c) = MachChar   c
 101 hsLitKey (HsStringPrim  s) = MachStr    s
 102 hsLitKey (HsFloatPrim   f) = MachFloat  f
 103 hsLitKey (HsDoublePrim  d) = MachDouble d
 104 hsLitKey (HsString s)      = MachStr    s
 105
 106 hsOverLitKey :: HsOverLit a -> Bool -> Literal
 107 -- Ditto for HsOverLit; the boolean indicates to negate
 108 hsOverLitKey (HsIntegral i _) False   = MachInt i
 109 hsOverLitKey (HsIntegral i _) True    = MachInt (-i)
 110 hsOverLitKey (HsFractional r _) False = MachFloat r
 111 hsOverLitKey (HsFractional r _) True  = MachFloat (-r)
 112 \end{code}
 113
 114 %************************************************************************
 115 %*                                                                      *
 116         Tidying lit pats
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 \begin{code}
 121 tidyLitPat :: HsLit -> Pat Id
 122 -- Result has only the following HsLits:
 123 --      HsIntPrim, HsCharPrim, HsFloatPrim
 124 --      HsDoublePrim, HsStringPrim, HsString
 125 --  * HsInteger, HsRat, HsInt can't show up in LitPats
 126 --  * We get rid of HsChar right here
 127 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
 128 tidyLitPat (HsString s)
 129   | lengthFS s <= 1     -- Short string literals only
 130   = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
 131                   (mkNilPat stringTy) (unpackFS s)
 132         -- The stringTy is the type of the whole pattern, not
 133         -- the type to instantiate (:) or [] with!
 134 tidyLitPat lit = LitPat lit
 135
 136 ----------------
 137 tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
 138          -> Type -> Pat Id
 139 tidyNPat over_lit mb_neg eq lit_ty
 140   | isIntTy    lit_ty = mk_con_pat intDataCon    (HsIntPrim int_val)
 141   | isFloatTy  lit_ty = mk_con_pat floatDataCon  (HsFloatPrim  rat_val)
 142   | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
 143   | otherwise         = NPat over_lit mb_neg eq lit_ty
 144   where
 145     mk_con_pat :: DataCon -> HsLit -> Pat Id
 146     mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] lit_ty)
 147     neg_lit = case (mb_neg, over_lit) of
 148                 (Nothing,              _)   -> over_lit
 149                 (Just _,  HsIntegral i s)   -> HsIntegral   (-i) s
 150                 (Just _,  HsFractional f s) -> HsFractional (-f) s
 151
 152     int_val :: Integer
 153     int_val = case neg_lit of
 154                 HsIntegral   i _ -> i
 155                 HsFractional f _ -> panic "tidyNPat"
 156
 157     rat_val :: Rational
 158     rat_val = case neg_lit of
 159                 HsIntegral   i _ -> fromInteger i
 160                 HsFractional f _ -> f
 161 \end{code}
 162
 163
 164 %************************************************************************
 165 %*                                                                      *
 166                 Pattern matching on LitPat
 167 %*                                                                      *
 168 %************************************************************************
 169
 170 \begin{code}
 171 matchLiterals :: [Id]
 172               -> Type                   -- Type of the whole case expression
 173               -> [[EquationInfo]]       -- All PgLits
 174               -> DsM MatchResult
 175
 176 matchLiterals (var:vars) ty sub_groups
 177   = do  {       -- Deal with each group
 178         ; alts <- mapM match_group sub_groups
 179
 180                 -- Combine results.  For everything except String
 181                 -- we can use a case expression; for String we need
 182                 -- a chain of if-then-else
 183         ; if isStringTy (idType var) then
 184             do  { eq_str <- dsLookupGlobalId eqStringName
 185                 ; mrs <- mapM (wrap_str_guard eq_str) alts
 186                 ; return (foldr1 combineMatchResults mrs) }
 187           else
 188             return (mkCoPrimCaseMatchResult var ty alts)
 189         }
 190   where
 191     match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
 192     match_group eqns
 193         = do { let LitPat hs_lit = firstPat (head eqns)
 194              ; match_result <- match vars ty (shiftEqns eqns)
 195              ; return (hsLitKey hs_lit, match_result) }
 196
 197     wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
 198         -- Equality check for string literals
 199     wrap_str_guard eq_str (MachStr s, mr)
 200         = do { lit    <- mkStringExprFS s
 201              ; let pred = mkApps (Var eq_str) [Var var, lit]
 202              ; return (mkGuardedMatchResult pred mr) }
 203 \end{code}
 204
 205
 206 %************************************************************************
 207 %*                                                                      *
 208                 Pattern matching on NPat
 209 %*                                                                      *
 210 %************************************************************************
 211
 212 \begin{code}
 213 matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
 214         -- All NPats, but perhaps for different literals
 215 matchNPats vars ty groups
 216   = do {  match_results <- mapM (matchOneNPat vars ty) groups
 217         ; return (foldr1 combineMatchResults match_results) }
 218
 219 matchOneNPat (var:vars) ty (eqn1:eqns)  -- All for the same literal
 220   = do  { let NPat lit mb_neg eq_chk _ = firstPat eqn1
 221         ; lit_expr <- dsOverLit lit
 222         ; neg_lit <- case mb_neg of
 223                             Nothing -> return lit_expr
 224                             Just neg -> do { neg_expr <- dsExpr neg
 225                                            ; return (App neg_expr lit_expr) }
 226         ; eq_expr <- dsExpr eq_chk
 227         ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
 228         ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
 229         ; return (mkGuardedMatchResult pred_expr match_result) }
 230 \end{code}
 231
 232
 233 %************************************************************************
 234 %*                                                                      *
 235                 Pattern matching on n+k patterns
 236 %*                                                                      *
 237 %************************************************************************
 238
 239 For an n+k pattern, we use the various magic expressions we've been given.
 240 We generate:
 241 \begin{verbatim}
 242     if ge var lit then
 243         let n = sub var lit
 244         in  <expr-for-a-successful-match>
 245     else
 246         <try-next-pattern-or-whatever>
 247 \end{verbatim}
 248
 249
 250 \begin{code}
 251 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 252         -- All NPlusKPats, for the *same* literal k
 253 matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns)
 254   = do  { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
 255         ; ge_expr     <- dsExpr ge
 256         ; minus_expr  <- dsExpr minus
 257         ; lit_expr    <- dsOverLit lit
 258         ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
 259               minusk_expr = mkApps minus_expr [Var var, lit_expr]
 260               (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
 261         ; match_result <- match vars ty eqns'
 262         ; return  (mkGuardedMatchResult pred_expr               $
 263                    mkCoLetMatchResult (NonRec n1 minusk_expr)   $
 264                    adjustMatchResult (foldr1 (.) wraps)         $
 265                    match_result) }
 266   where
 267     shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
 268         = (wrapBind n n1, eqn { eqn_pats = pats })
 269         -- The wrapBind is a no-op for the first equation
 270 \end{code}