module RnPat (
rnPat, rnPats, rnBindPat, rnPatAndThen,
NameMaker, applyNameMaker,
localRecNameMaker, topRecNameMaker,
isTopRecNameMaker,
rnHsRecFields, HsRecFieldContext(..),
rnHsRecUpdFields,
CpsRn, liftCps,
rnLit, rnOverLit,
checkTupSize, patSigErr
) where
import RnExpr ( rnLExpr )
import RnSplice ( rnSplicePat )
#include "HsVersions.h"
import HsSyn
import TcRnMonad
import TcHsSyn ( hsOverLitName )
import RnEnv
import RnTypes
import PrelNames
import TyCon ( tyConName )
import ConLike
import Type ( TyThing(..) )
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, unless )
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 :: (a -> CpsRn b) -> Located a -> CpsRn (Located b)
wrapSrcSpanCps fn (L loc a)
= CpsRn (\k -> setSrcSpan loc $
unCpsRn (fn a) $ \v ->
k (L 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 RdrName -> CpsRn (LHsSigWcType Name)
rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped PatCtx sig)
newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
newPatLName name_maker rdr_name@(L loc _)
= do { name <- newPatName name_maker rdr_name
; return (L 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 RdrName]
-> ([LPat Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnPats ctxt pats thing_inside
= do { envs_before <- getRdrEnvs
; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do
{
; unless (isPatSynCtxt ctxt)
(addErrCtxt doc_pat $
checkDupAndShadowedNames envs_before $
collectPatsBinders pats')
; thing_inside pats' } }
where
doc_pat = text "In" <+> pprMatchContext ctxt
rnPat :: HsMatchContext Name
-> LPat RdrName
-> (LPat Name -> 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 RdrName
-> RnM (LPat Name, FreeVars)
rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)
rnLPatsAndThen :: NameMaker -> [LPat RdrName] -> CpsRn [LPat Name]
rnLPatsAndThen mk = mapM (rnLPatAndThen mk)
rnLPatAndThen :: NameMaker -> LPat RdrName -> CpsRn (LPat Name)
rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
rnPatAndThen :: NameMaker -> Pat RdrName -> CpsRn (Pat Name)
rnPatAndThen _ (WildPat _) = return (WildPat placeHolderType)
rnPatAndThen mk (ParPat pat) = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') }
rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') }
rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') }
rnPatAndThen mk (VarPat (L l rdr)) = do { loc <- liftCps getSrcSpanM
; name <- newPatName mk (L loc rdr)
; return (VarPat (L l name)) }
rnPatAndThen mk (SigPatIn pat sig)
= do { sig' <- rnHsSigCps sig
; pat' <- rnLPatAndThen mk pat
; return (SigPatIn pat' sig') }
rnPatAndThen mk (LitPat lit)
| HsString src s <- lit
= do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
; if ovlStr
then rnPatAndThen mk
(mkNPat (noLoc (mkHsIsString src s placeHolderType))
Nothing)
else normal_lit }
| otherwise = normal_lit
where
normal_lit = do { liftCps (rnLit lit); return (LitPat lit) }
rnPatAndThen _ (NPat (L l lit) mb_neg _eq _)
= do { lit' <- liftCpsFV $ rnOverLit lit
; mb_neg' <- liftCpsFV $ case mb_neg of
Nothing -> return (Nothing, emptyFVs)
Just _ -> do { (neg, fvs) <- lookupSyntaxName negateName
; return (Just neg, fvs) }
; eq' <- liftCpsFV $ lookupSyntaxName eqName
; return (NPat (L l lit') mb_neg' eq' placeHolderType) }
rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _)
= do { new_name <- newPatName mk rdr
; lit' <- liftCpsFV $ rnOverLit lit
; minus <- liftCpsFV $ lookupSyntaxName minusName
; ge <- liftCpsFV $ lookupSyntaxName geName
; return (NPlusKPat (L (nameSrcSpan new_name) new_name)
(L l lit') lit' ge minus placeHolderType) }
rnPatAndThen mk (AsPat rdr pat)
= do { new_name <- newPatLName mk rdr
; pat' <- rnLPatAndThen mk pat
; return (AsPat new_name pat') }
rnPatAndThen mk p@(ViewPat expr pat _ty)
= do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
; checkErr vp_flag (badViewPat p) }
; expr' <- liftCpsFV $ rnLExpr expr
; pat' <- rnLPatAndThen mk pat
; return (ViewPat expr' pat' placeHolderType) }
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 [] placeHolderType Nothing)
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 pats' placeHolderType
(Just (placeHolderType, to_list_name)))}
False -> return (ListPat pats' placeHolderType Nothing) }
rnPatAndThen mk (PArrPat pats _)
= do { pats' <- rnLPatsAndThen mk pats
; return (PArrPat pats' placeHolderType) }
rnPatAndThen mk (TuplePat pats boxed _)
= do { liftCps $ checkTupSize (length pats)
; pats' <- rnLPatsAndThen mk pats
; return (TuplePat pats' boxed []) }
rnPatAndThen mk (SumPat pat alt arity _)
= do { pat <- rnLPatAndThen mk pat
; return (SumPat pat alt arity PlaceHolder)
}
rnPatAndThen mk (SplicePat (HsSpliced mfs (HsSplicedPat pat)))
= SplicePat . HsSpliced 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 RdrName
-> CpsRn (Pat Name)
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 RdrName (LPat RdrName)
-> CpsRn (HsRecFields Name (LPat Name))
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..])
; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
where
mkVarPat l n = VarPat (L l n)
rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n')
(hsRecFieldArg fld)
; return (L 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.
HsRecFieldContext
-> (SrcSpan -> RdrName -> arg)
-> HsRecFields RdrName (Located arg)
-> RnM ([LHsRecField Name (Located arg)], FreeVars)
rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
= do { pun_ok <- xoptM LangExt.RecordPuns
; disambig_ok <- xoptM LangExt.DisambiguateRecordFields
; parent <- check_disambiguation 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 | not (isUnboundName con) -> Just con
HsRecFieldPat con | not (isUnboundName con) -> Just con
_ -> Nothing
doc = case mb_con of
Nothing -> text "constructor field name"
Just con -> text "field of constructor" <+> quotes (ppr con)
rn_fld :: Bool -> Maybe Name -> LHsRecField RdrName (Located arg)
-> RnM (LHsRecField Name (Located arg))
rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl
= L loc (FieldOcc (L ll lbl) _)
, hsRecFieldArg = arg
, hsRecPun = pun }))
= do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl
; arg' <- if pun
then do { checkErr pun_ok (badPun (L loc lbl))
; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
; return (L loc (mk_arg loc arg_rdr)) }
else return arg
; return (L l (HsRecField { hsRecFieldLbl
= L loc (FieldOcc (L ll lbl) sel)
, hsRecFieldArg = arg'
, hsRecPun = pun })) }
rn_dotdot :: Maybe Int
-> Maybe Name
-> [LHsRecField Name (Located arg)]
-> RnM [LHsRecField Name (Located arg)]
rn_dotdot Nothing _mb_con _flds
= return []
rn_dotdot (Just {}) Nothing _flds
= return []
rn_dotdot (Just n) (Just con) flds
= ASSERT( n == length flds )
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 [ L loc (HsRecField
{ hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel)
, hsRecFieldArg = L loc (mk_arg loc arg_rdr)
, hsRecPun = False })
| fl <- dot_dot_fields
, let sel = flSelector fl
, let arg_rdr = mkVarUnqual (flLabel fl) ] }
check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name)
check_disambiguation disambig_ok mb_con
| disambig_ok, Just con <- mb_con
= do { env <- getGlobalRdrEnv; return (find_tycon env con) }
| otherwise = return Nothing
find_tycon :: GlobalRdrEnv -> Name -> Maybe Name
find_tycon env con_name
| Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con_name
= Just (tyConName (dataConTyCon dc))
| Just gre <- lookupGRE_Name env con_name
= case gre_par gre of
ParentIs p -> Just p
_ -> Nothing
| otherwise = Nothing
dup_flds :: [[RdrName]]
(_, dup_flds) = removeDups compare (getFieldLbls flds)
rnHsRecUpdFields
:: [LHsRecUpdField RdrName]
-> RnM ([LHsRecUpdField Name], 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 RdrName -> RnM (LHsRecUpdField Name, FreeVars)
rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = 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 (L loc lbl))
; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
; return (L loc (HsVar (L loc arg_rdr))) }
else return arg
; (arg'', fvs) <- rnLExpr arg'
; let fvs' = case sel of
Left sel_name -> fvs `addOneFV` sel_name
Right [FieldOcc _ sel_name] -> fvs `addOneFV` sel_name
Right _ -> fvs
lbl' = case sel of
Left sel_name ->
L loc (Unambiguous (L loc lbl) sel_name)
Right [FieldOcc lbl sel_name] ->
L loc (Unambiguous lbl sel_name)
Right _ -> L loc (Ambiguous (L loc lbl) PlaceHolder)
; return (L l (HsRecField { hsRecFieldLbl = lbl'
, hsRecFieldArg = arg''
, hsRecPun = pun }), fvs') }
dup_flds :: [[RdrName]]
(_, dup_flds) = removeDups compare (getFieldUpdLbls flds)
getFieldIds :: [LHsRecField Name 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 id] -> [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 -> [RdrName] -> SDoc
dupFieldErr ctxt dups
= hsep [text "duplicate field name",
quotes (ppr (head dups)),
text "in record", pprRFC ctxt]
pprRFC :: HsRecFieldContext -> SDoc
pprRFC (HsRecFieldCon {}) = text "construction"
pprRFC (HsRecFieldPat {}) = text "pattern"
pprRFC (HsRecFieldUpd {}) = text "update"
rnLit :: HsLit -> RnM ()
rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)
rnLit _ = return ()
generalizeOverLitVal :: OverLitVal -> OverLitVal
generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_value=val}))
| denominator val == 1 = HsIntegral (SourceText src) (numerator val)
generalizeOverLitVal lit = lit
rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, 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 }, fvs)
<- lookupSyntaxName std_name
; let rebindable = case from_thing_name of
HsVar (L _ v) -> v /= std_name
_ -> panic "rnOverLit"
; return (lit { ol_witness = from_thing_name
, ol_rebindable = rebindable
, ol_type = placeHolderType }, fvs) }
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 RdrName -> SDoc
badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,
text "Use ViewPatterns to enable view patterns"]