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