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   = ASSERT( all notNull sub_groups )
 187     do  {       -- Deal with each group
 188         ; alts <- mapM match_group sub_groups
 189
 190                 -- Combine results.  For everything except String
 191                 -- we can use a case expression; for String we need
 192                 -- a chain of if-then-else
 193         ; if isStringTy (idType var) then
 194             do  { eq_str <- dsLookupGlobalId eqStringName
 195                 ; mrs <- mapM (wrap_str_guard eq_str) alts
 196                 ; return (foldr1 combineMatchResults mrs) }
 197           else
 198             return (mkCoPrimCaseMatchResult var ty alts)
 199         }
 200   where
 201     match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
 202     match_group eqns
 203         = do { let LitPat hs_lit = firstPat (head eqns)
 204              ; match_result <- match vars ty (shiftEqns eqns)
 205              ; return (hsLitKey hs_lit, match_result) }
 206
 207     wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
 208         -- Equality check for string literals
 209     wrap_str_guard eq_str (MachStr s, mr)
 210         = do { lit    <- mkStringExprFS s
 211              ; let pred = mkApps (Var eq_str) [Var var, lit]
 212              ; return (mkGuardedMatchResult pred mr) }
 213 \end{code}
 214
 215
 216 %************************************************************************
 217 %*                                                                      *
 218                 Pattern matching on NPat
 219 %*                                                                      *
 220 %************************************************************************
 221
 222 \begin{code}
 223 matchNPats :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
 224         -- All NPats, but perhaps for different literals
 225 matchNPats vars ty groups
 226   = do {  match_results <- mapM (matchOneNPat vars ty) groups
 227         ; return (foldr1 combineMatchResults match_results) }
 228
 229 matchOneNPat (var:vars) ty (eqn1:eqns)  -- All for the same literal
 230   = do  { let NPat lit mb_neg eq_chk _ = firstPat eqn1
 231         ; lit_expr <- dsOverLit lit
 232         ; neg_lit <- case mb_neg of
 233                             Nothing -> return lit_expr
 234                             Just neg -> do { neg_expr <- dsExpr neg
 235                                            ; return (App neg_expr lit_expr) }
 236         ; eq_expr <- dsExpr eq_chk
 237         ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
 238         ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
 239         ; return (mkGuardedMatchResult pred_expr match_result) }
 240 \end{code}
 241
 242
 243 %************************************************************************
 244 %*                                                                      *
 245                 Pattern matching on n+k patterns
 246 %*                                                                      *
 247 %************************************************************************
 248
 249 For an n+k pattern, we use the various magic expressions we've been given.
 250 We generate:
 251 \begin{verbatim}
 252     if ge var lit then
 253         let n = sub var lit
 254         in  <expr-for-a-successful-match>
 255     else
 256         <try-next-pattern-or-whatever>
 257 \end{verbatim}
 258
 259
 260 \begin{code}
 261 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 262         -- All NPlusKPats, for the *same* literal k
 263 matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns)
 264   = do  { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
 265         ; ge_expr     <- dsExpr ge
 266         ; minus_expr  <- dsExpr minus
 267         ; lit_expr    <- dsOverLit lit
 268         ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
 269               minusk_expr = mkApps minus_expr [Var var, lit_expr]
 270               (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
 271         ; match_result <- match vars ty eqns'
 272         ; return  (mkGuardedMatchResult pred_expr               $
 273                    mkCoLetMatchResult (NonRec n1 minusk_expr)   $
 274                    adjustMatchResult (foldr1 (.) wraps)         $
 275                    match_result) }
 276   where
 277     shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
 278         = (wrapBind n n1, eqn { eqn_pats = pats })
 279         -- The wrapBind is a no-op for the first equation
 280 \end{code}