Commit f62fd70d authored by simonpj's avatar simonpj
Browse files

[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
parent a0cc55a8
......@@ -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))
......
......@@ -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,
......
......@@ -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
......
......@@ -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}
_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 ;;
......@@ -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.
......@@ -526,155 +524,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]
......@@ -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)"))]
......
%
% (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