Merge remote-tracking branch 'github/pr/83'
[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 (HsStringPrim _ s) = return (Lit (MachStr s))
81 dsLit (HsCharPrim _ c) = return (Lit (MachChar c))
82 dsLit (HsIntPrim _ i) = return (Lit (MachInt i))
83 dsLit (HsWordPrim _ w) = return (Lit (MachWord w))
84 dsLit (HsInt64Prim _ i) = return (Lit (MachInt64 i))
85 dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w))
86 dsLit (HsFloatPrim _ f) = return (Lit (MachFloat (fl_value f)))
87 dsLit (HsDoublePrim _ d) = return (Lit (MachDouble (fl_value d)))
88 dsLit (HsChar _ c) = return (mkCharExpr c)
89 dsLit (HsString _ str) = mkStringExprFS str
90 dsLit (HsInteger _ i _) = mkIntegerExpr i
91 dsLit (HsInt _ i) = do dflags <- getDynFlags
92 return (mkIntExpr dflags (il_value i))
93
94 dsLit (HsRat _ (FL _ _ val) ty) = do
95 num <- mkIntegerExpr (numerator val)
96 denom <- mkIntegerExpr (denominator val)
97 return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
98 where
99 (ratio_data_con, integer_ty)
100 = case tcSplitTyConApp ty of
101 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
102 (head (tyConDataCons tycon), i_ty)
103 x -> pprPanic "dsLit" (ppr x)
104
105 dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
106 dsOverLit lit = do { dflags <- getDynFlags
107 ; warnAboutOverflowedLiterals dflags lit
108 ; dsOverLit' dflags lit }
109
110 dsOverLit' :: DynFlags -> HsOverLit GhcTc -> DsM CoreExpr
111 -- Post-typechecker, the HsExpr field of an OverLit contains
112 -- (an expression for) the literal value itself
113 dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
114 , ol_witness = witness, ol_type = ty })
115 | not rebindable
116 , Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut]
117 | otherwise = dsExpr witness
118
119 {-
120 Note [Literal short cut]
121 ~~~~~~~~~~~~~~~~~~~~~~~~
122 The type checker tries to do this short-cutting as early as possible, but
123 because of unification etc, more information is available to the desugarer.
124 And where it's possible to generate the correct literal right away, it's
125 much better to do so.
126
127
128 ************************************************************************
129 * *
130 Warnings about overflowed literals
131 * *
132 ************************************************************************
133
134 Warn about functions like toInteger, fromIntegral, that convert
135 between one type and another when the to- and from- types are the
136 same. Then it's probably (albeit not definitely) the identity
137 -}
138
139 warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()
140 warnAboutIdentities dflags (Var conv_fn) type_of_conv
141 | wopt Opt_WarnIdentities dflags
142 , idName conv_fn `elem` conversionNames
143 , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
144 , arg_ty `eqType` res_ty -- So we are converting ty -> ty
145 = warnDs (Reason Opt_WarnIdentities)
146 (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
147 , nest 2 $ text "can probably be omitted"
148 ])
149 warnAboutIdentities _ _ _ = return ()
150
151 conversionNames :: [Name]
152 conversionNames
153 = [ toIntegerName, toRationalName
154 , fromIntegralName, realToFracName ]
155 -- We can't easily add fromIntegerName, fromRationalName,
156 -- because they are generated by literals
157
158 warnAboutOverflowedLiterals :: DynFlags -> HsOverLit GhcTc -> DsM ()
159 warnAboutOverflowedLiterals dflags lit
160 | wopt Opt_WarnOverflowedLiterals dflags
161 , Just (i, tc) <- getIntegralLit lit
162 = if tc == intTyConName then check i tc (Proxy :: Proxy Int)
163 else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8)
164 else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16)
165 else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32)
166 else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64)
167 else if tc == wordTyConName then check i tc (Proxy :: Proxy Word)
168 else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8)
169 else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16)
170 else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32)
171 else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64)
172 else return ()
173
174 | otherwise = return ()
175 where
176 check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()
177 check i tc _proxy
178 = when (i < minB || i > maxB) $ do
179 warnDs (Reason Opt_WarnOverflowedLiterals)
180 (vcat [ text "Literal" <+> integer i
181 <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")
182 <+> integer minB <> text ".." <> 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 LangExt.NegativeLiterals dflags)
190 = text "If you are trying to write a large negative literal, use NegativeLiterals"
191 | otherwise = Outputable.empty
192
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
205 warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
206 -> LHsExpr GhcTc -> DsM ()
207 -- Warns about [2,3 .. 1] which returns the empty list
208 -- Only works for integral types, not floating point
209 warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
210 | wopt Opt_WarnEmptyEnumerations dflags
211 , Just (from,tc) <- getLHsIntegralLit fromExpr
212 , Just mThn <- traverse getLHsIntegralLit mThnExpr
213 , Just (to,_) <- getLHsIntegralLit toExpr
214 , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM ()
215 check _proxy
216 = when (null enumeration) $
217 warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")
218 where
219 enumeration :: [a]
220 enumeration = case mThn of
221 Nothing -> [fromInteger from .. fromInteger to]
222 Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to]
223
224 = if tc == intTyConName then check (Proxy :: Proxy Int)
225 else if tc == int8TyConName then check (Proxy :: Proxy Int8)
226 else if tc == int16TyConName then check (Proxy :: Proxy Int16)
227 else if tc == int32TyConName then check (Proxy :: Proxy Int32)
228 else if tc == int64TyConName then check (Proxy :: Proxy Int64)
229 else if tc == wordTyConName then check (Proxy :: Proxy Word)
230 else if tc == word8TyConName then check (Proxy :: Proxy Word8)
231 else if tc == word16TyConName then check (Proxy :: Proxy Word16)
232 else if tc == word32TyConName then check (Proxy :: Proxy Word32)
233 else if tc == word64TyConName then check (Proxy :: Proxy Word64)
234 else if tc == integerTyConName then check (Proxy :: Proxy Integer)
235 else return ()
236
237 | otherwise = return ()
238
239 getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
240 -- See if the expression is an Integral literal
241 -- Remember to look through automatically-added tick-boxes! (Trac #8384)
242 getLHsIntegralLit (L _ (HsPar e)) = getLHsIntegralLit e
243 getLHsIntegralLit (L _ (HsTick _ e)) = getLHsIntegralLit e
244 getLHsIntegralLit (L _ (HsBinTick _ _ e)) = getLHsIntegralLit e
245 getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
246 getLHsIntegralLit _ = Nothing
247
248 getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
249 getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty })
250 | Just tc <- tyConAppTyCon_maybe ty
251 = Just (il_value i, tyConName tc)
252 getIntegralLit _ = Nothing
253
254 {-
255 ************************************************************************
256 * *
257 Tidying lit pats
258 * *
259 ************************************************************************
260 -}
261
262 tidyLitPat :: HsLit GhcTc -> Pat GhcTc
263 -- Result has only the following HsLits:
264 -- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
265 -- HsDoublePrim, HsStringPrim, HsString
266 -- * HsInteger, HsRat, HsInt can't show up in LitPats
267 -- * We get rid of HsChar right here
268 tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
269 tidyLitPat (HsString src s)
270 | lengthFS s <= 1 -- Short string literals only
271 = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
272 [mkCharLitPat src c, pat] [charTy])
273 (mkNilPat charTy) (unpackFS s)
274 -- The stringTy is the type of the whole pattern, not
275 -- the type to instantiate (:) or [] with!
276 tidyLitPat lit = LitPat lit
277
278 ----------------
279 tidyNPat :: (HsLit GhcTc -> Pat GhcTc) -- How to tidy a LitPat
280 -- We need this argument because tidyNPat is called
281 -- both by Match and by Check, but they tidy LitPats
282 -- slightly differently; and we must desugar
283 -- literals consistently (see Trac #5117)
284 -> HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
285 -> Type
286 -> Pat GhcTc
287 tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
288 -- False: Take short cuts only if the literal is not using rebindable syntax
289 --
290 -- Once that is settled, look for cases where the type of the
291 -- entire overloaded literal matches the type of the underlying literal,
292 -- and in that case take the short cut
293 -- NB: Watch out for weird cases like Trac #3382
294 -- f :: Int -> Int
295 -- f "blah" = 4
296 -- which might be ok if we have 'instance IsString Int'
297 --
298 | not type_change, isIntTy ty, Just int_lit <- mb_int_lit
299 = mk_con_pat intDataCon (HsIntPrim NoSourceText int_lit)
300 | not type_change, isWordTy ty, Just int_lit <- mb_int_lit
301 = mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit)
302 | not type_change, isStringTy ty, Just str_lit <- mb_str_lit
303 = tidy_lit_pat (HsString NoSourceText str_lit)
304 -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
305 -- If we do convert to the constructor form, we'll generate a case
306 -- expression on a Float# or Double# and that's not allowed in Core; see
307 -- Trac #9238 and Note [Rules for floating-point comparisons] in PrelRules
308 where
309 -- Sometimes (like in test case
310 -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include
311 -- type-changing wrappers (for example, from Id Int to Int, for the identity
312 -- type family Id). In these cases, we can't do the short-cut.
313 type_change = not (outer_ty `eqType` ty)
314
315 mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
316 mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
317
318 mb_int_lit :: Maybe Integer
319 mb_int_lit = case (mb_neg, val) of
320 (Nothing, HsIntegral i) -> Just (il_value i)
321 (Just _, HsIntegral i) -> Just (-(il_value i))
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 outer_ty
330 = NPat (noLoc over_lit) mb_neg eq outer_ty
331
332 {-
333 ************************************************************************
334 * *
335 Pattern matching on LitPat
336 * *
337 ************************************************************************
338 -}
339
340 matchLiterals :: [Id]
341 -> Type -- Type of the whole case expression
342 -> [[EquationInfo]] -- All PgLits
343 -> DsM MatchResult
344
345 matchLiterals (var:vars) ty sub_groups
346 = ASSERT( notNull sub_groups && all notNull sub_groups )
347 do { -- Deal with each group
348 ; alts <- mapM match_group sub_groups
349
350 -- Combine results. For everything except String
351 -- we can use a case expression; for String we need
352 -- a chain of if-then-else
353 ; if isStringTy (idType var) then
354 do { eq_str <- dsLookupGlobalId eqStringName
355 ; mrs <- mapM (wrap_str_guard eq_str) alts
356 ; return (foldr1 combineMatchResults mrs) }
357 else
358 return (mkCoPrimCaseMatchResult var ty alts)
359 }
360 where
361 match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
362 match_group eqns
363 = do dflags <- getDynFlags
364 let LitPat hs_lit = firstPat (head eqns)
365 match_result <- match vars ty (shiftEqns eqns)
366 return (hsLitKey dflags hs_lit, match_result)
367
368 wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
369 -- Equality check for string literals
370 wrap_str_guard eq_str (MachStr s, mr)
371 = do { -- We now have to convert back to FastString. Perhaps there
372 -- should be separate MachBytes and MachStr constructors?
373 let s' = mkFastStringByteString s
374 ; lit <- mkStringExprFS s'
375 ; let pred = mkApps (Var eq_str) [Var var, lit]
376 ; return (mkGuardedMatchResult pred mr) }
377 wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
378
379 matchLiterals [] _ _ = panic "matchLiterals []"
380
381 ---------------------------
382 hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
383 -- Get the Core literal corresponding to a HsLit.
384 -- It only works for primitive types and strings;
385 -- others have been removed by tidy
386 -- For HsString, it produces a MachStr, which really represents an _unboxed_
387 -- string literal; and we deal with it in matchLiterals above. Otherwise, it
388 -- produces a primitive Literal of type matching the original HsLit.
389 -- In the case of the fixed-width numeric types, we need to wrap here
390 -- because Literal has an invariant that the literal is in range, while
391 -- HsLit does not.
392 hsLitKey dflags (HsIntPrim _ i) = mkMachIntWrap dflags i
393 hsLitKey dflags (HsWordPrim _ w) = mkMachWordWrap dflags w
394 hsLitKey _ (HsInt64Prim _ i) = mkMachInt64Wrap i
395 hsLitKey _ (HsWord64Prim _ w) = mkMachWord64Wrap w
396 hsLitKey _ (HsCharPrim _ c) = mkMachChar c
397 hsLitKey _ (HsFloatPrim _ f) = mkMachFloat (fl_value f)
398 hsLitKey _ (HsDoublePrim _ d) = mkMachDouble (fl_value d)
399 hsLitKey _ (HsString _ s) = MachStr (fastStringToByteString s)
400 hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
401
402 {-
403 ************************************************************************
404 * *
405 Pattern matching on NPat
406 * *
407 ************************************************************************
408 -}
409
410 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
411 matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal
412 = do { let NPat (L _ lit) mb_neg eq_chk _ = firstPat eqn1
413 ; lit_expr <- dsOverLit lit
414 ; neg_lit <- case mb_neg of
415 Nothing -> return lit_expr
416 Just neg -> dsSyntaxExpr neg [lit_expr]
417 ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]
418 ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
419 ; return (mkGuardedMatchResult pred_expr match_result) }
420 matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
421
422 {-
423 ************************************************************************
424 * *
425 Pattern matching on n+k patterns
426 * *
427 ************************************************************************
428
429 For an n+k pattern, we use the various magic expressions we've been given.
430 We generate:
431 \begin{verbatim}
432 if ge var lit then
433 let n = sub var lit
434 in <expr-for-a-successful-match>
435 else
436 <try-next-pattern-or-whatever>
437 \end{verbatim}
438 -}
439
440 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
441 -- All NPlusKPats, for the *same* literal k
442 matchNPlusKPats (var:vars) ty (eqn1:eqns)
443 = do { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1
444 ; lit1_expr <- dsOverLit lit1
445 ; lit2_expr <- dsOverLit lit2
446 ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr]
447 ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]
448 ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
449 ; match_result <- match vars ty eqns'
450 ; return (mkGuardedMatchResult pred_expr $
451 mkCoLetMatchResult (NonRec n1 minusk_expr) $
452 adjustMatchResult (foldr1 (.) wraps) $
453 match_result) }
454 where
455 shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats })
456 = (wrapBind n n1, eqn { eqn_pats = pats })
457 -- The wrapBind is a no-op for the first equation
458 shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
459
460 matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))