module GHC.Rename.Pat (
rnPat, rnPats, rnBindPat, rnPatAndThen,
NameMaker, applyNameMaker,
localRecNameMaker, topRecNameMaker,
isTopRecNameMaker,
rnHsRecFields, HsRecFieldContext(..),
rnHsRecUpdFields,
CpsRn, liftCps, liftCpsWithCont,
rnLit, rnOverLit,
) where
import GHC.Prelude
import GHC.Rename.Expr ( rnLExpr )
import GHC.Rename.Splice ( rnSplicePat )
import GHC.Hs
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Zonk ( hsOverLitName )
import GHC.Rename.Env
import GHC.Rename.Fixity
import GHC.Rename.Utils ( newLocalBndrRn, bindLocalNames
, warnUnusedMatches, newLocalBndrRn
, checkUnusedRecordWildcard
, checkDupNames, checkDupAndShadowedNames
, wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, warnForallIdentifier )
import GHC.Rename.HsType
import GHC.Builtin.Names
import GHC.Types.Avail ( greNameMangledName )
import GHC.Types.Error
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Reader
import GHC.Types.Basic
import GHC.Types.SourceText
import GHC.Utils.Misc
import GHC.Data.List.SetOps( removeDups )
import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Types.Literal ( inCharRange )
import GHC.Builtin.Types ( nilDataCon )
import GHC.Core.DataCon
import GHC.Driver.Session ( getDynFlags, xopt_DuplicateRecordFields )
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad ( when, ap, guard, forM, unless )
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.Ratio
import GHC.Types.FieldLabel (DuplicateRecordFields(..))
newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))
-> RnM (r, FreeVars) }
deriving (Functor)
instance Applicative CpsRn where
pure x = CpsRn (\k -> k x)
(<*>) = ap
instance Monad CpsRn where
(CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
runCps :: CpsRn a -> RnM (a, FreeVars)
runCps (CpsRn m) = m (\r -> return (r, emptyFVs))
liftCps :: RnM a -> CpsRn a
liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)
liftCpsFV :: RnM (a, FreeVars) -> CpsRn a
liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing
; (r,fvs2) <- k v
; return (r, fvs1 `plusFV` fvs2) })
liftCpsWithCont :: (forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)) -> CpsRn b
liftCpsWithCont = CpsRn
wrapSrcSpanCps :: (a -> CpsRn b) -> LocatedA a -> CpsRn (LocatedA b)
wrapSrcSpanCps fn (L loc a)
= CpsRn (\k -> setSrcSpanA loc $
unCpsRn (fn a) $ \v ->
k (L loc v))
lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN Name)
lookupConCps con_rdr
= CpsRn (\k -> do { con_name <- lookupLocatedOccRnConstr con_rdr
; (r, fvs) <- k con_name
; return (r, addOneFV fvs (unLoc con_name)) })
data NameMaker
= LamMk
Bool
| LetMk
TopLevelFlag
MiniFixityEnv
topRecNameMaker :: MiniFixityEnv -> NameMaker
topRecNameMaker fix_env = LetMk TopLevel fix_env
isTopRecNameMaker :: NameMaker -> Bool
isTopRecNameMaker (LetMk TopLevel _) = True
isTopRecNameMaker _ = False
localRecNameMaker :: MiniFixityEnv -> NameMaker
localRecNameMaker fix_env = LetMk NotTopLevel fix_env
matchNameMaker :: HsMatchContext a -> NameMaker
matchNameMaker ctxt = LamMk report_unused
where
report_unused = case ctxt of
StmtCtxt (HsDoStmt GhciStmtCtxt) -> False
ThPatQuote -> False
_ -> True
newPatLName :: NameMaker -> LocatedN RdrName -> CpsRn (LocatedN Name)
newPatLName name_maker rdr_name@(L loc _)
= do { name <- newPatName name_maker rdr_name
; return (L loc name) }
newPatName :: NameMaker -> LocatedN RdrName -> CpsRn Name
newPatName (LamMk report_unused) rdr_name
= CpsRn (\ thing_inside ->
do { warnForallIdentifier rdr_name
; name <- newLocalBndrRn rdr_name
; (res, fvs) <- bindLocalNames [name] (thing_inside name)
; when report_unused $ warnUnusedMatches [name] fvs
; return (res, name `delFV` fvs) })
newPatName (LetMk is_top fix_env) rdr_name
= CpsRn (\ thing_inside ->
do { warnForallIdentifier rdr_name
; name <- case is_top of
NotTopLevel -> newLocalBndrRn rdr_name
TopLevel -> newTopSrcBinder rdr_name
; bindLocalNames [name] $
addLocalFixities fix_env [name] $
thing_inside name })
rnPats :: HsMatchContext GhcRn
-> [LPat GhcPs]
-> ([LPat GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPats ctxt pats thing_inside
= do { envs_before <- getRdrEnvs
; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do
{
; let bndrs = collectPatsBinders CollNoDictBinders pats'
; addErrCtxt doc_pat $
if isPatSynCtxt ctxt
then checkDupNames bndrs
else checkDupAndShadowedNames envs_before bndrs
; thing_inside pats' } }
where
doc_pat = text "In" <+> pprMatchContext ctxt
rnPat :: HsMatchContext GhcRn
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPat ctxt pat thing_inside
= rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')
applyNameMaker :: NameMaker -> LocatedN RdrName -> RnM (LocatedN Name)
applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)
; return n }
rnBindPat :: NameMaker
-> LPat GhcPs
-> RnM (LPat GhcRn, FreeVars)
rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)
rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]
rnLPatsAndThen mk = mapM (rnLPatAndThen mk)
rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
rnPatAndThen _ (WildPat _) = return (WildPat noExtField)
rnPatAndThen mk (ParPat x lpar pat rpar) =
do { pat' <- rnLPatAndThen mk pat
; return (ParPat x lpar pat' rpar) }
rnPatAndThen mk (LazyPat _ pat) = do { pat' <- rnLPatAndThen mk pat
; return (LazyPat noExtField pat') }
rnPatAndThen mk (BangPat _ pat) = do { pat' <- rnLPatAndThen mk pat
; return (BangPat noExtField pat') }
rnPatAndThen mk (VarPat x (L l rdr))
= do { loc <- liftCps getSrcSpanM
; name <- newPatName mk (L (noAnnSrcSpan loc) rdr)
; return (VarPat x (L l name)) }
rnPatAndThen mk (SigPat _ pat sig)
= do { sig' <- rnHsPatSigTypeAndThen sig
; pat' <- rnLPatAndThen mk pat
; return (SigPat noExtField pat' sig' ) }
where
rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn)
rnHsPatSigTypeAndThen sig = liftCpsWithCont (rnHsPatSigType AlwaysBind PatCtx sig)
rnPatAndThen mk (LitPat x lit)
| HsString src s <- lit
= do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
; if ovlStr
then rnPatAndThen mk
(mkNPat (noLocA (mkHsIsString src s))
Nothing noAnn)
else normal_lit }
| otherwise = normal_lit
where
normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }
rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
= do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
; mb_neg'
<- let negative = do { (neg, fvs) <- lookupSyntax negateName
; return (Just neg, fvs) }
positive = return (Nothing, emptyFVs)
in liftCpsFV $ case (mb_neg , mb_neg') of
(Nothing, Just _ ) -> negative
(Just _ , Nothing) -> negative
(Nothing, Nothing) -> positive
(Just _ , Just _ ) -> positive
; eq' <- liftCpsFV $ lookupSyntax eqName
; return (NPat x (L l lit') mb_neg' eq') }
rnPatAndThen mk (NPlusKPat _ rdr (L l lit) _ _ _ )
= do { new_name <- newPatName mk (l2n rdr)
; (lit', _) <- liftCpsFV $ rnOverLit lit
; minus <- liftCpsFV $ lookupSyntax minusName
; ge <- liftCpsFV $ lookupSyntax geName
; return (NPlusKPat noExtField (L (noAnnSrcSpan $ nameSrcSpan new_name) new_name)
(L l lit') lit' ge minus) }
rnPatAndThen mk (AsPat _ rdr pat)
= do { new_name <- newPatLName mk rdr
; pat' <- rnLPatAndThen mk pat
; return (AsPat noExtField new_name pat') }
rnPatAndThen mk p@(ViewPat _ expr pat)
= do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
; checkErr vp_flag (TcRnIllegalViewPattern p) }
; expr' <- liftCpsFV $ rnLExpr expr
; pat' <- rnLPatAndThen mk pat
; return (ViewPat Nothing expr' pat') }
rnPatAndThen mk (ConPat _ con args)
= case unLoc con == nameRdrName (dataConName nilDataCon) of
True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
; if ol_flag then rnPatAndThen mk (ListPat noAnn [])
else rnConPatAndThen mk con args}
False -> rnConPatAndThen mk con args
rnPatAndThen mk (ListPat _ pats)
= do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
; pats' <- rnLPatsAndThen mk pats
; if not opt_OverloadedLists
then return (ListPat noExtField pats')
else
do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
; (from_list_n_name,_) <- liftCps $ lookupSyntaxName fromListNName
; let
lit_n = mkIntegralLit (length pats)
hs_lit = genHsIntegralLit lit_n
inverse = genHsApps from_list_n_name [hs_lit]
rn_list_pat = ListPat noExtField pats'
exp_expr = genLHsVar to_list_name
exp_list_pat = ViewPat (Just inverse) exp_expr (wrapGenSpan rn_list_pat)
; return $ mkExpandedPat rn_list_pat exp_list_pat }}
rnPatAndThen mk (TuplePat _ pats boxed)
= do { pats' <- rnLPatsAndThen mk pats
; return (TuplePat noExtField pats' boxed) }
rnPatAndThen mk (SumPat _ pat alt arity)
= do { pat <- rnLPatAndThen mk pat
; return (SumPat noExtField pat alt arity)
}
rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat)))
= SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat
rnPatAndThen mk (SplicePat _ splice)
= do { eith <- liftCpsFV $ rnSplicePat splice
; case eith of
Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed
Right already_renamed -> return already_renamed }
rnConPatAndThen :: NameMaker
-> LocatedN RdrName
-> HsConPatDetails GhcPs
-> CpsRn (Pat GhcRn)
rnConPatAndThen mk con (PrefixCon tyargs pats)
= do { con' <- lookupConCps con
; liftCps check_lang_exts
; tyargs' <- forM tyargs $ \t ->
liftCpsWithCont $ rnHsPatSigTypeBindingVars HsTypeCtx t
; pats' <- rnLPatsAndThen mk pats
; return $ ConPat
{ pat_con_ext = noExtField
, pat_con = con'
, pat_args = PrefixCon tyargs' pats'
}
}
where
check_lang_exts :: RnM ()
check_lang_exts = do
scoped_tyvars <- xoptM LangExt.ScopedTypeVariables
type_app <- xoptM LangExt.TypeApplications
unless (scoped_tyvars && type_app) $
case listToMaybe tyargs of
Nothing -> pure ()
Just tyarg -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $
hang (text "Illegal visible type application in a pattern:"
<+> quotes (char '@' <> ppr tyarg))
2 (text "Both ScopedTypeVariables and TypeApplications are"
<+> text "required to use this feature")
rnConPatAndThen mk con (InfixCon pat1 pat2)
= do { con' <- lookupConCps con
; pat1' <- rnLPatAndThen mk pat1
; pat2' <- rnLPatAndThen mk pat2
; fixity <- liftCps $ lookupFixityRn (unLoc con')
; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }
rnConPatAndThen mk con (RecCon rpats)
= do { con' <- lookupConCps con
; rpats' <- rnHsRecPatsAndThen mk con' rpats
; return $ ConPat
{ pat_con_ext = noExtField
, pat_con = con'
, pat_args = RecCon rpats'
}
}
checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()
checkUnusedRecordWildcardCps loc dotdot_names =
CpsRn (\thing -> do
(r, fvs) <- thing ()
checkUnusedRecordWildcard loc fvs dotdot_names
return (r, fvs) )
rnHsRecPatsAndThen :: NameMaker
-> LocatedN Name
-> HsRecFields GhcPs (LPat GhcPs)
-> CpsRn (HsRecFields GhcRn (LPat GhcRn))
rnHsRecPatsAndThen mk (L _ con)
hs_rec_fields@(HsRecFields { rec_dotdot = dd })
= do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat
hs_rec_fields
; flds' <- mapM rn_field (flds `zip` [1..])
; check_unused_wildcard (implicit_binders flds' <$> dd)
; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
where
mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n)
rn_field (L l fld, n') =
do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hfbRHS fld)
; return (L l (fld { hfbRHS = arg' })) }
loc = maybe noSrcSpan getLoc dd
implicit_binders fs (unLoc -> n) = collectPatsBinders CollNoDictBinders implicit_pats
where
implicit_pats = map (hfbRHS . unLoc) (drop n fs)
check_unused_wildcard = case mk of
LetMk{} -> const (return ())
LamMk{} -> checkUnusedRecordWildcardCps loc
nested_mk Nothing mk _ = mk
nested_mk (Just _) mk@(LetMk {}) _ = mk
nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'
= LamMk (report_unused && (n' <= n))
mkExpandedPat
:: Pat GhcRn
-> Pat GhcRn
-> Pat GhcRn
mkExpandedPat a b = XPat (HsPatExpanded a b)
data HsRecFieldContext
= HsRecFieldCon Name
| HsRecFieldPat Name
| HsRecFieldUpd
rnHsRecFields
:: forall arg.
HsRecFieldContext
-> (SrcSpan -> RdrName -> arg)
-> HsRecFields GhcPs (LocatedA arg)
-> RnM ([LHsRecField GhcRn (LocatedA arg)], FreeVars)
rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
= do { pun_ok <- xoptM LangExt.NamedFieldPuns
; disambig_ok <- xoptM LangExt.DisambiguateRecordFields
; let parent = guard disambig_ok >> mb_con
; flds1 <- mapM (rn_fld pun_ok parent) flds
; mapM_ (addErr . dupFieldErr ctxt) dup_flds
; dotdot_flds <- rn_dotdot dotdot mb_con flds1
; let all_flds | null dotdot_flds = flds1
| otherwise = flds1 ++ dotdot_flds
; return (all_flds, mkFVs (getFieldIds all_flds)) }
where
mb_con = case ctxt of
HsRecFieldCon con -> Just con
HsRecFieldPat con -> Just con
_ -> Nothing
rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (LocatedA arg)
-> RnM (LHsRecField GhcRn (LocatedA arg))
rn_fld pun_ok parent (L l
(HsFieldBind
{ hfbLHS =
(L loc (FieldOcc _ (L ll lbl)))
, hfbRHS = arg
, hfbPun = pun }))
= do { sel <- setSrcSpanA loc $ lookupRecFieldOcc parent lbl
; arg' <- if pun
then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))
; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
; return (L (l2l loc) (mk_arg (locA loc) arg_rdr)) }
else return arg
; return (L l (HsFieldBind
{ hfbAnn = noAnn
, hfbLHS = (L loc (FieldOcc sel (L ll lbl)))
, hfbRHS = arg'
, hfbPun = pun })) }
rn_dotdot :: Maybe (Located Int)
-> Maybe Name
-> [LHsRecField GhcRn (LocatedA arg)]
-> RnM ([LHsRecField GhcRn (LocatedA arg)])
rn_dotdot (Just (L loc n)) (Just con) flds
| not (isUnboundName con)
= assert (flds `lengthIs` n) $
do { dd_flag <- xoptM LangExt.RecordWildCards
; checkErr dd_flag (needFlagDotDot ctxt)
; (rdr_env, lcl_env) <- getRdrEnvs
; con_fields <- lookupConstructorFields con
; when (null con_fields) (addErr (TcRnIllegalWildcardsInConstructor con))
; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)
arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env
(dot_dot_fields, dot_dot_gres)
= unzip [ (fl, gre)
| fl <- con_fields
, let lbl = mkVarOccFS (flLabel fl)
, not (lbl `elemOccSet` present_flds)
, Just gre <- [lookupGRE_FieldLabel rdr_env fl]
, case ctxt of
HsRecFieldCon {} -> arg_in_scope lbl
_other -> True ]
; addUsedGREs dot_dot_gres
; let locn = noAnnSrcSpan loc
; return [ L (noAnnSrcSpan loc) (HsFieldBind
{ hfbAnn = noAnn
, hfbLHS
= L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))
, hfbRHS = L locn (mk_arg loc arg_rdr)
, hfbPun = False })
| fl <- dot_dot_fields
, let sel = flSelector fl
, let arg_rdr = mkVarUnqual (flLabel fl) ] }
rn_dotdot _dotdot _mb_con _flds
= return []
dup_flds :: [NE.NonEmpty RdrName]
(_, dup_flds) = removeDups compare (getFieldLbls flds)
rnHsRecUpdFields
:: [LHsRecUpdField GhcPs]
-> RnM ([LHsRecUpdField GhcRn], FreeVars)
rnHsRecUpdFields flds
= do { pun_ok <- xoptM LangExt.NamedFieldPuns
; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags
; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok dup_fields_ok) flds
; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds
; when (null flds) $ addErr TcRnEmptyRecordUpdate
; return (flds1, plusFVs fvss) }
where
rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs
-> RnM (LHsRecUpdField GhcRn, FreeVars)
rn_fld pun_ok dup_fields_ok (L l (HsFieldBind { hfbLHS = L loc f
, hfbRHS = arg
, hfbPun = pun }))
= do { let lbl = rdrNameAmbiguousFieldOcc f
; mb_sel <- setSrcSpanA loc $
lookupRecFieldOcc_update dup_fields_ok lbl
; arg' <- if pun
then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))
; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
; return (L (l2l loc) (HsVar noExtField
(L (l2l loc) arg_rdr))) }
else return arg
; (arg'', fvs) <- rnLExpr arg'
; let (lbl', fvs') = case mb_sel of
UnambiguousGre gname -> let sel_name = greNameMangledName gname
in (Unambiguous sel_name (L (l2l loc) lbl), fvs `addOneFV` sel_name)
AmbiguousFields -> (Ambiguous noExtField (L (l2l loc) lbl), fvs)
; return (L l (HsFieldBind { hfbAnn = noAnn
, hfbLHS = L loc lbl'
, hfbRHS = arg''
, hfbPun = pun }), fvs') }
dup_flds :: [NE.NonEmpty RdrName]
(_, dup_flds) = removeDups compare (getFieldUpdLbls flds)
getFieldIds :: [LHsRecField GhcRn arg] -> [Name]
getFieldIds flds = map (hsRecFieldSel . unLoc) flds
getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName]
getFieldLbls flds
= map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p) flds
getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) flds
needFlagDotDot :: HsRecFieldContext -> TcRnMessage
needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart
dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> TcRnMessage
dupFieldErr ctxt = TcRnDuplicateFieldName (toRecordFieldPart ctxt)
toRecordFieldPart :: HsRecFieldContext -> RecordFieldPart
toRecordFieldPart (HsRecFieldCon n) = RecordFieldConstructor n
toRecordFieldPart (HsRecFieldPat n) = RecordFieldPattern n
toRecordFieldPart (HsRecFieldUpd {}) = RecordFieldUpdate
rnLit :: HsLit p -> RnM ()
rnLit (HsChar _ c) = checkErr (inCharRange c) (TcRnCharLiteralOutOfRange c)
rnLit _ = return ()
generalizeOverLitVal :: OverLitVal -> OverLitVal
generalizeOverLitVal (HsFractional fl@(FL {fl_text=src,fl_neg=neg,fl_exp=e}))
| e >= 100 && e <= 100
, let val = rationalFromFractionalLit fl
, denominator val == 1 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val})
generalizeOverLitVal lit = lit
isNegativeZeroOverLit :: HsOverLit t -> Bool
isNegativeZeroOverLit lit
= case ol_val lit of
HsIntegral i -> 0 == il_value i && il_neg i
HsFractional fl -> 0 == fl_signi fl && fl_neg fl
_ -> False
rnOverLit :: HsOverLit t ->
RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
rnOverLit origLit
= do { opt_NumDecimals <- xoptM LangExt.NumDecimals
; let { lit@(OverLit {ol_val=val})
| opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)}
| otherwise = origLit
}
; let std_name = hsOverLitName val
; (from_thing_name, fvs1) <- lookupSyntaxName std_name
; let rebindable = from_thing_name /= std_name
lit' = lit { ol_ext = OverLitRn { ol_rebindable = rebindable
, ol_from_fun = noLocA from_thing_name } }
; if isNegativeZeroOverLit lit'
then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName
; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
, fvs1 `plusFV` fvs2) }
else return ((lit', Nothing), fvs1) }