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 dsOverLit (HsIsString   _ lit) = dsExpr lit
  91 \end{code}
  92
  93 \begin{code}
  94 hsLitKey :: HsLit -> Literal
  95 -- Get a Core literal to use (only) a grouping key
  96 -- Hence its type doesn't need to match the type of the original literal
  97 --      (and doesn't for strings)
  98 -- It only works for primitive types and strings;
  99 -- others have been removed by tidy
 100 hsLitKey (HsIntPrim     i) = mkMachInt  i
 101 hsLitKey (HsCharPrim    c) = MachChar   c
 102 hsLitKey (HsStringPrim  s) = MachStr    s
 103 hsLitKey (HsFloatPrim   f) = MachFloat  f
 104 hsLitKey (HsDoublePrim  d) = MachDouble d
 105 hsLitKey (HsString s)      = MachStr    s
 106
 107 hsOverLitKey :: HsOverLit a -> Bool -> Literal
 108 -- Ditto for HsOverLit; the boolean indicates to negate
 109 hsOverLitKey (HsIntegral i _) False   = MachInt i
 110 hsOverLitKey (HsIntegral i _) True    = MachInt (-i)
 111 hsOverLitKey (HsFractional r _) False = MachFloat r
 112 hsOverLitKey (HsFractional r _) True  = MachFloat (-r)
 113 hsOverLitKey (HsIsString s _)  False  = MachStr s
 114 -- negated string should never happen
 115 \end{code}
 116
 117 %************************************************************************
 118 %*                                                                      *
 119         Tidying lit pats
 120 %*                                                                      *
 121 %************************************************************************
 122
 123 \begin{code}
 124 tidyLitPat :: HsLit -> Pat Id
 125 -- Result has only the following HsLits:
 126 --      HsIntPrim, HsCharPrim, HsFloatPrim
 127 --      HsDoublePrim, HsStringPrim, HsString
 128 --  * HsInteger, HsRat, HsInt can't show up in LitPats
 129 --  * We get rid of HsChar right here
 130 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
 131 tidyLitPat (HsString s)
 132   | lengthFS s <= 1     -- Short string literals only
 133   = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
 134                   (mkNilPat stringTy) (unpackFS s)
 135         -- The stringTy is the type of the whole pattern, not
 136         -- the type to instantiate (:) or [] with!
 137 tidyLitPat lit = LitPat lit
 138
 139 ----------------
 140 tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
 141          -> Type -> Pat Id
 142 tidyNPat over_lit mb_neg eq lit_ty
 143   | isIntTy    lit_ty = mk_con_pat intDataCon    (HsIntPrim int_val)
 144   | isFloatTy  lit_ty = mk_con_pat floatDataCon  (HsFloatPrim  rat_val)
 145   | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
 146 --  | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
 147   | otherwise         = NPat over_lit mb_neg eq lit_ty
 148   where
 149     mk_con_pat :: DataCon -> HsLit -> Pat Id
 150     mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] lit_ty)
 151     neg_lit = case (mb_neg, over_lit) of
 152                 (Nothing,              _)   -> over_lit
 153                 (Just _,  HsIntegral i s)   -> HsIntegral   (-i) s
 154                 (Just _,  HsFractional f s) -> HsFractional (-f) s
 155
 156     int_val :: Integer
 157     int_val = case neg_lit of
 158                 HsIntegral   i _ -> i
 159                 HsFractional f _ -> panic "tidyNPat"
 160
 161     rat_val :: Rational
 162     rat_val = case neg_lit of
 163                 HsIntegral   i _ -> fromInteger i
 164                 HsFractional f _ -> f
 165
 166     str_val :: FastString
 167     str_val = case neg_lit of
 168                 HsIsString   s _ -> s
 169                 _                -> error "tidyNPat"
 170 \end{code}
 171
 172
 173 %************************************************************************
 174 %*                                                                      *
 175                 Pattern matching on LitPat
 176 %*                                                                      *
 177 %************************************************************************
 178
 179 \begin{code}
 180 matchLiterals :: [Id]
 181               -> Type                   -- Type of the whole case expression
 182               -> [[EquationInfo]]       -- All PgLits
 183               -> DsM MatchResult
 184
 185 matchLiterals (var:vars) ty sub_groups
 186   = do  {       -- Deal with each group
 187         ; alts <- mapM match_group sub_groups
 188
 189                 -- Combine results.  For everything except String
 190                 -- we can use a case expression; for String we need
 191                 -- a chain of if-then-else
 192         ; if isStringTy (idType var) then
 193             do  { eq_str <- dsLookupGlobalId eqStringName
 194                 ; mrs <- mapM (wrap_str_guard eq_str) alts
 195                 ; return (foldr1 combineMatchResults mrs) }
 196           else
 197             return (mkCoPrimCaseMatchResult var ty alts)
 198         }
 199   where
 200     match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
 201     match_group eqns
 202         = do { let LitPat hs_lit = firstPat (head eqns)
 203              ; match_result <- match vars ty (shiftEqns eqns)
 204              ; return (hsLitKey hs_lit, match_result) }
 205
 206     wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
 207         -- Equality check for string literals
 208     wrap_str_guard eq_str (MachStr s, mr)
 209         = do { lit    <- mkStringExprFS s
 210              ; let pred = mkApps (Var eq_str) [Var var, lit]
 211              ; return (mkGuardedMatchResult pred mr) }
 212 \end{code}
 213
 214
 215 %************************************************************************
 216 %*                                                                      *
 217                 Pattern matching on NPat
 218 %*                                                                      *
 219 %************************************************************************
 220
 221 \begin{code}
 222 matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
 223         -- All NPats, but perhaps for different literals
 224 matchNPats vars ty groups
 225   = do {  match_results <- mapM (matchOneNPat vars ty) groups
 226         ; return (foldr1 combineMatchResults match_results) }
 227
 228 matchOneNPat (var:vars) ty (eqn1:eqns)  -- All for the same literal
 229   = do  { let NPat lit mb_neg eq_chk _ = firstPat eqn1
 230         ; lit_expr <- dsOverLit lit
 231         ; neg_lit <- case mb_neg of
 232                             Nothing -> return lit_expr
 233                             Just neg -> do { neg_expr <- dsExpr neg
 234                                            ; return (App neg_expr lit_expr) }
 235         ; eq_expr <- dsExpr eq_chk
 236         ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
 237         ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
 238         ; return (mkGuardedMatchResult pred_expr match_result) }
 239 \end{code}
 240
 241
 242 %************************************************************************
 243 %*                                                                      *
 244                 Pattern matching on n+k patterns
 245 %*                                                                      *
 246 %************************************************************************
 247
 248 For an n+k pattern, we use the various magic expressions we've been given.
 249 We generate:
 250 \begin{verbatim}
 251     if ge var lit then
 252         let n = sub var lit
 253         in  <expr-for-a-successful-match>
 254     else
 255         <try-next-pattern-or-whatever>
 256 \end{verbatim}
 257
 258
 259 \begin{code}
 260 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 261         -- All NPlusKPats, for the *same* literal k
 262 matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns)
 263   = do  { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
 264         ; ge_expr     <- dsExpr ge
 265         ; minus_expr  <- dsExpr minus
 266         ; lit_expr    <- dsOverLit lit
 267         ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
 268               minusk_expr = mkApps minus_expr [Var var, lit_expr]
 269               (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
 270         ; match_result <- match vars ty eqns'
 271         ; return  (mkGuardedMatchResult pred_expr               $
 272                    mkCoLetMatchResult (NonRec n1 minusk_expr)   $
 273                    adjustMatchResult (foldr1 (.) wraps)         $
 274                    match_result) }
 275   where
 276     shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
 277         = (wrapBind n n1, eqn { eqn_pats = pats })
 278         -- The wrapBind is a no-op for the first equation
 279 \end{code}