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