import RdrHsSyn
import RnHsSyn
import TcRnMonad
-import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,checkPrecMatch)
+import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch)
import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat,
- NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker,
- patSigErr)
+ NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker
+ )
import RnEnv
import DynFlags ( DynFlag(..) )
import Name
import NameEnv
import NameSet
-import PrelNames ( isUnboundName )
import RdrName ( RdrName, rdrNameOcc )
import SrcLoc
import ListSetOps ( findDupsEq )
import BasicTypes ( RecFlag(..) )
-import Digraph ( SCC(..), stronglyConnComp )
+import Digraph ( SCC(..), stronglyConnCompFromEdgedVertices )
import Bag
import Outputable
import FastString
+import Data.List ( partition )
import Maybes ( orElse )
-import Util ( filterOut )
import Monad ( foldM, unless )
\end{code}
rnTopBindsLHS fix_env binds =
(uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds
-rnTopBindsRHS :: [Name] -- the names bound by these binds
+rnTopBindsRHS :: NameSet -- Names bound by these binds
-> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
rnTopBindsRHS bound_names binds =
then rnTopBindsBoot binds
else rnValBindsRHSGen (\x -> x) -- don't trim free vars
bound_names binds }
-
--- wrapper if we don't need to do anything in between the left and right,
+-- Wrapper if we don't need to do anything in between the left and right,
-- or anything else in the scope of the left
--
--- never used when there are fixity declarations
+-- Never used when there are fixity declarations
rnTopBinds :: HsValBinds RdrName
-> RnM (HsValBinds Name, DefUses)
rnTopBinds b =
do nl <- rnTopBindsLHS emptyFsEnv b
let bound_names = map unLoc (collectHsValBinders nl)
- bindLocalNames bound_names $ rnTopBindsRHS bound_names nl
+ bindLocalNames bound_names $ rnTopBindsRHS (mkNameSet bound_names) nl
rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
-- Return a single HsBindGroup with empty binds and renamed signatures
rnTopBindsBoot (ValBindsIn mbinds sigs)
= do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
- ; sigs' <- renameSigs okHsBootSig sigs
+ ; sigs' <- renameSigs Nothing okHsBootSig sigs
; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) }
rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b)
\end{code}
return $ ValBindsIn mbinds' sigs
rnValBindsLHSFromDoc _ _ _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
--- assumes the LHS vars are in scope
--- general version used both from the top-level and for local things
+-- General version used both from the top-level and for local things
+-- Assumes the LHS vars are in scope
--
--- does not bind the local fixity declarations
+-- Does not bind the local fixity declarations
rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets
-- The trimming function trims the free vars we attach to a
-- binding so that it stays reasonably small
- -> [Name] -- names bound by the LHSes
+ -> NameSet -- Names bound by the LHSes
-> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
-rnValBindsRHSGen trim _bound_names (ValBindsIn mbinds sigs) = do
+rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) = do
-- rename the sigs
- env <- getGblEnv
- traceRn (ptext (sLit "Rename sigs") <+> ppr (tcg_rdr_env env))
- sigs' <- rename_sigs sigs
+ sigs' <- renameSigs (Just bound_names) okBindSig sigs
-- rename the RHSes
binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
- let (anal_binds, anal_dus) = depAnalBinds binds_w_dus
- (valbind', valbind'_dus) = (ValBindsOut anal_binds sigs',
- usesOnly (hsSigsFVs sigs') `plusDU` anal_dus)
- -- We do the check-sigs after renaming the bindings,
- -- so that we have convenient access to the binders
- check_sigs (okBindSig (duDefs anal_dus)) sigs'
- return (valbind', valbind'_dus)
+ case depAnalBinds binds_w_dus of
+ (anal_binds, anal_dus) ->
+ do let valbind' = ValBindsOut anal_binds sigs'
+ valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus
+ return (valbind', valbind'_dus)
rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b)
-- it doesn't (and can't: we don't have the thing inside the binds) happen here
--
-- The client is also responsible for bringing the fixities into scope
-rnValBindsRHS :: [Name] -- names bound by the LHSes
+rnValBindsRHS :: NameSet -- names bound by the LHSes
-> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
rnValBindsRHS bound_names binds =
rnValBindsRHSGen (\ fvs -> -- only keep the names the names from this group
- intersectNameSet (mkNameSet bound_names) fvs) bound_names binds
+ intersectNameSet bound_names fvs) bound_names binds
-- for local binds
; bindLocalNamesFV_WithFixities bound_names new_fixities $ do
{ -- (C) Do the RHS and thing inside
- (binds', dus) <- rnValBindsRHS bound_names new_lhs
+ (binds', dus) <- rnValBindsRHS (mkNameSet bound_names) new_lhs
; (result, result_fvs) <- thing_inside binds'
-- Report unused bindings based on the (accurate)
; (grhss', fvs) <- rnGRHSs PatBindRhs grhss
-- No scoped type variables for pattern bindings
+ ; let fvs' = trim fvs
- ; return (L loc (PatBind { pat_lhs = pat,
+ ; fvs' `seq` -- See Note [Free-variable space leak]
+ return (L loc (PatBind { pat_lhs = pat,
pat_rhs = grhss',
pat_rhs_ty = placeHolderType,
- bind_fvs = trim fvs }),
+ bind_fvs = fvs' }),
bndrs, pat_fvs `plusFV` fvs) }
rnBind sig_fn
; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
-- bindSigTyVars tests for Opt_ScopedTyVars
rnMatchGroup (FunRhs plain_name inf) matches
+ ; let fvs' = trim fvs
; checkPrecMatch inf plain_name matches'
- ; return (L loc (FunBind { fun_id = name,
+ ; fvs' `seq` -- See Note [Free-variable space leak]
+ return (L loc (FunBind { fun_id = name,
fun_infix = inf,
fun_matches = matches',
- bind_fvs = trim fvs,
+ bind_fvs = fvs',
fun_co_fn = idHsWrapper,
fun_tick = Nothing }),
[plain_name], fvs)
}
rnBind _ _ b = pprPanic "rnBind" (ppr b)
-
+
+{-
+Note [Free-variable space leak]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have
+ fvs' = trim fvs
+and we seq fvs' before turning it as part of a record.
+
+The reason is that trim is sometimes something like
+ \xs -> intersectNameSet (mkNameSet bound_names) xs
+and we don't want to retain the list bound_names. This showed up in
+trac ticket #1136.
+-}
+
---------------------
depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
-> ([(RecFlag, LHsBinds Name)], DefUses)
depAnalBinds binds_w_dus
= (map get_binds sccs, map get_du sccs)
where
- sccs = stronglyConnComp edges
+ sccs = stronglyConnCompFromEdgedVertices edges
keyd_nodes = bagToList binds_w_dus `zip` [0::Int ..]
\begin{enumerate}
\item more than one sig for one thing;
\item signatures given for things not bound here;
-\item with suitably flaggery, that all top-level things have type signatures.
\end{enumerate}
%
At the moment we don't gather free-var info from the types in
signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code}
-renameSigs :: (LSig Name -> Bool) -> [LSig RdrName] -> RnM [LSig Name]
+renameSigs :: Maybe NameSet -- If (Just ns) complain if the sig isn't for one of ns
+ -> (Sig RdrName -> Bool) -- Complain about the wrong kind of signature if this is False
+ -> [LSig RdrName]
+ -> RnM [LSig Name]
-- Renames the signatures and performs error checks
-renameSigs ok_sig sigs
- = do { sigs' <- rename_sigs sigs
- ; check_sigs ok_sig sigs'
- ; return sigs' }
-
-----------------------
-rename_sigs :: [LSig RdrName] -> RnM [LSig Name]
-rename_sigs sigs = mapM (wrapLocM renameSig) sigs
+renameSigs mb_names ok_sig sigs
+ = do { let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs
+ ; mapM_ unknownSigErr bad_sigs -- Misplaced
+ ; mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs) -- Duplicate
+ ; sigs' <- mapM (wrapLocM (renameSig mb_names)) good_sigs
+ ; return sigs' }
----------------------
-check_sigs :: (LSig Name -> Bool) -> [LSig Name] -> RnM ()
--- Used for class and instance decls, as well as regular bindings
-check_sigs ok_sig sigs = do
- -- Check for (a) duplicate signatures
- -- (b) signatures for things not in this group = do
- traceRn (text "SIGS" <+> ppr sigs)
- mapM_ unknownSigErr (filter (not . ok_sig) sigs')
- mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs')
- where
- -- Don't complain about an unbound name again
- sigs' = filterOut bad_name sigs
- bad_name sig = case sigName sig of
- Just n -> isUnboundName n
- _ -> False
-
--- We use lookupLocatedSigOccRn in the signatures, which is a little bit unsatisfactory
+-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
-- because this won't work for:
-- instance Foo T where
-- {-# INLINE op #-}
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
-renameSig :: Sig RdrName -> RnM (Sig Name)
--- FixitSig is renamed elsewhere.
-renameSig (TypeSig v ty) = do
- new_v <- lookupLocatedSigOccRn v
- new_ty <- rnHsSigType (quotes (ppr v)) ty
- return (TypeSig new_v new_ty)
-
-renameSig (SpecInstSig ty) = do
- new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
- return (SpecInstSig new_ty)
-
-renameSig (SpecSig v ty inl) = do
- new_v <- lookupLocatedSigOccRn v
- new_ty <- rnHsSigType (quotes (ppr v)) ty
- return (SpecSig new_v new_ty inl)
-
-renameSig (InlineSig v s) = do
- new_v <- lookupLocatedSigOccRn v
- return (InlineSig new_v s)
-
-renameSig (FixSig (FixitySig v f)) = do
- new_v <- lookupLocatedSigOccRn v
- return (FixSig (FixitySig new_v f))
+renameSig :: Maybe NameSet -> Sig RdrName -> RnM (Sig Name)
+-- FixitySig is renamed elsewhere.
+renameSig mb_names sig@(TypeSig v ty)
+ = do { new_v <- lookupSigOccRn mb_names sig v
+ ; new_ty <- rnHsSigType (quotes (ppr v)) ty
+ ; return (TypeSig new_v new_ty) }
+
+renameSig _ (SpecInstSig ty)
+ = do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
+ ; return (SpecInstSig new_ty) }
+
+renameSig mb_names sig@(SpecSig v ty inl)
+ = do { new_v <- lookupSigOccRn mb_names sig v
+ ; new_ty <- rnHsSigType (quotes (ppr v)) ty
+ ; return (SpecSig new_v new_ty inl) }
+
+renameSig mb_names sig@(InlineSig v s)
+ = do { new_v <- lookupSigOccRn mb_names sig v
+ ; return (InlineSig new_v s) }
+
+renameSig mb_names sig@(FixSig (FixitySig v f))
+ = do { new_v <- lookupSigOccRn mb_names sig v
+ ; return (FixSig (FixitySig new_v f)) }
\end{code}
-************************************************************************
-* *
+%************************************************************************
+%* *
\subsection{Match}
-* *
-************************************************************************
+%* *
+%************************************************************************
\begin{code}
rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
-rnMatchGroup ctxt (MatchGroup ms _) = do
- (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms
- return (MatchGroup new_ms placeHolderType, ms_fvs)
+rnMatchGroup ctxt (MatchGroup ms _)
+ = do { (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms
+ ; return (MatchGroup new_ms placeHolderType, ms_fvs) }
rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
rnMatch ctxt = wrapLocFstM (rnMatch' ctxt)
rnMatch' :: HsMatchContext Name -> Match RdrName -> RnM (Match Name, FreeVars)
-rnMatch' ctxt (Match pats maybe_rhs_sig grhss)
- =
- -- Deal with the rhs type signature
- bindPatSigTyVarsFV rhs_sig_tys $ do
- opt_PatternSignatures <- doptM Opt_PatternSignatures
- (maybe_rhs_sig', ty_fvs) <-
- case maybe_rhs_sig of
- Nothing -> return (Nothing, emptyFVs)
- Just ty | opt_PatternSignatures -> do (ty', ty_fvs) <- rnHsTypeFVs doc_sig ty
- return (Just ty', ty_fvs)
- | otherwise -> do addLocErr ty patSigErr
- return (Nothing, emptyFVs)
-
- -- Now the main event
- -- note that there are no local ficity decls for matches
- rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do
- (grhss', grhss_fvs) <- rnGRHSs ctxt grhss
-
- return (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
+rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
+ = do { -- Result type signatures are no longer supported
+ case maybe_rhs_sig of
+ Nothing -> return ()
+ Just ty -> addLocErr ty (resSigErr ctxt match)
+
+
+ -- Now the main event
+ -- note that there are no local ficity decls for matches
+ ; rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do
+ { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss
+
+ ; return (Match pats' Nothing grhss', grhss_fvs) }}
-- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
where
- rhs_sig_tys = case maybe_rhs_sig of
- Nothing -> []
- Just ty -> [ty]
- doc_sig = text "In a result type-signature"
+
+resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc
+resSigErr ctxt match ty
+ = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty)
+ , nest 2 $ ptext (sLit "Result signatures are no longer supported in pattern matches")
+ , pprMatchInCtxt ctxt match ]
\end{code}
%************************************************************************
\begin{code}
-dupSigDeclErr :: [LSig Name] -> RnM ()
+dupSigDeclErr :: [LSig RdrName] -> RnM ()
dupSigDeclErr sigs@(L loc sig : _)
= addErrAt loc $
vcat [ptext (sLit "Duplicate") <+> what_it_is <> colon,
ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig
dupSigDeclErr [] = panic "dupSigDeclErr"
-unknownSigErr :: LSig Name -> RnM ()
+unknownSigErr :: LSig RdrName -> RnM ()
unknownSigErr (L loc sig)
- = do { mod <- getModule
- ; addErrAt loc $
- vcat [sep [ptext (sLit "Misplaced") <+> what_it_is <> colon, ppr sig],
- extra_stuff mod sig] }
- where
- what_it_is = hsSigDoc sig
- extra_stuff mod (TypeSig (L _ n) _)
- | nameIsLocalOrFrom mod n
- = ptext (sLit "The type signature must be given where")
- <+> quotes (ppr n) <+> ptext (sLit "is declared")
- | otherwise
- = ptext (sLit "You cannot give a type signature for an imported value")
-
- extra_stuff _ _ = empty
+ = addErrAt loc $
+ sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]
methodBindErr :: HsBindLR RdrName RdrName -> SDoc
methodBindErr mbind
projects / ghc-hetmet.git / blobdiff