Capture original source for literals
[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 src c) = unLoc (mkCharLitPat src c)
268 tidyLitPat (HsString src s)
269   | lengthFS s <= 1     -- Short string literals only
270   = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
271                                              [mkCharLitPat src c, pat] [charTy])
272                   (mkNilPat charTy) (unpackFS s)
273         -- The stringTy is the type of the whole pattern, not
274         -- the type to instantiate (:) or [] with!
275 tidyLitPat lit = LitPat lit
276
277 ----------------
278 tidyNPat :: (HsLit -> Pat Id)   -- How to tidy a LitPat
279                  -- We need this argument because tidyNPat is called
280                  -- both by Match and by Check, but they tidy LitPats
281                  -- slightly differently; and we must desugar
282                  -- literals consistently (see Trac #5117)
283          -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
284          -> Pat Id
285 tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
286         -- False: Take short cuts only if the literal is not using rebindable syntax
287         --
288         -- Once that is settled, look for cases where the type of the
289         -- entire overloaded literal matches the type of the underlying literal,
290         -- and in that case take the short cut
291         -- NB: Watch out for weird cases like Trac #3382
292         --        f :: Int -> Int
293         --        f "blah" = 4
294         --     which might be ok if we hvae 'instance IsString Int'
295         --
296
297   | isIntTy ty,    Just int_lit <- mb_int_lit
298                             = mk_con_pat intDataCon    (HsIntPrim    "" int_lit)
299   | isWordTy ty,   Just int_lit <- mb_int_lit
300                             = mk_con_pat wordDataCon   (HsWordPrim   "" int_lit)
301   | isFloatTy ty,  Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon  (HsFloatPrim  rat_lit)
302   | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
303   | isStringTy ty, Just str_lit <- mb_str_lit
304                             = tidy_lit_pat (HsString "" str_lit)
305   where
306     mk_con_pat :: DataCon -> HsLit -> Pat Id
307     mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
308
309     mb_int_lit :: Maybe Integer
310     mb_int_lit = case (mb_neg, val) of
311                    (Nothing, HsIntegral _ i) -> Just i
312                    (Just _,  HsIntegral _ i) -> Just (-i)
313                    _ -> Nothing
314
315     mb_rat_lit :: Maybe FractionalLit
316     mb_rat_lit = case (mb_neg, val) of
317        (Nothing, HsIntegral _ i) -> Just (integralFractionalLit (fromInteger i))
318        (Just _,  HsIntegral _ i) -> Just (integralFractionalLit
319                                                              (fromInteger (-i)))
320        (Nothing, HsFractional f) -> Just f
321        (Just _, HsFractional f)  -> Just (negateFractionalLit f)
322        _ -> Nothing
323
324     mb_str_lit :: Maybe FastString
325     mb_str_lit = case (mb_neg, val) of
326                    (Nothing, HsIsString _ s) -> Just s
327                    _ -> Nothing
328
329 tidyNPat _ over_lit mb_neg eq
330   = NPat over_lit mb_neg eq
331 \end{code}
332
333
334 %************************************************************************
335 %*                                                                      *
336                 Pattern matching on LitPat
337 %*                                                                      *
338 %************************************************************************
339
340 \begin{code}
341 matchLiterals :: [Id]
342               -> Type                   -- Type of the whole case expression
343               -> [[EquationInfo]]       -- All PgLits
344               -> DsM MatchResult
345
346 matchLiterals (var:vars) ty sub_groups
347   = ASSERT( notNull sub_groups && all notNull sub_groups )
348     do  {       -- Deal with each group
349         ; alts <- mapM match_group sub_groups
350
351                 -- Combine results.  For everything except String
352                 -- we can use a case expression; for String we need
353                 -- a chain of if-then-else
354         ; if isStringTy (idType var) then
355             do  { eq_str <- dsLookupGlobalId eqStringName
356                 ; mrs <- mapM (wrap_str_guard eq_str) alts
357                 ; return (foldr1 combineMatchResults mrs) }
358           else
359             return (mkCoPrimCaseMatchResult var ty alts)
360         }
361   where
362     match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
363     match_group eqns
364         = do dflags <- getDynFlags
365              let LitPat hs_lit = firstPat (head eqns)
366              match_result <- match vars ty (shiftEqns eqns)
367              return (hsLitKey dflags hs_lit, match_result)
368
369     wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
370         -- Equality check for string literals
371     wrap_str_guard eq_str (MachStr s, mr)
372         = do { -- We now have to convert back to FastString. Perhaps there
373                -- should be separate MachBytes and MachStr constructors?
374                let s'  = mkFastStringByteString s
375              ; lit    <- mkStringExprFS s'
376              ; let pred = mkApps (Var eq_str) [Var var, lit]
377              ; return (mkGuardedMatchResult pred mr) }
378     wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
379
380 matchLiterals [] _ _ = panic "matchLiterals []"
381
382 ---------------------------
383 hsLitKey :: DynFlags -> HsLit -> Literal
384 -- Get a Core literal to use (only) a grouping key
385 -- Hence its type doesn't need to match the type of the original literal
386 --      (and doesn't for strings)
387 -- It only works for primitive types and strings;
388 -- others have been removed by tidy
389 hsLitKey dflags (HsIntPrim    _ i) = mkMachInt  dflags i
390 hsLitKey dflags (HsWordPrim   _ w) = mkMachWord dflags w
391 hsLitKey _      (HsInt64Prim  _ i) = mkMachInt64  i
392 hsLitKey _      (HsWord64Prim _ w) = mkMachWord64 w
393 hsLitKey _      (HsCharPrim   _ c) = MachChar   c
394 hsLitKey _      (HsStringPrim _ s) = MachStr    s
395 hsLitKey _      (HsFloatPrim    f) = MachFloat  (fl_value f)
396 hsLitKey _      (HsDoublePrim   d) = MachDouble (fl_value d)
397 hsLitKey _      (HsString _ s)     = MachStr    (fastStringToByteString s)
398 hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)
399
400 ---------------------------
401 hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
402 -- Ditto for HsOverLit; the boolean indicates to negate
403 hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
404
405 ---------------------------
406 litValKey :: OverLitVal -> Bool -> Literal
407 litValKey (HsIntegral _ i) False = MachInt i
408 litValKey (HsIntegral _ i) True  = MachInt (-i)
409 litValKey (HsFractional r) False = MachFloat (fl_value r)
410 litValKey (HsFractional r) True  = MachFloat (negate (fl_value r))
411 litValKey (HsIsString _ s) neg   = ASSERT( not neg) MachStr
412                                                       (fastStringToByteString s)
413 \end{code}
414
415 %************************************************************************
416 %*                                                                      *
417                 Pattern matching on NPat
418 %*                                                                      *
419 %************************************************************************
420
421 \begin{code}
422 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
423 matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal
424   = do  { let NPat lit mb_neg eq_chk = firstPat eqn1
425         ; lit_expr <- dsOverLit lit
426         ; neg_lit <- case mb_neg of
427                             Nothing -> return lit_expr
428                             Just neg -> do { neg_expr <- dsExpr neg
429                                            ; return (App neg_expr lit_expr) }
430         ; eq_expr <- dsExpr eq_chk
431         ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
432         ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
433         ; return (mkGuardedMatchResult pred_expr match_result) }
434 matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
435 \end{code}
436
437
438 %************************************************************************
439 %*                                                                      *
440                 Pattern matching on n+k patterns
441 %*                                                                      *
442 %************************************************************************
443
444 For an n+k pattern, we use the various magic expressions we've been given.
445 We generate:
446 \begin{verbatim}
447     if ge var lit then
448         let n = sub var lit
449         in  <expr-for-a-successful-match>
450     else
451         <try-next-pattern-or-whatever>
452 \end{verbatim}
453
454
455 \begin{code}
456 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
457 -- All NPlusKPats, for the *same* literal k
458 matchNPlusKPats (var:vars) ty (eqn1:eqns)
459   = do  { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1
460         ; ge_expr     <- dsExpr ge
461         ; minus_expr  <- dsExpr minus
462         ; lit_expr    <- dsOverLit lit
463         ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
464               minusk_expr = mkApps minus_expr [Var var, lit_expr]
465               (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
466         ; match_result <- match vars ty eqns'
467         ; return  (mkGuardedMatchResult pred_expr               $
468                    mkCoLetMatchResult (NonRec n1 minusk_expr)   $
469                    adjustMatchResult (foldr1 (.) wraps)         $
470                    match_result) }
471   where
472     shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
473         = (wrapBind n n1, eqn { eqn_pats = pats })
474         -- The wrapBind is a no-op for the first equation
475     shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
476
477 matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
478 \end{code}