61db4080667b598cafbf65da9a205e0b79be2c2f
[ghc.git] / 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 {-# LANGUAGE CPP, ScopedTypeVariables #-}
10
11 module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey
12                 , tidyLitPat, tidyNPat
13                 , matchLiterals, matchNPlusKPats, matchNPats
14                 , warnAboutIdentities, warnAboutEmptyEnumerations
15                 ) where
16
17 #include "HsVersions.h"
18
19 import {-# SOURCE #-} Match  ( match )
20 import {-# SOURCE #-} DsExpr ( dsExpr )
21
22 import DsMonad
23 import DsUtils
24
25 import HsSyn
26
27 import Id
28 import CoreSyn
29 import MkCore
30 import TyCon
31 import DataCon
32 import TcHsSyn ( shortCutLit )
33 import TcType
34 import Name
35 import Type
36 import PrelNames
37 import TysWiredIn
38 import Literal
39 import SrcLoc
40 import Data.Ratio
41 import Outputable
42 import BasicTypes
43 import DynFlags
44 import Util
45 import FastString
46 import Control.Monad
47
48 import Data.Int
49 #if __GLASGOW_HASKELL__ < 709
50 import Data.Traversable (traverse)
51 #endif
52 import Data.Word
53 \end{code}
54
55 %************************************************************************
56 %*                                                                      *
57                 Desugaring literals
58         [used to be in DsExpr, but DsMeta needs it,
59          and it's nice to avoid a loop]
60 %*                                                                      *
61 %************************************************************************
62
63 We give int/float literals type @Integer@ and @Rational@, respectively.
64 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
65 around them.
66
67 ToDo: put in range checks for when converting ``@i@''
68 (or should that be in the typechecker?)
69
70 For numeric literals, we try to detect there use at a standard type
71 (@Int@, @Float@, etc.) are directly put in the right constructor.
72 [NB: down with the @App@ conversion.]
73
74 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
75
76 \begin{code}
77 dsLit :: HsLit -> DsM CoreExpr
78 dsLit (HsStringPrim s) = return (Lit (MachStr s))
79 dsLit (HsCharPrim   c) = return (Lit (MachChar c))
80 dsLit (HsIntPrim    i) = return (Lit (MachInt i))
81 dsLit (HsWordPrim   w) = return (Lit (MachWord w))
82 dsLit (HsInt64Prim  i) = return (Lit (MachInt64 i))
83 dsLit (HsWord64Prim w) = return (Lit (MachWord64 w))
84 dsLit (HsFloatPrim  f) = return (Lit (MachFloat (fl_value f)))
85 dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d)))
86
87 dsLit (HsChar c)       = return (mkCharExpr c)
88 dsLit (HsString str)   = mkStringExprFS str
89 dsLit (HsInteger i _)  = mkIntegerExpr i
90 dsLit (HsInt i)        = do dflags <- getDynFlags
91                             return (mkIntExpr dflags i)
92
93 dsLit (HsRat r ty) = do
94    num   <- mkIntegerExpr (numerator (fl_value r))
95    denom <- mkIntegerExpr (denominator (fl_value r))
96    return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
97   where
98     (ratio_data_con, integer_ty)
99         = case tcSplitTyConApp ty of
100                 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
101                                    (head (tyConDataCons tycon), i_ty)
102                 x -> pprPanic "dsLit" (ppr x)
103
104 dsOverLit :: HsOverLit Id -> DsM CoreExpr
105 dsOverLit lit = do { dflags <- getDynFlags
106                    ; warnAboutOverflowedLiterals dflags lit
107                    ; dsOverLit' dflags lit }
108
109 dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr
110 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
111 -- (an expression for) the literal value itself
112 dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
113                            , ol_witness = witness, ol_type = ty })
114   | not rebindable
115   , Just expr <- shortCutLit dflags val ty = dsExpr expr        -- Note [Literal short cut]
116   | otherwise                              = dsExpr witness
117 \end{code}
118
119 Note [Literal short cut]
120 ~~~~~~~~~~~~~~~~~~~~~~~~
121 The type checker tries to do this short-cutting as early as possible, but
122 because of unification etc, more information is available to the desugarer.
123 And where it's possible to generate the correct literal right away, it's
124 much better to do so.
125
126
127 %************************************************************************
128 %*                                                                      *
129                  Warnings about overflowed literals
130 %*                                                                      *
131 %************************************************************************
132
133 Warn about functions like toInteger, fromIntegral, that convert
134 between one type and another when the to- and from- types are the
135 same.  Then it's probably (albeit not definitely) the identity
136
137 \begin{code}
138 warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()
139 warnAboutIdentities dflags (Var conv_fn) type_of_conv
140   | wopt Opt_WarnIdentities dflags
141   , idName conv_fn `elem` conversionNames
142   , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
143   , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
144   = warnDs (vcat [ ptext (sLit "Call of") <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
145                  , nest 2 $ ptext (sLit "can probably be omitted")
146                  , parens (ptext (sLit "Use -fno-warn-identities to suppress this message"))
147            ])
148 warnAboutIdentities _ _ _ = return ()
149
150 conversionNames :: [Name]
151 conversionNames
152   = [ toIntegerName, toRationalName
153     , fromIntegralName, realToFracName ]
154  -- We can't easily add fromIntegerName, fromRationalName,
155  -- because they are generated by literals
156 \end{code}
157
158 \begin{code}
159 warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM ()
160 warnAboutOverflowedLiterals dflags lit
161  | wopt Opt_WarnOverflowedLiterals dflags
162  , Just (i, tc) <- getIntegralLit lit
163   = if      tc == intTyConName    then check i tc (undefined :: Int)
164     else if tc == int8TyConName   then check i tc (undefined :: Int8)
165     else if tc == int16TyConName  then check i tc (undefined :: Int16)
166     else if tc == int32TyConName  then check i tc (undefined :: Int32)
167     else if tc == int64TyConName  then check i tc (undefined :: Int64)
168     else if tc == wordTyConName   then check i tc (undefined :: Word)
169     else if tc == word8TyConName  then check i tc (undefined :: Word8)
170     else if tc == word16TyConName then check i tc (undefined :: Word16)
171     else if tc == word32TyConName then check i tc (undefined :: Word32)
172     else if tc == word64TyConName then check i tc (undefined :: Word64)
173     else return ()
174
175   | otherwise = return ()
176   where
177     check :: forall a. (Bounded a, Integral a) => Integer -> Name -> a -> DsM ()
178     check i tc _proxy
179       = when (i < minB || i > maxB) $ do
180         warnDs (vcat [ ptext (sLit "Literal") <+> integer i
181                        <+> ptext (sLit "is out of the") <+> ppr tc <+> ptext (sLit "range")
182                        <+> integer minB <> ptext (sLit "..") <> integer maxB
183                      , sug ])
184       where
185         minB = toInteger (minBound :: a)
186         maxB = toInteger (maxBound :: a)
187         sug | minB == -i   -- Note [Suggest NegativeLiterals]
188             , i > 0
189             , not (xopt Opt_NegativeLiterals dflags)
190             = ptext (sLit "If you are trying to write a large negative literal, use NegativeLiterals")
191             | otherwise = Outputable.empty
192 \end{code}
193
194 Note [Suggest NegativeLiterals]
195 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
196 If you write
197   x :: Int8
198   x = -128
199 it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.
200 We get an erroneous suggestion for
201   x = 128
202 but perhaps that does not matter too much.
203
204 \begin{code}
205 warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM ()
206 -- Warns about [2,3 .. 1] which returns the empty list
207 -- Only works for integral types, not floating point
208 warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
209   | wopt Opt_WarnEmptyEnumerations dflags
210   , Just (from,tc) <- getLHsIntegralLit fromExpr
211   , Just mThn      <- traverse getLHsIntegralLit mThnExpr
212   , Just (to,_)    <- getLHsIntegralLit toExpr
213   , let check :: forall a. (Enum a, Num a) => a -> DsM ()
214         check _proxy
215           = when (null enumeration) $
216             warnDs (ptext (sLit "Enumeration is empty"))
217           where
218             enumeration :: [a]
219             enumeration = case mThn of
220                             Nothing      -> [fromInteger from                    .. fromInteger to]
221                             Just (thn,_) -> [fromInteger from, fromInteger thn   .. fromInteger to]
222
223   = if      tc == intTyConName    then check (undefined :: Int)
224     else if tc == int8TyConName   then check (undefined :: Int8)
225     else if tc == int16TyConName  then check (undefined :: Int16)
226     else if tc == int32TyConName  then check (undefined :: Int32)
227     else if tc == int64TyConName  then check (undefined :: Int64)
228     else if tc == wordTyConName   then check (undefined :: Word)
229     else if tc == word8TyConName  then check (undefined :: Word8)
230     else if tc == word16TyConName then check (undefined :: Word16)
231     else if tc == word32TyConName then check (undefined :: Word32)
232     else if tc == word64TyConName then check (undefined :: Word64)
233     else return ()
234
235   | otherwise = return ()
236
237 getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name)
238 -- See if the expression is an Integral literal
239 -- Remember to look through automatically-added tick-boxes! (Trac #8384)
240 getLHsIntegralLit (L _ (HsPar e))            = getLHsIntegralLit e
241 getLHsIntegralLit (L _ (HsTick _ e))         = getLHsIntegralLit e
242 getLHsIntegralLit (L _ (HsBinTick _ _ e))    = getLHsIntegralLit e
243 getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
244 getLHsIntegralLit _ = Nothing
245
246 getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name)
247 getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })
248   | Just tc <- tyConAppTyCon_maybe ty
249   = Just (i, tyConName tc)
250 getIntegralLit _ = Nothing
251 \end{code}
252
253
254 %************************************************************************
255 %*                                                                      *
256         Tidying lit pats
257 %*                                                                      *
258 %************************************************************************
259
260 \begin{code}
261 tidyLitPat :: HsLit -> Pat Id
262 -- Result has only the following HsLits:
263 --      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
264 --      HsDoublePrim, HsStringPrim, HsString
265 --  * HsInteger, HsRat, HsInt can't show up in LitPats
266 --  * We get rid of HsChar right here
267 tidyLitPat (HsChar c) = unLoc (mkCharLitPat c)
268 tidyLitPat (HsString s)
269   | lengthFS s <= 1     -- Short string literals only
270   = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] [charTy])
271                   (mkNilPat charTy) (unpackFS s)
272         -- The stringTy is the type of the whole pattern, not
273         -- the type to instantiate (:) or [] with!
274 tidyLitPat lit = LitPat lit
275
276 ----------------
277 tidyNPat :: (HsLit -> Pat Id)   -- How to tidy a LitPat
278                  -- We need this argument because tidyNPat is called
279                  -- both by Match and by Check, but they tidy LitPats
280                  -- slightly differently; and we must desugar
281                  -- literals consistently (see Trac #5117)
282          -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
283          -> Pat Id
284 tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
285         -- False: Take short cuts only if the literal is not using rebindable syntax
286         --
287         -- Once that is settled, look for cases where the type of the
288         -- entire overloaded literal matches the type of the underlying literal,
289         -- and in that case take the short cut
290         -- NB: Watch out for weird cases like Trac #3382
291         --        f :: Int -> Int
292         --        f "blah" = 4
293         --     which might be ok if we hvae 'instance IsString Int'
294         --
295
296   | isIntTy ty,    Just int_lit <- mb_int_lit = mk_con_pat intDataCon    (HsIntPrim    int_lit)
297   | isWordTy ty,   Just int_lit <- mb_int_lit = mk_con_pat wordDataCon   (HsWordPrim   int_lit)
298   | isFloatTy ty,  Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon  (HsFloatPrim  rat_lit)
299   | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
300   | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
301   where
302     mk_con_pat :: DataCon -> HsLit -> Pat Id
303     mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
304
305     mb_int_lit :: Maybe Integer
306     mb_int_lit = case (mb_neg, val) of
307                    (Nothing, HsIntegral i) -> Just i
308                    (Just _,  HsIntegral i) -> Just (-i)
309                    _ -> Nothing
310
311     mb_rat_lit :: Maybe FractionalLit
312     mb_rat_lit = case (mb_neg, val) of
313                    (Nothing, HsIntegral   i) -> Just (integralFractionalLit (fromInteger i))
314                    (Just _,  HsIntegral   i) -> Just (integralFractionalLit (fromInteger (-i)))
315                    (Nothing, HsFractional f) -> Just f
316                    (Just _, HsFractional f)  -> Just (negateFractionalLit f)
317                    _ -> Nothing
318
319     mb_str_lit :: Maybe FastString
320     mb_str_lit = case (mb_neg, val) of
321                    (Nothing, HsIsString s) -> Just s
322                    _ -> Nothing
323
324 tidyNPat _ over_lit mb_neg eq
325   = NPat over_lit mb_neg eq
326 \end{code}
327
328
329 %************************************************************************
330 %*                                                                      *
331                 Pattern matching on LitPat
332 %*                                                                      *
333 %************************************************************************
334
335 \begin{code}
336 matchLiterals :: [Id]
337               -> Type                   -- Type of the whole case expression
338               -> [[EquationInfo]]       -- All PgLits
339               -> DsM MatchResult
340
341 matchLiterals (var:vars) ty sub_groups
342   = ASSERT( notNull sub_groups && all notNull sub_groups )
343     do  {       -- Deal with each group
344         ; alts <- mapM match_group sub_groups
345
346                 -- Combine results.  For everything except String
347                 -- we can use a case expression; for String we need
348                 -- a chain of if-then-else
349         ; if isStringTy (idType var) then
350             do  { eq_str <- dsLookupGlobalId eqStringName
351                 ; mrs <- mapM (wrap_str_guard eq_str) alts
352                 ; return (foldr1 combineMatchResults mrs) }
353           else
354             return (mkCoPrimCaseMatchResult var ty alts)
355         }
356   where
357     match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
358     match_group eqns
359         = do dflags <- getDynFlags
360              let LitPat hs_lit = firstPat (head eqns)
361              match_result <- match vars ty (shiftEqns eqns)
362              return (hsLitKey dflags hs_lit, match_result)
363
364     wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
365         -- Equality check for string literals
366     wrap_str_guard eq_str (MachStr s, mr)
367         = do { -- We now have to convert back to FastString. Perhaps there
368                -- should be separate MachBytes and MachStr constructors?
369                let s'  = mkFastStringByteString s
370              ; lit    <- mkStringExprFS s'
371              ; let pred = mkApps (Var eq_str) [Var var, lit]
372              ; return (mkGuardedMatchResult pred mr) }
373     wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
374
375 matchLiterals [] _ _ = panic "matchLiterals []"
376
377 ---------------------------
378 hsLitKey :: DynFlags -> HsLit -> Literal
379 -- Get a Core literal to use (only) a grouping key
380 -- Hence its type doesn't need to match the type of the original literal
381 --      (and doesn't for strings)
382 -- It only works for primitive types and strings;
383 -- others have been removed by tidy
384 hsLitKey dflags (HsIntPrim     i) = mkMachInt  dflags i
385 hsLitKey dflags (HsWordPrim    w) = mkMachWord dflags w
386 hsLitKey _      (HsInt64Prim   i) = mkMachInt64  i
387 hsLitKey _      (HsWord64Prim  w) = mkMachWord64 w
388 hsLitKey _      (HsCharPrim    c) = MachChar   c
389 hsLitKey _      (HsStringPrim  s) = MachStr    s
390 hsLitKey _      (HsFloatPrim   f) = MachFloat  (fl_value f)
391 hsLitKey _      (HsDoublePrim  d) = MachDouble (fl_value d)
392 hsLitKey _      (HsString s)      = MachStr    (fastStringToByteString s)
393 hsLitKey _      l                 = pprPanic "hsLitKey" (ppr l)
394
395 ---------------------------
396 hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
397 -- Ditto for HsOverLit; the boolean indicates to negate
398 hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
399
400 ---------------------------
401 litValKey :: OverLitVal -> Bool -> Literal
402 litValKey (HsIntegral i)   False = MachInt i
403 litValKey (HsIntegral i)   True  = MachInt (-i)
404 litValKey (HsFractional r) False = MachFloat (fl_value r)
405 litValKey (HsFractional r) True  = MachFloat (negate (fl_value r))
406 litValKey (HsIsString s)   neg   = ASSERT( not neg) MachStr (fastStringToByteString s)
407 \end{code}
408
409 %************************************************************************
410 %*                                                                      *
411                 Pattern matching on NPat
412 %*                                                                      *
413 %************************************************************************
414
415 \begin{code}
416 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
417 matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal
418   = do  { let NPat lit mb_neg eq_chk = firstPat eqn1
419         ; lit_expr <- dsOverLit lit
420         ; neg_lit <- case mb_neg of
421                             Nothing -> return lit_expr
422                             Just neg -> do { neg_expr <- dsExpr neg
423                                            ; return (App neg_expr lit_expr) }
424         ; eq_expr <- dsExpr eq_chk
425         ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
426         ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
427         ; return (mkGuardedMatchResult pred_expr match_result) }
428 matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
429 \end{code}
430
431
432 %************************************************************************
433 %*                                                                      *
434                 Pattern matching on n+k patterns
435 %*                                                                      *
436 %************************************************************************
437
438 For an n+k pattern, we use the various magic expressions we've been given.
439 We generate:
440 \begin{verbatim}
441     if ge var lit then
442         let n = sub var lit
443         in  <expr-for-a-successful-match>
444     else
445         <try-next-pattern-or-whatever>
446 \end{verbatim}
447
448
449 \begin{code}
450 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
451 -- All NPlusKPats, for the *same* literal k
452 matchNPlusKPats (var:vars) ty (eqn1:eqns)
453   = do  { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
454         ; ge_expr     <- dsExpr ge
455         ; minus_expr  <- dsExpr minus
456         ; lit_expr    <- dsOverLit lit
457         ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
458               minusk_expr = mkApps minus_expr [Var var, lit_expr]
459               (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
460         ; match_result <- match vars ty eqns'
461         ; return  (mkGuardedMatchResult pred_expr               $
462                    mkCoLetMatchResult (NonRec n1 minusk_expr)   $
463                    adjustMatchResult (foldr1 (.) wraps)         $
464                    match_result) }
465   where
466     shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
467         = (wrapBind n n1, eqn { eqn_pats = pats })
468         -- The wrapBind is a no-op for the first equation
469     shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
470
471 matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
472 \end{code}