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