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