X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=d4d43373aaa187f1e8d07a66b0e0232f56110144;hb=90c0b29e6d8d847e5357bd0a9df98e2846046db7;hp=ef1b7612e1052cbe85ba31a8e07a4355f71a4a67;hpb=83817d01dff687643eee23218435b968ba358a25;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index ef1b761..d4d4337 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -1,10 +1,10 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[RnSource]{Main pass of renamer} \begin{code} -module RnSource ( rnDecl, rnHsType, rnHsSigType ) where +module RnSource ( rnIfaceDecl, rnSourceDecls, rnHsType, rnHsSigType ) where #include "HsVersions.h" @@ -13,37 +13,48 @@ import HsSyn import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) ) import HsPragmas import HsTypes ( getTyVarName, pprClassAssertion, cmpHsTypes ) -import RdrHsSyn +import RdrName ( RdrName, isRdrDataCon, rdrNameOcc ) +import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, + extractHsTyVars + ) import RnHsSyn import HsCore -import CmdLineOpts ( opt_IgnoreIfacePragmas ) -import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs ) -import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn, - newDfunName, checkDupOrQualNames, checkDupNames, - newLocallyDefinedGlobalName, newImportedGlobalName, ifaceFlavour, - listType_RDR, tupleType_RDR ) +import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr ) +import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, + lookupImplicitOccRn, addImplicitOccRn, + bindLocalsRn, + bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn, + checkDupOrQualNames, checkDupNames, + newLocallyDefinedGlobalName, newImportedGlobalName, + newImportedGlobalFromRdrName, + newDFunName, + FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV + ) import RnMonad -import Name ( Name, OccName(..), occNameString, prefixOccName, - ExportFlag(..), Provenance(..), NameSet, mkNameSet, - elemNameSet, nameOccName, NamedThing(..) +import Name ( Name, OccName, + ExportFlag(..), Provenance(..), + nameOccName, NamedThing(..), + mkDefaultMethodOcc, mkDFunOcc ) +import NameSet import BasicTypes ( TopLevelFlag(..) ) -import FiniteMap ( lookupFM ) -import Id ( GenId{-instance NamedThing-} ) -import IdInfo ( FBTypeInfo, ArgUsageInfo ) -import Lex ( isLexCon ) -import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME ) -import Maybes ( maybeToBool ) +import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) +import Type ( funTyCon ) +import FiniteMap ( elemFM ) +import PrelInfo ( derivingOccurrences, numClass_RDR, + deRefStablePtr_NAME, makeStablePtr_NAME, + bindIO_NAME + ) import Bag ( bagToList ) +import List ( partition ) import Outputable import SrcLoc ( SrcLoc ) -import Unique ( Unique ) -import UniqSet ( UniqSet ) -import UniqFM ( UniqFM, lookupUFM ) +import CmdLineOpts ( opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars +import UniqFM ( lookupUFM ) +import Maybes ( maybeToBool, catMaybes ) import Util -import List ( partition, nub ) \end{code} rnDecl `renames' declarations. @@ -67,24 +78,53 @@ Checks the (..) etc constraints in the export list. %********************************************************* \begin{code} -rnDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl +rnSourceDecls :: [RdrNameHsDecl] -> RnMS s ([RenamedHsDecl], FreeVars) + -- The decls get reversed, but that's ok + +rnSourceDecls decls + = go emptyFVs [] decls + where + -- Fixity decls have been dealt with already; ignore them + go fvs ds' [] = returnRn (ds', fvs) + go fvs ds' (FixD _:ds) = go fvs ds' ds + go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') -> + go (fvs `plusFV` fvs') (d':ds') ds + +rnIfaceDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl +rnIfaceDecl d + = rnDecl d `thenRn` \ (d', fvs) -> + returnRn d' +\end{code} + + +%********************************************************* +%* * +\subsection{Value declarations} +%* * +%********************************************************* + +\begin{code} +-- rnDecl does all the work +rnDecl :: RdrNameHsDecl -> RnMS s (RenamedHsDecl, FreeVars) -rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ new_binds -> - returnRn (ValD new_binds) +rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) -> + returnRn (ValD new_binds, fvs) rnDecl (SigD (IfaceSig name ty id_infos loc)) = pushSrcLocRn loc $ lookupBndrRn name `thenRn` \ name' -> - rnHsType ty `thenRn` \ ty' -> + rnIfaceType doc_str ty `thenRn` \ ty' -> -- Get the pragma info (if any). - getModeRn `thenRn` \ (InterfaceMode _ print_unqual) -> - setModeRn (InterfaceMode Optional print_unqual) $ + setModeRn (InterfaceMode Optional) $ -- In all the rest of the signature we read in optional mode, -- so that (a) we don't die mapRn rnIdInfo id_infos `thenRn` \ id_infos' -> - returnRn (SigD (IfaceSig name' ty' id_infos' loc)) + returnRn (SigD (IfaceSig name' ty' id_infos' loc), emptyFVs) + -- Don't need free-var info for iface binds + where + doc_str = text "the interface signature for" <+> quotes (ppr name) \end{code} %********************************************************* @@ -106,63 +146,68 @@ it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnDecl (TyD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)) +rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)) = pushSrcLocRn src_loc $ lookupBndrRn tycon `thenRn` \ tycon' -> - bindTyVarsRn data_doc tyvars $ \ tyvars' -> - rnContext context `thenRn` \ context' -> + bindTyVarsFVRn data_doc tyvars $ \ tyvars' -> + rnContext data_doc context `thenRn` \ (context', cxt_fvs) -> checkDupOrQualNames data_doc con_names `thenRn_` - mapRn rnConDecl condecls `thenRn` \ condecls' -> - rnDerivs derivings `thenRn` \ derivings' -> + mapAndUnzipRn rnConDecl condecls `thenRn` \ (condecls', con_fvs_s) -> + rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) -> ASSERT(isNoDataPragmas pragmas) - returnRn (TyD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)) + returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc), + cxt_fvs `plusFV` plusFVs con_fvs_s `plusFV` deriv_fvs) where - data_doc = text "the data type declaration for" <+> ppr tycon + data_doc = text "the data type declaration for" <+> quotes (ppr tycon) con_names = map conDeclName condecls -rnDecl (TyD (TySynonym name tyvars ty src_loc)) +rnDecl (TyClD (TySynonym name tyvars ty src_loc)) = pushSrcLocRn src_loc $ lookupBndrRn name `thenRn` \ name' -> - bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - rnHsType ty `thenRn` \ ty' -> - returnRn (TyD (TySynonym name' tyvars' ty' src_loc)) + bindTyVarsFVRn syn_doc tyvars $ \ tyvars' -> + rnHsType syn_doc ty `thenRn` \ (ty', ty_fvs) -> + returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs) where - syn_doc = text "the declaration for type synonym" <+> ppr name -\end{code} - -%********************************************************* -%* * -\subsection{Class declarations} -%* * -%********************************************************* + syn_doc = text "the declaration for type synonym" <+> quotes (ppr name) -@rnClassDecl@ uses the `global name function' to create a new -class declaration in which local names have been replaced by their -original names, reporting any unknown names. - -\begin{code} -rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_loc)) +rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_loc)) = pushSrcLocRn src_loc $ lookupBndrRn cname `thenRn` \ cname' -> - lookupBndrRn tname `thenRn` \ tname' -> - lookupBndrRn dname `thenRn` \ dname' -> - bindTyVarsRn cls_doc tyvars ( \ tyvars' -> - rnContext context `thenRn` \ context' -> + -- Deal with the implicit tycon and datacon name + -- They aren't in scope (because they aren't visible to the user) + -- and what we want to do is simply look them up in the cache; + -- we jolly well ought to get a 'hit' there! + -- So the 'Imported' part of this call is not relevant. + -- Unclean; but since these two are the only place this happens + -- I can't work up the energy to do it more beautifully + newImportedGlobalFromRdrName tname `thenRn` \ tname' -> + newImportedGlobalFromRdrName dname `thenRn` \ dname' -> - -- Check the signatures - let - clas_tyvar_names = map getTyVarName tyvars' - in - checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` - mapRn (rn_op cname' clas_tyvar_names) sigs `thenRn` \ sigs' -> - returnRn (tyvars', context', sigs') - ) `thenRn` \ (tyvars', context', sigs') -> + -- Tyvars scope over bindings and context + bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' -> + + -- Check the superclasses + rnContext cls_doc context `thenRn` \ (context', cxt_fvs) -> + + -- Check the signatures + let + -- 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) 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_` - rnMethodBinds mbinds `thenRn` \ mbinds' -> + rnMethodBinds mbinds `thenRn` \ (mbinds', meth_fvs) -> -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. @@ -170,7 +215,13 @@ rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_ -- for instance decls. ASSERT(isNoClassPragmas pragmas) - returnRn (ClD (ClassDecl context' cname' tyvars' sigs' mbinds' NoClassPragmas tname' dname' src_loc)) + 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 sig_doc = text "the signatures for class" <+> ppr cname @@ -182,12 +233,19 @@ rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_ rn_op clas clas_tyvars sig@(ClassOpSig op maybe_dm ty locn) = pushSrcLocRn locn $ - lookupBndrRn op `thenRn` \ op_name -> - rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty -> + lookupBndrRn op `thenRn` \ op_name -> + + -- Check the signature + rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) -> + let + 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_` -- Make the default-method name let - dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op) + dm_occ = mkDefaultMethodOcc (rdrNameOcc op) in getModuleRn `thenRn` \ mod_name -> getModeRn `thenRn` \ mode -> @@ -198,29 +256,17 @@ rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_ (\_ -> Exported) locn `thenRn` \ dm_name -> returnRn (Just dm_name) - (InterfaceMode _ _, Just _) + (InterfaceMode _, Just _) -> -- Imported class that has a default method decl - newImportedGlobalName mod_name dm_occ (ifaceFlavour clas) `thenRn` \ dm_name -> - addOccurrenceName dm_name `thenRn_` + newImportedGlobalName mod_name dm_occ `thenRn` \ dm_name -> + addOccurrenceName dm_name `thenRn_` returnRn (Just dm_name) other -> returnRn Nothing ) `thenRn` \ maybe_dm_name -> - -- Check that each class tyvar appears in op_ty - let - (ctxt, op_ty) = case new_ty of - HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty) - other -> ([], new_ty) - ctxt_fvs = extractHsCtxtTyNames ctxt -- Includes tycons/classes but we - op_ty_fvs = extractHsTyNames op_ty -- don't care about that - - 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_` - returnRn (ClassOpSig op_name maybe_dm_name new_ty locn) + returnRn (ClassOpSig op_name maybe_dm_name new_ty locn, op_ty_fvs) \end{code} @@ -233,52 +279,48 @@ rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_ \begin{code} rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) = pushSrcLocRn src_loc $ - rnHsSigType (text "an instance decl") inst_ty `thenRn` \ inst_ty' -> - + rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) -> + let + inst_tyvars = case inst_ty' of + HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars + other -> [] + -- (Slightly strangely) the forall-d tyvars scope over + -- the method bindings too + in + extendTyVarEnvFVRn inst_tyvars $ -- Rename the bindings -- NB meth_names can be qualified! checkDupNames meth_doc meth_names `thenRn_` - rnMethodBinds mbinds `thenRn` \ mbinds' -> + 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 -> - - let - -- We use the class name and the name of the first - -- type constructor the class is applied to. - (cl_nm, tycon_nm) = mkDictPrefix inst_ty' - - mkDictPrefix (MonoDictTy cl tys) = - case tys of - [] -> (c_nm, nilOccName ) - (ty:_) -> (c_nm, getInstHeadTy ty) - where - c_nm = nameOccName (getName cl) - - mkDictPrefix (HsPreForAllTy _ ty) = mkDictPrefix ty - mkDictPrefix (HsForAllTy _ _ ty) = mkDictPrefix ty -- can this - mkDictPrefix _ = (nilOccName, nilOccName) - - getInstHeadTy t - = case t of - MonoTyVar tv -> nameOccName (getName tv) - MonoTyApp t _ -> getInstHeadTy t - _ -> nilOccName - -- I cannot see how the rest of HsType constructors - -- can occur, but this isn't really a failure condition, - -- so we return silently. - - nilOccName = (VarOcc _NIL_) -- ToDo: add OccName constructor fun for this. - in - newDfunName cl_nm tycon_nm 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 -- The typechecker checks that all the bindings are for the right class. - returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc)) + returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc), + inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs) where meth_doc = text "the bindings in an instance declaration" meth_names = bagToList (collectMonoBinders mbinds) @@ -293,9 +335,38 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) \begin{code} rnDecl (DefD (DefaultDecl tys src_loc)) = pushSrcLocRn src_loc $ - mapRn rnHsType tys `thenRn` \ tys' -> + rnHsTypes doc_str tys `thenRn` \ (tys', fvs) -> lookupImplicitOccRn numClass_RDR `thenRn_` - returnRn (DefD (DefaultDecl tys' src_loc)) + returnRn (DefD (DefaultDecl tys' src_loc), fvs) + where + doc_str = text "a `default' declaration" +\end{code} + +%********************************************************* +%* * +\subsection{Foreign declarations} +%* * +%********************************************************* + +\begin{code} +rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) + = pushSrcLocRn src_loc $ + lookupBndrRn name `thenRn` \ name' -> + (case imp_exp of + FoImport _ | not isDyn -> addImplicitOccRn name' + FoLabel -> addImplicitOccRn name' + FoExport | isDyn -> + addImplicitOccRn makeStablePtr_NAME `thenRn_` + addImplicitOccRn deRefStablePtr_NAME `thenRn_` + addImplicitOccRn bindIO_NAME `thenRn_` + returnRn name' + _ -> 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") + isDyn = isDynamic ext_nm + \end{code} %********************************************************* @@ -305,16 +376,14 @@ rnDecl (DefD (DefaultDecl tys src_loc)) %********************************************************* \begin{code} -rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name]) +rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name], FreeVars) rnDerivs Nothing -- derivs not specified - = lookupImplicitOccRn evalClass_RDR `thenRn_` - returnRn Nothing + = returnRn (Nothing, emptyFVs) rnDerivs (Just ds) - = lookupImplicitOccRn evalClass_RDR `thenRn_` - mapRn rn_deriv ds `thenRn` \ derivs -> - returnRn (Just derivs) + = mapRn rn_deriv ds `thenRn` \ derivs -> + returnRn (Just derivs, foldl addOneFV emptyFVs derivs) where rn_deriv clas = lookupOccRn clas `thenRn` \ clas_name -> @@ -326,56 +395,70 @@ rnDerivs (Just ds) 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} \begin{code} conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc) -conDeclName (ConDecl n _ _ l) = (n,l) +conDeclName (ConDecl n _ _ _ l) = (n,l) -rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl -rnConDecl (ConDecl name cxt details locn) +rnConDecl :: RdrNameConDecl -> RnMS s (RenamedConDecl, FreeVars) +rnConDecl (ConDecl name tvs cxt details locn) = pushSrcLocRn locn $ checkConName name `thenRn_` lookupBndrRn name `thenRn` \ new_name -> - rnConDetails name locn details `thenRn` \ new_details -> - rnContext cxt `thenRn` \ new_context -> - returnRn (ConDecl new_name new_context new_details locn) - -rnConDetails con locn (VanillaCon tys) - = mapRn rnBangTy tys `thenRn` \ new_tys -> - returnRn (VanillaCon new_tys) - -rnConDetails con locn (InfixCon ty1 ty2) - = rnBangTy ty1 `thenRn` \ new_ty1 -> - rnBangTy ty2 `thenRn` \ new_ty2 -> - returnRn (InfixCon new_ty1 new_ty2) - -rnConDetails con locn (NewCon ty) - = rnHsType ty `thenRn` \ new_ty -> - returnRn (NewCon new_ty) - -rnConDetails con locn (RecCon fields) - = checkDupOrQualNames fld_doc field_names `thenRn_` - mapRn rnField fields `thenRn` \ new_fields -> - returnRn (RecCon new_fields) + bindTyVarsFVRn doc tvs $ \ new_tyvars -> + rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) -> + rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) -> + returnRn (ConDecl new_name new_tyvars new_context new_details locn, + cxt_fvs `plusFV` det_fvs) + where + doc = text "the definition of data constructor" <+> quotes (ppr name) + +rnConDetails doc locn (VanillaCon tys) + = mapAndUnzipRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs_s) -> + returnRn (VanillaCon new_tys, plusFVs fvs_s) + +rnConDetails doc locn (InfixCon ty1 ty2) + = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) -> + rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) -> + returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) + +rnConDetails doc locn (NewCon ty mb_field) + = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> + rn_field mb_field `thenRn` \ new_mb_field -> + returnRn (NewCon new_ty new_mb_field, fvs) + where + rn_field Nothing = returnRn Nothing + rn_field (Just f) = + lookupBndrRn f `thenRn` \ new_f -> + returnRn (Just new_f) + +rnConDetails doc locn (RecCon fields) + = checkDupOrQualNames doc field_names `thenRn_` + mapAndUnzipRn (rnField doc) fields `thenRn` \ (new_fields, fvs_s) -> + returnRn (RecCon new_fields, plusFVs fvs_s) where - fld_doc = text "the fields of constructor" <> ppr con field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds] -rnField (names, ty) +rnField doc (names, ty) = mapRn lookupBndrRn names `thenRn` \ new_names -> - rnBangTy ty `thenRn` \ new_ty -> - returnRn (new_names, new_ty) + rnBangTy doc ty `thenRn` \ (new_ty, fvs) -> + returnRn ((new_names, new_ty), fvs) -rnBangTy (Banged ty) - = rnHsType ty `thenRn` \ new_ty -> - returnRn (Banged new_ty) +rnBangTy doc (Banged ty) + = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> + returnRn (Banged new_ty, fvs) -rnBangTy (Unbanged ty) - = rnHsType ty `thenRn` \ new_ty -> - returnRn (Unbanged new_ty) +rnBangTy doc (Unbanged ty) + = 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 @@ -388,154 +471,180 @@ rnBangTy (Unbanged ty) -- from interface files, which always print in prefix form checkConName name - = checkRn (isLexCon (occNameString (rdrNameOcc name))) + = checkRn (isRdrDataCon name) (badDataCon name) \end{code} %********************************************************* %* * -\subsection{Support code to rename types} +\subsection{Naming a dfun} %* * %********************************************************* -\begin{code} -rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType - -- rnHsSigType is used for source-language type signatures, - -- which use *implicit* universal quantification. - --- 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. +Make a name for the dict fun for an instance decl -rnHsSigType doc_str full_ty@(HsPreForAllTy ctxt ty) -- From source code (no kinds on tyvars) - = getLocalNameEnv `thenRn` \ name_env -> - let - mentioned_tyvars = extractHsTyVars ty - forall_tyvars = filter (not . in_scope) mentioned_tyvars - in_scope tv = maybeToBool (lookupFM name_env tv) - - constrained_tyvars = extractHsCtxtTyVars ctxt - constrained_and_in_scope = filter in_scope constrained_tyvars - constrained_and_not_mentioned = filter (not . (`elem` mentioned_tyvars)) constrained_tyvars +\begin{code} +mkDFunName :: RenamedHsType -- Instance type + -> Maybe RdrName -- Dfun thing from decl; Nothing <=> source + -> SrcLoc + -> RnMS s Name - -- Zap the context if there's a problem, to avoid duplicate error message. - ctxt' | null constrained_and_in_scope && null constrained_and_not_mentioned = ctxt - | otherwise = [] - in - checkRn (null constrained_and_in_scope) - (ctxtErr1 sig_doc constrained_and_in_scope) `thenRn_` - checkRn (null constrained_and_not_mentioned) - (ctxtErr2 sig_doc constrained_and_not_mentioned ty) `thenRn_` - - (bindTyVarsRn sig_doc (map UserTyVar forall_tyvars) $ \ new_tyvars -> - rnContext ctxt' `thenRn` \ new_ctxt -> - rnHsType ty `thenRn` \ new_ty -> - returnRn (HsForAllTy new_tyvars new_ctxt new_ty) - ) +mkDFunName inst_ty maybe_df src_loc + = newDFunName cl_occ tycon_occ maybe_df src_loc where - sig_doc = text "the type signature for" <+> doc_str - + (cl_occ, tycon_occ) = get_key inst_ty + + get_key (HsForAllTy _ _ ty) = get_key ty + get_key (MonoFunTy _ ty) = get_key ty + get_key (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty) + + get_tycon_key (MonoTyVar tv) = nameOccName (getName tv) + get_tycon_key (MonoTyApp ty _) = get_tycon_key ty + get_tycon_key (MonoTupleTy tys True) = getOccName (tupleTyCon (length tys)) + get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys)) + get_tycon_key (MonoListTy _) = getOccName listTyCon + get_tycon_key (MonoFunTy _ _) = getOccName funTyCon +\end{code} -rnHsSigType doc_str other_ty = rnHsType other_ty -rnHsType :: RdrNameHsType -> RnMS s RenamedHsType -rnHsType (HsForAllTy tvs ctxt ty) -- From an interface file (tyvars may be kinded) - = rn_poly_help tvs ctxt ty +%********************************************************* +%* * +\subsection{Support code to rename types} +%* * +%********************************************************* -rnHsType full_ty@(HsPreForAllTy ctxt ty) -- A (context => ty) embedded in a type. - -- Universally quantify over tyvars in context +\begin{code} +rnHsSigType :: SDoc -> RdrNameHsType -> RnMS s (RenamedHsType, FreeVars) + -- rnHsSigType is used for source-language type signatures, + -- which use *implicit* universal quantification. +rnHsSigType doc_str ty + = rnHsType (text "the type signature for" <+> doc_str) ty + +rnIfaceType :: SDoc -> RdrNameHsType -> RnMS s RenamedHsType +rnIfaceType doc ty + = 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 Nothing ctxt ty) + -- From source code (no kinds on tyvars) + -- Given the signature C => T we universally quantify + -- over FV(T) \ {in-scope-tyvars} = getLocalNameEnv `thenRn` \ name_env -> let - forall_tyvars = extractHsCtxtTyVars ctxt + mentioned_tyvars = extractHsTyVars ty + forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_tyvars in - rn_poly_help (map UserTyVar forall_tyvars) ctxt ty + 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 (MonoTyVar tyvar) +rnHsType doc (MonoTyVar tyvar) = lookupOccRn tyvar `thenRn` \ tyvar' -> - returnRn (MonoTyVar tyvar') - -rnHsType (MonoFunTy ty1 ty2) - = andRn MonoFunTy (rnHsType ty1) (rnHsType ty2) - -rnHsType (MonoListTy _ ty) - = lookupImplicitOccRn listType_RDR `thenRn` \ tycon_name -> - rnHsType ty `thenRn` \ ty' -> - returnRn (MonoListTy tycon_name ty') - -rnHsType (MonoTupleTy _ tys) - = lookupImplicitOccRn (tupleType_RDR (length tys)) `thenRn` \ tycon_name -> - mapRn rnHsType tys `thenRn` \ tys' -> - returnRn (MonoTupleTy tycon_name tys') + returnRn (MonoTyVar tyvar', unitFV tyvar') + +rnHsType doc (MonoFunTy ty1 ty2) + = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> + rnHsType doc ty2 `thenRn` \ (ty2', fvs2) -> + returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2) + +rnHsType doc (MonoListTy ty) + = addImplicitOccRn listTyCon_name `thenRn_` + rnHsType doc ty `thenRn` \ (ty', fvs) -> + returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name) + +rnHsType doc (MonoTupleTy tys boxed) + = addImplicitOccRn tup_con_name `thenRn_` + rnHsTypes doc tys `thenRn` \ (tys', fvs) -> + returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name) + where + tup_con_name = tupleTyCon_name boxed (length tys) -rnHsType (MonoTyApp ty1 ty2) - = rnHsType ty1 `thenRn` \ ty1' -> - rnHsType ty2 `thenRn` \ ty2' -> - returnRn (MonoTyApp ty1' ty2') +rnHsType doc (MonoTyApp ty1 ty2) + = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> + rnHsType doc ty2 `thenRn` \ (ty2', fvs2) -> + returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2) -rnHsType (MonoDictTy clas tys) +rnHsType doc (MonoDictTy clas tys) = lookupOccRn clas `thenRn` \ clas' -> - mapRn rnHsType tys `thenRn` \ tys' -> - returnRn (MonoDictTy clas' tys') - -rn_poly_help :: [HsTyVar RdrName] -- Universally quantified tyvars - -> RdrNameContext - -> RdrNameHsType - -> RnMS s RenamedHsType -rn_poly_help tyvars ctxt ty - = bindTyVarsRn sig_doc tyvars $ \ new_tyvars -> - rnContext ctxt `thenRn` \ new_ctxt -> - rnHsType ty `thenRn` \ new_ty -> - returnRn (HsForAllTy new_tyvars new_ctxt new_ty) - where - sig_doc = text "a nested for-all type" + rnHsTypes doc tys `thenRn` \ (tys', fvs) -> + returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas') + +rnHsTypes doc tys + = mapAndUnzipRn (rnHsType doc) tys `thenRn` \ (tys, fvs_s) -> + returnRn (tys, plusFVs fvs_s) \end{code} \begin{code} -rnContext :: RdrNameContext -> RnMS s RenamedContext +rnContext :: SDoc -> RdrNameContext -> RnMS s (RenamedContext, FreeVars) -rnContext ctxt - = mapRn rn_ctxt ctxt `thenRn` \ result -> +rnContext doc ctxt + = mapAndUnzipRn rn_ctxt ctxt `thenRn` \ (theta, fvs_s) -> let - (_, dup_asserts) = removeDups cmp_assert result - (alls, theta) = partition (\(c,_) -> c == allClass_NAME) result + (_, dup_asserts) = removeDups cmp_assert theta 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_` - -- Check for All constraining a non-type-variable - mapRn check_All alls `thenRn_` - - -- Done. Return a theta omitting all the "All" constraints. - -- They have done done their work by ensuring that we universally - -- quantify over their tyvar. - returnRn theta + returnRn (theta, plusFVs fvs_s) where rn_ctxt (clas, tys) - = -- Mini hack here. If the class is our pseudo-class "All", - -- then we don't want to record it as an occurrence, otherwise - -- we try to slurp it in later and it doesn't really exist at all. - -- Easiest thing is simply not to put it in the occurrence set. - lookupBndrRn clas `thenRn` \ clas_name -> - (if clas_name /= allClass_NAME then - addOccurrenceName clas_name - else - returnRn clas_name - ) `thenRn_` - mapRn rnHsType tys `thenRn` \ tys' -> - returnRn (clas_name, tys') - + = lookupOccRn clas `thenRn` \ clas_name -> + rnHsTypes doc tys `thenRn` \ (tys', fvs) -> + returnRn ((clas_name, tys'), fvs `addOneFV` clas_name) cmp_assert (c1,tys1) (c2,tys2) = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2) - - check_All (c, [MonoTyVar _]) = returnRn () -- OK! - check_All assertion = addErrRn (wierdAllErr assertion) \end{code} @@ -546,58 +655,64 @@ rnContext ctxt %********************************************************* \begin{code} -rnIdInfo (HsStrictness strict) - = rnStrict strict `thenRn` \ strict' -> - returnRn (HsStrictness strict') - -rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' -> - returnRn (HsUnfold inline expr') -rnIdInfo (HsArity arity) = returnRn (HsArity arity) -rnIdInfo (HsUpdate update) = returnRn (HsUpdate update) -rnIdInfo (HsFBType fb) = returnRn (HsFBType fb) -rnIdInfo (HsArgUsage au) = returnRn (HsArgUsage au) +rnIdInfo (HsStrictness str) = returnRn (HsStrictness str) -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. +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 (HsStrictnessInfo demands (Just (worker',[]))) + returnRn (HsWorker worker' []) --- Boring, but necessary for the type checker. -rnStrict (HsStrictnessInfo demands Nothing) = returnRn (HsStrictnessInfo demands Nothing) -rnStrict HsBottom = returnRn HsBottom +rnIdInfo (HsUnfold inline (Just expr)) = rnCoreExpr expr `thenRn` \ expr' -> + returnRn (HsUnfold inline (Just expr')) +rnIdInfo (HsUnfold inline Nothing) = returnRn (HsUnfold inline Nothing) +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' -> + mapRn (rnIfaceType doc) tys `thenRn` \ tys' -> + returnRn (HsSpecialise tyvars' tys' expr') + where + doc = text "Specialise in interface pragma" \end{code} UfCore expressions. \begin{code} +rnCoreExpr (UfType ty) + = rnIfaceType (text "unfolding type") ty `thenRn` \ ty' -> + returnRn (UfType ty') + rnCoreExpr (UfVar v) = lookupOccRn v `thenRn` \ v' -> returnRn (UfVar v') -rnCoreExpr (UfLit lit) = returnRn (UfLit lit) - rnCoreExpr (UfCon con args) - = lookupOccRn con `thenRn` \ con' -> - mapRn rnCoreArg args `thenRn` \ args' -> + = rnUfCon con `thenRn` \ con' -> + mapRn rnCoreExpr args `thenRn` \ args' -> returnRn (UfCon con' args') -rnCoreExpr (UfPrim prim args) - = rnCorePrim prim `thenRn` \ prim' -> - mapRn rnCoreArg args `thenRn` \ args' -> - returnRn (UfPrim prim' args') +rnCoreExpr (UfTuple con args) + = lookupOccRn con `thenRn` \ con' -> + mapRn rnCoreExpr args `thenRn` \ args' -> + returnRn (UfTuple con' args') rnCoreExpr (UfApp fun arg) = rnCoreExpr fun `thenRn` \ fun' -> - rnCoreArg arg `thenRn` \ arg' -> + rnCoreExpr arg `thenRn` \ arg' -> returnRn (UfApp fun' arg') -rnCoreExpr (UfCase scrut alts) - = rnCoreExpr scrut `thenRn` \ scrut' -> - rnCoreAlts alts `thenRn` \ alts' -> - returnRn (UfCase scrut' alts') +rnCoreExpr (UfCase scrut bndr alts) + = rnCoreExpr scrut `thenRn` \ scrut' -> + bindLocalsRn "a UfCase" [bndr] $ \ [bndr'] -> + mapRn rnCoreAlt alts `thenRn` \ alts' -> + returnRn (UfCase scrut' bndr' alts') rnCoreExpr (UfNote note expr) = rnNote note `thenRn` \ note' -> @@ -626,70 +741,62 @@ rnCoreExpr (UfLet (UfRec pairs) body) \begin{code} rnCoreBndr (UfValBinder name ty) thing_inside - = rnHsType ty `thenRn` \ ty' -> - bindLocalsRn "unfolding value" [name] $ \ [name'] -> + = rnIfaceType (text str) ty `thenRn` \ ty' -> + bindLocalsRn str [name] $ \ [name'] -> thing_inside (UfValBinder name' ty') + where + str = "unfolding id" rnCoreBndr (UfTyBinder name kind) thing_inside - = bindLocalsRn "unfolding tyvar" [name] $ \ [name'] -> + = bindLocalsRn "an unfolding tyvar" [name] $ \ [name'] -> thing_inside (UfTyBinder name' kind) rnCoreBndrs bndrs thing_inside -- Expect them all to be ValBinders - = mapRn rnHsType tys `thenRn` \ tys' -> - bindLocalsRn "unfolding value" names $ \ names' -> + = mapRn (rnIfaceType (text str)) tys `thenRn` \ tys' -> + bindLocalsRn str names $ \ names' -> thing_inside (zipWith UfValBinder names' tys') where - names = map (\ (UfValBinder name _) -> name) bndrs - tys = map (\ (UfValBinder _ ty) -> ty) bndrs - -rnCoreBndrNamess names thing_inside - = bindLocalsRn "unfolding value" names $ \ names' -> - thing_inside names' + str = "unfolding id" + names = map (\ (UfValBinder name _ ) -> name) bndrs + tys = map (\ (UfValBinder _ ty) -> ty) bndrs \end{code} \begin{code} -rnCoreArg (UfVarArg v) = lookupOccRn v `thenRn` \ v' -> returnRn (UfVarArg v') -rnCoreArg (UfTyArg ty) = rnHsType ty `thenRn` \ ty' -> returnRn (UfTyArg ty') -rnCoreArg (UfLitArg lit) = returnRn (UfLitArg lit) - -rnCoreAlts (UfAlgAlts alts deflt) - = mapRn rn_alt alts `thenRn` \ alts' -> - rnCoreDefault deflt `thenRn` \ deflt' -> - returnRn (UfAlgAlts alts' deflt') - where - rn_alt (con, bndrs, rhs) = lookupOccRn con `thenRn` \ con' -> - bindLocalsRn "unfolding alt" bndrs $ \ bndrs' -> - rnCoreExpr rhs `thenRn` \ rhs' -> - returnRn (con', bndrs', rhs') - -rnCoreAlts (UfPrimAlts alts deflt) - = mapRn rn_alt alts `thenRn` \ alts' -> - rnCoreDefault deflt `thenRn` \ deflt' -> - returnRn (UfPrimAlts alts' deflt') - where - rn_alt (lit, rhs) = rnCoreExpr rhs `thenRn` \ rhs' -> - returnRn (lit, rhs') +rnCoreAlt (con, bndrs, rhs) + = rnUfCon con `thenRn` \ con' -> + bindLocalsRn "an unfolding alt" bndrs $ \ bndrs' -> + rnCoreExpr rhs `thenRn` \ rhs' -> + returnRn (con', bndrs', rhs') -rnCoreDefault UfNoDefault = returnRn UfNoDefault -rnCoreDefault (UfBindDefault bndr rhs) = bindLocalsRn "unfolding default" [bndr] $ \ [bndr'] -> - rnCoreExpr rhs `thenRn` \ rhs' -> - returnRn (UfBindDefault bndr' rhs') rnNote (UfCoerce ty) - = rnHsType ty `thenRn` \ ty' -> + = rnIfaceType (text "unfolding coerce") ty `thenRn` \ ty' -> returnRn (UfCoerce ty') rnNote (UfSCC cc) = returnRn (UfSCC cc) rnNote UfInlineCall = returnRn UfInlineCall -rnCorePrim (UfOtherOp op) - = lookupOccRn op `thenRn` \ op' -> - returnRn (UfOtherOp op') -rnCorePrim (UfCCallOp str casm gc arg_tys res_ty) - = mapRn rnHsType arg_tys `thenRn` \ arg_tys' -> - rnHsType res_ty `thenRn` \ res_ty' -> - returnRn (UfCCallOp str casm gc arg_tys' res_ty') +rnUfCon UfDefault + = returnRn UfDefault + +rnUfCon (UfDataCon con) + = lookupOccRn con `thenRn` \ con' -> + returnRn (UfDataCon con') + +rnUfCon (UfLitCon lit) + = returnRn (UfLitCon lit) + +rnUfCon (UfLitLitCon lit ty) + = rnIfaceType (text "litlit") ty `thenRn` \ ty' -> + returnRn (UfLitLitCon lit ty') + +rnUfCon (UfPrimOp op) + = lookupOccRn op `thenRn` \ op' -> + returnRn (UfPrimOp op') + +rnUfCon (UfCCallOp str is_dyn casm gc) + = returnRn (UfCCallOp str is_dyn casm gc) \end{code} %********************************************************* @@ -709,27 +816,38 @@ classTyVarNotInOpTyErr clas_tyvar sig 4 (ppr sig) dupClassAssertWarn ctxt (assertion : dups) - = sep [hsep [ptext SLIT("Duplicated class assertion"), + = sep [hsep [ptext SLIT("Duplicate class assertion"), quotes (pprClassAssertion assertion), ptext SLIT("in the context:")], - nest 4 (pprContext ctxt)] + nest 4 (pprContext ctxt <+> ptext SLIT("..."))] badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] -wierdAllErr assertion - = ptext SLIT("Mal-formed use of `All':") <+> pprClassAssertion assertion - -ctxtErr1 doc tyvars - = hsep [ptext SLIT("Context constrains in-scope type variable(s)"), - pprQuotedList tyvars] - $$ - nest 4 (ptext SLIT("in") <+> doc) - -ctxtErr2 doc tyvars ty - = (ptext SLIT("Context constrains type variable(s)") - <+> pprQuotedList tyvars) +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 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)) + ] $$ - nest 4 (vcat [ptext SLIT("that do not appear in") <+> quotes (ppr ty), - ptext SLIT("in") <+> doc]) + (ptext SLIT("In") <+> doc) \end{code}