import RnHsSyn
import HsCore
-import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
+import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn,
lookupImplicitOccRn, addImplicitOccRn,
bindLocalsRn,
bindIO_NAME
)
import Bag ( bagToList )
+import List ( partition )
import Outputable
import SrcLoc ( SrcLoc )
+import CmdLineOpts ( opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars
import UniqFM ( lookupUFM )
import Maybes ( maybeToBool, catMaybes )
import Util
-- Check the signatures
let
- -- Filter out fixity signatures;
- -- they are done at top level
- nofix_sigs = nonFixitySigs sigs
+ -- First process the class op sigs, then the fixity sigs.
+ (op_sigs, non_op_sigs) = partition isClassOpSig sigs
+ (fix_sigs, non_sigs) = partition isFixitySig non_op_sigs
in
- checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
- mapAndUnzipRn (rn_op cname' clas_tyvar_names) nofix_sigs `thenRn` \ (sigs', sig_fvs_s) ->
+ checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
+ mapAndUnzipRn (rn_op cname' clas_tyvar_names) op_sigs `thenRn` \ (sigs', sig_fvs_s) ->
+ mapRn_ (unknownSigErr) non_sigs `thenRn_`
+ let
+ binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
+ in
+ renameSigs False binders lookupOccRn fix_sigs `thenRn` \ (fixs', fix_fvs) ->
-- Check the methods
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
-- for instance decls.
ASSERT(isNoClassPragmas pragmas)
- returnRn (TyClD (ClassDecl context' cname' tyvars' sigs' mbinds' NoClassPragmas tname' dname' src_loc),
- plusFVs sig_fvs_s `plusFV` cxt_fvs `plusFV` meth_fvs)
+ returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') mbinds' NoClassPragmas tname' dname' src_loc),
+ plusFVs sig_fvs_s `plusFV`
+ fix_fvs `plusFV`
+ cxt_fvs `plusFV`
+ meth_fvs
+ )
)
where
cls_doc = text "the declaration for class" <+> ppr cname
check_in_op_ty clas_tyvar = checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
(classTyVarNotInOpTyErr clas_tyvar sig)
in
- mapRn check_in_op_ty clas_tyvars `thenRn_`
+ mapRn_ check_in_op_ty clas_tyvars `thenRn_`
-- Make the default-method name
let
rnMethodBinds mbinds `thenRn` \ (mbinds', meth_fvs) ->
let
binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
+
+ -- Delete sigs (&report) sigs that aren't allowed inside an
+ -- instance decl:
+ --
+ -- + type signatures
+ -- + fixity decls
+ --
+ (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags
+
+ okInInstDecl (FixSig _) = False
+ okInInstDecl (Sig _ _ _) = False
+ okInInstDecl _ = True
+
in
- renameSigs NotTopLevel True binders uprags `thenRn` \ (new_uprags, prag_fvs) ->
- mkDFunName inst_ty' maybe_dfun src_loc `thenRn` \ dfun_name ->
- addOccurrenceName dfun_name `thenRn_`
+ -- You can't have fixity decls & type signatures
+ -- within an instance declaration.
+ mapRn_ unknownSigErr not_ok_idecl_sigs `thenRn_`
+ renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) ->
+ mkDFunName inst_ty' maybe_dfun src_loc `thenRn` \ dfun_name ->
+ addOccurrenceName dfun_name `thenRn_`
-- The dfun is not optional, because we use its version number
-- to identify the version of the instance declaration
addImplicitOccRn deRefStablePtr_NAME `thenRn_`
addImplicitOccRn bindIO_NAME `thenRn_`
returnRn name'
- _ -> returnRn name') `thenRn_`
- rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs) ->
+ _ -> returnRn name') `thenRn_`
+ rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs) ->
returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), fvs)
where
fo_decl_msg = ptext SLIT("a foreign declaration")
Nothing -> addErrRn (derivingNonStdClassErr clas_name) `thenRn_`
returnRn clas_name
- Just occs -> mapRn lookupImplicitOccRn occs `thenRn_`
+ Just occs -> mapRn_ lookupImplicitOccRn occs `thenRn_`
returnRn clas_name
\end{code}
returnRn (Banged new_ty, fvs)
rnBangTy doc (Unbanged ty)
- = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
+ = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
returnRn (Unbanged new_ty, fvs)
+rnBangTy doc (Unpacked ty)
+ = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
+ returnRn (Unpacked new_ty, fvs)
+
-- This data decl will parse OK
-- data T = a Int
-- treating "a" as the constructor.
-- Explicit quantification.
-- Check that the forall'd tyvars are a subset of the
-- free tyvars in the tau-type part
+ -- That's only a warning... unless the tyvar is constrained by a
+ -- context in which case it's an error
= let
- mentioned_tyvars = extractHsTyVars ty
- bad_guys = filter (`notElem` mentioned_tyvars) forall_tyvar_names
- forall_tyvar_names = map getTyVarName forall_tyvars
+ mentioned_tyvars = extractHsTyVars ty
+ constrained_tyvars = [tv | (_,tys) <- ctxt,
+ ty <- tys,
+ tv <- extractHsTyVars ty]
+ dubious_guys = filter (`notElem` mentioned_tyvars) forall_tyvar_names
+ (bad_guys, warn_guys) = partition (`elem` constrained_tyvars) dubious_guys
+ forall_tyvar_names = map getTyVarName forall_tyvars
in
- mapRn (forAllErr doc ty) bad_guys `thenRn_`
+ mapRn_ (forAllErr doc ty) bad_guys `thenRn_`
+ mapRn_ (forAllWarn doc ty) warn_guys `thenRn_`
checkConstraints True doc forall_tyvar_names ctxt ty `thenRn` \ ctxt' ->
rnForAll doc forall_tyvars ctxt' ty
in
-- Check for duplicate assertions
-- If this isn't an error, then it ought to be:
- mapRn (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
+ mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
returnRn (theta, plusFVs fvs_s)
where
%*********************************************************
\begin{code}
-rnIdInfo (HsStrictness strict)
- = rnStrict strict `thenRn` \ strict' ->
- returnRn (HsStrictness strict')
+rnIdInfo (HsStrictness str) = returnRn (HsStrictness str)
+
+rnIdInfo (HsWorker worker cons)
+ -- The sole purpose of the "cons" field is so that we can mark the
+ -- constructors needed to build the wrapper as "needed", so that their
+ -- data type decl will be slurped in. After that their usefulness is
+ -- o'er, so we just put in the empty list.
+ = lookupOccRn worker `thenRn` \ worker' ->
+ mapRn lookupOccRn cons `thenRn_`
+ returnRn (HsWorker worker' [])
rnIdInfo (HsUnfold inline (Just expr)) = rnCoreExpr expr `thenRn` \ expr' ->
returnRn (HsUnfold inline (Just expr'))
rnIdInfo (HsArity arity) = returnRn (HsArity arity)
rnIdInfo (HsUpdate update) = returnRn (HsUpdate update)
rnIdInfo (HsNoCafRefs) = returnRn (HsNoCafRefs)
+rnIdInfo (HsCprInfo cpr_info) = returnRn (HsCprInfo cpr_info)
rnIdInfo (HsSpecialise tyvars tys expr)
= bindTyVarsRn doc tyvars $ \ tyvars' ->
rnCoreExpr expr `thenRn` \ expr' ->
returnRn (HsSpecialise tyvars' tys' expr')
where
doc = text "Specialise in interface pragma"
-
-
-rnStrict (HsStrictnessInfo demands (Just (worker,cons)))
- -- The sole purpose of the "cons" field is so that we can mark the constructors
- -- needed to build the wrapper as "needed", so that their data type decl will be
- -- slurped in. After that their usefulness is o'er, so we just put in the empty list.
- = lookupOccRn worker `thenRn` \ worker' ->
- mapRn lookupOccRn cons `thenRn_`
- returnRn (HsStrictnessInfo demands (Just (worker',[])))
-
--- Boring, but necessary for the type checker.
-rnStrict (HsStrictnessInfo demands Nothing) = returnRn (HsStrictnessInfo demands Nothing)
-rnStrict HsBottom = returnRn HsBottom
\end{code}
UfCore expressions.
badDataCon name
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
+forAllWarn doc ty tyvar
+ | not opt_WarnUnusedMatches = returnRn ()
+ | otherwise
+ = addWarnRn (
+ sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
+ nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
+ $$
+ (ptext SLIT("In") <+> doc))
+
forAllErr doc ty tyvar
= addErrRn (
- sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
+ sep [ptext SLIT("The constrained type variable") <+> quotes (ppr tyvar),
nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
$$
(ptext SLIT("In") <+> doc))
projects / ghc-hetmet.git / blobdiff