module GHC.HsToCore.Match.Literal
( dsLit, dsOverLit, hsLitKey
, tidyLitPat, tidyNPat
, matchLiterals, matchNPlusKPats, matchNPats
, warnAboutIdentities
, warnAboutOverflowedOverLit, warnAboutOverflowedLit
, warnAboutEmptyEnumerations
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.HsToCore.Match ( match )
import GHC.HsToCore.Expr ( dsExpr, dsSyntaxExpr )
import GHC.HsToCore.Monad
import GHC.HsToCore.Utils
import GHC.Hs
import GHC.Types.Id
import GHC.Core
import GHC.Core.Make
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Tc.Utils.Zonk ( shortCutLit )
import GHC.Tc.Utils.TcType
import GHC.Types.Name
import GHC.Core.Type
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Types.Literal
import GHC.Types.SrcLoc
import Data.Ratio
import GHC.Utils.Outputable as Outputable
import GHC.Types.Basic
import GHC.Driver.Session
import GHC.Utils.Misc
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )
import Control.Monad
import Data.Int
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import Data.Word
import Data.Proxy
dsLit :: HsLit GhcRn -> DsM CoreExpr
dsLit l = do
dflags <- getDynFlags
let platform = targetPlatform dflags
case l of
HsStringPrim _ s -> return (Lit (LitString s))
HsCharPrim _ c -> return (Lit (LitChar c))
HsIntPrim _ i -> return (Lit (mkLitIntWrap platform i))
HsWordPrim _ w -> return (Lit (mkLitWordWrap platform w))
HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap platform i))
HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap platform w))
HsFloatPrim _ f -> return (Lit (LitFloat (fl_value f)))
HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d)))
HsChar _ c -> return (mkCharExpr c)
HsString _ str -> mkStringExprFS str
HsInteger _ i _ -> return (mkIntegerExpr i)
HsInt _ i -> return (mkIntExpr platform (il_value i))
HsRat _ (FL _ _ val) ty -> do
return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
where
num = mkIntegerExpr (numerator val)
denom = mkIntegerExpr (denominator val)
(ratio_data_con, integer_ty)
= case tcSplitTyConApp ty of
(tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
(head (tyConDataCons tycon), i_ty)
x -> pprPanic "dsLit" (ppr x)
dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
, ol_witness = witness }) = do
dflags <- getDynFlags
let platform = targetPlatform dflags
case shortCutLit platform val ty of
Just expr | not rebindable -> dsExpr expr
_ -> dsExpr witness
warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()
warnAboutIdentities dflags (Var conv_fn) type_of_conv
| wopt Opt_WarnIdentities dflags
, idName conv_fn `elem` conversionNames
, Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
, arg_ty `eqType` res_ty
= warnDs (Reason Opt_WarnIdentities)
(vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
, nest 2 $ text "can probably be omitted"
])
warnAboutIdentities _ _ _ = return ()
conversionNames :: [Name]
conversionNames
= [ toIntegerName, toRationalName
, fromIntegralName, realToFracName ]
warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
warnAboutOverflowedOverLit hsOverLit = do
dflags <- getDynFlags
fam_envs <- dsGetFamInstEnvs
warnAboutOverflowedLiterals dflags $
getIntegralLit hsOverLit >>= getNormalisedTyconName fam_envs
warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
warnAboutOverflowedLit hsLit = do
dflags <- getDynFlags
warnAboutOverflowedLiterals dflags $
getSimpleIntegralLit hsLit >>= getTyconName
warnAboutOverflowedLiterals
:: DynFlags
-> Maybe (Integer, Name)
-> DsM ()
warnAboutOverflowedLiterals dflags lit
| wopt Opt_WarnOverflowedLiterals dflags
, Just (i, tc) <- lit
= if tc == intTyConName then check i tc (Proxy :: Proxy Int)
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)
else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64)
else if tc == wordTyConName then check i tc (Proxy :: Proxy Word)
else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8)
else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16)
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
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
warnDs (Reason Opt_WarnOverflowedLiterals)
(vcat [ text "Literal" <+> integer i
<+> text "is negative but" <+> ppr tc
<+> ptext (sLit "only supports positive numbers")
])
check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()
check i tc _proxy
= when (i < minB || i > maxB) $ do
warnDs (Reason Opt_WarnOverflowedLiterals)
(vcat [ text "Literal" <+> integer i
<+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")
<+> integer minB <> text ".." <> integer maxB
, sug ])
where
minB = toInteger (minBound :: a)
maxB = toInteger (maxBound :: a)
sug | minB == i
, i > 0
, not (xopt LangExt.NegativeLiterals dflags)
= text "If you are trying to write a large negative literal, use NegativeLiterals"
| otherwise = Outputable.empty
warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc
-> Maybe (LHsExpr GhcTc)
-> LHsExpr GhcTc -> DsM ()
warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr
| not $ wopt Opt_WarnEmptyEnumerations dflags
= return ()
| Just from_ty@(from,_) <- getLHsIntegralLit fromExpr
, Just (_, tc) <- getNormalisedTyconName fam_envs from_ty
, Just mThn <- traverse getLHsIntegralLit mThnExpr
, Just (to,_) <- getLHsIntegralLit toExpr
, let check :: forall a. (Enum a, Num a) => Proxy a -> DsM ()
check _proxy
= when (null enumeration) raiseWarning
where
enumeration :: [a]
enumeration = case mThn of
Nothing -> [fromInteger from .. fromInteger to]
Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to]
= if tc == intTyConName then check (Proxy :: Proxy Int)
else if tc == int8TyConName then check (Proxy :: Proxy Int8)
else if tc == int16TyConName then check (Proxy :: Proxy Int16)
else if tc == int32TyConName then check (Proxy :: Proxy Int32)
else if tc == int64TyConName then check (Proxy :: Proxy Int64)
else if tc == wordTyConName then check (Proxy :: Proxy Word)
else if tc == word8TyConName then check (Proxy :: Proxy Word8)
else if tc == word16TyConName then check (Proxy :: Proxy Word16)
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)
else return ()
| Just fromChar <- getLHsCharLit fromExpr
, Just mThnChar <- traverse getLHsCharLit mThnExpr
, Just toChar <- getLHsCharLit toExpr
, let enumeration = case mThnChar of
Nothing -> [fromChar .. toChar]
Just thnChar -> [fromChar, thnChar .. toChar]
= when (null enumeration) raiseWarning
| otherwise = return ()
where
raiseWarning = warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")
getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type)
getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e
getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e
getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e
getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
getLHsIntegralLit (L _ (HsLit _ lit)) = getSimpleIntegralLit lit
getLHsIntegralLit _ = Nothing
getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type)
getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
= Just (il_value i, ty)
getIntegralLit _ = Nothing
getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type)
getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTy)
getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTy)
getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTy)
getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTy)
getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy)
getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty)
getSimpleIntegralLit _ = Nothing
getLHsCharLit :: LHsExpr GhcTc -> Maybe Char
getLHsCharLit (L _ (HsPar _ e)) = getLHsCharLit e
getLHsCharLit (L _ (HsTick _ _ e)) = getLHsCharLit e
getLHsCharLit (L _ (HsBinTick _ _ _ e)) = getLHsCharLit e
getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c
getLHsCharLit _ = Nothing
getNormalisedTyconName :: FamInstEnvs -> (Integer, Type) -> Maybe (Integer, Name)
getNormalisedTyconName fam_envs (i,ty)
| Just tc <- tyConAppTyCon_maybe (normaliseNominal fam_envs ty)
= Just (i, tyConName tc)
| otherwise = Nothing
where
normaliseNominal :: FamInstEnvs -> Type -> Type
normaliseNominal fam_envs ty = snd $ normaliseType fam_envs Nominal ty
getTyconName :: (Integer, Type) -> Maybe (Integer, Name)
getTyconName (i,ty)
| Just tc <- tyConAppTyCon_maybe ty = Just (i, tyConName tc)
| otherwise = Nothing
tidyLitPat :: HsLit GhcTc -> Pat GhcTc
tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
tidyLitPat (HsString src s)
| lengthFS s <= 1
= unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
[mkCharLitPat src c, pat] [charTy])
(mkNilPat charTy) (unpackFS s)
tidyLitPat lit = LitPat noExtField lit
tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
-> Type
-> Pat GhcTc
tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
| not type_change, isIntTy ty, Just int_lit <- mb_int_lit
= mk_con_pat intDataCon (HsIntPrim NoSourceText int_lit)
| not type_change, isWordTy ty, Just int_lit <- mb_int_lit
= mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit)
| not type_change, isStringTy ty, Just str_lit <- mb_str_lit
= tidyLitPat (HsString NoSourceText str_lit)
where
type_change = not (outer_ty `eqType` ty)
mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
mk_con_pat con lit
= unLoc (mkPrefixConPat con [noLoc $ LitPat noExtField lit] [])
mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
(Nothing, HsIntegral i) -> Just (il_value i)
(Just _, HsIntegral i) -> Just ((il_value i))
_ -> Nothing
mb_str_lit :: Maybe FastString
mb_str_lit = case (mb_neg, val) of
(Nothing, HsIsString _ s) -> Just s
_ -> Nothing
tidyNPat over_lit mb_neg eq outer_ty
= NPat outer_ty (noLoc over_lit) mb_neg eq
matchLiterals :: NonEmpty Id
-> Type
-> NonEmpty (NonEmpty EquationInfo)
-> DsM (MatchResult CoreExpr)
matchLiterals (var :| vars) ty sub_groups
= do {
; alts <- mapM match_group sub_groups
; if isStringTy (idType var) then
do { eq_str <- dsLookupGlobalId eqStringName
; mrs <- mapM (wrap_str_guard eq_str) alts
; return (foldr1 combineMatchResults mrs) }
else
return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts)
}
where
match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr)
match_group eqns@(firstEqn :| _)
= do { dflags <- getDynFlags
; let platform = targetPlatform dflags
; let LitPat _ hs_lit = firstPat firstEqn
; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
; return (hsLitKey platform hs_lit, match_result) }
wrap_str_guard :: Id -> (Literal,MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
wrap_str_guard eq_str (LitString s, mr)
= do {
let s' = mkFastStringByteString s
; lit <- mkStringExprFS s'
; let pred = mkApps (Var eq_str) [Var var, lit]
; return (mkGuardedMatchResult pred mr) }
wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
hsLitKey :: Platform -> HsLit GhcTc -> Literal
hsLitKey platform (HsIntPrim _ i) = mkLitIntWrap platform i
hsLitKey platform (HsWordPrim _ w) = mkLitWordWrap platform w
hsLitKey platform (HsInt64Prim _ i) = mkLitInt64Wrap platform i
hsLitKey platform (HsWord64Prim _ w) = mkLitWord64Wrap platform w
hsLitKey _ (HsCharPrim _ c) = mkLitChar c
hsLitKey _ (HsFloatPrim _ f) = mkLitFloat (fl_value f)
hsLitKey _ (HsDoublePrim _ d) = mkLitDouble (fl_value d)
hsLitKey _ (HsString _ s) = LitString (bytesFS s)
hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchNPats (var :| vars) ty (eqn1 :| eqns)
= do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
; lit_expr <- dsOverLit lit
; neg_lit <- case mb_neg of
Nothing -> return lit_expr
Just neg -> dsSyntaxExpr neg [lit_expr]
; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]
; match_result <- match vars ty (shiftEqns (eqn1:eqns))
; return (mkGuardedMatchResult pred_expr match_result) }
matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
= do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus
= firstPat eqn1
; lit1_expr <- dsOverLit lit1
; lit2_expr <- dsOverLit lit2
; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr]
; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]
; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
; match_result <- match vars ty eqns'
; return (mkGuardedMatchResult pred_expr $
mkCoLetMatchResult (NonRec n1 minusk_expr) $
fmap (foldr1 (.) wraps) $
match_result) }
where
shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
= (wrapBind n n1, eqn { eqn_pats = pats })
shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)