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 )
+import Maybes ( maybeToBool, catMaybes )
import Util
\end{code}
-- 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
rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) ->
let
inst_tyvars = case inst_ty' of
- HsForAllTy inst_tyvars _ _ -> inst_tyvars
- other -> []
+ HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
+ other -> []
-- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too
in
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.
= rnHsType doc ty `thenRn` \ (ty,_) ->
returnRn ty
+
+rnForAll doc forall_tyvars ctxt ty
+ = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
+ rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
+ rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
+ returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
+ cxt_fvs `plusFV` ty_fvs)
+
+-- Check that each constraint mentions at least one of the forall'd type variables
+-- Since the forall'd type variables are a subset of the free tyvars
+-- of the tau-type part, this guarantees that every constraint mentions
+-- at least one of the free tyvars in ty
+checkConstraints explicit_forall doc forall_tyvars ctxt ty
+ = mapRn check ctxt `thenRn` \ maybe_ctxt' ->
+ returnRn (catMaybes maybe_ctxt')
+ -- Remove problem ones, to avoid duplicate error message.
+ where
+ check ct@(_,tys)
+ | forall_mentioned = returnRn (Just ct)
+ | otherwise = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty) `thenRn_`
+ returnRn Nothing
+ where
+ forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyVars)
+ False
+ tys
+
+
rnHsType :: SDoc -> RdrNameHsType -> RnMS s (RenamedHsType, FreeVars)
-rnHsType doc (HsForAllTy [] ctxt ty)
+rnHsType doc (HsForAllTy Nothing ctxt ty)
-- From source code (no kinds on tyvars)
-
-- Given the signature C => T we universally quantify
-- over FV(T) \ {in-scope-tyvars}
- --
- -- We insist that the universally quantified type vars is a superset of FV(C)
- -- It follows that FV(T) is a superset of FV(C), so that the context constrains
- -- no type variables that don't appear free in the tau-type part.
-
= getLocalNameEnv `thenRn` \ name_env ->
let
mentioned_tyvars = extractHsTyVars ty
forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_tyvars
-
- ctxt_w_ftvs :: [((RdrName,[RdrNameHsType]), [RdrName])]
- ctxt_w_ftvs = [ (constraint, foldr ((++) . extractHsTyVars) [] tys)
- | constraint@(_,tys) <- ctxt]
-
- -- A 'non-poly constraint' is one that does not mention *any*
- -- of the forall'd type variables
- non_poly_constraints = filter non_poly ctxt_w_ftvs
- non_poly (c,ftvs) = not (any (`elem` forall_tyvars) ftvs)
-
- -- A 'non-mentioned' constraint is one that mentions a
- -- type variable that does not appear in 'ty'
- non_mentioned_constraints = filter non_mentioned ctxt_w_ftvs
- non_mentioned (c,ftvs) = any (not . (`elem` mentioned_tyvars)) ftvs
-
- -- Zap the context if there's a problem, to avoid duplicate error message.
- ctxt' | null non_poly_constraints && null non_mentioned_constraints = ctxt
- | otherwise = []
in
- mapRn (ctxtErr1 doc forall_tyvars ty) non_poly_constraints `thenRn_`
- mapRn (ctxtErr2 doc ty) non_mentioned_constraints `thenRn_`
-
- (bindTyVarsFVRn doc (map UserTyVar forall_tyvars) $ \ new_tyvars ->
- rnContext doc ctxt' `thenRn` \ (new_ctxt, cxt_fvs) ->
- rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
- returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
- cxt_fvs `plusFV` ty_fvs)
- )
-
-rnHsType doc (HsForAllTy tvs ctxt ty)
- -- tvs are non-empty, hence must be from an interface file
- -- (tyvars may be kinded)
- = bindTyVarsFVRn doc tvs $ \ new_tyvars ->
- rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) ->
- rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) ->
- returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty,
- cxt_fvs `plusFV` ty_fvs)
+ checkConstraints False doc forall_tyvars ctxt ty `thenRn` \ ctxt' ->
+ rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
+
+rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt ty)
+ -- 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
+ 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_ (forAllWarn doc ty) warn_guys `thenRn_`
+ checkConstraints True doc forall_tyvar_names ctxt ty `thenRn` \ ctxt' ->
+ rnForAll doc forall_tyvars ctxt' ty
rnHsType doc (MonoTyVar tyvar)
= lookupOccRn tyvar `thenRn` \ tyvar' ->
rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas')
+rnHsType doc (MonoUsgTy usg ty)
+ = rnHsType doc ty `thenRn` \ (ty', fvs) ->
+ returnRn (MonoUsgTy usg ty', fvs)
+
rnHsTypes doc tys
= mapAndUnzipRn (rnHsType doc) tys `thenRn` \ (tys, fvs_s) ->
returnRn (tys, plusFVs fvs_s)
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)]
-ctxtErr1 doc tyvars ty (constraint, _)
- = addErrRn (
- sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+>
- ptext SLIT("does not mention any of"),
- nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars)),
- nest 4 (ptext SLIT("of the type") <+> quotes (ppr ty))
- ]
+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)
- )
+ (ptext SLIT("In") <+> doc))
-ctxtErr2 doc ty (constraint,_)
+forAllErr doc ty tyvar
= addErrRn (
- sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint),
- nest 4 (ptext SLIT("mentions type variables that do not appear in the type")),
- nest 4 (quotes (ppr ty))]
- $$
- (ptext SLIT("In") <+> doc)
- )
+ 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))
+
+ctxtErr explicit_forall doc tyvars constraint ty
+ = sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+>
+ ptext SLIT("does not mention any of"),
+ if explicit_forall then
+ nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars))
+ else
+ nest 4 (ptext SLIT("the type variables in the type") <+> quotes (ppr ty))
+ ]
+ $$
+ (ptext SLIT("In") <+> doc)
\end{code}