RdrMatch(..),
SigConverter,
- extractHsTyRdrNames, extractSomeHsTyRdrNames,
- extractHsTysRdrNames, extractSomeHsTysRdrNames,
+ extractHsTyRdrNames, extractHsTyRdrTyVars,
extractRuleBndrsTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars,
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 (..) )
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))
#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,
#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 )
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
)
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 )
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 )
import Finder ( findModule, findPackageModule )
import Lex
import FiniteMap
+import ListSetOps ( minusList )
import Outputable
import Bag
import Config
-- 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)
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.
warnSelfImport mod
= ptext SLIT("Importing my own interface: module") <+> ppr mod
\end{code}
-
+++ /dev/null
-_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 ;;
-
\begin{code}
module RnSource ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls,
- rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs
) where
#include "HsVersions.h"
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,
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.
%*********************************************************
\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
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)]
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)"))]
--- /dev/null
+%
+% (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
projects / ghc-hetmet.git / commitdiff