module RnPat (
rnPat, rnPats, rnBindPat, rnPatAndThen,
NameMaker, applyNameMaker,
localRecNameMaker, topRecNameMaker,
isTopRecNameMaker,
rnHsRecFields, HsRecFieldContext(..),
rnHsRecUpdFields,
CpsRn, liftCps,
rnLit, rnOverLit,
checkTupSize, patSigErr
) where
import GhcPrelude
import RnExpr ( rnLExpr )
import RnSplice ( rnSplicePat )
#include "HsVersions.h"
import HsSyn
import TcRnMonad
import TcHsSyn ( hsOverLitName )
import RnEnv
import RnFixity
import RnUtils ( HsDocContext(..), newLocalBndrRn, bindLocalNames
, warnUnusedMatches, newLocalBndrRn
, checkDupNames, checkDupAndShadowedNames
, checkTupSize , unknownSubordinateErr )
import RnTypes
import PrelNames
import Name
import NameSet
import RdrName
import BasicTypes
import Util
import ListSetOps ( removeDups )
import Outputable
import SrcLoc
import Literal ( inCharRange )
import TysWiredIn ( nilDataCon )
import DataCon
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad ( when, liftM, ap, guard )
import qualified Data.List.NonEmpty as NE
import Data.Ratio
newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))
-> RnM (r, FreeVars) }
instance Functor CpsRn where
fmap = liftM
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) })
wrapSrcSpanCps :: (HasSrcSpan a, HasSrcSpan b) =>
(SrcSpanLess a -> CpsRn (SrcSpanLess b)) -> a -> CpsRn b
wrapSrcSpanCps fn (dL->L loc a)
= CpsRn (\k -> setSrcSpan loc $
unCpsRn (fn a) $ \v ->
k (cL loc v))
lookupConCps :: Located RdrName -> CpsRn (Located Name)
lookupConCps con_rdr
= CpsRn (\k -> do { con_name <- lookupLocatedOccRn 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 GhciStmtCtxt -> False
ThPatQuote -> False
_ -> True
rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn)
rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig)
newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
newPatLName name_maker rdr_name@(dL->L loc _)
= do { name <- newPatName name_maker rdr_name
; return (cL loc name) }
newPatName :: NameMaker -> Located RdrName -> CpsRn Name
newPatName (LamMk report_unused) rdr_name
= CpsRn (\ thing_inside ->
do { 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 { name <- case is_top of
NotTopLevel -> newLocalBndrRn rdr_name
TopLevel -> newTopSrcBinder rdr_name
; bindLocalNames [name] $
addLocalFixities fix_env [name] $
thing_inside name })
rnPats :: HsMatchContext Name
-> [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 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 Name
-> 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 -> Located RdrName -> RnM (Located 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 noExt)
rnPatAndThen mk (ParPat x pat) = do { pat' <- rnLPatAndThen mk pat
; return (ParPat x pat') }
rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat
; return (LazyPat x pat') }
rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat
; return (BangPat x pat') }
rnPatAndThen mk (VarPat x (dL->L l rdr))
= do { loc <- liftCps getSrcSpanM
; name <- newPatName mk (cL loc rdr)
; return (VarPat x (cL l name)) }
rnPatAndThen mk (SigPat x pat sig)
= do { sig' <- rnHsSigCps sig
; pat' <- rnLPatAndThen mk pat
; return (SigPat x pat' sig' ) }
rnPatAndThen mk (LitPat x lit)
| HsString src s <- lit
= do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
; if ovlStr
then rnPatAndThen mk
(mkNPat (noLoc (mkHsIsString src s))
Nothing)
else normal_lit }
| otherwise = normal_lit
where
normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }
rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq)
= do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
; mb_neg'
<- let negative = do { (neg, fvs) <- lookupSyntaxName 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 $ lookupSyntaxName eqName
; return (NPat x (cL l lit') mb_neg' eq') }
rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ )
= do { new_name <- newPatName mk rdr
; (lit', _) <- liftCpsFV $ rnOverLit lit
; minus <- liftCpsFV $ lookupSyntaxName minusName
; ge <- liftCpsFV $ lookupSyntaxName geName
; return (NPlusKPat x (cL (nameSrcSpan new_name) new_name)
(cL l lit') lit' ge minus) }
rnPatAndThen mk (AsPat x rdr pat)
= do { new_name <- newPatLName mk rdr
; pat' <- rnLPatAndThen mk pat
; return (AsPat x new_name pat') }
rnPatAndThen mk p@(ViewPat x expr pat)
= do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
; checkErr vp_flag (badViewPat p) }
; expr' <- liftCpsFV $ rnLExpr expr
; pat' <- rnLPatAndThen mk pat
; return (ViewPat x expr' pat') }
rnPatAndThen mk (ConPatIn con stuff)
= case unLoc con == nameRdrName (dataConName nilDataCon) of
True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
; if ol_flag then rnPatAndThen mk (ListPat noExt [])
else rnConPatAndThen mk con stuff}
False -> rnConPatAndThen mk con stuff
rnPatAndThen mk (ListPat _ pats)
= do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
; pats' <- rnLPatsAndThen mk pats
; case opt_OverloadedLists of
True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
; return (ListPat (Just to_list_name) pats')}
False -> return (ListPat Nothing pats') }
rnPatAndThen mk (TuplePat x pats boxed)
= do { liftCps $ checkTupSize (length pats)
; pats' <- rnLPatsAndThen mk pats
; return (TuplePat x pats' boxed) }
rnPatAndThen mk (SumPat x pat alt arity)
= do { pat <- rnLPatAndThen mk pat
; return (SumPat x 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 }
rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)
rnConPatAndThen :: NameMaker
-> Located RdrName
-> HsConPatDetails GhcPs
-> CpsRn (Pat GhcRn)
rnConPatAndThen mk con (PrefixCon pats)
= do { con' <- lookupConCps con
; pats' <- rnLPatsAndThen mk pats
; return (ConPatIn con' (PrefixCon pats')) }
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 (ConPatIn con' (RecCon rpats')) }
rnHsRecPatsAndThen :: NameMaker
-> Located Name
-> HsRecFields GhcPs (LPat GhcPs)
-> CpsRn (HsRecFields GhcRn (LPat GhcRn))
rnHsRecPatsAndThen mk (dL->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..])
; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
where
mkVarPat l n = VarPat noExt (cL l n)
rn_field (dL->L l fld, n') =
do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)
; return (cL l (fld { hsRecFieldArg = arg' })) }
nested_mk Nothing mk _ = mk
nested_mk (Just _) mk@(LetMk {}) _ = mk
nested_mk (Just n) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n))
data HsRecFieldContext
= HsRecFieldCon Name
| HsRecFieldPat Name
| HsRecFieldUpd
rnHsRecFields
:: forall arg. HasSrcSpan arg =>
HsRecFieldContext
-> (SrcSpan -> RdrName -> SrcSpanLess arg)
-> HsRecFields GhcPs arg
-> RnM ([LHsRecField GhcRn arg], FreeVars)
rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
= do { pun_ok <- xoptM LangExt.RecordPuns
; 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 arg
-> RnM (LHsRecField GhcRn arg)
rn_fld pun_ok parent (dL->L l
(HsRecField
{ hsRecFieldLbl =
(dL->L loc (FieldOcc _ (dL->L ll lbl)))
, hsRecFieldArg = arg
, hsRecPun = pun }))
= do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl
; arg' <- if pun
then do { checkErr pun_ok (badPun (cL loc lbl))
; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
; return (cL loc (mk_arg loc arg_rdr)) }
else return arg
; return (cL l (HsRecField
{ hsRecFieldLbl = (cL loc (FieldOcc
sel (cL ll lbl)))
, hsRecFieldArg = arg'
, hsRecPun = pun })) }
rn_fld _ _ (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _))
= panic "rnHsRecFields"
rn_fld _ _ _ = panic "rn_fld: Impossible Match"
rn_dotdot :: Maybe Int
-> Maybe Name
-> [LHsRecField GhcRn arg]
-> RnM [LHsRecField GhcRn arg]
rn_dotdot (Just n) (Just con) flds
| not (isUnboundName con)
= ASSERT( flds `lengthIs` n )
do { loc <- getSrcSpanM
; dd_flag <- xoptM LangExt.RecordWildCards
; checkErr dd_flag (needFlagDotDot ctxt)
; (rdr_env, lcl_env) <- getRdrEnvs
; con_fields <- lookupConstructorFields con
; when (null con_fields) (addErr (badDotDotCon 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
; return [ cL loc (HsRecField
{ hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr))
, hsRecFieldArg = cL loc (mk_arg loc arg_rdr)
, hsRecPun = 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.RecordPuns
; overload_ok <- xoptM LangExt.DuplicateRecordFields
; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds
; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds
; when (null flds) $ addErr emptyUpdateErr
; return (flds1, plusFVs fvss) }
where
doc = text "constructor field name"
rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs
-> RnM (LHsRecUpdField GhcRn, FreeVars)
rn_fld pun_ok overload_ok (dL->L l (HsRecField { hsRecFieldLbl = dL->L loc f
, hsRecFieldArg = arg
, hsRecPun = pun }))
= do { let lbl = rdrNameAmbiguousFieldOcc f
; sel <- setSrcSpan loc $
if overload_ok
then do { mb <- lookupGlobalOccRn_overloaded
overload_ok lbl
; case mb of
Nothing ->
do { addErr
(unknownSubordinateErr doc lbl)
; return (Right []) }
Just r -> return r }
else fmap Left $ lookupGlobalOccRn lbl
; arg' <- if pun
then do { checkErr pun_ok (badPun (cL loc lbl))
; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
; return (cL loc (HsVar noExt (cL loc arg_rdr))) }
else return arg
; (arg'', fvs) <- rnLExpr arg'
; let fvs' = case sel of
Left sel_name -> fvs `addOneFV` sel_name
Right [sel_name] -> fvs `addOneFV` sel_name
Right _ -> fvs
lbl' = case sel of
Left sel_name ->
cL loc (Unambiguous sel_name (cL loc lbl))
Right [sel_name] ->
cL loc (Unambiguous sel_name (cL loc lbl))
Right _ -> cL loc (Ambiguous noExt (cL loc lbl))
; return (cL l (HsRecField { hsRecFieldLbl = lbl'
, hsRecFieldArg = arg''
, hsRecPun = pun }), fvs') }
dup_flds :: [NE.NonEmpty RdrName]
(_, dup_flds) = removeDups compare (getFieldUpdLbls flds)
getFieldIds :: [LHsRecField GhcRn arg] -> [Name]
getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds
getFieldLbls :: [LHsRecField id arg] -> [RdrName]
getFieldLbls flds
= map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
needFlagDotDot :: HsRecFieldContext -> SDoc
needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,
text "Use RecordWildCards to permit this"]
badDotDotCon :: Name -> SDoc
badDotDotCon con
= vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)
, nest 2 (text "The constructor has no labelled fields") ]
emptyUpdateErr :: SDoc
emptyUpdateErr = text "Empty record update"
badPun :: Located RdrName -> SDoc
badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),
text "Use NamedFieldPuns to permit this"]
dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc
dupFieldErr ctxt dups
= hsep [text "duplicate field name",
quotes (ppr (NE.head dups)),
text "in record", pprRFC ctxt]
pprRFC :: HsRecFieldContext -> SDoc
pprRFC (HsRecFieldCon {}) = text "construction"
pprRFC (HsRecFieldPat {}) = text "pattern"
pprRFC (HsRecFieldUpd {}) = text "update"
rnLit :: HsLit p -> RnM ()
rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)
rnLit _ = return ()
generalizeOverLitVal :: OverLitVal -> OverLitVal
generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val}))
| 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 f -> 0 == fl_value f && fl_neg f
_ -> 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
; (SyntaxExpr { syn_expr = from_thing_name }, fvs1)
<- lookupSyntaxName std_name
; let rebindable = case from_thing_name of
HsVar _ lv -> (unLoc lv) /= std_name
_ -> panic "rnOverLit"
; let lit' = lit { ol_witness = from_thing_name
, ol_ext = rebindable }
; if isNegativeZeroOverLit lit'
then do { (SyntaxExpr { syn_expr = negate_name }, fvs2)
<- lookupSyntaxName negateName
; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
, fvs1 `plusFV` fvs2) }
else return ((lit', Nothing), fvs1) }
patSigErr :: Outputable a => a -> SDoc
patSigErr ty
= (text "Illegal signature in pattern:" <+> ppr ty)
$$ nest 4 (text "Use ScopedTypeVariables to permit it")
bogusCharError :: Char -> SDoc
bogusCharError c
= text "character literal out of range: '\\" <> char c <> char '\''
badViewPat :: Pat GhcPs -> SDoc
badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,
text "Use ViewPatterns to enable view patterns"]