import RnExpr
import HsSyn
import HsPragmas
-import HsTypes ( getTyVarName )
+import HsTypes ( getTyVarName, pprHsContext )
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar, mkRdrNameWkr )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
- extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars
+ extractRuleBndrsTyVars, extractHsTyRdrTyVars,
+ extractHsTysRdrTyVars, extractHsCtxtRdrTyVars
)
import RnHsSyn
import HsCore
checkDupOrQualNames, checkDupNames,
mkImportedGlobalName, mkImportedGlobalFromRdrName,
newDFunName, getDFunKey, newImplicitBinder,
- FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, mapFvRn
+ FreeVars, emptyFVs, plusFV, plusFVs, unitFV,
+ addOneFV, mapFvRn
)
import RnMonad
)
import NameSet
import OccName ( mkDefaultMethodOcc )
-import BasicTypes ( TopLevelFlag(..) )
import FiniteMap ( elemFM )
import PrelInfo ( derivableClassKeys, cCallishClassKeys,
deRefStablePtr_RDR, makeStablePtr_RDR,
import SrcLoc ( SrcLoc )
import CmdLineOpts ( opt_GlasgowExts, opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars
import Unique ( Uniquable(..) )
-import UniqFM ( lookupUFM )
import ErrUtils ( Message )
import CStrings ( isCLabelString )
import Maybes ( maybeToBool, catMaybes )
lookupOccRn name `thenRn` \ name' ->
let
extra_fvs FoExport
- | isDyn = lookupImplicitOccsRn [makeStablePtr_RDR, deRefStablePtr_RDR]
- | otherwise = returnRn (unitFV name')
+ | isDyn =
+ lookupImplicitOccsRn [makeStablePtr_RDR, deRefStablePtr_RDR,
+ bindIO_RDR, returnIO_RDR]
+ | otherwise =
+ lookupImplicitOccsRn [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
+ returnRn (addOneFV fvs name')
extra_fvs other = returnRn emptyFVs
in
checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
- lookupImplicitOccsRn [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs1 ->
- extra_fvs imp_exp `thenRn` \ fvs2 ->
+ extra_fvs imp_exp `thenRn` \ fvs1 ->
- rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs3) ->
+ rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
- fvs1 `plusFV` fvs2 `plusFV` fvs3)
+ fvs1 `plusFV` fvs2)
where
fo_decl_msg = ptext SLIT("a foreign declaration")
isDyn = isDynamicExtName ext_nm
-- over FV(T) \ {in-scope-tyvars}
= getLocalNameEnv `thenRn` \ name_env ->
let
- mentioned_in_tau = extractHsTyRdrTyVars ty
- forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_in_tau
+ mentioned_in_tau = extractHsTyRdrTyVars ty
+ mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
+ mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
+ forall_tyvars = filter (not . (`elemFM` name_env)) mentioned
in
- checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' ->
- rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
+ rnForAll doc (map UserTyVar forall_tyvars) ctxt ty
rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
-- 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
+ -- Check that the forall'd tyvars are actually
+ -- mentioned in the type, and produce a warning if not
= let
- mentioned_in_tau = extractHsTyRdrTyVars tau
- mentioned_in_ctxt = nub [tv | p <- ctxt,
- ty <- tys_of_pred p,
- tv <- extractHsTyRdrTyVars ty]
- tys_of_pred (HsPClass clas tys) = tys
- tys_of_pred (HsPIParam n ty) = [ty]
-
- dubious_guys = filter (`notElem` mentioned_in_tau) forall_tyvar_names
- -- dubious = explicitly quantified but not mentioned in tau type
-
- (bad_guys, warn_guys) = partition (`elem` mentioned_in_ctxt) dubious_guys
- -- bad = explicitly quantified and constrained, but not mentioned in tau
- -- warn = explicitly quantified but not mentioned in ctxt or tau
-
- forall_tyvar_names = map getTyVarName forall_tyvars
+ mentioned_in_tau = extractHsTyRdrTyVars tau
+ mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
+ mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
+ forall_tyvar_names = map getTyVarName forall_tyvars
+
+ -- Explicitly quantified but not mentioned in ctxt or tau
+ warn_guys = filter (`notElem` mentioned) forall_tyvar_names
in
- -- mapRn_ (forAllErr doc tau) bad_guys `thenRn_`
- mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
- checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau `thenRn` \ ctxt' ->
- rnForAll doc forall_tyvars ctxt' tau
+ mapRn_ (forAllWarn doc tau) warn_guys `thenRn_`
+ rnForAll doc forall_tyvars ctxt tau
rnHsType doc (HsTyVar tyvar)
= lookupOccRn tyvar `thenRn` \ tyvar' ->
$$
(ptext SLIT("In") <+> doc)
-ambigErr doc constraint ty
- = sep [ptext SLIT("Ambiguous constraint") <+> quotes (ppr constraint),
- nest 4 (ptext SLIT("in the type:") <+> ppr ty),
- nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
- $$
- (ptext SLIT("In") <+> doc)
-
badRuleLhsErr name lhs
= sep [ptext SLIT("Rule") <+> ptext name <> colon,
nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
= sep [hsep [ptext SLIT("Duplicate class assertion"),
quotes (ppr assertion),
ptext SLIT("in the context:")],
- nest 4 (ppr ctxt <+> ptext SLIT("..."))]
+ nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
naughtyCCallContextErr (HsPClass clas _)
= sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
projects / ghc-hetmet.git / blobdiff