1{- 2(c) The University of Glasgow 2006 3(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 4 5 6Pattern-matching literal patterns 7-} 8 9{-# LANGUAGE CPP, ScopedTypeVariables #-} 10{-# LANGUAGE ViewPatterns #-} 11 12module MatchLit ( dsLit, dsOverLit, hsLitKey 13 , tidyLitPat, tidyNPat 14 , matchLiterals, matchNPlusKPats, matchNPats 15 , warnAboutIdentities 16 , warnAboutOverflowedOverLit, warnAboutOverflowedLit 17 , warnAboutEmptyEnumerations 18 ) where 19 20#include "HsVersions.h" 21 22import GhcPrelude 23 24import {-# SOURCE #-} Match ( match ) 25import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr ) 26 27import DsMonad 28import DsUtils 29 30import GHC.Hs 31 32import Id 33import CoreSyn 34import MkCore 35import TyCon 36import DataCon 37import TcHsSyn ( shortCutLit ) 38import TcType 39import Name 40import Type 41import PrelNames 42import TysWiredIn 43import TysPrim 44import Literal 45import SrcLoc 46import Data.Ratio 47import Outputable 48import BasicTypes 49import DynFlags 50import Util 51import FastString 52import qualified GHC.LanguageExtensions as LangExt 53 54import Control.Monad 55import Data.Int 56import Data.Word 57import Data.Proxy 58 59{- 60************************************************************************ 61* * 62 Desugaring literals 63 [used to be in DsExpr, but DsMeta needs it, 64 and it's nice to avoid a loop] 65* * 66************************************************************************ 67 68We give int/float literals type @Integer@ and @Rational@, respectively. 69The typechecker will (presumably) have put \tr{from{Integer,Rational}s} 70around them. 71 72ToDo: put in range checks for when converting ``@i@'' 73(or should that be in the typechecker?) 74 75For numeric literals, we try to detect there use at a standard type 76(@Int@, @Float@, etc.) are directly put in the right constructor. 77[NB: down with the @App@ conversion.] 78 79See also below where we look for @DictApps@ for \tr{plusInt}, etc. 80-} 81 82dsLit :: HsLit GhcRn -> DsM CoreExpr 83dsLit l = do 84 dflags <- getDynFlags 85 case l of 86 HsStringPrim _ s -> return (Lit (LitString s)) 87 HsCharPrim _ c -> return (Lit (LitChar c)) 88 HsIntPrim _ i -> return (Lit (mkLitIntWrap dflags i)) 89 HsWordPrim _ w -> return (Lit (mkLitWordWrap dflags w)) 90 HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap dflags i)) 91 HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w)) 92 HsFloatPrim _ f -> return (Lit (LitFloat (fl_value f))) 93 HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d))) 94 HsChar _ c -> return (mkCharExpr c) 95 HsString _ str -> mkStringExprFS str 96 HsInteger _ i _ -> mkIntegerExpr i 97 HsInt _ i -> return (mkIntExpr dflags (il_value i)) 98 XLit nec -> noExtCon nec 99 HsRat _ (FL _ _ val) ty -> do 100 num <- mkIntegerExpr (numerator val) 101 denom <- mkIntegerExpr (denominator val) 102 return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) 103 where 104 (ratio_data_con, integer_ty) 105 = case tcSplitTyConApp ty of 106 (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) 107 (head (tyConDataCons tycon), i_ty) 108 x -> pprPanic "dsLit" (ppr x) 109 110dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr 111-- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains 112-- (an expression for) the literal value itself. 113dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty 114 , ol_witness = witness }) = do 115 dflags <- getDynFlags 116 case shortCutLit dflags val ty of 117 Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut] 118 _ -> dsExpr witness 119dsOverLit (XOverLit nec) = noExtCon nec 120{- 121Note [Literal short cut] 122~~~~~~~~~~~~~~~~~~~~~~~~ 123The type checker tries to do this short-cutting as early as possible, but 124because of unification etc, more information is available to the desugarer. 125And where it's possible to generate the correct literal right away, it's 126much better to do so. 127 128 129************************************************************************ 130* * 131 Warnings about overflowed literals 132* * 133************************************************************************ 134 135Warn about functions like toInteger, fromIntegral, that convert 136between one type and another when the to- and from- types are the 137same. Then it's probably (albeit not definitely) the identity 138-} 139 140warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM () 141warnAboutIdentities dflags (Var conv_fn) type_of_conv 142 | wopt Opt_WarnIdentities dflags 143 , idName conv_fn `elem` conversionNames 144 , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv 145 , arg_ty `eqType` res_ty -- So we are converting ty -> ty 146 = warnDs (Reason Opt_WarnIdentities) 147 (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv 148 , nest 2 $ text "can probably be omitted" 149 ]) 150warnAboutIdentities _ _ _ = return () 151 152conversionNames :: [Name] 153conversionNames 154 = [ toIntegerName, toRationalName 155 , fromIntegralName, realToFracName ] 156 -- We can't easily add fromIntegerName, fromRationalName, 157 -- because they are generated by literals 158 159 160-- | Emit warnings on overloaded integral literals which overflow the bounds 161-- implied by their type. 162warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM () 163warnAboutOverflowedOverLit hsOverLit = do 164 dflags <- getDynFlags 165 warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit) 166 167-- | Emit warnings on integral literals which overflow the boudns implied by 168-- their type. 169warnAboutOverflowedLit :: HsLit GhcTc -> DsM () 170warnAboutOverflowedLit hsLit = do 171 dflags <- getDynFlags 172 warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit) 173 174-- | Emit warnings on integral literals which overflow the bounds implied by 175-- their type. 176warnAboutOverflowedLiterals 177 :: DynFlags 178 -> Maybe (Integer, Name) -- ^ the literal value and name of its tycon 179 -> DsM () 180warnAboutOverflowedLiterals dflags lit 181 | wopt Opt_WarnOverflowedLiterals dflags 182 , Just (i, tc) <- lit 183 = if tc == intTyConName then check i tc (Proxy :: Proxy Int) 184 185 -- These only show up via the 'HsOverLit' route 186 else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8) 187 else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16) 188 else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32) 189 else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64) 190 else if tc == wordTyConName then check i tc (Proxy :: Proxy Word) 191 else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8) 192 else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16) 193 else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32) 194 else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64) 195 else if tc == naturalTyConName then checkPositive i tc 196 197 -- These only show up via the 'HsLit' route 198 else if tc == intPrimTyConName then check i tc (Proxy :: Proxy Int) 199 else if tc == int8PrimTyConName then check i tc (Proxy :: Proxy Int8) 200 else if tc == int32PrimTyConName then check i tc (Proxy :: Proxy Int32) 201 else if tc == int64PrimTyConName then check i tc (Proxy :: Proxy Int64) 202 else if tc == wordPrimTyConName then check i tc (Proxy :: Proxy Word) 203 else if tc == word8PrimTyConName then check i tc (Proxy :: Proxy Word8) 204 else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32) 205 else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64) 206 207 else return () 208 209 | otherwise = return () 210 where 211 212 checkPositive :: Integer -> Name -> DsM () 213 checkPositive i tc 214 = when (i < 0) $ do 215 warnDs (Reason Opt_WarnOverflowedLiterals) 216 (vcat [ text "Literal" <+> integer i 217 <+> text "is negative but" <+> ppr tc 218 <+> ptext (sLit "only supports positive numbers") 219 ]) 220 221 check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM () 222 check i tc _proxy 223 = when (i < minB || i > maxB) $ do 224 warnDs (Reason Opt_WarnOverflowedLiterals) 225 (vcat [ text "Literal" <+> integer i 226 <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range") 227 <+> integer minB <> text ".." <> integer maxB 228 , sug ]) 229 where 230 minB = toInteger (minBound :: a) 231 maxB = toInteger (maxBound :: a) 232 sug | minB == -i -- Note [Suggest NegativeLiterals] 233 , i > 0 234 , not (xopt LangExt.NegativeLiterals dflags) 235 = text "If you are trying to write a large negative literal, use NegativeLiterals" 236 | otherwise = Outputable.empty 237 238{- 239Note [Suggest NegativeLiterals] 240~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 241If you write 242 x :: Int8 243 x = -128 244it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals. 245We get an erroneous suggestion for 246 x = 128 247but perhaps that does not matter too much. 248-} 249 250warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc) 251 -> LHsExpr GhcTc -> DsM () 252-- ^ Warns about @[2,3 .. 1]@ which returns the empty list. 253-- Only works for integral types, not floating point. 254warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr 255 | wopt Opt_WarnEmptyEnumerations dflags 256 , Just (from,tc) <- getLHsIntegralLit fromExpr 257 , Just mThn <- traverse getLHsIntegralLit mThnExpr 258 , Just (to,_) <- getLHsIntegralLit toExpr 259 , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM () 260 check _proxy 261 = when (null enumeration) $ 262 warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty") 263 where 264 enumeration :: [a] 265 enumeration = case mThn of 266 Nothing -> [fromInteger from .. fromInteger to] 267 Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to] 268 269 = if tc == intTyConName then check (Proxy :: Proxy Int) 270 else if tc == int8TyConName then check (Proxy :: Proxy Int8) 271 else if tc == int16TyConName then check (Proxy :: Proxy Int16) 272 else if tc == int32TyConName then check (Proxy :: Proxy Int32) 273 else if tc == int64TyConName then check (Proxy :: Proxy Int64) 274 else if tc == wordTyConName then check (Proxy :: Proxy Word) 275 else if tc == word8TyConName then check (Proxy :: Proxy Word8) 276 else if tc == word16TyConName then check (Proxy :: Proxy Word16) 277 else if tc == word32TyConName then check (Proxy :: Proxy Word32) 278 else if tc == word64TyConName then check (Proxy :: Proxy Word64) 279 else if tc == integerTyConName then check (Proxy :: Proxy Integer) 280 else if tc == naturalTyConName then check (Proxy :: Proxy Integer) 281 -- We use 'Integer' because otherwise a negative 'Natural' literal 282 -- could cause a compile time crash (instead of a runtime one). 283 -- See the T10930b test case for an example of where this matters. 284 else return () 285 286 | otherwise = return () 287 288getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name) 289-- ^ See if the expression is an 'Integral' literal. 290-- Remember to look through automatically-added tick-boxes! (#8384) 291getLHsIntegralLit (dL->L _ (HsPar _ e)) = getLHsIntegralLit e 292getLHsIntegralLit (dL->L _ (HsTick _ _ e)) = getLHsIntegralLit e 293getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e 294getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit 295getLHsIntegralLit (dL->L _ (HsLit _ lit)) = getSimpleIntegralLit lit 296getLHsIntegralLit _ = Nothing 297 298-- | If 'Integral', extract the value and type name of the overloaded literal. 299getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name) 300getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty }) 301 | Just tc <- tyConAppTyCon_maybe ty 302 = Just (il_value i, tyConName tc) 303getIntegralLit _ = Nothing 304 305-- | If 'Integral', extract the value and type name of the non-overloaded 306-- literal. 307getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name) 308getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName) 309getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName) 310getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName) 311getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName) 312getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName) 313getSimpleIntegralLit (HsInteger _ i ty) 314 | Just tc <- tyConAppTyCon_maybe ty 315 = Just (i, tyConName tc) 316getSimpleIntegralLit _ = Nothing 317 318{- 319************************************************************************ 320* * 321 Tidying lit pats 322* * 323************************************************************************ 324-} 325 326tidyLitPat :: HsLit GhcTc -> Pat GhcTc 327-- Result has only the following HsLits: 328-- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim 329-- HsDoublePrim, HsStringPrim, HsString 330-- * HsInteger, HsRat, HsInt can't show up in LitPats 331-- * We get rid of HsChar right here 332tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c) 333tidyLitPat (HsString src s) 334 | lengthFS s <= 1 -- Short string literals only 335 = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon 336 [mkCharLitPat src c, pat] [charTy]) 337 (mkNilPat charTy) (unpackFS s) 338 -- The stringTy is the type of the whole pattern, not 339 -- the type to instantiate (:) or [] with! 340tidyLitPat lit = LitPat noExtField lit 341 342---------------- 343tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc 344 -> Type 345 -> Pat GhcTc 346tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty 347 -- False: Take short cuts only if the literal is not using rebindable syntax 348 -- 349 -- Once that is settled, look for cases where the type of the 350 -- entire overloaded literal matches the type of the underlying literal, 351 -- and in that case take the short cut 352 -- NB: Watch out for weird cases like #3382 353 -- f :: Int -> Int 354 -- f "blah" = 4 355 -- which might be ok if we have 'instance IsString Int' 356 -- 357 | not type_change, isIntTy ty, Just int_lit <- mb_int_lit 358 = mk_con_pat intDataCon (HsIntPrim NoSourceText int_lit) 359 | not type_change, isWordTy ty, Just int_lit <- mb_int_lit 360 = mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit) 361 | not type_change, isStringTy ty, Just str_lit <- mb_str_lit 362 = tidyLitPat (HsString NoSourceText str_lit) 363 -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3 364 -- If we do convert to the constructor form, we'll generate a case 365 -- expression on a Float# or Double# and that's not allowed in Core; see 366 -- #9238 and Note [Rules for floating-point comparisons] in PrelRules 367 where 368 -- Sometimes (like in test case 369 -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include 370 -- type-changing wrappers (for example, from Id Int to Int, for the identity 371 -- type family Id). In these cases, we can't do the short-cut. 372 type_change = not (outer_ty `eqType` ty) 373 374 mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc 375 mk_con_pat con lit 376 = unLoc (mkPrefixConPat con [noLoc $ LitPat noExtField lit] []) 377 378 mb_int_lit :: Maybe Integer 379 mb_int_lit = case (mb_neg, val) of 380 (Nothing, HsIntegral i) -> Just (il_value i) 381 (Just _, HsIntegral i) -> Just (-(il_value i)) 382 _ -> Nothing 383 384 mb_str_lit :: Maybe FastString 385 mb_str_lit = case (mb_neg, val) of 386 (Nothing, HsIsString _ s) -> Just s 387 _ -> Nothing 388 389tidyNPat over_lit mb_neg eq outer_ty 390 = NPat outer_ty (noLoc over_lit) mb_neg eq 391 392{- 393************************************************************************ 394* * 395 Pattern matching on LitPat 396* * 397************************************************************************ 398-} 399 400matchLiterals :: [Id] 401 -> Type -- Type of the whole case expression 402 -> [[EquationInfo]] -- All PgLits 403 -> DsM MatchResult 404 405matchLiterals (var:vars) ty sub_groups 406 = ASSERT( notNull sub_groups && all notNull sub_groups ) 407 do { -- Deal with each group 408 ; alts <- mapM match_group sub_groups 409 410 -- Combine results. For everything except String 411 -- we can use a case expression; for String we need 412 -- a chain of if-then-else 413 ; if isStringTy (idType var) then 414 do { eq_str <- dsLookupGlobalId eqStringName 415 ; mrs <- mapM (wrap_str_guard eq_str) alts 416 ; return (foldr1 combineMatchResults mrs) } 417 else 418 return (mkCoPrimCaseMatchResult var ty alts) 419 } 420 where 421 match_group :: [EquationInfo] -> DsM (Literal, MatchResult) 422 match_group eqns 423 = do { dflags <- getDynFlags 424 ; let LitPat _ hs_lit = firstPat (head eqns) 425 ; match_result <- match vars ty (shiftEqns eqns) 426 ; return (hsLitKey dflags hs_lit, match_result) } 427 428 wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult 429 -- Equality check for string literals 430 wrap_str_guard eq_str (LitString s, mr) 431 = do { -- We now have to convert back to FastString. Perhaps there 432 -- should be separate LitBytes and LitString constructors? 433 let s' = mkFastStringByteString s 434 ; lit <- mkStringExprFS s' 435 ; let pred = mkApps (Var eq_str) [Var var, lit] 436 ; return (mkGuardedMatchResult pred mr) } 437 wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) 438 439matchLiterals [] _ _ = panic "matchLiterals []" 440 441--------------------------- 442hsLitKey :: DynFlags -> HsLit GhcTc -> Literal 443-- Get the Core literal corresponding to a HsLit. 444-- It only works for primitive types and strings; 445-- others have been removed by tidy 446-- For HsString, it produces a LitString, which really represents an _unboxed_ 447-- string literal; and we deal with it in matchLiterals above. Otherwise, it 448-- produces a primitive Literal of type matching the original HsLit. 449-- In the case of the fixed-width numeric types, we need to wrap here 450-- because Literal has an invariant that the literal is in range, while 451-- HsLit does not. 452hsLitKey dflags (HsIntPrim _ i) = mkLitIntWrap dflags i 453hsLitKey dflags (HsWordPrim _ w) = mkLitWordWrap dflags w 454hsLitKey dflags (HsInt64Prim _ i) = mkLitInt64Wrap dflags i 455hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w 456hsLitKey _ (HsCharPrim _ c) = mkLitChar c 457hsLitKey _ (HsFloatPrim _ f) = mkLitFloat (fl_value f) 458hsLitKey _ (HsDoublePrim _ d) = mkLitDouble (fl_value d) 459hsLitKey _ (HsString _ s) = LitString (bytesFS s) 460hsLitKey _ l = pprPanic "hsLitKey" (ppr l) 461 462{- 463************************************************************************ 464* * 465 Pattern matching on NPat 466* * 467************************************************************************ 468-} 469 470matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult 471matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal 472 = do { let NPat _ (dL->L _ lit) mb_neg eq_chk = firstPat eqn1 473 ; lit_expr <- dsOverLit lit 474 ; neg_lit <- case mb_neg of 475 Nothing -> return lit_expr 476 Just neg -> dsSyntaxExpr neg [lit_expr] 477 ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit] 478 ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) 479 ; return (mkGuardedMatchResult pred_expr match_result) } 480matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns)) 481 482{- 483************************************************************************ 484* * 485 Pattern matching on n+k patterns 486* * 487************************************************************************ 488 489For an n+k pattern, we use the various magic expressions we've been given. 490We generate: 491\begin{verbatim} 492 if ge var lit then 493 let n = sub var lit 494 in <expr-for-a-successful-match> 495 else 496 <try-next-pattern-or-whatever> 497\end{verbatim} 498-} 499 500matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult 501-- All NPlusKPats, for the *same* literal k 502matchNPlusKPats (var:vars) ty (eqn1:eqns) 503 = do { let NPlusKPat _ (dL->L _ n1) (dL->L _ lit1) lit2 ge minus 504 = firstPat eqn1 505 ; lit1_expr <- dsOverLit lit1 506 ; lit2_expr <- dsOverLit lit2 507 ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr] 508 ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr] 509 ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) 510 ; match_result <- match vars ty eqns' 511 ; return (mkGuardedMatchResult pred_expr $ 512 mkCoLetMatchResult (NonRec n1 minusk_expr) $ 513 adjustMatchResult (foldr1 (.) wraps) $ 514 match_result) } 515 where 516 shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (dL->L _ n) _ _ _ _ : pats }) 517 = (wrapBind n n1, eqn { eqn_pats = pats }) 518 -- The wrapBind is a no-op for the first equation 519 shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) 520 521matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns)) 522