summaryrefslogtreecommitdiff
path: root/compiler/rename
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/rename')
-rw-r--r--compiler/rename/RnBinds.lhs6
-rw-r--r--compiler/rename/RnEnv.lhs7
-rw-r--r--compiler/rename/RnExpr.lhs6
-rw-r--r--compiler/rename/RnHsSyn.lhs23
-rw-r--r--compiler/rename/RnNames.lhs2
-rw-r--r--compiler/rename/RnPat.lhs14
-rw-r--r--compiler/rename/RnSource.lhs6
-rw-r--r--compiler/rename/RnTypes.lhs44
8 files changed, 43 insertions, 65 deletions
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 2737752081..5fd0f1cc0c 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -28,7 +28,7 @@ import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
import RnHsSyn
import TcRnMonad
-import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch)
+import RnTypes ( rnIPName, rnHsSigType, rnLHsType, checkPrecMatch )
import RnPat (rnPats, rnBindPat,
NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker
)
@@ -231,9 +231,9 @@ rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars)
rnIPBind (IPBind n expr) = do
- name <- newIPNameRn n
+ n' <- rnIPName n
(expr',fvExpr) <- rnLExpr expr
- return (IPBind name expr', fvExpr)
+ return (IPBind n' expr', fvExpr)
\end{code}
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 8faf6e3eb0..cfdeab29c9 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -17,7 +17,7 @@ module RnEnv (
lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
getLookupOccRn, addUsedRdrNames,
- newLocalBndrRn, newLocalBndrsRn, newIPNameRn,
+ newLocalBndrRn, newLocalBndrsRn,
bindLocalName, bindLocalNames, bindLocalNamesFV,
MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv,
addLocalFixities,
@@ -36,7 +36,7 @@ module RnEnv (
#include "HsVersions.h"
import LoadIface ( loadInterfaceForName, loadSrcInterface )
-import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName, updNameCache, extendNameCache )
+import IfaceEnv ( lookupOrig, newGlobalBinder, updNameCache, extendNameCache )
import HsSyn
import RdrHsSyn ( extractHsTyRdrTyVars )
import RdrName
@@ -351,9 +351,6 @@ lookupSubBndrGREs env parent rdr_name
parent_is p (GRE { gre_par = ParentIs p' }) = p == p'
parent_is _ _ = False
-
-newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
-newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
\end{code}
Note [Looking up Exact RdrNames]
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 88e0462e74..8478db0cf9 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -27,7 +27,7 @@ import HsSyn
import TcRnMonad
import TcEnv ( thRnBrack )
import RnEnv
-import RnTypes ( rnHsTypeFVs, rnSplice, checkTH,
+import RnTypes ( rnHsTypeFVs, rnSplice, rnIPName, checkTH,
mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
import RnPat
import DynFlags
@@ -105,8 +105,8 @@ rnExpr (HsVar v)
finishHsVar name
rnExpr (HsIPVar v)
- = newIPNameRn v `thenM` \ name ->
- return (HsIPVar name, emptyFVs)
+ = do v' <- rnIPName v
+ return (HsIPVar v', emptyFVs)
rnExpr (HsLit lit@(HsString s))
= do {
diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs
index bfbcdc515f..79aaf6aa7a 100644
--- a/compiler/rename/RnHsSyn.lhs
+++ b/compiler/rename/RnHsSyn.lhs
@@ -8,7 +8,7 @@ module RnHsSyn(
-- Names
charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name,
extractHsTyVars, extractHsTyNames, extractHsTyNames_s,
- extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames,
+ extractFunDepNames, extractHsCtxtTyNames,
-- Free variables
hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs
@@ -21,7 +21,7 @@ import Class ( FunDep )
import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon )
import Name ( Name, getName, isTyVarName )
import NameSet
-import BasicTypes ( Boxity )
+import BasicTypes ( TupleSort )
import SrcLoc
\end{code}
@@ -39,8 +39,8 @@ charTyCon_name = getName charTyCon
listTyCon_name = getName listTyCon
parrTyCon_name = getName parrTyCon
-tupleTyCon_name :: Boxity -> Int -> Name
-tupleTyCon_name boxity n = getName (tupleTyCon boxity n)
+tupleTyCon_name :: TupleSort -> Int -> Name
+tupleTyCon_name sort n = getName (tupleTyCon sort n)
extractHsTyVars :: LHsType Name -> NameSet
extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x)
@@ -59,7 +59,8 @@ extractHsTyNames ty
get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` getl ty
get (HsTupleTy _ tys) = extractHsTyNames_s tys
get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2
- get (HsPredTy p) = extractHsPredTyNames p
+ get (HsIParamTy _ ty) = getl ty
+ get (HsEqTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2
get (HsOpTy ty1 op ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op)
get (HsParTy ty) = getl ty
get (HsBangTy _ ty) = getl ty
@@ -82,17 +83,7 @@ extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet t
extractHsCtxtTyNames :: LHsContext Name -> NameSet
extractHsCtxtTyNames (L _ ctxt)
- = foldr (unionNameSets . extractHsPredTyNames . unLoc) emptyNameSet ctxt
-
--- You don't import or export implicit parameters,
--- so don't mention the IP names
-extractHsPredTyNames :: HsPred Name -> NameSet
-extractHsPredTyNames (HsClassP cls tys)
- = unitNameSet cls `unionNameSets` extractHsTyNames_s tys
-extractHsPredTyNames (HsEqualP ty1 ty2)
- = extractHsTyNames ty1 `unionNameSets` extractHsTyNames ty2
-extractHsPredTyNames (HsIParam _ ty)
- = extractHsTyNames ty
+ = foldr (unionNameSets . extractHsTyNames) emptyNameSet ctxt
\end{code}
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 88113e409b..ef842f261e 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -544,7 +544,7 @@ getLocalNonValBinders fixity_env
= do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
; mapM (new_ti (Just cls_nm)) ats }
where
- (_, _, L loc cls_rdr, _) = splitHsInstDeclTy inst_ty
+ Just (_, _, L loc cls_rdr, _) = splitLHsInstDeclTy_maybe inst_ty
lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name)
-- Used for TyData and TySynonym only
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 975969d0b1..a6f619a447 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -155,15 +155,15 @@ matchNameMaker ctxt = LamMk report_unused
StmtCtxt GhciStmt -> False
_ -> True
-newName :: NameMaker -> Located RdrName -> CpsRn Name
-newName (LamMk report_unused) rdr_name
+newPatName :: NameMaker -> Located RdrName -> CpsRn Name
+newPatName (LamMk report_unused) rdr_name
= CpsRn (\ thing_inside ->
do { name <- newLocalBndrRn rdr_name
; (res, fvs) <- bindLocalName name (thing_inside name)
; when report_unused $ warnUnusedMatches [name] fvs
; return (res, name `delFV` fvs) })
-newName (LetMk is_top fix_env) rdr_name
+newPatName (LetMk is_top fix_env) rdr_name
= CpsRn (\ thing_inside ->
do { name <- case is_top of
NotTopLevel -> newLocalBndrRn rdr_name
@@ -253,7 +253,7 @@ rnPat ctxt pat thing_inside
= rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')
applyNameMaker :: NameMaker -> Located RdrName -> RnM Name
-applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newName mk rdr); return n }
+applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatName mk rdr); return n }
-- ----------- Entry point 2: rnBindPat -------------------
-- Binds local names; in a recursive scope that involves other bound vars
@@ -298,7 +298,7 @@ rnPatAndThen mk (ParPat pat) = do { pat' <- rnLPatAndThen mk pat; return (ParPa
rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') }
rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') }
rnPatAndThen mk (VarPat rdr) = do { loc <- liftCps getSrcSpanM
- ; name <- newName mk (L loc rdr)
+ ; name <- newPatName mk (L loc rdr)
; return (VarPat name) }
-- we need to bind pattern variables for view pattern expressions
-- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
@@ -334,7 +334,7 @@ rnPatAndThen _ (NPat lit mb_neg _eq)
; return (NPat lit' mb_neg' eq') }
rnPatAndThen mk (NPlusKPat rdr lit _ _)
- = do { new_name <- newName mk rdr
+ = do { new_name <- newPatName mk rdr
; lit' <- liftCpsFV $ rnOverLit lit
; minus <- liftCpsFV $ lookupSyntaxName minusName
; ge <- liftCpsFV $ lookupSyntaxName geName
@@ -342,7 +342,7 @@ rnPatAndThen mk (NPlusKPat rdr lit _ _)
-- The Report says that n+k patterns must be in Integral
rnPatAndThen mk (AsPat rdr pat)
- = do { new_name <- newName mk rdr
+ = do { new_name <- newPatName mk rdr
; pat' <- rnLPatAndThen mk pat
; return (AsPat (L (nameSrcSpan new_name) new_name) pat') }
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 2f01d7d418..76b81465f9 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -27,6 +27,7 @@ import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn, lookupTcdNa
import HscTypes ( AvailInfo(..) )
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
+import Kind ( liftedTypeKind )
import ForeignCall ( CCallTarget(..) )
import Module
@@ -42,7 +43,6 @@ import Util ( filterOut )
import SrcLoc
import DynFlags
import HscTypes ( HscEnv, hsc_dflags )
-import BasicTypes ( Boxity(..) )
import ListSetOps ( findDupsEq )
import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
@@ -424,7 +424,7 @@ rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
-- Used for both source and interface file decls
= do { inst_ty' <- rnHsSigType (text "an instance decl") inst_ty
- ; let (inst_tyvars, _, L _ cls, _) = splitHsInstDeclTy inst_ty'
+ ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty'
-- Rename the bindings
-- The typechecker (not the renamer) checks that all
@@ -991,7 +991,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
, con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
- get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
+ get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy (HsBoxyTuple liftedTypeKind) tys))
rnConResult :: SDoc
-> HsConDetails (LHsType Name) [ConDeclField Name]
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 392e411b37..770ef28959 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -7,7 +7,8 @@
module RnTypes (
-- Type related stuff
rnHsType, rnLHsType, rnLHsTypes, rnContext,
- rnHsSigType, rnHsTypeFVs, rnConDeclFields, rnLPred,
+ rnHsSigType, rnHsTypeFVs, rnConDeclFields,
+ rnIPName,
-- Precence related stuff
mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
@@ -29,6 +30,7 @@ import RnHsSyn ( extractHsTyNames )
import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
import TcRnMonad
+import IfaceEnv ( newIPName )
import RdrName
import PrelNames
import TysPrim ( funTyConName )
@@ -37,7 +39,7 @@ import SrcLoc
import NameSet
import Util ( filterOut )
-import BasicTypes ( compareFixity, funTyFixity, negateFixity,
+import BasicTypes ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFixity,
Fixity(..), FixityDirection(..) )
import Outputable
import FastString
@@ -172,9 +174,15 @@ rnHsType doc (HsAppTy ty1 ty2) = do
ty2' <- rnLHsType doc ty2
return (HsAppTy ty1' ty2')
-rnHsType doc (HsPredTy pred) = do
- pred' <- rnPred doc pred
- return (HsPredTy pred')
+rnHsType doc (HsIParamTy n ty) = do
+ ty' <- rnLHsType doc ty
+ n' <- rnIPName n
+ return (HsIParamTy n' ty')
+
+rnHsType doc (HsEqTy ty1 ty2) = do
+ ty1' <- rnLHsType doc ty1
+ ty2' <- rnLHsType doc ty2
+ return (HsEqTy ty1' ty2')
rnHsType _ (HsSpliceTy sp _ k)
= do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs
@@ -243,28 +251,10 @@ rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
rnContext doc = wrapLocM (rnContext' doc)
rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
-rnContext' doc ctxt = mapM (rnLPred doc) ctxt
-
-rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
-rnLPred doc = wrapLocM (rnPred doc)
-
-rnPred :: SDoc -> HsPred RdrName
- -> IOEnv (Env TcGblEnv TcLclEnv) (HsPred Name)
-rnPred doc (HsClassP clas tys)
- = do { clas_name <- lookupOccRn clas
- ; tys' <- rnLHsTypes doc tys
- ; return (HsClassP clas_name tys')
- }
-rnPred doc (HsEqualP ty1 ty2)
- = do { ty1' <- rnLHsType doc ty1
- ; ty2' <- rnLHsType doc ty2
- ; return (HsEqualP ty1' ty2')
- }
-rnPred doc (HsIParam n ty)
- = do { name <- newIPNameRn n
- ; ty' <- rnLHsType doc ty
- ; return (HsIParam name ty')
- }
+rnContext' doc ctxt = mapM (rnLHsType doc) ctxt
+
+rnIPName :: IPName RdrName -> RnM (IPName Name)
+rnIPName n = newIPName (occNameFS (rdrNameOcc (ipNameName n)))
\end{code}
View Lorry Controller Status