diff options
Diffstat (limited to 'compiler/deSugar/MatchLit.hs')
| -rw-r--r-- | compiler/deSugar/MatchLit.hs | 101 |
1 files changed, 76 insertions, 25 deletions
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index 94ffe81781..824dce138b 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -9,10 +9,11 @@ Pattern-matching literal patterns {-# LANGUAGE CPP, ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -module MatchLit ( dsLit, dsOverLit, dsOverLit', hsLitKey +module MatchLit ( dsLit, dsOverLit, hsLitKey , tidyLitPat, tidyNPat , matchLiterals, matchNPlusKPats, matchNPats - , warnAboutIdentities, warnAboutOverflowedLiterals + , warnAboutIdentities + , warnAboutOverflowedOverLit, warnAboutOverflowedLit , warnAboutEmptyEnumerations ) where @@ -39,6 +40,7 @@ import Name import Type import PrelNames import TysWiredIn +import TysPrim import Literal import SrcLoc import Data.Ratio @@ -106,19 +108,15 @@ dsLit l = do x -> pprPanic "dsLit" (ppr x) dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr -dsOverLit lit = do { dflags <- getDynFlags - ; warnAboutOverflowedLiterals dflags lit - ; dsOverLit' dflags lit } - -dsOverLit' :: DynFlags -> HsOverLit GhcTc -> DsM CoreExpr --- Post-typechecker, the HsExpr field of an OverLit contains --- (an expression for) the literal value itself -dsOverLit' dflags (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty - , ol_witness = witness }) - | not rebindable - , Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut] - | otherwise = dsExpr witness -dsOverLit' _ XOverLit{} = panic "dsOverLit'" +-- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains +-- (an expression for) the literal value itself. +dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty + , ol_witness = witness }) = do + dflags <- getDynFlags + case shortCutLit dflags val ty of + Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut] + _ -> dsExpr witness +dsOverLit XOverLit{} = panic "dsOverLit" {- Note [Literal short cut] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -158,11 +156,33 @@ conversionNames -- We can't easily add fromIntegerName, fromRationalName, -- because they are generated by literals -warnAboutOverflowedLiterals :: DynFlags -> HsOverLit GhcTc -> DsM () + +-- | Emit warnings on overloaded integral literals which overflow the bounds +-- implied by their type. +warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM () +warnAboutOverflowedOverLit hsOverLit = do + dflags <- getDynFlags + warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit) + +-- | Emit warnings on integral literals which overflow the boudns implied by +-- their type. +warnAboutOverflowedLit :: HsLit GhcTc -> DsM () +warnAboutOverflowedLit hsLit = do + dflags <- getDynFlags + warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit) + +-- | Emit warnings on integral literals which overflow the bounds implied by +-- their type. +warnAboutOverflowedLiterals + :: DynFlags + -> Maybe (Integer, Name) -- ^ the literal value and name of its tycon + -> DsM () warnAboutOverflowedLiterals dflags lit | wopt Opt_WarnOverflowedLiterals dflags - , Just (i, tc) <- getIntegralLit lit - = if tc == intTyConName then check i tc (Proxy :: Proxy Int) + , Just (i, tc) <- lit + = if tc == intTyConName then check i tc (Proxy :: Proxy Int) + + -- These only show up via the 'HsOverLit' route else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8) else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16) else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32) @@ -173,10 +193,22 @@ warnAboutOverflowedLiterals dflags lit else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32) else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64) else if tc == naturalTyConName then checkPositive i tc + + -- These only show up via the 'HsLit' route + else if tc == intPrimTyConName then check i tc (Proxy :: Proxy Int) + else if tc == int8PrimTyConName then check i tc (Proxy :: Proxy Int8) + else if tc == int32PrimTyConName then check i tc (Proxy :: Proxy Int32) + else if tc == int64PrimTyConName then check i tc (Proxy :: Proxy Int64) + else if tc == wordPrimTyConName then check i tc (Proxy :: Proxy Word) + else if tc == word8PrimTyConName then check i tc (Proxy :: Proxy Word8) + else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32) + else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64) + else return () | otherwise = return () where + checkPositive :: Integer -> Name -> DsM () checkPositive i tc = when (i < 0) $ do @@ -217,8 +249,8 @@ but perhaps that does not matter too much. warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc) -> LHsExpr GhcTc -> DsM () --- Warns about [2,3 .. 1] which returns the empty list --- Only works for integral types, not floating point +-- ^ Warns about @[2,3 .. 1]@ which returns the empty list. +-- Only works for integral types, not floating point. warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr | wopt Opt_WarnEmptyEnumerations dflags , Just (from,tc) <- getLHsIntegralLit fromExpr @@ -245,25 +277,44 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr else if tc == word32TyConName then check (Proxy :: Proxy Word32) else if tc == word64TyConName then check (Proxy :: Proxy Word64) else if tc == integerTyConName then check (Proxy :: Proxy Integer) + else if tc == naturalTyConName then check (Proxy :: Proxy Integer) + -- We use 'Integer' because otherwise a negative 'Natural' literal + -- could cause a compile time crash (instead of a runtime one). + -- See the T10930b test case for an example of where this matters. else return () | otherwise = return () getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name) --- See if the expression is an Integral literal +-- ^ See if the expression is an 'Integral' literal. -- Remember to look through automatically-added tick-boxes! (Trac #8384) getLHsIntegralLit (dL->L _ (HsPar _ e)) = getLHsIntegralLit e getLHsIntegralLit (dL->L _ (HsTick _ _ e)) = getLHsIntegralLit e getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit +getLHsIntegralLit (dL->L _ (HsLit _ lit)) = getSimpleIntegralLit lit getLHsIntegralLit _ = Nothing +-- | If 'Integral', extract the value and type name of the overloaded literal. getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name) getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty }) | Just tc <- tyConAppTyCon_maybe ty = Just (il_value i, tyConName tc) getIntegralLit _ = Nothing +-- | If 'Integral', extract the value and type name of the non-overloaded +-- literal. +getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name) +getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName) +getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName) +getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName) +getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName) +getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName) +getSimpleIntegralLit (HsInteger _ i ty) + | Just tc <- tyConAppTyCon_maybe ty + = Just (i, tyConName tc) +getSimpleIntegralLit _ = Nothing + {- ************************************************************************ * * @@ -369,10 +420,10 @@ matchLiterals (var:vars) ty sub_groups where match_group :: [EquationInfo] -> DsM (Literal, MatchResult) match_group eqns - = do dflags <- getDynFlags - let LitPat _ hs_lit = firstPat (head eqns) - match_result <- match vars ty (shiftEqns eqns) - return (hsLitKey dflags hs_lit, match_result) + = do { dflags <- getDynFlags + ; let LitPat _ hs_lit = firstPat (head eqns) + ; match_result <- match vars ty (shiftEqns eqns) + ; return (hsLitKey dflags hs_lit, match_result) } wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult -- Equality check for string literals |