Commit 77a8c0db authored by simonpj's avatar simonpj
Browse files

[project @ 2000-07-14 08:17:36 by simonpj]

This commit completely re-does the kind-inference mechanism.
Previously it was inter-wound with type inference, but that was
always hard to understand, and it finally broke when we started
checking for ambiguity when type-checking a type signature (details
irrelevant).

So now kind inference is more clearly separated, so that it never
takes place at the same time as type inference.  The biggest change
is in TcTyClsDecls, which does the kind inference for a group of
type and class declarations.  It now contains comments to explain
how it all works.

There are also comments in TypeRep which describes the slightly
tricky way in which we deal with the fact that kind 'type' (written
'*') actually has 'boxed type' and 'unboxed type' as sub-kinds.
The whole thing is a bit of a hack, because we don't really have 
sub-kinding, but it's less of a hack than before.

A lot of general tidying up happened at the same time.
In particular, I removed some dead code here and there
parent 8d873902
# -----------------------------------------------------------------------------
# $Id: Makefile,v 1.82 2000/07/07 09:37:39 simonmar Exp $
# $Id: Makefile,v 1.83 2000/07/14 08:17:36 simonpj Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
......@@ -107,7 +107,7 @@ space:= $(empty) $(empty)
SRC_HC_OPTS += \
-cpp -fglasgow-exts -Rghc-timing \
-I. -IcodeGen -InativeGen -Iparser \
-i$(subst $(space),:,$(DIRS))
-i$(subst $(space),:,$(DIRS))
SRC_CC_OPTS += -Iparser -I. -I$(TOP)/includes -O
......
......@@ -321,8 +321,8 @@ mkDataConWrapId data_con
MarkedUnboxed con tys ->
Case (Var arg) arg [(DataAlt con, con_args,
body i' (reverse con_args++rep_args))]
where n_tys = length tys
(con_args,i') = mkLocals i tys
where
(con_args,i') = mkLocals i tys
\end{code}
......@@ -381,7 +381,6 @@ mkRecordSelId tycon field_label unpack_id
sel_id = mkId (fieldLabelName field_label) selector_ty info
field_ty = fieldLabelType field_label
field_name = fieldLabelName field_label
data_cons = tyConDataCons tycon
tyvars = tyConTyVars tycon -- These scope over the types in
-- the FieldLabels of constructors of this type
......@@ -573,15 +572,15 @@ mkDictFunId :: Name -- Name to use for the dict fun;
mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
= mkVanillaId dfun_name dfun_ty
where
(class_tyvars, sc_theta, _, _) = classBigSig clas
sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
dfun_theta = classesToPreds inst_decl_theta
{- 1 dec 99: disable the Mark Jones optimisation for the sake
of compatibility with Hugs.
See `types/InstEnv' for a discussion related to this.
(class_tyvars, sc_theta, _, _) = classBigSig clas
not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
dfun_theta = case inst_decl_theta of
[] -> [] -- If inst_decl_theta is empty, then we don't
-- want to have any dict arguments, so that we can
......@@ -603,8 +602,6 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
-- Now sc_theta' has Foo T
-}
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
\end{code}
......
......@@ -30,11 +30,11 @@ module Name (
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
-- Environment
NameEnv,
NameEnv, mkNameEnv,
emptyNameEnv, unitNameEnv, nameEnvElts,
addToNameEnv_C, addToNameEnv, addListToNameEnv,
plusNameEnv, plusNameEnv_C, extendNameEnv,
lookupNameEnv, delFromNameEnv, elemNameEnv,
extendNameEnv_C, extendNameEnv,
plusNameEnv, plusNameEnv_C, extendNameEnv, extendNameEnvList,
lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, elemNameEnv,
-- Provenance
......@@ -59,6 +59,7 @@ import CmdLineOpts ( opt_Static, opt_PprStyle_NoPrags, opt_OmitInterfacePragmas,
import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc )
import Unique ( pprUnique, Unique, Uniquable(..), hasKey, unboundKey, u2i )
import Maybes ( expectJust )
import UniqFM
import Outputable
import GlaExts
......@@ -552,30 +553,33 @@ instance NamedThing Name where
type NameEnv a = UniqFM a -- Domain is Name
emptyNameEnv :: NameEnv a
mkNameEnv :: [(Name,a)] -> NameEnv a
nameEnvElts :: NameEnv a -> [a]
addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a
addListToNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a
extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a
plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a
extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a
lookupNameEnv :: NameEnv a -> Name -> Maybe a
extendNameEnvList:: NameEnv a -> [(Name,a)] -> NameEnv a
delFromNameEnv :: NameEnv a -> Name -> NameEnv a
elemNameEnv :: Name -> NameEnv a -> Bool
unitNameEnv :: Name -> a -> NameEnv a
lookupNameEnv :: NameEnv a -> Name -> Maybe a
lookupNameEnv_NF :: NameEnv a -> Name -> a
emptyNameEnv = emptyUFM
mkNameEnv = listToUFM
nameEnvElts = eltsUFM
addToNameEnv_C = addToUFM_C
addToNameEnv = addToUFM
addListToNameEnv = addListToUFM
extendNameEnv_C = addToUFM_C
extendNameEnv = addToUFM
plusNameEnv = plusUFM
plusNameEnv_C = plusUFM_C
extendNameEnv = addListToUFM
lookupNameEnv = lookupUFM
extendNameEnvList= addListToUFM
delFromNameEnv = delFromUFM
elemNameEnv = elemUFM
unitNameEnv = unitUFM
lookupNameEnv = lookupUFM
lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupUFM env n)
\end{code}
......
......@@ -142,6 +142,7 @@ foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b
\begin{code}
elemVarEnv = elemUFM
extendVarEnv = addToUFM
extendVarEnvList = addListToUFM
plusVarEnv_C = plusUFM_C
delVarEnvList = delListFromUFM
delVarEnv = delFromUFM
......@@ -156,8 +157,7 @@ unitVarEnv = unitUFM
isEmptyVarEnv = isNullUFM
foldVarEnv = foldUFM
zipVarEnv tyvars tys = listToUFM (zipEqual "zipVarEnv" tyvars tys)
extendVarEnvList env pairs = plusUFM env (listToUFM pairs)
zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys)
lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx }
\end{code}
......
......@@ -177,14 +177,12 @@ unboxArg arg
= getSrcLocDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = exprType arg
arg_rep_ty = repType arg_ty
maybe_product_type = splitProductType_maybe arg_ty
is_product_type = maybeToBool maybe_product_type
Just (tycon, _, data_con, data_con_arg_tys) = maybe_product_type
data_con_arity = dataConSourceArity data_con
(data_con_arg_ty1 : _) = data_con_arg_tys
arg_ty = exprType arg
maybe_product_type = splitProductType_maybe arg_ty
is_product_type = maybeToBool maybe_product_type
Just (_, _, data_con, data_con_arg_tys) = maybe_product_type
data_con_arity = dataConSourceArity data_con
(data_con_arg_ty1 : _) = data_con_arg_tys
(_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
maybe_arg3_tycon = splitTyConApp_maybe data_con_arg_ty3
......@@ -299,8 +297,8 @@ resultWrapper result_ty
| otherwise
= pprPanic "resultWrapper" (ppr result_ty)
where
maybe_product_type = splitProductType_maybe result_ty
is_product_type = maybeToBool maybe_product_type
Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
data_con_arity = dataConSourceArity data_con
maybe_product_type = splitProductType_maybe result_ty
is_product_type = maybeToBool maybe_product_type
Just (_, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
data_con_arity = dataConSourceArity data_con
\end{code}
......@@ -11,7 +11,8 @@ module HsDecls (
HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
DefaultDecl(..), ForeignDecl(..), ForKind(..),
ExtName(..), isDynamicExtName, extNameStatic,
ConDecl(..), ConDetails(..), BangType(..),
ConDecl(..), ConDetails(..),
BangType(..), getBangType,
IfaceSig(..), SpecDataSig(..),
DeprecDecl(..), DeprecTxt,
hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule
......@@ -313,12 +314,6 @@ data ConDetails name
(HsType name)
(Maybe name) -- Just x => labelled field 'x'
data BangType name
= Banged (HsType name) -- HsType: to allow Haskell extensions
| Unbanged (HsType name) -- (MonoType only needed for straight Haskell)
| Unpacked (HsType name) -- Field is strict and to be unpacked if poss.
eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _)
(ConDecl n2 _ tvs2 cxt2 cds2 _)
= n1 == n2 &&
......@@ -338,6 +333,16 @@ eq_ConDetails env _ _ = False
eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2
data BangType name
= Banged (HsType name) -- HsType: to allow Haskell extensions
| Unbanged (HsType name) -- (MonoType only needed for straight Haskell)
| Unpacked (HsType name) -- Field is strict and to be unpacked if poss.
getBangType (Banged ty) = ty
getBangType (Unbanged ty) = ty
getBangType (Unpacked ty) = ty
eq_btype env (Banged t1) (Banged t2) = eq_hsType env t1 t2
eq_btype env (Unbanged t1) (Unbanged t2) = eq_hsType env t1 t2
eq_btype env (Unpacked t1) (Unpacked t2) = eq_hsType env t1 t2
......
......@@ -12,7 +12,8 @@ module HsPat (
failureFreePat, isWildPat,
patsAreAllCons, isConPat,
patsAreAllLits, isLitPat,
collectPatBinders, collectPatsBinders
collectPatBinders, collectPatsBinders,
collectSigTysFromPats
) where
#include "HsVersions.h"
......@@ -330,3 +331,24 @@ collect (ListPatIn pats) bndrs = foldr collect bndrs pats
collect (TuplePatIn pats _) bndrs = foldr collect bndrs pats
collect (RecPatIn c fields) bndrs = foldr (\ (f,pat,_) bndrs -> collect pat bndrs) bndrs fields
\end{code}
\begin{code}
collectSigTysFromPats :: [InPat name] -> [HsType name]
collectSigTysFromPats pats = foldr collect_pat [] pats
collect_pat (SigPatIn pat ty) acc = collect_pat pat (ty:acc)
collect_pat WildPatIn acc = acc
collect_pat (VarPatIn var) acc = acc
collect_pat (LitPatIn _) acc = acc
collect_pat (LazyPatIn pat) acc = collect_pat pat acc
collect_pat (AsPatIn a pat) acc = collect_pat pat acc
collect_pat (NPlusKPatIn n _) acc = acc
collect_pat (ConPatIn c pats) acc = foldr collect_pat acc pats
collect_pat (ConOpPatIn p1 c f p2) acc = collect_pat p1 (collect_pat p2 acc)
collect_pat (NegPatIn pat) acc = collect_pat pat acc
collect_pat (ParPatIn pat) acc = collect_pat pat acc
collect_pat (ListPatIn pats) acc = foldr collect_pat acc pats
collect_pat (TuplePatIn pats _) acc = foldr collect_pat acc pats
collect_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> collect_pat pat acc) acc fields
\end{code}
......@@ -92,9 +92,6 @@ instance (Outputable name, Outputable pat)
pp_nonnull [] = empty
pp_nonnull xs = vcat (map ppr xs)
pp_iface_version Nothing = empty
pp_iface_version (Just n) = hsep [text "{-# INTERFACE", int n, text "#-}"]
\end{code}
......
......@@ -10,7 +10,7 @@ module HsTypes (
, HsTupCon(..), hsTupParens, mkHsTupCon,
, mkHsForAllTy, mkHsUsForAllTy, mkHsDictTy, mkHsIParamTy
, getTyVarName, replaceTyVarName
, hsTyVarName, hsTyVarNames, replaceTyVarName
-- Printing
, pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr
......@@ -128,8 +128,10 @@ data HsTyVarBndr name
-- for-alls in it, (mostly to do with dictionaries). These
-- must be explicitly Kinded.
getTyVarName (UserTyVar n) = n
getTyVarName (IfaceTyVar n _) = n
hsTyVarName (UserTyVar n) = n
hsTyVarName (IfaceTyVar n _) = n
hsTyVarNames tvs = map hsTyVarName tvs
replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2
replaceTyVarName (UserTyVar n) n' = UserTyVar n'
......
......@@ -587,11 +587,6 @@ getRegister (StPrim primop [x]) -- unary PrimOps
Int2DoubleOp -> coerceInt2FP DoubleRep x
other_op ->
let
fixed_x = if is_float_op -- promote to double
then StPrim Float2DoubleOp [x]
else x
in
getRegister (StCall fn cCallConv DoubleRep [x])
where
(is_float_op, fn)
......@@ -956,6 +951,8 @@ getRegister (StPrim primop [x]) -- unary PrimOps
FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x
Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
......@@ -1555,7 +1552,6 @@ condFltCode cond x y
code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
pk2 = registerRep register2
code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
......
......@@ -74,7 +74,6 @@ macroCode UPD_CAF args
[cafptr,bhptr] = map amodeToStix args
w0 = StInd PtrRep cafptr
w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS)
blocking_queue = StInd PtrRep (StIndex PtrRep bhptr fixedHS)
a1 = StAssign PtrRep w0 ind_static_info
a2 = StAssign PtrRep w1 bhptr
a3 = StCall SLIT("newCAF") cCallConv VoidRep [cafptr]
......
......@@ -1006,7 +1006,6 @@ mk_var_token pk_str
| otherwise = ITvarsym pk_str
where
(C# f) = _HEAD_ pk_str
tl = _TAIL_ pk_str
mk_qvar_token m token =
case mk_var_token token of
......
......@@ -66,6 +66,7 @@ module RdrHsSyn (
#include "HsVersions.h"
import HsSyn
import HsPat ( collectSigTysFromPats )
import Name ( mkClassTyConOcc, mkClassDataConOcc )
import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
mkSuperDictSelOcc, mkDefaultMethodOcc
......@@ -144,7 +145,7 @@ extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
extractHsTyRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty)
extractHsTysRdrTyVars :: [RdrNameHsType] -> [RdrName]
extractHsTysRdrTyVars tys = filter isRdrTyVar (nub (extract_tys tys []))
extractHsTysRdrTyVars tys = filter isRdrTyVar (nub (extract_tys tys))
extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
......@@ -162,7 +163,7 @@ extract_ctxt ctxt acc = foldr extract_pred acc ctxt
extract_pred (HsPClass cls tys) acc = foldr extract_ty (cls : acc) tys
extract_pred (HsPIParam n ty) acc = extract_ty ty acc
extract_tys tys acc = foldr extract_ty acc tys
extract_tys tys = foldr extract_ty [] tys
extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc)
extract_ty (HsListTy ty) acc = extract_ty ty acc
......@@ -178,26 +179,14 @@ extract_ty (HsForAllTy (Just tvs) ctxt ty)
(filter (`notElem` locals) $
extract_ctxt ctxt (extract_ty ty []))
where
locals = map getTyVarName tvs
locals = hsTyVarNames tvs
extractPatsTyVars :: [RdrNamePat] -> [RdrName]
extractPatsTyVars pats = filter isRdrTyVar (nub (foldr extract_pat [] pats))
extract_pat (SigPatIn pat ty) acc = extract_ty ty acc
extract_pat WildPatIn acc = acc
extract_pat (VarPatIn var) acc = acc
extract_pat (LitPatIn _) acc = acc
extract_pat (LazyPatIn pat) acc = extract_pat pat acc
extract_pat (AsPatIn a pat) acc = extract_pat pat acc
extract_pat (NPlusKPatIn n _) acc = acc
extract_pat (ConPatIn c pats) acc = foldr extract_pat acc pats
extract_pat (ConOpPatIn p1 c f p2) acc = extract_pat p1 (extract_pat p2 acc)
extract_pat (NegPatIn pat) acc = extract_pat pat acc
extract_pat (ParPatIn pat) acc = extract_pat pat acc
extract_pat (ListPatIn pats) acc = foldr extract_pat acc pats
extract_pat (TuplePatIn pats _) acc = foldr extract_pat acc pats
extract_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> extract_pat pat acc) acc fields
extractPatsTyVars = filter isRdrTyVar .
nub .
extract_tys .
collectSigTysFromPats
\end{code}
mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
......
......@@ -39,7 +39,8 @@ import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
nameOccName, nameUnique, nameModule, maybeUserImportedFrom,
isUserImportedExplicitlyName, isUserImportedName,
maybeWiredInTyConName, maybeWiredInIdName,
isUserExportedName, toRdrName
isUserExportedName, toRdrName,
nameEnvElts, extendNameEnv
)
import OccName ( occNameFlavour, isValOcc )
import Id ( idType )
......@@ -489,7 +490,7 @@ getGates source_fvs (SigD (IfaceSig _ ty _ _))
getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _ _))
= (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
(map getTyVarName tvs)
(hsTyVarNames tvs)
`addOneToNameSet` cls)
`plusFV` maybe_double
where
......@@ -509,12 +510,12 @@ getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _ _))
getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
= delListFromNameSet (extractHsTyNames ty)
(map getTyVarName tvs)
(hsTyVarNames tvs)
-- A type synonym type constructor isn't a "gate" for instance decls
getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _))
= delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
(map getTyVarName tvs)
(hsTyVarNames tvs)
`addOneToNameSet` tycon
where
get (ConDecl n _ tvs ctxt details _)
......@@ -522,7 +523,7 @@ getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _))
-- If the constructor is method, get fvs from all its fields
= delListFromNameSet (get_details details `plusFV`
extractHsCtxtTyNames ctxt)
(map getTyVarName tvs)
(hsTyVarNames tvs)
get (ConDecl n _ tvs ctxt (RecCon fields) _)
-- Even if the constructor isn't mentioned, the fields
-- might be, as selectors. They can't mention existentially
......@@ -540,9 +541,7 @@ getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _))
get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
| otherwise = emptyFVs
get_bang (Banged t) = extractHsTyNames t
get_bang (Unbanged t) = extractHsTyNames t
get_bang (Unpacked t) = extractHsTyNames t
get_bang bty = extractHsTyNames (getBangType bty)
getGates source_fvs other_decl = emptyFVs
\end{code}
......@@ -612,7 +611,7 @@ fixitiesFromLocalDecls gbl_env decls
Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')
`thenRn_` returnRn acc ;
Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc))
Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
}}
\end{code}
......
......@@ -16,7 +16,7 @@ import RnHsSyn ( RenamedHsType )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual,
mkRdrUnqual, qualifyRdrName
)
import HsTypes ( getTyVarName, replaceTyVarName )
import HsTypes ( hsTyVarName, hsTyVarNames, replaceTyVarName )
import RnMonad
import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
......@@ -25,7 +25,8 @@ import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
mkIPName, isWiredInName, hasBetterProv,
nameOccName, setNameModule, nameModule,
pprOccName, isLocallyDefined, nameUnique, nameOccName,
setNameProvenance, getNameProvenance, pprNameProvenance
setNameProvenance, getNameProvenance, pprNameProvenance,
extendNameEnv_C, plusNameEnv_C, nameEnvElts
)
import NameSet
import OccName ( OccName,
......@@ -351,7 +352,7 @@ extendTyVarEnvFVRn :: [HsTyVarBndr Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeV
extendTyVarEnvFVRn tyvars enclosed_scope
= getLocalNameEnv `thenRn` \ env ->
let
tyvar_names = map getTyVarName tyvars
tyvar_names = hsTyVarNames tyvars
new_env = addListToRdrEnv env [ (mkRdrUnqual (getOccName name), name)
| name <- tyvar_names
]
......@@ -373,7 +374,7 @@ bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName]
bindTyVars2Rn doc_str tyvar_names enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
let
located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names]
located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names]
in
bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
......@@ -633,7 +634,7 @@ plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
#endif
addAvail :: AvailEnv -> AvailInfo -> AvailEnv
addAvail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail
addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
emptyAvailEnv = emptyNameEnv
unitAvailEnv :: AvailInfo -> AvailEnv
......
......@@ -41,6 +41,7 @@ type RenamedMatch = Match Name RenamedPat
type RenamedMonoBinds = MonoBinds Name RenamedPat
type RenamedPat = InPat Name
type RenamedHsType = HsType Name
type RenamedHsPred = HsPred Name
type RenamedRecordBinds = HsRecordBinds Name RenamedPat
type RenamedSig = Sig Name
type RenamedStmt = Stmt Name RenamedPat
......@@ -87,7 +88,7 @@ extractHsTyNames ty
get (HsForAllTy (Just tvs)
ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty)
`minusNameSet`
mkNameSet (map getTyVarName tvs)
mkNameSet (hsTyVarNames tvs)
get ty@(HsForAllTy Nothing _ _) = pprPanic "extractHsTyNames" (ppr ty)
extractHsTyNames_s :: [RenamedHsType] -> NameSet
......
......@@ -41,7 +41,8 @@ import ParseIface ( parseIface, IfaceStuff(..) )
import Name ( Name {-instance NamedThing-}, nameOccName,
nameModule, isLocallyDefined,
isWiredInName, nameUnique, NamedThing(..)
isWiredInName, nameUnique, NamedThing(..),
elemNameEnv, extendNameEnv
)
import Module ( Module, moduleString, pprModule,
mkVanillaModule, pprModuleName,
......@@ -300,7 +301,7 @@ loadDecl mod decls_map (version, decl)
| name <- availNames full_avail]
add_decl decls_map (name, stuff)
= WARN( name `elemNameEnv` decls_map, ppr name )
addToNameEnv decls_map name stuff
extendNameEnv decls_map name stuff
in
returnRn new_decls_map
}
......@@ -343,7 +344,7 @@ loadFixDecls mod_name fixity_env (version, decls)
| otherwise
= mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add ->
returnRn (addListToNameEnv fixity_env to_add)
returnRn (extendNameEnvList fixity_env to_add)
loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc)
= mkImportedGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name ->
......@@ -438,7 +439,7 @@ loadDeprec mod deprec_env (Deprecation ie txt _)
= setModuleRn (moduleName mod) $
mapRn mkImportedGlobalFromRdrName (ieNames ie) `thenRn` \ names ->
traceRn (text "loaded deprecation(s) for" <+> hcat (punctuate comma (map ppr names)) <> colon <+> ppr txt) `thenRn_`
returnRn (extendNameEnv deprec_env (zip names (repeat txt)))
returnRn (extendNameEnvList deprec_env (zip names (repeat txt)))
\end{code}
......
......@@ -47,9 +47,7 @@ import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc,
import Name ( Name, OccName, NamedThing(..), getSrcLoc,
isLocallyDefinedName, nameModule, nameOccName,
decode, mkLocalName, mkUnboundName,
NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnv,
addToNameEnv_C, plusNameEnv_C, nameEnvElts,
elemNameEnv, addToNameEnv, addListToNameEnv
NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList
)
import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom,
mkModuleHiMaps, moduleName, mkSearchPath
......@@ -696,7 +694,7 @@ extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a
extendFixityEnv fixes enclosed_scope
rn_down l_down@(SDown {rn_fixenv = fixity_env})
= let
new_fixity_env = extendNameEnv fixity_env fixes
new_fixity_env = extendNameEnvList fixity_env fixes
in
enclosed_scope rn_down (l_down {rn_fixenv = new_fixity_env})
\end{code}
......
......@@ -37,7 +37,8 @@ import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) )
import NameSet
import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..),
isLocallyDefined, setNameProvenance,
nameOccName, getSrcLoc, pprProvenance, getNameProvenance
nameOccName, getSrcLoc, pprProvenance, getNameProvenance,
nameEnvElts
)
import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isQual, isUnqual )
import OccName ( setOccNameSpace, dataName )
......
......@@ -11,7 +11,7 @@ module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
import RnExpr
import HsSyn
import HsPragmas
import HsTypes ( getTyVarName, pprHsContext )
import HsTypes ( hsTyVarNames, pprHsContext )
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar, mkRdrNameWkr )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
extractRuleBndrsTyVars, extractHsTyRdrTyVars,
......@@ -570,7 +570,7 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
mentioned_in_tau = extractHsTyRdrTyVars tau
mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
forall_tyvar_names = map getTyVarName forall_tyvars
forall_tyvar_names = hsTyVarNames forall_tyvars
-- Explicitly quantified but not mentioned in ctxt or tau
warn_guys = filter (`notElem` mentioned) forall_tyvar_names
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment