never executed always true always false
1
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# LANGUAGE MultiWayIf #-}
4 {-# LANGUAGE TypeApplications #-}
5 {-# LANGUAGE AllowAmbiguousTypes #-}
6
7 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
8
9 {-
10 (c) The University of Glasgow 2006
11 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
12
13
14 Pattern-matching literal patterns
15 -}
16
17 module GHC.HsToCore.Match.Literal
18 ( dsLit, dsOverLit, hsLitKey
19 , tidyLitPat, tidyNPat
20 , matchLiterals, matchNPlusKPats, matchNPats
21 , warnAboutIdentities
22 , warnAboutOverflowedOverLit, warnAboutOverflowedLit
23 , warnAboutEmptyEnumerations
24 )
25 where
26
27 import GHC.Prelude
28 import GHC.Platform
29
30 import {-# SOURCE #-} GHC.HsToCore.Match ( match )
31 import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsSyntaxExpr )
32
33 import GHC.HsToCore.Errors.Types
34 import GHC.HsToCore.Monad
35 import GHC.HsToCore.Utils
36
37 import GHC.Hs
38
39 import GHC.Types.Id
40 import GHC.Types.SourceText
41 import GHC.Core
42 import GHC.Core.Make
43 import GHC.Core.TyCon
44 import GHC.Core.Reduction ( Reduction(..) )
45 import GHC.Core.DataCon
46 import GHC.Tc.Utils.Zonk ( shortCutLit )
47 import GHC.Tc.Utils.TcType
48 import GHC.Types.Name
49 import GHC.Core.Type
50 import GHC.Builtin.Names
51 import GHC.Builtin.Types
52 import GHC.Builtin.Types.Prim
53 import GHC.Types.Literal
54 import GHC.Types.SrcLoc
55 import GHC.Utils.Outputable as Outputable
56 import GHC.Driver.Session
57 import GHC.Utils.Misc
58 import GHC.Utils.Panic
59 import GHC.Utils.Panic.Plain
60 import GHC.Data.FastString
61 import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )
62
63 import Control.Monad
64 import Data.Int
65 import Data.List.NonEmpty (NonEmpty(..))
66 import qualified Data.List.NonEmpty as NEL
67 import Data.Word
68 import GHC.Real ( Ratio(..), numerator, denominator )
69
70 {-
71 ************************************************************************
72 * *
73 Desugaring literals
74 [used to be in GHC.HsToCore.Expr, but GHC.HsToCore.Quote needs it,
75 and it's nice to avoid a loop]
76 * *
77 ************************************************************************
78
79 We give int/float literals type @Integer@ and @Rational@, respectively.
80 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
81 around them.
82
83 ToDo: put in range checks for when converting ``@i@''
84 (or should that be in the typechecker?)
85
86 For numeric literals, we try to detect there use at a standard type
87 (@Int@, @Float@, etc.) are directly put in the right constructor.
88 [NB: down with the @App@ conversion.]
89
90 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
91 -}
92
93 dsLit :: HsLit GhcRn -> DsM CoreExpr
94 dsLit l = do
95 dflags <- getDynFlags
96 let platform = targetPlatform dflags
97 case l of
98 HsStringPrim _ s -> return (Lit (LitString s))
99 HsCharPrim _ c -> return (Lit (LitChar c))
100 HsIntPrim _ i -> return (Lit (mkLitIntWrap platform i))
101 HsWordPrim _ w -> return (Lit (mkLitWordWrap platform w))
102 HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap i))
103 HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap w))
104
105 -- This can be slow for very large literals. See Note [FractionalLit representation]
106 -- and #15646
107 HsFloatPrim _ fl -> return (Lit (LitFloat (rationalFromFractionalLit fl)))
108 HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl)))
109 HsChar _ c -> return (mkCharExpr c)
110 HsString _ str -> mkStringExprFS str
111 HsInteger _ i _ -> return (mkIntegerExpr platform i)
112 HsInt _ i -> return (mkIntExpr platform (il_value i))
113 HsRat _ fl ty -> dsFractionalLitToRational fl ty
114
115 {-
116 Note [FractionalLit representation]
117 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
118 There is a fun wrinkle to this, we used to simply compute the value
119 for these literals and store it as `Rational`. While this might seem
120 reasonable it meant typechecking literals of extremely large numbers
121 wasn't possible. This happend for example in #15646.
122
123 There a user would write in GHCi e.g. `:t 1e1234111111111111111111111`
124 which would trip up the compiler. The reason being we would parse it as
125 <Literal of value n>. Try to compute n, which would run out of memory
126 for truly large numbers, or take far too long for merely large ones.
127
128 To fix this we instead now store the significand and exponent of the
129 literal instead. Depending on the size of the exponent we then defer
130 the computation of the Rational value, potentially up to runtime of the
131 program! There are still cases left were we might compute large rationals
132 but it's a lot rarer then.
133
134 The current state of affairs for large literals is:
135 * Typechecking: Will produce a FractionalLit
136 * Desugaring a large overloaded literal to Float/Double *is* done
137 at compile time. So can still fail. But this only matters for values too large
138 to be represented as float anyway.
139 * Converting overloaded literals to a value of *Rational* is done at *runtime*.
140 If such a value is then demanded at runtime the program might hang or run out of
141 memory. But that is perhaps expected and acceptable.
142 * TH might also evaluate the literal even when overloaded.
143 But there a user should be able to work around #15646 by
144 generating a call to `mkRationalBase10/2` for large literals instead.
145
146
147 Note [FractionalLit representation]
148 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
149 For fractional literals, like 1.3 or 0.79e22, we do /not/ represent
150 them within the compiler as a Rational. Doing so would force the
151 compiler to compute a huge Rational for 2.3e300000000000, at compile
152 time (#15646)!
153
154 So instead we represent fractional literals as a FractionalLit,
155 in which we record the significand and exponent separately. Then
156 we can compute the huge Rational at /runtime/, by emitting code
157 for
158 mkRationalBase10 2.3 300000000000
159
160 where mkRationalBase10 is defined in the library GHC.Real
161
162 The moving parts are here:
163
164 * Parsing, renaming, typechecking: use FractionalLit, in which the
165 significand and exponent are represented separately.
166
167 * Desugaring. Remember that a fractional literal like 54.4e20 has type
168 Fractional a => a
169
170 - For fractional literals whose type turns out to be Float/Double,
171 we desugar to a Float/Double literal at /compile time/.
172 This conversion can still fail. But this only matters for values
173 too large to be represented as float anyway. See dsLit in
174 GHC.HsToCore.Match.Literal
175
176 - For fractional literals whose type turns out to be Rational, we
177 desugar the literal to a call of `mkRationalBase10` (etc for hex
178 literals), so that we only compute the Rational at /run time/. If
179 this value is then demanded at runtime the program might hang or
180 run out of memory. But that is perhaps expected and acceptable.
181 See dsFractionalLitToRational in GHC.HsToCore.Match.Literal
182
183 - For fractional literals whose type isn't one of the above, we just
184 call the typeclass method `fromRational`. But to do that we need
185 the rational to give to it, and we compute that at runtime, as
186 above.
187
188 * Template Haskell definitions are also problematic. While the TH code
189 works as expected once it's spliced into a program it will compute the
190 value of the large literal.
191 But there a user should be able to work around #15646
192 by having their TH code generating a call to `mkRationalBase[10/2]` for
193 large literals instead.
194
195 -}
196
197 -- | See Note [FractionalLit representation]
198 dsFractionalLitToRational :: FractionalLit -> Type -> DsM CoreExpr
199 dsFractionalLitToRational fl@FL{ fl_signi = signi, fl_exp = exp, fl_exp_base = base } ty
200 -- We compute "small" rationals here and now
201 | abs exp <= 100
202 = do
203 platform <- targetPlatform <$> getDynFlags
204 let !val = rationalFromFractionalLit fl
205 !num = mkIntegerExpr platform (numerator val)
206 !denom = mkIntegerExpr platform (denominator val)
207 (ratio_data_con, integer_ty)
208 = case tcSplitTyConApp ty of
209 (tycon, [i_ty]) -> assert (isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
210 (head (tyConDataCons tycon), i_ty)
211 x -> pprPanic "dsLit" (ppr x)
212 return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
213 -- Large rationals will be computed at runtime.
214 | otherwise
215 = do
216 let mkRationalName = case base of
217 Base2 -> mkRationalBase2Name
218 Base10 -> mkRationalBase10Name
219 mkRational <- dsLookupGlobalId mkRationalName
220 litR <- dsRational signi
221 platform <- targetPlatform <$> getDynFlags
222 let litE = mkIntegerExpr platform exp
223 return (mkCoreApps (Var mkRational) [litR, litE])
224
225 dsRational :: Rational -> DsM CoreExpr
226 dsRational (n :% d) = do
227 platform <- targetPlatform <$> getDynFlags
228 dcn <- dsLookupDataCon ratioDataConName
229 let cn = mkIntegerExpr platform n
230 let dn = mkIntegerExpr platform d
231 return $ mkCoreConApps dcn [Type integerTy, cn, dn]
232
233
234 dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
235 -- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains
236 -- (an expression for) the literal value itself.
237 dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable witness ty }) = do
238 dflags <- getDynFlags
239 let platform = targetPlatform dflags
240 case shortCutLit platform val ty of
241 Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut]
242 _ -> dsExpr witness
243
244 {-
245 Note [Literal short cut]
246 ~~~~~~~~~~~~~~~~~~~~~~~~
247 The type checker tries to do this short-cutting as early as possible, but
248 because of unification etc, more information is available to the desugarer.
249 And where it's possible to generate the correct literal right away, it's
250 much better to do so.
251
252
253 ************************************************************************
254 * *
255 Warnings about overflowed literals
256 * *
257 ************************************************************************
258
259 Warn about functions like toInteger, fromIntegral, that convert
260 between one type and another when the to- and from- types are the
261 same. Then it's probably (albeit not definitely) the identity
262 -}
263
264 warnAboutIdentities :: DynFlags -> Id -> Type -> DsM ()
265 warnAboutIdentities dflags conv_fn type_of_conv
266 | wopt Opt_WarnIdentities dflags
267 , idName conv_fn `elem` conversionNames
268 , Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
269 , arg_ty `eqType` res_ty -- So we are converting ty -> ty
270 = diagnosticDs (DsIdentitiesFound conv_fn type_of_conv)
271 warnAboutIdentities _ _ _ = return ()
272
273 conversionNames :: [Name]
274 conversionNames
275 = [ toIntegerName, toRationalName
276 , fromIntegralName, realToFracName ]
277 -- We can't easily add fromIntegerName, fromRationalName,
278 -- because they are generated by literals
279
280
281 -- | Emit warnings on overloaded integral literals which overflow the bounds
282 -- implied by their type.
283 warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
284 warnAboutOverflowedOverLit hsOverLit = do
285 dflags <- getDynFlags
286 fam_envs <- dsGetFamInstEnvs
287 warnAboutOverflowedLiterals dflags $
288 getIntegralLit hsOverLit >>= getNormalisedTyconName fam_envs
289
290 -- | Emit warnings on integral literals which overflow the bounds implied by
291 -- their type.
292 warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
293 warnAboutOverflowedLit hsLit = do
294 dflags <- getDynFlags
295 warnAboutOverflowedLiterals dflags $
296 getSimpleIntegralLit hsLit >>= getTyconName
297
298 -- | Emit warnings on integral literals which overflow the bounds implied by
299 -- their type.
300 warnAboutOverflowedLiterals
301 :: DynFlags
302 -> Maybe (Integer, Name) -- ^ the literal value and name of its tycon
303 -> DsM ()
304 warnAboutOverflowedLiterals dflags lit
305 | wopt Opt_WarnOverflowedLiterals dflags
306 , Just (i, tc) <- lit
307 = if
308 -- These only show up via the 'HsOverLit' route
309 | tc == intTyConName -> check i tc minInt maxInt
310 | tc == wordTyConName -> check i tc minWord maxWord
311 | tc == int8TyConName -> check i tc (min' @Int8) (max' @Int8)
312 | tc == int16TyConName -> check i tc (min' @Int16) (max' @Int16)
313 | tc == int32TyConName -> check i tc (min' @Int32) (max' @Int32)
314 | tc == int64TyConName -> check i tc (min' @Int64) (max' @Int64)
315 | tc == word8TyConName -> check i tc (min' @Word8) (max' @Word8)
316 | tc == word16TyConName -> check i tc (min' @Word16) (max' @Word16)
317 | tc == word32TyConName -> check i tc (min' @Word32) (max' @Word32)
318 | tc == word64TyConName -> check i tc (min' @Word64) (max' @Word64)
319 | tc == naturalTyConName -> checkPositive i tc
320
321 -- These only show up via the 'HsLit' route
322 | tc == intPrimTyConName -> check i tc minInt maxInt
323 | tc == wordPrimTyConName -> check i tc minWord maxWord
324 | tc == int8PrimTyConName -> check i tc (min' @Int8) (max' @Int8)
325 | tc == int16PrimTyConName -> check i tc (min' @Int16) (max' @Int16)
326 | tc == int32PrimTyConName -> check i tc (min' @Int32) (max' @Int32)
327 | tc == int64PrimTyConName -> check i tc (min' @Int64) (max' @Int64)
328 | tc == word8PrimTyConName -> check i tc (min' @Word8) (max' @Word8)
329 | tc == word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16)
330 | tc == word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32)
331 | tc == word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64)
332
333 | otherwise -> return ()
334
335 | otherwise = return ()
336 where
337 -- use target Int/Word sizes! See #17336
338 platform = targetPlatform dflags
339 (minInt,maxInt) = (platformMinInt platform, platformMaxInt platform)
340 (minWord,maxWord) = (0, platformMaxWord platform)
341
342 min' :: forall a. (Integral a, Bounded a) => Integer
343 min' = fromIntegral (minBound :: a)
344
345 max' :: forall a. (Integral a, Bounded a) => Integer
346 max' = fromIntegral (maxBound :: a)
347
348 checkPositive :: Integer -> Name -> DsM ()
349 checkPositive i tc
350 = when (i < 0) $
351 diagnosticDs (DsOverflowedLiterals i tc Nothing (negLiteralExtEnabled dflags))
352
353 check i tc minB maxB
354 = when (i < minB || i > maxB) $
355 diagnosticDs (DsOverflowedLiterals i tc bounds (negLiteralExtEnabled dflags))
356 where
357 bounds = Just (MinBound minB, MaxBound maxB)
358
359 warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc
360 -> Maybe (LHsExpr GhcTc)
361 -> LHsExpr GhcTc -> DsM ()
362 -- ^ Warns about @[2,3 .. 1]@ or @['b' .. 'a']@ which return the empty list.
363 -- For numeric literals, only works for integral types, not floating point.
364 warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr
365 | not $ wopt Opt_WarnEmptyEnumerations dflags
366 = return ()
367 -- Numeric Literals
368 | Just from_ty@(from',_) <- getLHsIntegralLit fromExpr
369 , Just (_, tc) <- getNormalisedTyconName fam_envs from_ty
370 , Just mThn' <- traverse getLHsIntegralLit mThnExpr
371 , Just (to',_) <- getLHsIntegralLit toExpr
372 = do
373 let
374 check :: forall a. (Integral a, Num a) => DsM ()
375 check = when (null enumeration) raiseWarning
376 where
377 enumeration = case mThn of
378 Nothing -> [from .. to]
379 Just thn -> [from, thn .. to]
380 wrap :: forall a. (Integral a, Num a) => Integer -> Integer
381 wrap i = toInteger (fromIntegral i :: a)
382 from = wrap @a from'
383 to = wrap @a to'
384 mThn = fmap (wrap @a . fst) mThn'
385
386 platform <- targetPlatform <$> getDynFlags
387 -- Be careful to use target Int/Word sizes! cf #17336
388 if | tc == intTyConName -> case platformWordSize platform of
389 PW4 -> check @Int32
390 PW8 -> check @Int64
391 | tc == wordTyConName -> case platformWordSize platform of
392 PW4 -> check @Word32
393 PW8 -> check @Word64
394 | tc == int8TyConName -> check @Int8
395 | tc == int16TyConName -> check @Int16
396 | tc == int32TyConName -> check @Int32
397 | tc == int64TyConName -> check @Int64
398 | tc == word8TyConName -> check @Word8
399 | tc == word16TyConName -> check @Word16
400 | tc == word32TyConName -> check @Word32
401 | tc == word64TyConName -> check @Word64
402 | tc == integerTyConName -> check @Integer
403 | tc == naturalTyConName -> check @Integer
404 -- We use 'Integer' because otherwise a negative 'Natural' literal
405 -- could cause a compile time crash (instead of a runtime one).
406 -- See the T10930b test case for an example of where this matters.
407 | otherwise -> return ()
408
409 -- Char literals (#18402)
410 | Just fromChar <- getLHsCharLit fromExpr
411 , Just mThnChar <- traverse getLHsCharLit mThnExpr
412 , Just toChar <- getLHsCharLit toExpr
413 , let enumeration = case mThnChar of
414 Nothing -> [fromChar .. toChar]
415 Just thnChar -> [fromChar, thnChar .. toChar]
416 = when (null enumeration) raiseWarning
417
418 | otherwise = return ()
419 where
420 raiseWarning =
421 diagnosticDs DsEmptyEnumeration
422
423 getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type)
424 -- ^ See if the expression is an 'Integral' literal.
425 getLHsIntegralLit (L _ e) = go e
426 where
427 go (HsPar _ _ e _) = getLHsIntegralLit e
428 go (HsOverLit _ over_lit) = getIntegralLit over_lit
429 go (HsLit _ lit) = getSimpleIntegralLit lit
430
431 -- Remember to look through automatically-added tick-boxes! (#8384)
432 go (XExpr (HsTick _ e)) = getLHsIntegralLit e
433 go (XExpr (HsBinTick _ _ e)) = getLHsIntegralLit e
434
435 -- The literal might be wrapped in a case with -XOverloadedLists
436 go (XExpr (WrapExpr (HsWrap _ e))) = go e
437 go _ = Nothing
438
439 -- | If 'Integral', extract the value and type of the overloaded literal.
440 -- See Note [Literals and the OverloadedLists extension]
441 getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type)
442 getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc { ol_type = ty } })
443 = Just (il_value i, ty)
444 getIntegralLit _ = Nothing
445
446 -- | If 'Integral', extract the value and type of the non-overloaded literal.
447 getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type)
448 getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTy)
449 getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTy)
450 getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTy)
451 getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTy)
452 getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy)
453 getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty)
454 getSimpleIntegralLit _ = Nothing
455
456 -- | Extract the Char if the expression is a Char literal.
457 getLHsCharLit :: LHsExpr GhcTc -> Maybe Char
458 getLHsCharLit (L _ (HsPar _ _ e _)) = getLHsCharLit e
459 getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c
460 getLHsCharLit (L _ (XExpr (HsTick _ e))) = getLHsCharLit e
461 getLHsCharLit (L _ (XExpr (HsBinTick _ _ e))) = getLHsCharLit e
462 getLHsCharLit _ = Nothing
463
464 -- | Convert a pair (Integer, Type) to (Integer, Name) after eventually
465 -- normalising the type
466 getNormalisedTyconName :: FamInstEnvs -> (Integer, Type) -> Maybe (Integer, Name)
467 getNormalisedTyconName fam_envs (i,ty)
468 | Just tc <- tyConAppTyCon_maybe (normaliseNominal fam_envs ty)
469 = Just (i, tyConName tc)
470 | otherwise = Nothing
471 where
472 normaliseNominal :: FamInstEnvs -> Type -> Type
473 normaliseNominal fam_envs ty
474 = reductionReducedType
475 $ normaliseType fam_envs Nominal ty
476
477 -- | Convert a pair (Integer, Type) to (Integer, Name) without normalising
478 -- the type
479 getTyconName :: (Integer, Type) -> Maybe (Integer, Name)
480 getTyconName (i,ty)
481 | Just tc <- tyConAppTyCon_maybe ty = Just (i, tyConName tc)
482 | otherwise = Nothing
483
484 {-
485 Note [Literals and the OverloadedLists extension]
486 ~~~~
487 Consider the Literal `[256] :: [Data.Word.Word8]`
488
489 When the `OverloadedLists` extension is not active, then the `ol_ext` field
490 in the `OverLitTc` record that is passed to the function `getIntegralLit`
491 contains the type `Word8`. This is a simple type, and we can use its
492 type constructor immediately for the `warnAboutOverflowedLiterals` function.
493
494 When the `OverloadedLists` extension is active, then the `ol_ext` field
495 contains the type family `Item [Word8]`. The function `nomaliseType` is used
496 to convert it to the needed type `Word8`.
497 -}
498
499 {-
500 ************************************************************************
501 * *
502 Tidying lit pats
503 * *
504 ************************************************************************
505 -}
506
507 tidyLitPat :: HsLit GhcTc -> Pat GhcTc
508 -- Result has only the following HsLits:
509 -- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
510 -- HsDoublePrim, HsStringPrim, HsString
511 -- * HsInteger, HsRat, HsInt can't show up in LitPats
512 -- * We get rid of HsChar right here
513 tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
514 tidyLitPat (HsString src s)
515 | lengthFS s <= 1 -- Short string literals only
516 = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
517 [mkCharLitPat src c, pat] [charTy])
518 (mkNilPat charTy) (unpackFS s)
519 -- The stringTy is the type of the whole pattern, not
520 -- the type to instantiate (:) or [] with!
521 tidyLitPat lit = LitPat noExtField lit
522
523 ----------------
524 tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
525 -> Type
526 -> Pat GhcTc
527 tidyNPat (OverLit (OverLitTc False _ ty) val) mb_neg _eq outer_ty
528 -- False: Take short cuts only if the literal is not using rebindable syntax
529 --
530 -- Once that is settled, look for cases where the type of the
531 -- entire overloaded literal matches the type of the underlying literal,
532 -- and in that case take the short cut
533 -- NB: Watch out for weird cases like #3382
534 -- f :: Int -> Int
535 -- f "blah" = 4
536 -- which might be ok if we have 'instance IsString Int'
537 --
538 | not type_change, isIntTy ty, Just int_lit <- mb_int_lit
539 = mk_con_pat intDataCon (HsIntPrim NoSourceText int_lit)
540 | not type_change, isWordTy ty, Just int_lit <- mb_int_lit
541 = mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit)
542 | not type_change, isStringTy ty, Just str_lit <- mb_str_lit
543 = tidyLitPat (HsString NoSourceText str_lit)
544 -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
545 -- If we do convert to the constructor form, we'll generate a case
546 -- expression on a Float# or Double# and that's not allowed in Core; see
547 -- #9238 and Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold
548 where
549 -- Sometimes (like in test case
550 -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include
551 -- type-changing wrappers (for example, from Id Int to Int, for the identity
552 -- type family Id). In these cases, we can't do the short-cut.
553 type_change = not (outer_ty `eqType` ty)
554
555 mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
556 mk_con_pat con lit
557 = unLoc (mkPrefixConPat con [noLocA $ LitPat noExtField lit] [])
558
559 mb_int_lit :: Maybe Integer
560 mb_int_lit = case (mb_neg, val) of
561 (Nothing, HsIntegral i) -> Just (il_value i)
562 (Just _, HsIntegral i) -> Just (-(il_value i))
563 _ -> Nothing
564
565 mb_str_lit :: Maybe FastString
566 mb_str_lit = case (mb_neg, val) of
567 (Nothing, HsIsString _ s) -> Just s
568 _ -> Nothing
569
570 tidyNPat over_lit mb_neg eq outer_ty
571 = NPat outer_ty (noLocA over_lit) mb_neg eq
572
573 {-
574 ************************************************************************
575 * *
576 Pattern matching on LitPat
577 * *
578 ************************************************************************
579 -}
580
581 matchLiterals :: NonEmpty Id
582 -> Type -- ^ Type of the whole case expression
583 -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits
584 -> DsM (MatchResult CoreExpr)
585
586 matchLiterals (var :| vars) ty sub_groups
587 = do { -- Deal with each group
588 ; alts <- mapM match_group sub_groups
589
590 -- Combine results. For everything except String
591 -- we can use a case expression; for String we need
592 -- a chain of if-then-else
593 ; if isStringTy (idType var) then
594 do { eq_str <- dsLookupGlobalId eqStringName
595 ; mrs <- mapM (wrap_str_guard eq_str) alts
596 ; return (foldr1 combineMatchResults mrs) }
597 else
598 return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts)
599 }
600 where
601 match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr)
602 match_group eqns@(firstEqn :| _)
603 = do { dflags <- getDynFlags
604 ; let platform = targetPlatform dflags
605 ; let LitPat _ hs_lit = firstPat firstEqn
606 ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
607 ; return (hsLitKey platform hs_lit, match_result) }
608
609 wrap_str_guard :: Id -> (Literal,MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
610 -- Equality check for string literals
611 wrap_str_guard eq_str (LitString s, mr)
612 = do { -- We now have to convert back to FastString. Perhaps there
613 -- should be separate LitBytes and LitString constructors?
614 let s' = mkFastStringByteString s
615 ; lit <- mkStringExprFS s'
616 ; let pred = mkApps (Var eq_str) [Var var, lit]
617 ; return (mkGuardedMatchResult pred mr) }
618 wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
619
620
621 ---------------------------
622 hsLitKey :: Platform -> HsLit GhcTc -> Literal
623 -- Get the Core literal corresponding to a HsLit.
624 -- It only works for primitive types and strings;
625 -- others have been removed by tidy
626 -- For HsString, it produces a LitString, which really represents an _unboxed_
627 -- string literal; and we deal with it in matchLiterals above. Otherwise, it
628 -- produces a primitive Literal of type matching the original HsLit.
629 -- In the case of the fixed-width numeric types, we need to wrap here
630 -- because Literal has an invariant that the literal is in range, while
631 -- HsLit does not.
632 hsLitKey platform (HsIntPrim _ i) = mkLitIntWrap platform i
633 hsLitKey platform (HsWordPrim _ w) = mkLitWordWrap platform w
634 hsLitKey _ (HsInt64Prim _ i) = mkLitInt64Wrap i
635 hsLitKey _ (HsWord64Prim _ w) = mkLitWord64Wrap w
636 hsLitKey _ (HsCharPrim _ c) = mkLitChar c
637 -- This following two can be slow. See Note [FractionalLit representation]
638 hsLitKey _ (HsFloatPrim _ fl) = mkLitFloat (rationalFromFractionalLit fl)
639 hsLitKey _ (HsDoublePrim _ fl) = mkLitDouble (rationalFromFractionalLit fl)
640
641 hsLitKey _ (HsString _ s) = LitString (bytesFS s)
642 hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
643
644 {-
645 ************************************************************************
646 * *
647 Pattern matching on NPat
648 * *
649 ************************************************************************
650 -}
651
652 matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
653 matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal
654 = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
655 ; lit_expr <- dsOverLit lit
656 ; neg_lit <- case mb_neg of
657 Nothing -> return lit_expr
658 Just neg -> dsSyntaxExpr neg [lit_expr]
659 ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]
660 ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
661 ; return (mkGuardedMatchResult pred_expr match_result) }
662
663 {-
664 ************************************************************************
665 * *
666 Pattern matching on n+k patterns
667 * *
668 ************************************************************************
669
670 For an n+k pattern, we use the various magic expressions we've been given.
671 We generate:
672 \begin{verbatim}
673 if ge var lit then
674 let n = sub var lit
675 in <expr-for-a-successful-match>
676 else
677 <try-next-pattern-or-whatever>
678 \end{verbatim}
679 -}
680
681 matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
682 -- All NPlusKPats, for the *same* literal k
683 matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
684 = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus
685 = firstPat eqn1
686 ; lit1_expr <- dsOverLit lit1
687 ; lit2_expr <- dsOverLit lit2
688 ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr]
689 ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]
690 ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
691 ; match_result <- match vars ty eqns'
692 ; return (mkGuardedMatchResult pred_expr $
693 mkCoLetMatchResult (NonRec n1 minusk_expr) $
694 fmap (foldr1 (.) wraps) $
695 match_result) }
696 where
697 shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
698 = (wrapBind n n1, eqn { eqn_pats = pats })
699 -- The wrapBind is a no-op for the first equation
700 shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)