module RnPat (
rnPat, rnPats, rnBindPat, rnPatAndThen,
NameMaker, applyNameMaker,
localRecNameMaker, topRecNameMaker,
isTopRecNameMaker,
rnHsRecFields, HsRecFieldContext(..),
CpsRn, liftCps,
rnLit, rnOverLit,
checkTupSize, patSigErr
) where
import RnExpr ( rnLExpr )
import RnSplice ( rnSplicePat )
import TcSplice ( runQuasiQuotePat )
#include "HsVersions.h"
import HsSyn
import TcRnMonad
import TcHsSyn ( hsOverLitName )
import RnEnv
import RnTypes
import DynFlags
import PrelNames
import TyCon ( tyConName )
import ConLike
import DataCon ( dataConTyCon )
import TypeRep ( TyThing(..) )
import Name
import NameSet
import RdrName
import BasicTypes
import Util
import ListSetOps ( removeDups )
import Outputable
import SrcLoc
import FastString
import Literal ( inCharRange )
import TysWiredIn ( nilDataCon )
import DataCon ( dataConName )
import Control.Monad ( when, liftM, ap )
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 = return
(<*>) = ap
instance Monad CpsRn where
return x = CpsRn (\k -> k x)
(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 :: HsWithBndrs RdrName (LHsType RdrName)
-> CpsRn (HsWithBndrs Name (LHsType Name))
rnHsSigCps sig
= CpsRn (rnHsBndrSig PatCtx sig)
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
{
; addErrCtxt doc_pat $
checkDupAndShadowedNames envs_before $
collectPatsBinders pats'
; thing_inside pats' } }
where
doc_pat = ptext (sLit "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 Name
applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatName 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 rdr) = do { loc <- liftCps getSrcSpanM
; name <- newPatName mk (L loc rdr)
; return (VarPat 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 Opt_OverloadedStrings)
; if ovlStr
then rnPatAndThen mk (mkNPat (mkHsIsString src s placeHolderType)
Nothing)
else normal_lit }
| otherwise = normal_lit
where
normal_lit = do { liftCps (rnLit lit); return (LitPat lit) }
rnPatAndThen _ (NPat 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 lit' mb_neg' eq') }
rnPatAndThen mk (NPlusKPat rdr 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) lit' ge minus) }
rnPatAndThen mk (AsPat rdr pat)
= do { new_name <- newPatName mk rdr
; pat' <- rnLPatAndThen mk pat
; return (AsPat (L (nameSrcSpan new_name) new_name) pat') }
rnPatAndThen mk p@(ViewPat expr pat _ty)
= do { liftCps $ do { vp_flag <- xoptM Opt_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 Opt_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 Opt_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 (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 mk (QuasiQuotePat qq)
= do { pat <- liftCps $ runQuasiQuotePat qq
; rnPatAndThen mk (ParPat pat) }
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) VarPat hs_rec_fields
; flds' <- mapM rn_field (flds `zip` [1..])
; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
where
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
-> (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 Opt_RecordPuns
; disambig_ok <- xoptM Opt_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
; case ctxt of
HsRecFieldUpd | Nothing <- dotdot
, null flds
-> addErr emptyUpdateErr
_ -> return ()
; 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 -> ptext (sLit "constructor field name")
Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con)
rn_fld pun_ok parent (L l (HsRecField { hsRecFieldId = fld
, hsRecFieldArg = arg
, hsRecPun = pun }))
= do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc True parent doc) fld
; arg' <- if pun
then do { checkErr pun_ok (badPun fld)
; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) }
else return arg
; return (L l (HsRecField { hsRecFieldId = fld'
, 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
= do { case ctxt of
HsRecFieldUpd -> addErr badDotDotUpd
_ -> return ()
; return [] }
rn_dotdot (Just n) (Just con) flds
= ASSERT( n == length flds )
do { loc <- getSrcSpanM
; dd_flag <- xoptM Opt_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 = getFieldIds flds
parent_tc = find_tycon rdr_env con
arg_in_scope fld
= rdr `elemLocalRdrEnv` lcl_env
|| notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env
, case gre_par gre of
ParentIs p -> p /= parent_tc
_ -> True ]
where
rdr = mkRdrUnqual (nameOccName fld)
dot_dot_gres = [ head gres
| fld <- con_fields
, not (fld `elem` present_flds)
, let gres = lookupGRE_Name rdr_env fld
, not (null gres)
, case ctxt of
HsRecFieldCon {} -> arg_in_scope fld
_other -> True ]
; addUsedRdrNames (map greRdrName dot_dot_gres)
; return [ L loc (HsRecField
{ hsRecFieldId = L loc fld
, hsRecFieldArg = L loc (mk_arg arg_rdr)
, hsRecPun = False })
| gre <- dot_dot_gres
, let fld = gre_name gre
arg_rdr = mkRdrUnqual (nameOccName fld) ] }
check_disambiguation :: Bool -> Maybe Name -> RnM Parent
check_disambiguation disambig_ok mb_con
| disambig_ok, Just con <- mb_con
= do { env <- getGlobalRdrEnv; return (ParentIs (find_tycon env con)) }
| otherwise = return NoParent
find_tycon :: GlobalRdrEnv -> Name -> Name
find_tycon env con
| Just (AConLike (RealDataCon dc)) <- wiredInNameTyThing_maybe con
= tyConName (dataConTyCon dc)
| [GRE { gre_par = ParentIs p }] <- lookupGRE_Name env con
= p
| otherwise
= pprPanic "find_tycon" (ppr con $$ ppr (lookupGRE_Name env con))
dup_flds :: [[RdrName]]
(_, dup_flds) = removeDups compare (getFieldIds flds)
getFieldIds :: [LHsRecField id arg] -> [id]
getFieldIds flds = map (unLoc . hsRecFieldId . unLoc) flds
needFlagDotDot :: HsRecFieldContext -> SDoc
needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt,
ptext (sLit "Use RecordWildCards to permit this")]
badDotDotCon :: Name -> SDoc
badDotDotCon con
= vcat [ ptext (sLit "Illegal `..' notation for constructor") <+> quotes (ppr con)
, nest 2 (ptext (sLit "The constructor has no labelled fields")) ]
badDotDotUpd :: SDoc
badDotDotUpd = ptext (sLit "You cannot use `..' in a record update")
emptyUpdateErr :: SDoc
emptyUpdateErr = ptext (sLit "Empty record update")
badPun :: Located RdrName -> SDoc
badPun fld = vcat [ptext (sLit "Illegal use of punning for field") <+> quotes (ppr fld),
ptext (sLit "Use NamedFieldPuns to permit this")]
dupFieldErr :: HsRecFieldContext -> [RdrName] -> SDoc
dupFieldErr ctxt dups
= hsep [ptext (sLit "duplicate field name"),
quotes (ppr (head dups)),
ptext (sLit "in record"), pprRFC ctxt]
pprRFC :: HsRecFieldContext -> SDoc
pprRFC (HsRecFieldCon {}) = ptext (sLit "construction")
pprRFC (HsRecFieldPat {}) = ptext (sLit "pattern")
pprRFC (HsRecFieldUpd {}) = ptext (sLit "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 src (numerator val)
generalizeOverLitVal lit = lit
rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars)
rnOverLit origLit
= do { opt_NumDecimals <- xoptM Opt_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, fvs) <- lookupSyntaxName std_name
; let rebindable = case from_thing_name of
HsVar 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
= (ptext (sLit "Illegal signature in pattern:") <+> ppr ty)
$$ nest 4 (ptext (sLit "Use ScopedTypeVariables to permit it"))
bogusCharError :: Char -> SDoc
bogusCharError c
= ptext (sLit "character literal out of range: '\\") <> char c <> char '\''
badViewPat :: Pat RdrName -> SDoc
badViewPat pat = vcat [ptext (sLit "Illegal view pattern: ") <+> ppr pat,
ptext (sLit "Use ViewPatterns to enable view patterns")]