Generate Typeable info at definition sites
[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, 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
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
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
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
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
157 warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM ()
158 warnAboutOverflowedLiterals dflags lit
159 | wopt Opt_WarnOverflowedLiterals dflags
160 , Just (i, tc) <- getIntegralLit lit
161 = if tc == intTyConName then check i tc (undefined :: Int)
162 else if tc == int8TyConName then check i tc (undefined :: Int8)
163 else if tc == int16TyConName then check i tc (undefined :: Int16)
164 else if tc == int32TyConName then check i tc (undefined :: Int32)
165 else if tc == int64TyConName then check i tc (undefined :: Int64)
166 else if tc == wordTyConName then check i tc (undefined :: Word)
167 else if tc == word8TyConName then check i tc (undefined :: Word8)
168 else if tc == word16TyConName then check i tc (undefined :: Word16)
169 else if tc == word32TyConName then check i tc (undefined :: Word32)
170 else if tc == word64TyConName then check i tc (undefined :: Word64)
171 else return ()
172
173 | otherwise = return ()
174 where
175 check :: forall a. (Bounded a, Integral a) => Integer -> Name -> a -> DsM ()
176 check i tc _proxy
177 = when (i < minB || i > maxB) $ do
178 warnDs (vcat [ ptext (sLit "Literal") <+> integer i
179 <+> ptext (sLit "is out of the") <+> ppr tc <+> ptext (sLit "range")
180 <+> integer minB <> ptext (sLit "..") <> integer maxB
181 , sug ])
182 where
183 minB = toInteger (minBound :: a)
184 maxB = toInteger (maxBound :: a)
185 sug | minB == -i -- Note [Suggest NegativeLiterals]
186 , i > 0
187 , not (xopt Opt_NegativeLiterals dflags)
188 = ptext (sLit "If you are trying to write a large negative literal, use NegativeLiterals")
189 | otherwise = Outputable.empty
190
191 {-
192 Note [Suggest NegativeLiterals]
193 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
194 If you write
195 x :: Int8
196 x = -128
197 it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals.
198 We get an erroneous suggestion for
199 x = 128
200 but perhaps that does not matter too much.
201 -}
202
203 warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM ()
204 -- Warns about [2,3 .. 1] which returns the empty list
205 -- Only works for integral types, not floating point
206 warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
207 | wopt Opt_WarnEmptyEnumerations dflags
208 , Just (from,tc) <- getLHsIntegralLit fromExpr
209 , Just mThn <- traverse getLHsIntegralLit mThnExpr
210 , Just (to,_) <- getLHsIntegralLit toExpr
211 , let check :: forall a. (Enum a, Num a) => a -> DsM ()
212 check _proxy
213 = when (null enumeration) $
214 warnDs (ptext (sLit "Enumeration is empty"))
215 where
216 enumeration :: [a]
217 enumeration = case mThn of
218 Nothing -> [fromInteger from .. fromInteger to]
219 Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to]
220
221 = if tc == intTyConName then check (undefined :: Int)
222 else if tc == int8TyConName then check (undefined :: Int8)
223 else if tc == int16TyConName then check (undefined :: Int16)
224 else if tc == int32TyConName then check (undefined :: Int32)
225 else if tc == int64TyConName then check (undefined :: Int64)
226 else if tc == wordTyConName then check (undefined :: Word)
227 else if tc == word8TyConName then check (undefined :: Word8)
228 else if tc == word16TyConName then check (undefined :: Word16)
229 else if tc == word32TyConName then check (undefined :: Word32)
230 else if tc == word64TyConName then check (undefined :: Word64)
231 else if tc == integerTyConName then check (undefined :: Integer)
232 else return ()
233
234 | otherwise = return ()
235
236 getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name)
237 -- See if the expression is an Integral literal
238 -- Remember to look through automatically-added tick-boxes! (Trac #8384)
239 getLHsIntegralLit (L _ (HsPar e)) = getLHsIntegralLit e
240 getLHsIntegralLit (L _ (HsTick _ e)) = getLHsIntegralLit e
241 getLHsIntegralLit (L _ (HsBinTick _ _ e)) = getLHsIntegralLit e
242 getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
243 getLHsIntegralLit _ = Nothing
244
245 getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name)
246 getIntegralLit (OverLit { ol_val = HsIntegral _ i, ol_type = ty })
247 | Just tc <- tyConAppTyCon_maybe ty
248 = Just (i, tyConName tc)
249 getIntegralLit _ = Nothing
250
251 {-
252 ************************************************************************
253 * *
254 Tidying lit pats
255 * *
256 ************************************************************************
257 -}
258
259 tidyLitPat :: HsLit -> Pat Id
260 -- Result has only the following HsLits:
261 -- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
262 -- HsDoublePrim, HsStringPrim, HsString
263 -- * HsInteger, HsRat, HsInt can't show up in LitPats
264 -- * We get rid of HsChar right here
265 tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
266 tidyLitPat (HsString src s)
267 | lengthFS s <= 1 -- Short string literals only
268 = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
269 [mkCharLitPat src c, pat] [charTy])
270 (mkNilPat charTy) (unpackFS s)
271 -- The stringTy is the type of the whole pattern, not
272 -- the type to instantiate (:) or [] with!
273 tidyLitPat lit = LitPat lit
274
275 ----------------
276 tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat
277 -- We need this argument because tidyNPat is called
278 -- both by Match and by Check, but they tidy LitPats
279 -- slightly differently; and we must desugar
280 -- literals consistently (see Trac #5117)
281 -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
282 -> Pat Id
283 tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
284 -- False: Take short cuts only if the literal is not using rebindable syntax
285 --
286 -- Once that is settled, look for cases where the type of the
287 -- entire overloaded literal matches the type of the underlying literal,
288 -- and in that case take the short cut
289 -- NB: Watch out for weird cases like Trac #3382
290 -- f :: Int -> Int
291 -- f "blah" = 4
292 -- which might be ok if we hvae 'instance IsString Int'
293 --
294
295 | isIntTy ty, Just int_lit <- mb_int_lit
296 = mk_con_pat intDataCon (HsIntPrim "" int_lit)
297 | isWordTy ty, Just int_lit <- mb_int_lit
298 = mk_con_pat wordDataCon (HsWordPrim "" int_lit)
299 | isStringTy ty, Just str_lit <- mb_str_lit
300 = tidy_lit_pat (HsString "" str_lit)
301 -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
302 -- If we do convert to the constructor form, we'll generate a case
303 -- expression on a Float# or Double# and that's not allowed in Core; see
304 -- Trac #9238 and Note [Rules for floating-point comparisons] in PrelRules
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_str_lit :: Maybe FastString
316 mb_str_lit = case (mb_neg, val) of
317 (Nothing, HsIsString _ s) -> Just s
318 _ -> Nothing
319
320 tidyNPat _ over_lit mb_neg eq
321 = NPat (noLoc over_lit) mb_neg eq
322
323 {-
324 ************************************************************************
325 * *
326 Pattern matching on LitPat
327 * *
328 ************************************************************************
329 -}
330
331 matchLiterals :: [Id]
332 -> Type -- Type of the whole case expression
333 -> [[EquationInfo]] -- All PgLits
334 -> DsM MatchResult
335
336 matchLiterals (var:vars) ty sub_groups
337 = ASSERT( notNull sub_groups && all notNull sub_groups )
338 do { -- Deal with each group
339 ; alts <- mapM match_group sub_groups
340
341 -- Combine results. For everything except String
342 -- we can use a case expression; for String we need
343 -- a chain of if-then-else
344 ; if isStringTy (idType var) then
345 do { eq_str <- dsLookupGlobalId eqStringName
346 ; mrs <- mapM (wrap_str_guard eq_str) alts
347 ; return (foldr1 combineMatchResults mrs) }
348 else
349 return (mkCoPrimCaseMatchResult var ty alts)
350 }
351 where
352 match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
353 match_group eqns
354 = do dflags <- getDynFlags
355 let LitPat hs_lit = firstPat (head eqns)
356 match_result <- match vars ty (shiftEqns eqns)
357 return (hsLitKey dflags hs_lit, match_result)
358
359 wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
360 -- Equality check for string literals
361 wrap_str_guard eq_str (MachStr s, mr)
362 = do { -- We now have to convert back to FastString. Perhaps there
363 -- should be separate MachBytes and MachStr constructors?
364 let s' = mkFastStringByteString s
365 ; lit <- mkStringExprFS s'
366 ; let pred = mkApps (Var eq_str) [Var var, lit]
367 ; return (mkGuardedMatchResult pred mr) }
368 wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
369
370 matchLiterals [] _ _ = panic "matchLiterals []"
371
372 ---------------------------
373 hsLitKey :: DynFlags -> HsLit -> Literal
374 -- Get a Core literal to use (only) a grouping key
375 -- Hence its type doesn't need to match the type of the original literal
376 -- (and doesn't for strings)
377 -- It only works for primitive types and strings;
378 -- others have been removed by tidy
379 hsLitKey dflags (HsIntPrim _ i) = mkMachInt dflags i
380 hsLitKey dflags (HsWordPrim _ w) = mkMachWord dflags w
381 hsLitKey _ (HsInt64Prim _ i) = mkMachInt64 i
382 hsLitKey _ (HsWord64Prim _ w) = mkMachWord64 w
383 hsLitKey _ (HsCharPrim _ c) = MachChar c
384 hsLitKey _ (HsStringPrim _ s) = MachStr s
385 hsLitKey _ (HsFloatPrim f) = MachFloat (fl_value f)
386 hsLitKey _ (HsDoublePrim d) = MachDouble (fl_value d)
387 hsLitKey _ (HsString _ s) = MachStr (fastStringToByteString s)
388 hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
389
390 ---------------------------
391 hsOverLitKey :: HsOverLit a -> Bool -> Literal
392 -- Ditto for HsOverLit; the boolean indicates to negate
393 hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
394
395 ---------------------------
396 litValKey :: OverLitVal -> Bool -> Literal
397 litValKey (HsIntegral _ i) False = MachInt i
398 litValKey (HsIntegral _ i) True = MachInt (-i)
399 litValKey (HsFractional r) False = MachFloat (fl_value r)
400 litValKey (HsFractional r) True = MachFloat (negate (fl_value r))
401 litValKey (HsIsString _ s) neg = ASSERT( not neg) MachStr
402 (fastStringToByteString s)
403
404 {-
405 ************************************************************************
406 * *
407 Pattern matching on NPat
408 * *
409 ************************************************************************
410 -}
411
412 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
413 matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal
414 = do { let NPat (L _ lit) mb_neg eq_chk = firstPat eqn1
415 ; lit_expr <- dsOverLit lit
416 ; neg_lit <- case mb_neg of
417 Nothing -> return lit_expr
418 Just neg -> do { neg_expr <- dsExpr neg
419 ; return (App neg_expr lit_expr) }
420 ; eq_expr <- dsExpr eq_chk
421 ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
422 ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
423 ; return (mkGuardedMatchResult pred_expr match_result) }
424 matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
425
426 {-
427 ************************************************************************
428 * *
429 Pattern matching on n+k patterns
430 * *
431 ************************************************************************
432
433 For an n+k pattern, we use the various magic expressions we've been given.
434 We generate:
435 \begin{verbatim}
436 if ge var lit then
437 let n = sub var lit
438 in <expr-for-a-successful-match>
439 else
440 <try-next-pattern-or-whatever>
441 \end{verbatim}
442 -}
443
444 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
445 -- All NPlusKPats, for the *same* literal k
446 matchNPlusKPats (var:vars) ty (eqn1:eqns)
447 = do { let NPlusKPat (L _ n1) (L _ lit) ge minus = firstPat eqn1
448 ; ge_expr <- dsExpr ge
449 ; minus_expr <- dsExpr minus
450 ; lit_expr <- dsOverLit lit
451 ; let pred_expr = mkApps ge_expr [Var var, lit_expr]
452 minusk_expr = mkApps minus_expr [Var var, lit_expr]
453 (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
454 ; match_result <- match vars ty eqns'
455 ; return (mkGuardedMatchResult pred_expr $
456 mkCoLetMatchResult (NonRec n1 minusk_expr) $
457 adjustMatchResult (foldr1 (.) wraps) $
458 match_result) }
459 where
460 shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
461 = (wrapBind n n1, eqn { eqn_pats = pats })
462 -- The wrapBind is a no-op for the first equation
463 shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
464
465 matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))