X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=1531d8c80911e252d435123cce2d4dbe2121b38d;hb=111cee3f1ad93816cb828e38b38521d85c3bcebb;hp=68b817f21b6a58bebb0117e1793cfe48becf2b90;hpb=be97d35b91db37fed3f5a4ea1f6efc538e3daaaa;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 68b817f..1531d8c 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -4,25 +4,25 @@ \section[RnSource]{Main pass of renamer} \begin{code} -module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where +module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) where #include "HsVersions.h" import RnExpr import HsSyn import HsPragmas -import HsTypes ( getTyVarName, pprClassAssertion, cmpHsTypes ) +import HsTypes ( getTyVarName, pprHsPred, cmpHsTypes ) import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, - extractHsTyRdrNames, extractRuleBndrsTyVars + extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars ) import RnHsSyn import HsCore import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr ) -import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, +import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName, lookupImplicitOccRn, - bindLocalsRn, bindLocalRn, bindLocalsFVRn, + bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn, bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn, bindCoreLocalFVRn, bindCoreLocalsFVRn, checkDupOrQualNames, checkDupNames, @@ -32,6 +32,8 @@ import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, ) import RnMonad +import FunDeps ( oclose ) + import Name ( Name, OccName, ExportFlag(..), Provenance(..), nameOccName, NamedThing(..) @@ -40,31 +42,35 @@ import NameSet import OccName ( mkDefaultMethodOcc ) import BasicTypes ( TopLevelFlag(..) ) import FiniteMap ( elemFM ) -import PrelInfo ( derivingOccurrences, numClass_RDR, - deRefStablePtr_NAME, makeStablePtr_NAME, - bindIO_NAME +import PrelInfo ( derivableClassKeys, + deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME ) import Bag ( bagToList ) import List ( partition, nub ) import Outputable import SrcLoc ( SrcLoc ) import CmdLineOpts ( 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 ) import Util \end{code} -rnDecl `renames' declarations. +@rnDecl@ `renames' declarations. It simultaneously performs dependency analysis and precedence parsing. It also does the following error checks: \begin{enumerate} \item Checks that tyvars are used properly. This includes checking for undefined tyvars, and tyvars in contexts that are ambiguous. +(Some of this checking has now been moved to module @TcMonoType@, +since we don't have functional dependency information at this point.) \item Checks that all variable occurences are defined. \item -Checks the (..) etc constraints in the export list. +Checks the @(..)@ etc constraints in the export list. \end{enumerate} @@ -106,7 +112,7 @@ rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) -> rnDecl (SigD (IfaceSig name ty id_infos loc)) = pushSrcLocRn loc $ lookupBndrRn name `thenRn` \ name' -> - rnHsType doc_str ty `thenRn` \ (ty',fvs1) -> + rnHsPolyType doc_str ty `thenRn` \ (ty',fvs1) -> mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) -> returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2) where @@ -125,23 +131,25 @@ names, reporting any unknown names. Renaming type variables is a pain. Because they now contain uniques, it is necessary to pass in an association list which maps a parsed -tyvar to its Name representation. In some cases (type signatures of -values), it is even necessary to go over the type first in order to -get the set of tyvars used by it, make an assoc list, and then go over -it again to rename the tyvars! However, we can also do some scoping -checks at the same time. +tyvar to its @Name@ representation. +In some cases (type signatures of values), +it is even necessary to go over the type first +in order to get the set of tyvars used by it, make an assoc list, +and then go over it again to rename the tyvars! +However, we can also do some scoping checks at the same time. \begin{code} rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)) = pushSrcLocRn src_loc $ - lookupBndrRn tycon `thenRn` \ tycon' -> - bindTyVarsFVRn data_doc tyvars $ \ tyvars' -> - rnContext data_doc context `thenRn` \ (context', cxt_fvs) -> - checkDupOrQualNames data_doc con_names `thenRn_` - mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) -> - rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) -> + lookupBndrRn tycon `thenRn` \ tycon' -> + bindTyVarsFVRn data_doc tyvars $ \ tyvars' -> + rnContext data_doc context `thenRn` \ (context', cxt_fvs) -> + checkDupOrQualNames data_doc con_names `thenRn_` + mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) -> + rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) -> ASSERT(isNoDataPragmas pragmas) - returnRn (TyClD (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` con_fvs `plusFV` deriv_fvs) where data_doc = text "the data type declaration for" <+> quotes (ppr tycon) @@ -156,7 +164,8 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc)) where syn_doc = text "the declaration for type synonym" <+> quotes (ppr name) -rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname snames src_loc)) +rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas + tname dname dwname snames src_loc)) = pushSrcLocRn src_loc $ lookupBndrRn cname `thenRn` \ cname' -> @@ -170,13 +179,17 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn -- I can't work up the energy to do it more beautifully mkImportedGlobalFromRdrName tname `thenRn` \ tname' -> mkImportedGlobalFromRdrName dname `thenRn` \ dname' -> + mkImportedGlobalFromRdrName dwname `thenRn` \ dwname' -> mapRn mkImportedGlobalFromRdrName snames `thenRn` \ snames' -> -- Tyvars scope over bindings and context - bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' -> + bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' -> -- Check the superclasses - rnContext cls_doc context `thenRn` \ (context', cxt_fvs) -> + rnContext cls_doc context `thenRn` \ (context', cxt_fvs) -> + + -- Check the functional dependencies + rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) -> -- Check the signatures let @@ -185,16 +198,19 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn (fix_sigs, non_sigs) = partition isFixitySig non_op_sigs in checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` - mapFvRn (rn_op cname' clas_tyvar_names) op_sigs `thenRn` \ (sigs', sig_fvs) -> + mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs + `thenRn` \ (sigs', sig_fvs) -> mapRn_ (unknownSigErr) non_sigs `thenRn_` let - binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ] + binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ] in - renameSigs False binders lookupOccRn fix_sigs `thenRn` \ (fixs', fix_fvs) -> + 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', meth_fvs) -> + rnMethodBinds mbinds + `thenRn` \ (mbinds', meth_fvs) -> -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. @@ -202,11 +218,12 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn -- for instance decls. ASSERT(isNoClassPragmas pragmas) - returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') - mbinds' NoClassPragmas tname' dname' snames' src_loc), + returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (fixs' ++ sigs') mbinds' + NoClassPragmas tname' dname' dwname' snames' src_loc), sig_fvs `plusFV` fix_fvs `plusFV` cxt_fvs `plusFV` + fds_fvs `plusFV` meth_fvs ) ) @@ -215,49 +232,41 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn sig_doc = text "the signatures for class" <+> ppr cname meth_doc = text "the default-methods for class" <+> ppr cname - sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs] + sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ _ locn <- sigs] meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds) meth_rdr_names = map fst meth_rdr_names_w_locs - rn_op clas clas_tyvars sig@(ClassOpSig op maybe_dm ty locn) + rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn) = pushSrcLocRn locn $ 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) + check_in_op_ty clas_tyvar = + checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs) + (classTyVarNotInOpTyErr clas_tyvar sig) in mapRn_ check_in_op_ty clas_tyvars `thenRn_` -- Make the default-method name getModeRn `thenRn` \ mode -> - (case (mode, maybe_dm) of - (SourceMode, _) - | op `elem` meth_rdr_names - -> -- Source class decl with an explicit method decl - newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn `thenRn` \ dm_name -> - returnRn (Just dm_name, emptyFVs) - - | otherwise - -> -- Source class dec, no explicit method decl - returnRn (Nothing, emptyFVs) - - (InterfaceMode, Just dm_rdr_name) + (case mode of + SourceMode -> -- Source class decl + newImplicitBinder (mkDefaultMethodOcc (rdrNameOcc op)) locn `thenRn` \ dm_name -> + returnRn (dm_name, op `elem` meth_rdr_names, emptyFVs) + + InterfaceMode -> -- Imported class that has a default method decl -- See comments with tname, snames, above - lookupImplicitOccRn dm_rdr_name `thenRn` \ dm_name -> - returnRn (Just dm_name, unitFV dm_name) - -- An imported class decl mentions, rather than defines, - -- the default method, so we must arrange to pull it in - - (InterfaceMode, Nothing) - -- Imported class with no default metho - -> returnRn (Nothing, emptyFVs) - ) `thenRn` \ (maybe_dm_name, dm_fvs) -> - - returnRn (ClassOpSig op_name maybe_dm_name new_ty locn, op_ty_fvs `plusFV` dm_fvs) + lookupImplicitOccRn dm_rdr_name `thenRn` \ dm_name -> + returnRn (dm_name, explicit_dm, if explicit_dm then unitFV dm_name else emptyFVs) + -- An imported class decl for a class decl that had an explicit default + -- method, mentions, rather than defines, + -- the default method, so we must arrange to pull it in + ) `thenRn` \ (dm_name, final_explicit_dm, dm_fvs) -> + + returnRn (ClassOpSig op_name dm_name final_explicit_dm new_ty locn, op_ty_fvs `plusFV` dm_fvs) \end{code} @@ -270,7 +279,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname sn \begin{code} rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc)) = pushSrcLocRn src_loc $ - rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) -> + 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 @@ -314,13 +323,15 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc)) getModeRn `thenRn` \ mode -> (case mode of - InterfaceMode -> lookupImplicitOccRn dfun_rdr_name `thenRn` \ dfun_name -> + InterfaceMode -> lookupImplicitOccRn dfun_rdr_name `thenRn` \ dfun_name -> returnRn (dfun_name, unitFV dfun_name) - SourceMode -> newDFunName (getDFunKey inst_ty') src_loc `thenRn` \ dfun_name -> + SourceMode -> newDFunName (getDFunKey inst_ty') src_loc + `thenRn` \ dfun_name -> returnRn (dfun_name, emptyFVs) - ) `thenRn` \ (dfun_name, dfun_fv) -> + ) + `thenRn` \ (dfun_name, dfun_fv) -> - -- The typechecker checks that all the bindings are for the right class. + -- The typechecker checks that all the bindings are for the right class. returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name src_loc), inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv) where @@ -338,8 +349,7 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc)) rnDecl (DefD (DefaultDecl tys src_loc)) = pushSrcLocRn src_loc $ rnHsTypes doc_str tys `thenRn` \ (tys', fvs) -> - lookupImplicitOccRn numClass_RDR `thenRn` \ num -> - returnRn (DefD (DefaultDecl tys' src_loc), fvs `addOneFV` num) + returnRn (DefD (DefaultDecl tys' src_loc), fvs) where doc_str = text "a `default' declaration" \end{code} @@ -353,22 +363,28 @@ rnDecl (DefD (DefaultDecl tys src_loc)) \begin{code} rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) = pushSrcLocRn src_loc $ - lookupBndrRn name `thenRn` \ name' -> + lookupOccRn name `thenRn` \ name' -> let + ok_ext_nm Dynamic = True + ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb + ok_ext_nm (ExtName nm Nothing) = isCLabelString nm + fvs1 = case imp_exp of FoImport _ | not isDyn -> emptyFVs FoLabel -> emptyFVs FoExport | isDyn -> mkNameSet [makeStablePtr_NAME, deRefStablePtr_NAME, bindIO_NAME] + | otherwise -> mkNameSet [name'] _ -> emptyFVs in - rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) -> + checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_` + rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) -> returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), fvs1 `plusFV` fvs2) where fo_decl_msg = ptext SLIT("a foreign declaration") - isDyn = isDynamic ext_nm + isDyn = isDynamicExtName ext_nm \end{code} %********************************************************* @@ -410,7 +426,7 @@ rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc)) get_var (RuleBndrSig v _) = v rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs) - rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) -> + rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t `thenRn` \ (t', fvs) -> returnRn (RuleBndrSig id t', fvs) \end{code} @@ -427,37 +443,33 @@ rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars) rnDerivs Nothing -- derivs not specified = returnRn (Nothing, emptyFVs) -rnDerivs (Just ds) - = mapFvRn rn_deriv ds `thenRn` \ (derivs, fvs) -> - returnRn (Just derivs, fvs) +rnDerivs (Just clss) + = mapRn do_one clss `thenRn` \ clss' -> + returnRn (Just clss', mkNameSet clss') where - rn_deriv clas - = lookupOccRn clas `thenRn` \ clas_name -> - - -- Now add extra "occurrences" for things that - -- the deriving mechanism will later need in order to - -- generate code for this class. - case lookupUFM derivingOccurrences clas_name of - Nothing -> addErrRn (derivingNonStdClassErr clas_name) `thenRn_` - returnRn (clas_name, unitFV clas_name) - - Just occs -> mapRn lookupImplicitOccRn occs `thenRn` \ names -> - returnRn (clas_name, mkNameSet (clas_name : names)) + do_one cls = lookupOccRn cls `thenRn` \ clas_name -> + checkRn (getUnique clas_name `elem` derivableClassKeys) + (derivingNonStdClassErr clas_name) `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 (RenamedConDecl, FreeVars) -rnConDecl (ConDecl name tvs cxt details locn) +rnConDecl (ConDecl name wkr tvs cxt details locn) = pushSrcLocRn locn $ checkConName name `thenRn_` lookupBndrRn name `thenRn` \ new_name -> + + mkImportedGlobalFromRdrName wkr `thenRn` \ new_wkr -> + -- See comments with ClassDecl + 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, + returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn, cxt_fvs `plusFV` det_fvs) where doc = text "the definition of data constructor" <+> quotes (ppr name) @@ -472,7 +484,7 @@ rnConDetails doc locn (InfixCon ty1 ty2) returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) rnConDetails doc locn (NewCon ty mb_field) - = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> + = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) -> rn_field mb_field `thenRn` \ new_mb_field -> returnRn (NewCon new_ty new_mb_field, fvs) where @@ -494,15 +506,15 @@ rnField doc (names, ty) returnRn ((new_names, new_ty), fvs) rnBangTy doc (Banged ty) - = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> + = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) -> returnRn (Banged new_ty, fvs) rnBangTy doc (Unbanged ty) - = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> + = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) -> returnRn (Unbanged new_ty, fvs) rnBangTy doc (Unpacked ty) - = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> + = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) -> returnRn (Unpacked new_ty, fvs) -- This data decl will parse OK @@ -532,61 +544,39 @@ rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (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 + = rnHsPolyType (text "the type signature for" <+> doc_str) 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) +--------------------------------------- +rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) +-- rnHsPolyType is prepared to see a for-all; rnHsType is not +-- The former is called for the top level of type sigs and function args. --- 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) . extractHsTyRdrNames) - False - tys - -freeRdrTyVars :: RdrNameHsType -> [RdrName] -freeRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty) - -rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) - -rnHsType doc (HsForAllTy Nothing ctxt ty) +--------------------------------------- +rnHsPolyType 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 - mentioned_in_tau = freeRdrTyVars ty + mentioned_in_tau = extractHsTyRdrTyVars ty forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_in_tau in - checkConstraints False doc forall_tyvars ctxt ty `thenRn` \ ctxt' -> + checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' -> rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty -rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau) +rnHsPolyType 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 = let - mentioned_in_tau = freeRdrTyVars tau - mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt, - ty <- tys, - tv <- freeRdrTyVars ty] + 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 @@ -597,27 +587,69 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau) forall_tyvar_names = map getTyVarName forall_tyvars in - mapRn_ (forAllErr doc tau) bad_guys `thenRn_` - mapRn_ (forAllWarn doc tau) warn_guys `thenRn_` - checkConstraints True doc forall_tyvar_names ctxt tau `thenRn` \ ctxt' -> + -- 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 +rnHsPolyType doc other_ty = rnHsType doc other_ty + + +-- 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 doc forall_tyvars tau_vars ctxt ty + = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' -> + returnRn (catMaybes maybe_ctxt') + -- Remove problem ones, to avoid duplicate error message. + +checkPred doc forall_tyvars ty p@(HsPClass clas tys) + | not_univ = failWithRn Nothing (univErr doc p ty) + | otherwise = returnRn (Just p) + where + ct_vars = extractHsTysRdrTyVars tys + not_univ = -- At least one of the tyvars in each constraint must + -- be universally quantified. This restriction isn't in Hugs + not (any (`elem` forall_tyvars) ct_vars) +checkPred doc forall_tyvars ty p@(HsPIParam _ _) + = returnRn (Just p) + +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 (Just new_tyvars) new_ctxt new_ty, + cxt_fvs `plusFV` ty_fvs) + +--------------------------------------- +rnHsType doc ty@(HsForAllTy _ _ inner_ty) + = addWarnRn (unexpectedForAllTy ty) `thenRn_` + rnHsPolyType doc ty + rnHsType doc (MonoTyVar tyvar) = lookupOccRn tyvar `thenRn` \ tyvar' -> returnRn (MonoTyVar tyvar', unitFV tyvar') rnHsType doc (MonoFunTy ty1 ty2) - = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> - rnHsType doc ty2 `thenRn` \ (ty2', fvs2) -> + = rnHsPolyType doc ty1 `thenRn` \ (ty1', fvs1) -> + -- Might find a for-all as the arg of a function type + rnHsPolyType doc ty2 `thenRn` \ (ty2', fvs2) -> + -- Or as the result. This happens when reading Prelude.hi + -- when we find return :: forall m. Monad m -> forall a. a -> m a returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2) rnHsType doc (MonoListTy ty) = rnHsType doc ty `thenRn` \ (ty', fvs) -> returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name) +-- Unboxed tuples are allowed to have poly-typed arguments. These +-- sometimes crop up as a result of CPR worker-wrappering dictionaries. rnHsType doc (MonoTupleTy tys boxed) - = rnHsTypes doc tys `thenRn` \ (tys', fvs) -> - returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name) + = (if boxed + then mapFvRn (rnHsType doc) tys + else mapFvRn (rnHsPolyType doc) tys) `thenRn` \ (tys', fvs) -> + returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name) where tup_con_name = tupleTyCon_name boxed (length tys) @@ -626,14 +658,34 @@ rnHsType doc (MonoTyApp ty1 ty2) rnHsType doc ty2 `thenRn` \ (ty2', fvs2) -> returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2) +rnHsType doc (MonoIParamTy n ty) + = getIPName n `thenRn` \ name -> + rnHsType doc ty `thenRn` \ (ty', fvs) -> + returnRn (MonoIParamTy name ty', fvs) + rnHsType doc (MonoDictTy clas tys) = lookupOccRn clas `thenRn` \ clas' -> rnHsTypes doc tys `thenRn` \ (tys', fvs) -> returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas') +rnHsType doc (MonoUsgForAllTy uv_rdr ty) + = bindUVarRn doc uv_rdr $ \ uv_name -> + rnHsType doc ty `thenRn` \ (ty', fvs) -> + returnRn (MonoUsgForAllTy uv_name ty', + fvs ) + rnHsType doc (MonoUsgTy usg ty) - = rnHsType doc ty `thenRn` \ (ty', fvs) -> - returnRn (MonoUsgTy usg ty', fvs) + = newUsg usg `thenRn` \ (usg', usg_fvs) -> + rnHsPolyType doc ty `thenRn` \ (ty', ty_fvs) -> + -- A for-all can occur inside a usage annotation + returnRn (MonoUsgTy usg' ty', + usg_fvs `plusFV` ty_fvs) + where + newUsg usg = case usg of + MonoUsOnce -> returnRn (MonoUsOnce, emptyFVs) + MonoUsMany -> returnRn (MonoUsMany, emptyFVs) + MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name -> + returnRn (MonoUsVar uv_name, emptyFVs) rnHsTypes doc tys = mapFvRn (rnHsType doc) tys \end{code} @@ -643,30 +695,48 @@ rnHsTypes doc tys = mapFvRn (rnHsType doc) tys rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars) rnContext doc ctxt - = mapAndUnzipRn rn_ctxt ctxt `thenRn` \ (theta, fvs_s) -> + = mapAndUnzipRn (rnPred doc) ctxt `thenRn` \ (theta, fvs_s) -> let - (_, dup_asserts) = removeDups cmp_assert theta + (_, dup_asserts) = removeDups (cmpHsPred compare) theta in -- Check for duplicate assertions -- If this isn't an error, then it ought to be: mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_` returnRn (theta, plusFVs fvs_s) - where - rn_ctxt (clas, 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) +rnPred doc (HsPClass clas tys) + = lookupOccRn clas `thenRn` \ clas_name -> + rnHsTypes doc tys `thenRn` \ (tys', fvs) -> + returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name) +rnPred doc (HsPIParam n ty) + = getIPName n `thenRn` \ name -> + rnHsType doc ty `thenRn` \ (ty', fvs) -> + returnRn (HsPIParam name ty', fvs) \end{code} +\begin{code} +rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars) + +rnFds doc fds + = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) -> + returnRn (theta, plusFVs fvs_s) + where + rn_fds (tys1, tys2) + = rnHsTyVars doc tys1 `thenRn` \ (tys1', fvs1) -> + rnHsTyVars doc tys2 `thenRn` \ (tys2', fvs2) -> + returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2) + +rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs +rnHsTyvar doc tyvar + = lookupOccRn tyvar `thenRn` \ tyvar' -> + returnRn (tyvar', unitFV tyvar') +\end{code} %********************************************************* -%* * +%* * \subsection{IdInfo} -%* * +%* * %********************************************************* \begin{code} @@ -676,14 +746,14 @@ rnIdInfo (HsWorker worker) = lookupOccRn worker `thenRn` \ worker' -> returnRn (HsWorker worker', unitFV worker') -rnIdInfo (HsUnfold inline (Just expr)) = rnCoreExpr expr `thenRn` \ (expr', fvs) -> - returnRn (HsUnfold inline (Just expr'), fvs) -rnIdInfo (HsUnfold inline Nothing) = returnRn (HsUnfold inline Nothing, emptyFVs) +rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) -> + returnRn (HsUnfold inline expr', fvs) rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs) rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs) -rnIdInfo (HsNoCafRefs) = returnRn (HsNoCafRefs, emptyFVs) -rnIdInfo (HsCprInfo cpr_info) = returnRn (HsCprInfo cpr_info, emptyFVs) -rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body `thenRn` \ (rule_body', fvs) -> +rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs) +rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs) +rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body + `thenRn` \ (rule_body', fvs) -> returnRn (HsSpecialise rule_body', fvs) rnRuleBody (UfRuleBody str vars args rhs) @@ -693,21 +763,27 @@ rnRuleBody (UfRuleBody str vars args rhs) returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2) \end{code} -UfCore expressions. +@UfCore@ expressions. \begin{code} rnCoreExpr (UfType ty) - = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) -> + = rnHsPolyType (text "unfolding type") ty `thenRn` \ (ty', fvs) -> returnRn (UfType ty', fvs) rnCoreExpr (UfVar v) = lookupOccRn v `thenRn` \ v' -> returnRn (UfVar v', unitFV v') -rnCoreExpr (UfCon con args) - = rnUfCon con `thenRn` \ (con', fvs1) -> - mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) -> - returnRn (UfCon con' args', fvs1 `plusFV` fvs2) +rnCoreExpr (UfLit l) + = returnRn (UfLit l, emptyFVs) + +rnCoreExpr (UfLitLit l ty) + = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) -> + returnRn (UfLitLit l ty', fvs) + +rnCoreExpr (UfCCall cc ty) + = rnHsPolyType (text "ccall") ty `thenRn` \ (ty', fvs) -> + returnRn (UfCCall cc ty', fvs) rnCoreExpr (UfTuple con args) = lookupOccRn con `thenRn` \ con' -> @@ -756,7 +832,7 @@ rnCoreExpr (UfLet (UfRec pairs) body) \begin{code} rnCoreBndr (UfValBinder name ty) thing_inside - = rnHsType doc ty `thenRn` \ (ty', fvs1) -> + = rnHsPolyType doc ty `thenRn` \ (ty', fvs1) -> bindCoreLocalFVRn name ( \ name' -> thing_inside (UfValBinder name' ty') ) `thenRn` \ (result, fvs2) -> @@ -784,7 +860,7 @@ rnCoreAlt (con, bndrs, rhs) returnRn (result, fvs1 `plusFV` fvs3) rnNote (UfCoerce ty) - = rnHsType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) -> + = rnHsPolyType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) -> returnRn (UfCoerce ty', fvs) rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs) @@ -795,34 +871,27 @@ rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs) rnUfCon UfDefault = returnRn (UfDefault, emptyFVs) -rnUfCon (UfDataCon con) +rnUfCon (UfDataAlt con) = lookupOccRn con `thenRn` \ con' -> - returnRn (UfDataCon con', unitFV con') - -rnUfCon (UfLitCon lit) - = returnRn (UfLitCon lit, emptyFVs) + returnRn (UfDataAlt con', unitFV con') -rnUfCon (UfLitLitCon lit ty) - = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) -> - returnRn (UfLitLitCon lit ty', fvs) +rnUfCon (UfLitAlt lit) + = returnRn (UfLitAlt lit, emptyFVs) -rnUfCon (UfPrimOp op) - = lookupOccRn op `thenRn` \ op' -> - returnRn (UfPrimOp op', emptyFVs) - -rnUfCon (UfCCallOp str is_dyn casm gc) - = returnRn (UfCCallOp str is_dyn casm gc, emptyFVs) +rnUfCon (UfLitLitAlt lit ty) + = rnHsPolyType (text "litlit") ty `thenRn` \ (ty', fvs) -> + returnRn (UfLitLitAlt lit ty', fvs) \end{code} %********************************************************* -%* * +%* * \subsection{Rule shapes} -%* * +%* * %********************************************************* Check the shape of a transformation rule LHS. Currently -we only allow LHSs of the form (f e1 .. en), where f is -not one of the forall'd variables. +we only allow LHSs of the form @(f e1 .. en)@, where @f@ is +not one of the @forall@'d variables. \begin{code} validRuleLhs foralls lhs @@ -835,9 +904,9 @@ validRuleLhs foralls lhs %********************************************************* -%* * +%* * \subsection{Errors} -%* * +%* * %********************************************************* \begin{code} @@ -852,9 +921,9 @@ classTyVarNotInOpTyErr clas_tyvar sig dupClassAssertWarn ctxt (assertion : dups) = sep [hsep [ptext SLIT("Duplicate class assertion"), - quotes (pprClassAssertion assertion), + quotes (pprHsPred assertion), ptext SLIT("in the context:")], - nest 4 (pprContext ctxt <+> ptext SLIT("..."))] + nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))] badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] @@ -885,16 +954,25 @@ forAllErr doc ty tyvar $$ (ptext SLIT("In") <+> doc)) -ctxtErr explicit_forall doc tyvars constraint ty - = sep [ptext SLIT("None of the type variable(s) in the constraint") <+> quotes (pprClassAssertion constraint), - if explicit_forall then - nest 4 (ptext SLIT("is universally quantified (i.e. bound by the forall)")) - else - nest 4 (ptext SLIT("appears in the type") <+> quotes (ppr ty)) +univErr doc constraint ty + = sep [ptext SLIT("All of the type variable(s) in the constraint") + <+> quotes (pprHsPred constraint) + <+> ptext SLIT("are already in scope"), + nest 4 (ptext SLIT("At least one must be universally quantified here")) ] $$ (ptext SLIT("In") <+> doc) +ambigErr doc constraint ty + = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred 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) + +unexpectedForAllTy ty + = ptext SLIT("Unexpected forall type:") <+> ppr ty + badRuleLhsErr name lhs = sep [ptext SLIT("Rule") <+> ptext name <> colon, nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)] @@ -905,4 +983,8 @@ badRuleVar name var = sep [ptext SLIT("Rule") <+> ptext name <> colon, ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> ptext SLIT("does not appear on left hand side")] + +badExtName :: ExtName -> Message +badExtName ext_nm + = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")] \end{code}