From: simonpj Date: Thu, 23 Aug 2001 15:05:53 +0000 (+0000) Subject: [project @ 2001-08-23 15:05:52 by simonpj] X-Git-Tag: Approximately_9120_patches~1095 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=f62fd70df7695286af55854911dad8a28eecb5e1;p=ghc-hetmet.git [project @ 2001-08-23 15:05:52 by simonpj] More instance-gate fiddling. This must be one of the most tiremsome bits of the entire compiler, and I appear to be incapable of modifying it without getting it wrong at least once. Still, this commit does tidy things up a bit. * The type renamers (rnHsType, etc) have moved from RnSource into a new module RnTypes. * This breaks a couple of loops, and lets us nuke RnSource.hi-boot. Hurrah! Simon --- diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 6334d33..de668a8 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -43,8 +43,7 @@ module RdrHsSyn ( RdrMatch(..), SigConverter, - extractHsTyRdrNames, extractSomeHsTyRdrNames, - extractHsTysRdrNames, extractSomeHsTysRdrNames, + extractHsTyRdrNames, extractHsTyRdrTyVars, extractRuleBndrsTyVars, extractHsCtxtRdrTyVars, extractGenericPatTyVars, @@ -66,8 +65,7 @@ import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, mkGenOcc2, ) import PrelNames ( minusName, negateName, fromIntegerName, fromRationalName ) -import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, - ) +import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar ) import List ( nub ) import BasicTypes ( RecFlag(..) ) import Class ( DefMeth (..) ) @@ -129,14 +127,8 @@ It's used when making the for-alls explicit. extractHsTyRdrNames :: RdrNameHsType -> [RdrName] extractHsTyRdrNames ty = nub (extract_ty ty []) -extractHsTysRdrNames :: [RdrNameHsType] -> [RdrName] -extractHsTysRdrNames tys = nub (extract_tys tys) - -extractSomeHsTyRdrNames :: (RdrName -> Bool) -> RdrNameHsType -> [RdrName] -extractSomeHsTyRdrNames ok ty = nub (filter ok (extract_ty ty [])) - -extractSomeHsTysRdrNames :: (RdrName -> Bool) -> [RdrNameHsType] -> [RdrName] -extractSomeHsTysRdrNames ok tys = nub (filter ok (extract_tys tys)) +extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName] +extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty [])) extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName] extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs)) diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index aea97d3..8cb0902 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -18,13 +18,13 @@ module RnBinds ( #include "HsVersions.h" -import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType ) import HsSyn import HsBinds ( eqHsSig, sigName, hsSigDoc ) import RdrHsSyn import RnHsSyn import RnMonad +import RnTypes ( rnHsSigType, rnHsType ) import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, lookupSigOccRn, diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 62e228f..ce22f17 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -18,15 +18,14 @@ module RnExpr ( #include "HsVersions.h" import {-# SOURCE #-} RnBinds ( rnBinds ) -import {-# SOURCE #-} RnSource ( rnHsTypeFVs ) import HsSyn import RdrHsSyn import RnHsSyn import RnMonad import RnEnv +import RnTypes ( rnHsTypeFVs ) import RnHiFiles ( lookupFixityRn ) -import RdrName ( isRdrTyVar ) import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) import Literal ( inIntRange, inCharRange ) import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity ) @@ -210,8 +209,7 @@ bindPatSigTyVars :: [RdrNameHsType] bindPatSigTyVars tys thing_inside = getLocalNameEnv `thenRn` \ name_env -> let - tyvars_in_sigs = extractSomeHsTysRdrNames isRdrTyVar tys - forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs + forall_tyvars = [ tv | ty <- tys, tv <- extractHsTyRdrTyVars ty, not (tv `elemFM` name_env)] doc_sig = text "In a pattern type-signature" in bindNakedTyVarsFVRn doc_sig forall_tyvars thing_inside diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index b0d6d18..86d02aa 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -29,12 +29,12 @@ import HscTypes ( ModuleLocation(..), ) import HsSyn ( TyClDecl(..), InstDecl(..), HsType(..), HsPred(..), FixitySig(..), RuleDecl(..), - tyClDeclNames, tyClDeclSysNames - ) -import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl, - extractSomeHsTysRdrNames + tyClDeclNames, tyClDeclSysNames, hsTyVarNames ) +import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) +import RnHsSyn ( extractHsTyNames_s ) import BasicTypes ( Version, defaultFixity ) +import RnTypes ( rnHsType ) import RnEnv import RnMonad import ParseIface ( parseIface ) @@ -43,8 +43,9 @@ import Name ( Name {-instance NamedThing-}, nameModule, isLocalName, nameIsLocalOrFrom ) import NameEnv +import NameSet import Module -import RdrName ( rdrNameOcc, isRdrTc ) +import RdrName ( rdrNameOcc ) import SrcLoc ( mkSrcLoc ) import Maybes ( maybeToBool, orElse ) import StringBuffer ( hGetStringBuffer ) @@ -53,6 +54,7 @@ import ErrUtils ( Message ) import Finder ( findModule, findPackageModule ) import Lex import FiniteMap +import ListSetOps ( minusList ) import Outputable import Bag import Config @@ -373,30 +375,39 @@ loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) -- if C is visible and *any one* of the Names in the types -- This is a slightly brutal approximation, but most instance decls -- are regular H98 ones and it's perfect for them. + -- + -- NOTICE that we rename the type before extracting its free + -- variables. The free-variable finder for a renamed HsType + -- does the Right Thing for built-in syntax like [] and (,). + initIfaceRnMS mod ( + rnHsType (text "In an interface instance decl") inst_ty + ) `thenRn` \ inst_ty' -> let - (cls_name,tys) = get_head inst_ty - free_ty_names = extractSomeHsTysRdrNames isRdrTc tys - in - lookupIfaceName cls_name `thenRn` \ cls_name' -> - mapRn lookupIfaceName free_ty_names `thenRn` \ free_ty_names' -> - let - gate_fn vis_fn = vis_fn cls_name' && any vis_fn free_ty_names' + (tvs,(cls,tys)) = get_head inst_ty' + free_tcs = nameSetToList (extractHsTyNames_s tys) `minusList` hsTyVarNames tvs + + gate_fn vis_fn = vis_fn cls && (null free_tcs || any vis_fn free_tcs) -- Here is the implementation of HOWEVER above + -- (Note that we do let the inst decl in if it mentions + -- no tycons at all. Hence the null free_ty_names.) in returnRn ((gate_fn, (mod, decl)) `consBag` insts) -- In interface files, the instance decls now look like -- forall a. Foo a -> Baz (T a) --- so we have to strip off function argument types as well --- as the bit before the '=>' (which is always empty in interface files) +-- so we have to strip off function argument types, +-- as well as the bit before the '=>' (which is always +-- empty in interface files) -- -- The parser ensures the type will have the right shape. -- (e.g. see ParseUtil.checkInstType) -get_head (HsForAllTy tvs cxt ty) = get_head ty -get_head (HsFunTy _ ty) = get_head ty -get_head (HsPredTy (HsClassP cls tys)) = (cls,tys) +get_head (HsForAllTy (Just tvs) _ tau) = (tvs, get_head1 tau) +get_head tau = ([], get_head1 tau) + +get_head1 (HsFunTy _ ty) = get_head1 ty +get_head1 (HsPredTy (HsClassP cls tys)) = (cls,tys) @@ -580,15 +591,14 @@ readIface file_path bale_out err = returnRn (Left (badIfaceFile file_path err)) \end{code} - %********************************************************* %* * \subsection{Looking up fixities} %* * %********************************************************* -@lookupFixityRn@ has to be in RnIfaces (or RnHiFiles) because -it calls @loadHomeInterface@. +@lookupFixityRn@ has to be in RnIfaces (or RnHiFiles), instead of +its obvious home in RnEnv, because it calls @loadHomeInterface@. lookupFixity is a bit strange. @@ -673,4 +683,3 @@ notLoaded mod warnSelfImport mod = ptext SLIT("Importing my own interface: module") <+> ppr mod \end{code} - diff --git a/ghc/compiler/rename/RnSource.hi-boot b/ghc/compiler/rename/RnSource.hi-boot deleted file mode 100644 index 802d0a8..0000000 --- a/ghc/compiler/rename/RnSource.hi-boot +++ /dev/null @@ -1,11 +0,0 @@ -_interface_ RnSource 2 -_exports_ -RnSource rnHsType rnHsSigType rnHsTypeFVs; -_declarations_ -1 rnHsTypeFVs _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType - -> RnMonad.RnMS (RnHsSyn.RenamedHsType, NameSet.FreeVars) ;; -2 rnHsSigType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType - -> RnMonad.RnMS RnHsSyn.RenamedHsType ;; -2 rnHsType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType - -> RnMonad.RnMS RnHsSyn.RenamedHsType ;; - diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 93010de..f3ccf33 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -5,7 +5,6 @@ \begin{code} module RnSource ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls, - rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs ) where #include "HsVersions.h" @@ -13,17 +12,17 @@ module RnSource ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls, import RnExpr import HsSyn import HscTypes ( GlobalRdrEnv ) -import HsTypes ( hsTyVarNames, pprHsContext ) -import RdrName ( RdrName, isRdrDataCon, isRdrTyVar, elemRdrEnv ) -import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl, - extractRuleBndrsTyVars, extractSomeHsTyRdrNames, - extractHsCtxtRdrTyVars, extractGenericPatTyVars +import RdrName ( RdrName, isRdrDataCon, elemRdrEnv ) +import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, + extractRuleBndrsTyVars, extractGenericPatTyVars ) import RnHsSyn import HsCore +import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext ) + import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs ) -import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName, lookupIfaceName, +import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupIfaceName, lookupOrigNames, lookupSysBinder, newLocalsRn, bindLocalsFVRn, bindTyVarsRn, bindTyVars2Rn, @@ -37,19 +36,18 @@ import Class ( FunDep, DefMeth (..) ) import DataCon ( dataConId ) import Name ( Name, NamedThing(..) ) import NameSet -import PrelInfo ( derivableClassKeys, cCallishClassKeys ) +import PrelInfo ( derivableClassKeys ) import PrelNames ( deRefStablePtr_RDR, newStablePtr_RDR, bindIO_RDR, returnIO_RDR ) import TysWiredIn ( tupleCon ) -import List ( partition, nub ) +import List ( partition ) import Outputable import SrcLoc ( SrcLoc ) import CmdLineOpts ( DynFlag(..) ) -- Warn of unused for-all'd tyvars import Unique ( Uniquable(..) ) import Maybes ( maybeToBool ) -import ListSetOps ( removeDupsEq ) \end{code} @rnSourceDecl@ `renames' declarations. @@ -527,155 +525,6 @@ checkConName name %********************************************************* \begin{code} -rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) -rnHsTypeFVs doc_str ty - = rnHsType doc_str ty `thenRn` \ ty' -> - returnRn (ty', extractHsTyNames ty') - -rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) -rnHsSigTypeFVs doc_str ty - = rnHsSigType doc_str ty `thenRn` \ ty' -> - returnRn (ty', extractHsTyNames ty') - -rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType - -- rnHsSigType is used for source-language type signatures, - -- which use *implicit* universal quantification. -rnHsSigType doc_str ty - = rnHsType (text "In the type signature for" <+> doc_str) ty - ---------------------------------------- -rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType - -rnHsType doc (HsForAllTy Nothing ctxt ty) - -- Implicit quantifiction in 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 = extractSomeHsTyRdrNames isRdrTyVar ty - mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt - mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt) - forall_tyvars = filter (not . (`elemRdrEnv` name_env)) mentioned - in - 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 actually - -- mentioned in the type, and produce a warning if not - = let - mentioned_in_tau = extractSomeHsTyRdrNames isRdrTyVar tau - mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt - mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt) - forall_tyvar_names = hsTyVarNames forall_tyvars - - -- Explicitly quantified but not mentioned in ctxt or tau - warn_guys = filter (`notElem` mentioned) forall_tyvar_names - in - mapRn_ (forAllWarn doc tau) warn_guys `thenRn_` - rnForAll doc forall_tyvars ctxt tau - -rnHsType doc (HsTyVar tyvar) - = lookupOccRn tyvar `thenRn` \ tyvar' -> - returnRn (HsTyVar tyvar') - -rnHsType doc (HsOpTy ty1 opname ty2) - = lookupOccRn opname `thenRn` \ name' -> - rnHsType doc ty1 `thenRn` \ ty1' -> - rnHsType doc ty2 `thenRn` \ ty2' -> - returnRn (HsOpTy ty1' name' ty2') - -rnHsType doc (HsNumTy i) - | i == 1 = returnRn (HsNumTy i) - | otherwise = failWithRn (HsNumTy i) - (ptext SLIT("Only unit numeric type pattern is valid")) - -rnHsType doc (HsFunTy ty1 ty2) - = rnHsType doc ty1 `thenRn` \ ty1' -> - -- Might find a for-all as the arg of a function type - rnHsType doc ty2 `thenRn` \ ty2' -> - -- Or as the result. This happens when reading Prelude.hi - -- when we find return :: forall m. Monad m -> forall a. a -> m a - returnRn (HsFunTy ty1' ty2') - -rnHsType doc (HsListTy ty) - = rnHsType doc ty `thenRn` \ ty' -> - returnRn (HsListTy ty') - --- Unboxed tuples are allowed to have poly-typed arguments. These --- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys) - -- Don't do lookupOccRn, because this is built-in syntax - -- so it doesn't need to be in scope - = mapRn (rnHsType doc) tys `thenRn` \ tys' -> - returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys') - where - tup_name = tupleTyCon_name boxity arity - - -rnHsType doc (HsAppTy ty1 ty2) - = rnHsType doc ty1 `thenRn` \ ty1' -> - rnHsType doc ty2 `thenRn` \ ty2' -> - returnRn (HsAppTy ty1' ty2') - -rnHsType doc (HsPredTy pred) - = rnPred doc pred `thenRn` \ pred' -> - returnRn (HsPredTy pred') - -rnHsTypes doc tys = mapRn (rnHsType doc) tys -\end{code} - -\begin{code} -rnForAll doc forall_tyvars ctxt ty - = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> - rnContext doc ctxt `thenRn` \ new_ctxt -> - rnHsType doc ty `thenRn` \ new_ty -> - returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty) -\end{code} - -\begin{code} -rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext -rnContext doc ctxt - = mapRn rn_pred ctxt `thenRn` \ theta -> - - -- Check for duplicate assertions - -- If this isn't an error, then it ought to be: - ifOptRn Opt_WarnMisc ( - let - (_, dups) = removeDupsEq theta - -- We only have equality, not ordering - in - mapRn (addWarnRn . dupClassAssertWarn theta) dups - ) `thenRn_` - - returnRn theta - where - --Someone discovered that @CCallable@ and @CReturnable@ - -- could be used in contexts such as: - -- foo :: CCallable a => a -> PrimIO Int - -- Doing this utterly wrecks the whole point of introducing these - -- classes so we specifically check that this isn't being done. - rn_pred pred = rnPred doc pred `thenRn` \ pred'-> - checkRn (not (bad_pred pred')) - (naughtyCCallContextErr pred') `thenRn_` - returnRn pred' - - bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys - bad_pred other = False - - -rnPred doc (HsClassP clas tys) - = lookupOccRn clas `thenRn` \ clas_name -> - rnHsTypes doc tys `thenRn` \ tys' -> - returnRn (HsClassP clas_name tys') - -rnPred doc (HsIParam n ty) - = newIPName n `thenRn` \ name -> - rnHsType doc ty `thenRn` \ ty' -> - returnRn (HsIParam name ty') -\end{code} - -\begin{code} rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name] rnFds doc fds @@ -860,25 +709,6 @@ derivingNonStdClassErr clas badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] - -forAllWarn doc ty tyvar - = ifOptRn Opt_WarnUnusedMatches $ - getModeRn `thenRn` \ mode -> - case mode of { -#ifndef DEBUG - InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files - -- unless DEBUG is on, in which case it is slightly - -- informative. They can arise from mkRhsTyLam, -#endif -- leading to (say) f :: forall a b. [b] -> [b] - other -> - 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))] - $$ - doc - ) - } - badRuleLhsErr name lhs = sep [ptext SLIT("Rule") <+> ptext name <> colon, nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)] @@ -890,15 +720,6 @@ badRuleVar name var ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> ptext SLIT("does not appear on left hand side")] -dupClassAssertWarn ctxt (assertion : dups) - = sep [hsep [ptext SLIT("Duplicate class assertion"), - quotes (ppr assertion), - ptext SLIT("in the context:")], - nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))] - -naughtyCCallContextErr (HsClassP clas _) - = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas), - ptext SLIT("in a context")] emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))] diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs new file mode 100644 index 0000000..61a14ef --- /dev/null +++ b/ghc/compiler/rename/RnTypes.lhs @@ -0,0 +1,220 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[RnSource]{Main pass of renamer} + +\begin{code} +module RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs, rnContext ) where + +import CmdLineOpts ( DynFlag(Opt_WarnMisc, Opt_WarnUnusedMatches) ) + +import HsSyn +import RdrHsSyn ( RdrNameContext, RdrNameHsType, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars ) +import RnHsSyn ( RenamedContext, RenamedHsType, extractHsTyNames, tupleTyCon_name ) +import RnEnv ( lookupOccRn, newIPName, bindTyVarsRn ) +import RnMonad + +import PrelInfo ( cCallishClassKeys ) +import RdrName ( elemRdrEnv ) +import NameSet ( FreeVars ) +import Unique ( Uniquable(..) ) + +import List ( nub ) +import ListSetOps ( removeDupsEq ) +import Outputable + +#include "HsVersions.h" +\end{code} + +These type renamers are in a separate module, rather than in (say) RnSource, +to break several loop. + +%********************************************************* +%* * +\subsection{Renaming types} +%* * +%********************************************************* + +\begin{code} +rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) +rnHsTypeFVs doc_str ty + = rnHsType doc_str ty `thenRn` \ ty' -> + returnRn (ty', extractHsTyNames ty') + +rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) +rnHsSigTypeFVs doc_str ty + = rnHsSigType doc_str ty `thenRn` \ ty' -> + returnRn (ty', extractHsTyNames ty') + +rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType + -- rnHsSigType is used for source-language type signatures, + -- which use *implicit* universal quantification. +rnHsSigType doc_str ty + = rnHsType (text "In the type signature for" <+> doc_str) ty +\end{code} + +rnHsType is here because we call it from loadInstDecl, and I didn't +want a gratuitous knot. + +\begin{code} +rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType + +rnHsType doc (HsForAllTy Nothing ctxt ty) + -- Implicit quantifiction in 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 = extractHsTyRdrTyVars ty + mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt + mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt) + forall_tyvars = filter (not . (`elemRdrEnv` name_env)) mentioned + in + 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 actually + -- mentioned in the type, and produce a warning if not + = let + mentioned_in_tau = extractHsTyRdrTyVars tau + mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt + mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt) + forall_tyvar_names = hsTyVarNames forall_tyvars + + -- Explicitly quantified but not mentioned in ctxt or tau + warn_guys = filter (`notElem` mentioned) forall_tyvar_names + in + mapRn_ (forAllWarn doc tau) warn_guys `thenRn_` + rnForAll doc forall_tyvars ctxt tau + +rnHsType doc (HsTyVar tyvar) + = lookupOccRn tyvar `thenRn` \ tyvar' -> + returnRn (HsTyVar tyvar') + +rnHsType doc (HsOpTy ty1 opname ty2) + = lookupOccRn opname `thenRn` \ name' -> + rnHsType doc ty1 `thenRn` \ ty1' -> + rnHsType doc ty2 `thenRn` \ ty2' -> + returnRn (HsOpTy ty1' name' ty2') + +rnHsType doc (HsNumTy i) + | i == 1 = returnRn (HsNumTy i) + | otherwise = failWithRn (HsNumTy i) + (ptext SLIT("Only unit numeric type pattern is valid")) + +rnHsType doc (HsFunTy ty1 ty2) + = rnHsType doc ty1 `thenRn` \ ty1' -> + -- Might find a for-all as the arg of a function type + rnHsType doc ty2 `thenRn` \ ty2' -> + -- Or as the result. This happens when reading Prelude.hi + -- when we find return :: forall m. Monad m -> forall a. a -> m a + returnRn (HsFunTy ty1' ty2') + +rnHsType doc (HsListTy ty) + = rnHsType doc ty `thenRn` \ ty' -> + returnRn (HsListTy ty') + +-- Unboxed tuples are allowed to have poly-typed arguments. These +-- sometimes crop up as a result of CPR worker-wrappering dictionaries. +rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys) + -- Don't do lookupOccRn, because this is built-in syntax + -- so it doesn't need to be in scope + = mapRn (rnHsType doc) tys `thenRn` \ tys' -> + returnRn (HsTupleTy (HsTupCon tup_name boxity arity) tys') + where + tup_name = tupleTyCon_name boxity arity + + +rnHsType doc (HsAppTy ty1 ty2) + = rnHsType doc ty1 `thenRn` \ ty1' -> + rnHsType doc ty2 `thenRn` \ ty2' -> + returnRn (HsAppTy ty1' ty2') + +rnHsType doc (HsPredTy pred) + = rnPred doc pred `thenRn` \ pred' -> + returnRn (HsPredTy pred') + +rnHsTypes doc tys = mapRn (rnHsType doc) tys +\end{code} + +\begin{code} +rnForAll doc forall_tyvars ctxt ty + = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> + rnContext doc ctxt `thenRn` \ new_ctxt -> + rnHsType doc ty `thenRn` \ new_ty -> + returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty) +\end{code} + +\begin{code} +rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext +rnContext doc ctxt + = mapRn rn_pred ctxt `thenRn` \ theta -> + + -- Check for duplicate assertions + -- If this isn't an error, then it ought to be: + ifOptRn Opt_WarnMisc ( + let + (_, dups) = removeDupsEq theta + -- We only have equality, not ordering + in + mapRn (addWarnRn . dupClassAssertWarn theta) dups + ) `thenRn_` + + returnRn theta + where + --Someone discovered that @CCallable@ and @CReturnable@ + -- could be used in contexts such as: + -- foo :: CCallable a => a -> PrimIO Int + -- Doing this utterly wrecks the whole point of introducing these + -- classes so we specifically check that this isn't being done. + rn_pred pred = rnPred doc pred `thenRn` \ pred'-> + checkRn (not (bad_pred pred')) + (naughtyCCallContextErr pred') `thenRn_` + returnRn pred' + + bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys + bad_pred other = False + + +rnPred doc (HsClassP clas tys) + = lookupOccRn clas `thenRn` \ clas_name -> + rnHsTypes doc tys `thenRn` \ tys' -> + returnRn (HsClassP clas_name tys') + +rnPred doc (HsIParam n ty) + = newIPName n `thenRn` \ name -> + rnHsType doc ty `thenRn` \ ty' -> + returnRn (HsIParam name ty') +\end{code} + +\end{code} +\begin{code} +forAllWarn doc ty tyvar + = ifOptRn Opt_WarnUnusedMatches $ + getModeRn `thenRn` \ mode -> + case mode of { +#ifndef DEBUG + InterfaceMode -> returnRn () ; -- Don't warn of unused tyvars in interface files + -- unless DEBUG is on, in which case it is slightly + -- informative. They can arise from mkRhsTyLam, +#endif -- leading to (say) f :: forall a b. [b] -> [b] + other -> + 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))] + $$ + doc + ) + } + +dupClassAssertWarn ctxt (assertion : dups) + = sep [hsep [ptext SLIT("Duplicate class assertion"), + quotes (ppr assertion), + ptext SLIT("in the context:")], + nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))] + +naughtyCCallContextErr (HsClassP clas _) + = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas), + ptext SLIT("in a context")] +\end{code} \ No newline at end of file