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