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