module MatchLit ( dsLit, dsOverLit, dsOverLit', hsLitKey
, tidyLitPat, tidyNPat
, matchLiterals, matchNPlusKPats, matchNPats
, warnAboutIdentities, warnAboutOverflowedLiterals
, warnAboutEmptyEnumerations
) where
#include "HsVersions.h"
import Match ( match )
import DsExpr ( dsExpr, dsSyntaxExpr )
import DsMonad
import DsUtils
import HsSyn
import Id
import CoreSyn
import MkCore
import TyCon
import DataCon
import TcHsSyn ( shortCutLit )
import TcType
import Name
import Type
import PrelNames
import TysWiredIn
import Literal
import SrcLoc
import Data.Ratio
import Outputable
import BasicTypes
import DynFlags
import Util
import FastString
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.Int
import Data.Word
dsLit :: HsLit -> DsM CoreExpr
dsLit (HsStringPrim _ s) = return (Lit (MachStr s))
dsLit (HsCharPrim _ c) = return (Lit (MachChar c))
dsLit (HsIntPrim _ i) = return (Lit (MachInt i))
dsLit (HsWordPrim _ w) = return (Lit (MachWord w))
dsLit (HsInt64Prim _ i) = return (Lit (MachInt64 i))
dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w))
dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f)))
dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d)))
dsLit (HsChar _ c) = return (mkCharExpr c)
dsLit (HsString _ str) = mkStringExprFS str
dsLit (HsInteger _ i _) = mkIntegerExpr i
dsLit (HsInt _ i) = do dflags <- getDynFlags
return (mkIntExpr dflags i)
dsLit (HsRat r ty) = do
num <- mkIntegerExpr (numerator (fl_value r))
denom <- mkIntegerExpr (denominator (fl_value r))
return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
where
(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 Id -> DsM CoreExpr
dsOverLit lit = do { dflags <- getDynFlags
; warnAboutOverflowedLiterals dflags lit
; dsOverLit' dflags lit }
dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr
dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
, ol_witness = witness, ol_type = ty })
| not rebindable
, Just expr <- shortCutLit dflags val ty = dsExpr expr
| otherwise = 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 ]
warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM ()
warnAboutOverflowedLiterals dflags lit
| wopt Opt_WarnOverflowedLiterals dflags
, Just (i, tc) <- getIntegralLit lit
= if tc == intTyConName then check i tc (undefined :: Int)
else if tc == int8TyConName then check i tc (undefined :: Int8)
else if tc == int16TyConName then check i tc (undefined :: Int16)
else if tc == int32TyConName then check i tc (undefined :: Int32)
else if tc == int64TyConName then check i tc (undefined :: Int64)
else if tc == wordTyConName then check i tc (undefined :: Word)
else if tc == word8TyConName then check i tc (undefined :: Word8)
else if tc == word16TyConName then check i tc (undefined :: Word16)
else if tc == word32TyConName then check i tc (undefined :: Word32)
else if tc == word64TyConName then check i tc (undefined :: Word64)
else return ()
| otherwise = return ()
where
check :: forall a. (Bounded a, Integral a) => Integer -> Name -> 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 :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM ()
warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
| wopt Opt_WarnEmptyEnumerations dflags
, Just (from,tc) <- getLHsIntegralLit fromExpr
, Just mThn <- traverse getLHsIntegralLit mThnExpr
, Just (to,_) <- getLHsIntegralLit toExpr
, let check :: forall a. (Enum a, Num a) => a -> DsM ()
check _proxy
= when (null enumeration) $
warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")
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 (undefined :: Int)
else if tc == int8TyConName then check (undefined :: Int8)
else if tc == int16TyConName then check (undefined :: Int16)
else if tc == int32TyConName then check (undefined :: Int32)
else if tc == int64TyConName then check (undefined :: Int64)
else if tc == wordTyConName then check (undefined :: Word)
else if tc == word8TyConName then check (undefined :: Word8)
else if tc == word16TyConName then check (undefined :: Word16)
else if tc == word32TyConName then check (undefined :: Word32)
else if tc == word64TyConName then check (undefined :: Word64)
else if tc == integerTyConName then check (undefined :: Integer)
else return ()
| otherwise = return ()
getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name)
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 _ = Nothing
getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name)
getIntegralLit (OverLit { ol_val = HsIntegral _ i, ol_type = ty })
| Just tc <- tyConAppTyCon_maybe ty
= Just (i, tyConName tc)
getIntegralLit _ = Nothing
tidyLitPat :: HsLit -> Pat Id
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 lit
tidyNPat :: (HsLit -> Pat Id)
-> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Type
-> Pat Id
tidyNPat tidy_lit_pat (OverLit val False _ ty) 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
= tidy_lit_pat (HsString NoSourceText str_lit)
where
type_change = not (outer_ty `eqType` ty)
mk_con_pat :: DataCon -> HsLit -> Pat Id
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
mb_int_lit :: Maybe Integer
mb_int_lit = case (mb_neg, val) of
(Nothing, HsIntegral _ i) -> Just i
(Just _, HsIntegral _ i) -> Just (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 (noLoc over_lit) mb_neg eq outer_ty
matchLiterals :: [Id]
-> Type
-> [[EquationInfo]]
-> DsM MatchResult
matchLiterals (var:vars) ty sub_groups
= ASSERT( notNull sub_groups && all notNull 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 alts)
}
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)
wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
wrap_str_guard eq_str (MachStr 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)
matchLiterals [] _ _ = panic "matchLiterals []"
hsLitKey :: DynFlags -> HsLit -> Literal
hsLitKey dflags (HsIntPrim _ i) = mkMachIntWrap dflags i
hsLitKey dflags (HsWordPrim _ w) = mkMachWordWrap dflags w
hsLitKey _ (HsInt64Prim _ i) = mkMachInt64Wrap i
hsLitKey _ (HsWord64Prim _ w) = mkMachWord64Wrap w
hsLitKey _ (HsCharPrim _ c) = mkMachChar c
hsLitKey _ (HsFloatPrim f) = mkMachFloat (fl_value f)
hsLitKey _ (HsDoublePrim d) = mkMachDouble (fl_value d)
hsLitKey _ (HsString _ s) = MachStr (fastStringToByteString s)
hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
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) }
matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
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) $
adjustMatchResult (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)
matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))