summaryrefslogtreecommitdiff
path: root/ghc/compiler/rename
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/rename')
-rw-r--r--ghc/compiler/rename/ParseIface.y231
-rw-r--r--ghc/compiler/rename/ParseType.y140
-rw-r--r--ghc/compiler/rename/ParseUnfolding.y344
-rw-r--r--ghc/compiler/rename/Rename.lhs119
-rw-r--r--ghc/compiler/rename/RnBinds.lhs42
-rw-r--r--ghc/compiler/rename/RnEnv.lhs245
-rw-r--r--ghc/compiler/rename/RnExpr.lhs151
-rw-r--r--ghc/compiler/rename/RnHsSyn.lhs1
-rw-r--r--ghc/compiler/rename/RnIfaces.lhs463
-rw-r--r--ghc/compiler/rename/RnMonad.lhs118
-rw-r--r--ghc/compiler/rename/RnNames.lhs140
-rw-r--r--ghc/compiler/rename/RnSource.lhs104
12 files changed, 1378 insertions, 720 deletions
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 0faa549453..5107c5bc0f 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -1,6 +1,5 @@
{
#include "HsVersions.h"
-
module ParseIface ( parseIface ) where
IMP_Ubiq(){-uitous-}
@@ -25,14 +24,16 @@ import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
-import Name ( OccName(..), Provenance )
+import Name ( OccName(..), isTCOcc, Provenance )
import SrcLoc ( mkIfaceSrcLoc )
import Util ( panic{-, pprPanic ToDo:rm-} )
-
+import ParseType ( parseType )
+import ParseUnfolding ( parseUnfolding )
+import Maybes
-----------------------------------------------------------------
-parseIface = parseIToks . lexIface
+parseIface ls = parseIToks (lexIface ls)
-----------------------------------------------------------------
}
@@ -51,33 +52,33 @@ parseIface = parseIToks . lexIface
FIXITIES_PART { ITfixities }
DECLARATIONS_PART { ITdeclarations }
PRAGMAS_PART { ITpragmas }
- BANG { ITbang }
- CBRACK { ITcbrack }
- CCURLY { ITccurly }
+ DATA { ITdata }
+ TYPE { ITtype }
+ NEWTYPE { ITnewtype }
+ DERIVING { ITderiving }
CLASS { ITclass }
+ WHERE { ITwhere }
+ INSTANCE { ITinstance }
+ INFIXL { ITinfixl }
+ INFIXR { ITinfixr }
+ INFIX { ITinfix }
+ FORALL { ITforall }
+ BANG { ITbang }
+ VBAR { ITvbar }
+ DCOLON { ITdcolon }
COMMA { ITcomma }
- CPAREN { ITcparen }
DARROW { ITdarrow }
- DATA { ITdata }
- DCOLON { ITdcolon }
- DERIVING { ITderiving }
DOTDOT { ITdotdot }
EQUAL { ITequal }
- FORALL { ITforall }
- INFIX { ITinfix }
- INFIXL { ITinfixl }
- INFIXR { ITinfixr }
- INSTANCE { ITinstance }
- NEWTYPE { ITnewtype }
- OBRACK { ITobrack }
OCURLY { ITocurly }
+ OBRACK { ITobrack }
OPAREN { IToparen }
RARROW { ITrarrow }
+ CCURLY { ITccurly }
+ CBRACK { ITcbrack }
+ CPAREN { ITcparen }
SEMI { ITsemi }
- TYPE { ITtype }
- VBAR { ITvbar }
- WHERE { ITwhere }
- INTEGER { ITinteger $$ }
+
VARID { ITvarid $$ }
CONID { ITconid $$ }
VARSYM { ITvarsym $$ }
@@ -87,6 +88,8 @@ parseIface = parseIToks . lexIface
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
+ IDINFO_PART { ITidinfo $$ }
+ TYPE_PART { ITtysig $$ }
ARITY_PART { ITarity }
STRICT_PART { ITstrict }
UNFOLD_PART { ITunfold }
@@ -96,23 +99,29 @@ parseIface = parseIToks . lexIface
BIGLAM { ITbiglam }
CASE { ITcase }
PRIM_CASE { ITprim_case }
- OF { ITof }
LET { ITlet }
LETREC { ITletrec }
IN { ITin }
- ATSIGN { ITatsign }
+ OF { ITof }
COERCE_IN { ITcoerce_in }
COERCE_OUT { ITcoerce_out }
+ ATSIGN { ITatsign }
+ CCALL { ITccall $$ }
+ SCC { ITscc $$ }
+
CHAR { ITchar $$ }
STRING { ITstring $$ }
+ INTEGER { ITinteger $$ }
DOUBLE { ITdouble $$ }
+
INTEGER_LIT { ITinteger_lit }
- STRING_LIT { ITstring_lit }
FLOAT_LIT { ITfloat_lit }
RATIONAL_LIT { ITrational_lit }
ADDR_LIT { ITaddr_lit }
LIT_LIT { ITlit_lit }
- CCALL { ITccall $$ }
+ STRING_LIT { ITstring_lit }
+
+ UNKNOWN { ITunknown $$ }
%%
iface :: { ParsedIface }
@@ -172,11 +181,14 @@ entities : { [] }
| entity entities { $1 : $2 }
entity :: { (OccName, [OccName]) }
-entity : entity_occ maybe_inside { ($1, $2) }
-
-maybe_inside :: { [OccName] }
-maybe_inside : { [] }
- | OPAREN val_occs CPAREN { $2
+entity : entity_occ { ($1, if isTCOcc $1
+ then [$1] {- AvailTC -}
+ else []) {- Avail -} }
+ | entity_occ stuff_inside { ($1, ($1 : $2)) {- TyCls exported too -} }
+ | entity_occ BANG stuff_inside { ($1, $3) {- TyCls not exported -} }
+
+stuff_inside :: { [OccName] }
+stuff_inside : OPAREN val_occs1 CPAREN { $2
--------------------------------------------------------------------------
}
@@ -219,23 +231,28 @@ version : INTEGER { fromInteger $1 }
topdecl :: { RdrNameHsDecl }
topdecl : TYPE tc_name tv_bndrs EQUAL type SEMI
{ TyD (TySynonym $2 $3 $5 mkIfaceSrcLoc) }
- | DATA decl_context tc_name tv_bndrs EQUAL constrs deriving SEMI
- { TyD (TyData $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) }
+ | DATA decl_context tc_name tv_bndrs constrs deriving SEMI
+ { TyD (TyData $2 $3 $4 $5 $6 noDataPragmas mkIfaceSrcLoc) }
| NEWTYPE decl_context tc_name tv_bndrs EQUAL constr1 deriving SEMI
{ TyD (TyNew $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) }
| CLASS decl_context tc_name tv_bndr csigs SEMI
{ ClD (ClassDecl $2 $3 $4 $5 EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) }
- | var_name DCOLON type id_info SEMI SEMI
- { {- Double semicolon allows easy pragma discard in lexer -}
- let
- id_info = if opt_IgnoreIfacePragmas then [] else $4
- in
- SigD (IfaceSig $1 $3 id_info mkIfaceSrcLoc) }
+ | var_name TYPE_PART id_info
+ {
+ let
+ (Succeeded tp) = parseType $2
+ in
+ SigD (IfaceSig $1 tp $3 mkIfaceSrcLoc) }
+
+id_info :: { [HsIdInfo RdrName] }
+id_info : { [] }
+ | IDINFO_PART { let { (Succeeded id_info) = parseUnfolding $1 } in id_info}
decl_context :: { RdrNameContext }
decl_context : { [] }
| OCURLY context_list1 CCURLY DARROW { $2 }
+
csigs :: { [RdrNameSig] }
csigs : { [] }
| WHERE OCURLY csigs1 CCURLY { $3 }
@@ -245,13 +262,17 @@ csigs1 : csig { [$1] }
| csig SEMI csigs1 { $1 : $3 }
csig :: { RdrNameSig }
-csig : var_name DCOLON type { ClassOpSig $1 $3 noClassOpPragmas mkIfaceSrcLoc
+csig : var_name DCOLON type { ClassOpSig $1 $1 $3 mkIfaceSrcLoc
----------------------------------------------------------------
}
constrs :: { [RdrNameConDecl] }
-constrs : constr { [$1] }
- | constr VBAR constrs { $1 : $3 }
+ : { [] }
+ | EQUAL constrs1 { $2 }
+
+constrs1 :: { [RdrNameConDecl] }
+constrs1 : constr { [$1] }
+ | constr VBAR constrs1 { $1 : $3 }
constr :: { RdrNameConDecl }
constr : data_name batypes { ConDecl $1 $2 mkIfaceSrcLoc }
@@ -349,9 +370,9 @@ val_occ : var_occ { $1 }
| CONID { VarOcc $1 }
| CONSYM { VarOcc $1 }
-val_occs :: { [OccName] }
- : { [] }
- | val_occ val_occs { $1 : $2 }
+val_occs1 :: { [OccName] }
+ : val_occ { [$1] }
+ | val_occ val_occs1 { $1 : $2 }
qvar_name :: { RdrName }
@@ -431,123 +452,3 @@ instd : INSTANCE type EQUAL var_name SEMI
mkIfaceSrcLoc
--------------------------------------------------------------------------
}
-
-id_info :: { [HsIdInfo RdrName] }
-id_info : { [] }
- | id_info_item id_info { $1 : $2 }
-
-id_info_item :: { HsIdInfo RdrName }
-id_info_item : ARITY_PART arity_info { HsArity $2 }
- | STRICT_PART strict_info { HsStrictness $2 }
- | BOTTOM { HsStrictness mkBottomStrictnessInfo }
- | UNFOLD_PART core_expr { HsUnfold $2 }
-
-arity_info :: { ArityInfo }
-arity_info : INTEGER { exactArity (fromInteger $1) }
-
-strict_info :: { StrictnessInfo RdrName }
-strict_info : DEMAND any_var_name { mkStrictnessInfo $1 (Just $2) }
- | DEMAND { mkStrictnessInfo $1 Nothing }
-
-core_expr :: { UfExpr RdrName }
-core_expr : any_var_name { UfVar $1 }
- | qdata_name { UfVar $1 }
- | core_lit { UfLit $1 }
- | OPAREN core_expr CPAREN { $2 }
-
- | core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) }
- | core_expr core_arg { UfApp $1 $2 }
- | LAM core_val_bndrs RARROW core_expr { foldr UfLam $4 $2 }
- | BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 }
-
- | CASE core_expr OF
- OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) }
- | PRIM_CASE core_expr OF
- OCURLY prim_alts core_default CCURLY { UfCase $2 (UfPrimAlts $5 $6) }
-
-
- | LET OCURLY core_val_bndr EQUAL core_expr CCURLY
- IN core_expr { UfLet (UfNonRec $3 $5) $8 }
- | LETREC OCURLY rec_binds CCURLY
- IN core_expr { UfLet (UfRec $3) $6 }
-
- | coerce atype core_expr { UfCoerce $1 $2 $3 }
-
- | CCALL ccall_string
- OBRACK atype atypes CBRACK core_args { let
- (is_casm, may_gc) = $1
- in
- UfPrim (UfCCallOp $2 is_casm may_gc $5 $4)
- $7
- }
-
-rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] }
- : { [] }
- | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 }
-
-coerce :: { UfCoercion RdrName }
-coerce : COERCE_IN qdata_name { UfIn $2 }
- | COERCE_OUT qdata_name { UfOut $2 }
-
-prim_alts :: { [(Literal,UfExpr RdrName)] }
- : { [] }
- | core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 }
-
-alg_alts :: { [(RdrName, [UfBinder RdrName], UfExpr RdrName)] }
- : { [] }
- | qdata_name core_val_bndrs RARROW
- core_expr SEMI alg_alts { ($1,$2,$4) : $6 }
-
-core_default :: { UfDefault RdrName }
- : { UfNoDefault }
- | core_val_bndr RARROW core_expr SEMI { UfBindDefault $1 $3 }
-
-core_arg :: { UfArg RdrName }
- : var_name { UfVarArg $1 }
- | qvar_name { UfVarArg $1 }
- | qdata_name { UfVarArg $1 }
- | core_lit { UfLitArg $1 }
-
-core_args :: { [UfArg RdrName] }
- : { [] }
- | core_arg core_args { $1 : $2 }
-
-core_lit :: { Literal }
-core_lit : INTEGER { MachInt $1 True }
- | CHAR { MachChar $1 }
- | STRING { MachStr $1 }
- | STRING_LIT STRING { NoRepStr $2 }
- | DOUBLE { MachDouble (toRational $1) }
- | FLOAT_LIT DOUBLE { MachFloat (toRational $2) }
-
- | INTEGER_LIT INTEGER { NoRepInteger $2 (panic "NoRepInteger type")
- -- The type checker will add the types
- }
-
- | RATIONAL_LIT INTEGER INTEGER { NoRepRational ($2 % $3)
- (panic "NoRepRational type")
- -- The type checker will add the type
- }
-
- | ADDR_LIT INTEGER { MachAddr $2 }
- | LIT_LIT STRING { MachLitLit $2 (panic "ParseIface.y: ToDo: need PrimRep on LitLits in ifaces") }
-
-core_val_bndr :: { UfBinder RdrName }
-core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 }
-
-core_val_bndrs :: { [UfBinder RdrName] }
-core_val_bndrs : { [] }
- | core_val_bndr core_val_bndrs { $1 : $2 }
-
-core_tv_bndr :: { UfBinder RdrName }
-core_tv_bndr : tv_name DCOLON akind { UfTyBinder $1 $3 }
- | tv_name { UfTyBinder $1 mkTypeKind }
-
-core_tv_bndrs :: { [UfBinder RdrName] }
-core_tv_bndrs : { [] }
- | core_tv_bndr core_tv_bndrs { $1 : $2 }
-
-ccall_string :: { FAST_STRING }
- : STRING { $1 }
- | VARID { $1 }
- | CONID { $1 }
diff --git a/ghc/compiler/rename/ParseType.y b/ghc/compiler/rename/ParseType.y
new file mode 100644
index 0000000000..d39c56b53a
--- /dev/null
+++ b/ghc/compiler/rename/ParseType.y
@@ -0,0 +1,140 @@
+{
+#include "HsVersions.h"
+module ParseType ( parseType ) where
+
+IMP_Ubiq(){-uitous-}
+
+import HsSyn -- quite a bit of stuff
+import RdrHsSyn -- oodles of synonyms
+import HsDecls ( HsIdInfo(..) )
+import HsTypes ( mkHsForAllTy )
+import HsCore
+import Literal
+import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas )
+import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo,
+ ArgUsageInfo, FBTypeInfo
+ )
+import Kind ( Kind, mkArrowKind, mkTypeKind )
+import Lex
+
+import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
+ SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
+ )
+import Bag ( emptyBag, unitBag, snocBag )
+import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
+import Name ( OccName(..), isTCOcc, Provenance )
+import SrcLoc ( mkIfaceSrcLoc )
+import Util ( panic{-, pprPanic ToDo:rm-} )
+import Pretty ( ppShow )
+import PprStyle -- PprDebug for panic
+import Maybes ( MaybeErr(..) )
+
+------------------------------------------------------------------
+
+parseType :: [IfaceToken] -> MaybeErr RdrNameHsType (PprStyle -> Int -> Bool -> PrettyRep)
+parseType ls =
+ let
+ res =
+ case parseT ls of
+ v@(Succeeded _) -> v
+ Failed err -> panic (ppShow 80 (err PprDebug))
+ in
+ res
+
+}
+
+%name parseT
+%tokentype { IfaceToken }
+%monad { IfM }{ thenIf }{ returnIf }
+
+%token
+ FORALL { ITforall }
+ DCOLON { ITdcolon }
+ COMMA { ITcomma }
+ DARROW { ITdarrow }
+ OCURLY { ITocurly }
+ OBRACK { ITobrack }
+ OPAREN { IToparen }
+ RARROW { ITrarrow }
+ CCURLY { ITccurly }
+ CBRACK { ITcbrack }
+ CPAREN { ITcparen }
+
+ VARID { ITvarid $$ }
+ CONID { ITconid $$ }
+ VARSYM { ITvarsym $$ }
+ CONSYM { ITconsym $$ }
+ QCONID { ITqconid $$ }
+
+ UNKNOWN { ITunknown $$ }
+%%
+
+type :: { RdrNameHsType }
+type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 }
+ | tautype { $1 }
+
+forall : OBRACK tv_bndrs CBRACK { $2 }
+
+context :: { RdrNameContext }
+context : { [] }
+ | OCURLY context_list1 CCURLY { $2 }
+
+context_list1 :: { RdrNameContext }
+context_list1 : class { [$1] }
+ | class COMMA context_list1 { $1 : $3 }
+
+class :: { (RdrName, RdrNameHsType) }
+class : qtc_name atype { ($1, $2) }
+
+
+tautype :: { RdrNameHsType }
+tautype : btype { $1 }
+ | btype RARROW tautype { MonoFunTy $1 $3 }
+
+types2 :: { [RdrNameHsType] {- Two or more -} }
+types2 : type COMMA type { [$1,$3] }
+ | type COMMA types2 { $1 : $3 }
+
+btype :: { RdrNameHsType }
+btype : atype { $1 }
+ | btype atype { MonoTyApp $1 $2 }
+
+atype :: { RdrNameHsType }
+atype : qtc_name { MonoTyVar $1 }
+ | tv_name { MonoTyVar $1 }
+ | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 }
+ | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 }
+ | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 }
+ | OPAREN type CPAREN { $2 }
+
+atypes :: { [RdrNameHsType] {- Zero or more -} }
+atypes : { [] }
+ | atype atypes { $1 : $2
+---------------------------------------------------------------------
+ }
+
+tv_bndr :: { HsTyVar RdrName }
+tv_bndr : tv_name DCOLON akind { IfaceTyVar $1 $3 }
+ | tv_name { UserTyVar $1 }
+
+tv_bndrs :: { [HsTyVar RdrName] }
+ : { [] }
+ | tv_bndr tv_bndrs { $1 : $2 }
+
+kind :: { Kind }
+ : akind { $1 }
+ | akind RARROW kind { mkArrowKind $1 $3 }
+
+akind :: { Kind }
+ : VARSYM { mkTypeKind {- ToDo: check that it's "*" -} }
+ | OPAREN kind CPAREN { $2 }
+
+tv_name :: { RdrName }
+tv_name : VARID { Unqual (TvOcc $1) }
+
+tv_names :: { [RdrName] }
+ : { [] }
+ | tv_name tv_names { $1 : $2 }
+qtc_name :: { RdrName }
+qtc_name : QCONID { tcQual $1 }
+
diff --git a/ghc/compiler/rename/ParseUnfolding.y b/ghc/compiler/rename/ParseUnfolding.y
new file mode 100644
index 0000000000..1336fb9f51
--- /dev/null
+++ b/ghc/compiler/rename/ParseUnfolding.y
@@ -0,0 +1,344 @@
+{
+#include "HsVersions.h"
+module ParseUnfolding ( parseUnfolding ) where
+
+IMP_Ubiq(){-uitous-}
+
+import HsSyn -- quite a bit of stuff
+import RdrHsSyn -- oodles of synonyms
+import HsDecls ( HsIdInfo(..) )
+import HsTypes ( mkHsForAllTy )
+import HsCore
+import Literal
+import PrimRep ( decodePrimRep )
+import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas )
+import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo,
+ ArgUsageInfo, FBTypeInfo
+ )
+import Kind ( Kind, mkArrowKind, mkTypeKind )
+import Lex
+
+import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
+ SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
+ )
+import Bag ( emptyBag, unitBag, snocBag )
+import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
+import Name ( OccName(..), isTCOcc, Provenance )
+import SrcLoc ( mkIfaceSrcLoc )
+import Util ( panic{-, pprPanic ToDo:rm-} )
+import Pretty ( ppShow )
+import PprStyle -- PprDebug for panic
+import Maybes ( MaybeErr(..) )
+
+------------------------------------------------------------------
+
+parseUnfolding ls =
+ let
+ res =
+ case parseUnfold ls of
+ v@(Succeeded _) -> v
+ -- ill-formed unfolding, crash and burn.
+ Failed err -> panic (ppShow 80 (err PprDebug))
+ in
+ res
+}
+
+%name parseUnfold
+%tokentype { IfaceToken }
+%monad { IfM }{ thenIf }{ returnIf }
+
+%token
+ PRAGMAS_PART { ITpragmas }
+ DATA { ITdata }
+ TYPE { ITtype }
+ NEWTYPE { ITnewtype }
+ DERIVING { ITderiving }
+ CLASS { ITclass }
+ WHERE { ITwhere }
+ INSTANCE { ITinstance }
+ FORALL { ITforall }
+ BANG { ITbang }
+ VBAR { ITvbar }
+ DCOLON { ITdcolon }
+ COMMA { ITcomma }
+ DARROW { ITdarrow }
+ DOTDOT { ITdotdot }
+ EQUAL { ITequal }
+ OCURLY { ITocurly }
+ OBRACK { ITobrack }
+ OPAREN { IToparen }
+ RARROW { ITrarrow }
+ CCURLY { ITccurly }
+ CBRACK { ITcbrack }
+ CPAREN { ITcparen }
+ SEMI { ITsemi }
+
+ VARID { ITvarid $$ }
+ CONID { ITconid $$ }
+ VARSYM { ITvarsym $$ }
+ CONSYM { ITconsym $$ }
+ QVARID { ITqvarid $$ }
+ QCONID { ITqconid $$ }
+ QVARSYM { ITqvarsym $$ }
+ QCONSYM { ITqconsym $$ }
+
+ ARITY_PART { ITarity }
+ STRICT_PART { ITstrict }
+ UNFOLD_PART { ITunfold }
+ DEMAND { ITdemand $$ }
+ BOTTOM { ITbottom }
+ LAM { ITlam }
+ BIGLAM { ITbiglam }
+ CASE { ITcase }
+ PRIM_CASE { ITprim_case }
+ LET { ITlet }
+ LETREC { ITletrec }
+ IN { ITin }
+ OF { ITof }
+ COERCE_IN { ITcoerce_in }
+ COERCE_OUT { ITcoerce_out }
+ ATSIGN { ITatsign }
+ CCALL { ITccall $$ }
+ SCC { ITscc $$ }
+
+ CHAR { ITchar $$ }
+ STRING { ITstring $$ }
+ INTEGER { ITinteger $$ }
+ DOUBLE { ITdouble $$ }
+
+ INTEGER_LIT { ITinteger_lit }
+ FLOAT_LIT { ITfloat_lit }
+ RATIONAL_LIT { ITrational_lit }
+ ADDR_LIT { ITaddr_lit }
+ LIT_LIT { ITlit_lit }
+ STRING_LIT { ITstring_lit }
+
+ UNKNOWN { ITunknown $$ }
+%%
+
+id_info :: { [HsIdInfo RdrName] }
+id_info : { [] }
+ | id_info_item id_info { $1 : $2 }
+
+id_info_item :: { HsIdInfo RdrName }
+id_info_item : ARITY_PART arity_info { HsArity $2 }
+ | STRICT_PART strict_info { HsStrictness $2 }
+ | BOTTOM { HsStrictness mkBottomStrictnessInfo }
+ | UNFOLD_PART core_expr { HsUnfold $2 }
+
+arity_info :: { ArityInfo }
+arity_info : INTEGER { exactArity (fromInteger $1) }
+
+strict_info :: { StrictnessInfo RdrName }
+strict_info : DEMAND any_var_name { mkStrictnessInfo $1 (Just $2) }
+ | DEMAND { mkStrictnessInfo $1 Nothing }
+
+core_expr :: { UfExpr RdrName }
+core_expr : any_var_name { UfVar $1 }
+ | qdata_name { UfVar $1 }
+ | core_lit { UfLit $1 }
+ | OPAREN core_expr CPAREN { $2 }
+ | qdata_name OCURLY data_args CCURLY { UfCon $1 $3 }
+
+ | core_expr ATSIGN atype { UfApp $1 (UfTyArg $3) }
+ | core_expr core_arg { UfApp $1 $2 }
+ | LAM core_val_bndrs RARROW core_expr { foldr UfLam $4 $2 }
+ | BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 }
+
+ | CASE core_expr OF
+ OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) }
+ | PRIM_CASE core_expr OF
+ OCURLY prim_alts core_default CCURLY { UfCase $2 (UfPrimAlts $5 $6) }
+
+
+ | LET OCURLY core_val_bndr EQUAL core_expr CCURLY
+ IN core_expr { UfLet (UfNonRec $3 $5) $8 }
+ | LETREC OCURLY rec_binds CCURLY
+ IN core_expr { UfLet (UfRec $3) $6 }
+
+ | coerce atype core_expr { UfCoerce $1 $2 $3 }
+
+ | CCALL ccall_string
+ OBRACK atype atypes CBRACK core_args { let
+ (is_casm, may_gc) = $1
+ in
+ UfPrim (UfCCallOp $2 is_casm may_gc $5 $4)
+ $7
+ }
+ | SCC OPAREN core_expr CPAREN { UfSCC $1 $3 }
+
+rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] }
+ : { [] }
+ | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 }
+
+coerce :: { UfCoercion RdrName }
+coerce : COERCE_IN qdata_name { UfIn $2 }
+ | COERCE_OUT qdata_name { UfOut $2 }
+
+prim_alts :: { [(Literal,UfExpr RdrName)] }
+ : { [] }
+ | core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 }
+
+alg_alts :: { [(RdrName, [RdrName], UfExpr RdrName)] }
+ : { [] }
+ | qdata_name var_names RARROW
+ core_expr SEMI alg_alts { ($1,$2,$4) : $6 }
+
+core_default :: { UfDefault RdrName }
+ : { UfNoDefault }
+ | var_name RARROW core_expr SEMI { UfBindDefault $1 $3 }
+
+core_arg :: { UfArg RdrName }
+ : var_name { UfVarArg $1 }
+ | qvar_name { UfVarArg $1 }
+ | qdata_name { UfVarArg $1 }
+ | core_lit { UfLitArg $1 }
+
+core_args :: { [UfArg RdrName] }
+ : { [] }
+ | core_arg core_args { $1 : $2 }
+
+data_args :: { [UfArg RdrName] }
+ : { [] }
+ | ATSIGN atype data_args { UfTyArg $2 : $3 }
+ | core_arg data_args { $1 : $2 }
+
+core_lit :: { Literal }
+core_lit : INTEGER { MachInt $1 True }
+ | CHAR { MachChar $1 }
+ | STRING { MachStr $1 }
+ | STRING_LIT STRING { NoRepStr $2 }
+ | DOUBLE { MachDouble (toRational $1) }
+ | FLOAT_LIT DOUBLE { MachFloat (toRational $2) }
+
+ | INTEGER_LIT INTEGER { NoRepInteger $2 (panic "NoRepInteger type")
+ -- The type checker will add the types
+ }
+
+ | RATIONAL_LIT INTEGER INTEGER { NoRepRational ($2 % $3)
+ (panic "NoRepRational type")
+ -- The type checker will add the type
+ }
+
+ | ADDR_LIT INTEGER { MachAddr $2 }
+ | LIT_LIT prim_rep STRING { MachLitLit $3 (decodePrimRep $2) }
+
+core_val_bndr :: { UfBinder RdrName }
+core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 }
+
+core_val_bndrs :: { [UfBinder RdrName] }
+core_val_bndrs : { [] }
+ | core_val_bndr core_val_bndrs { $1 : $2 }
+
+core_tv_bndr :: { UfBinder RdrName }
+core_tv_bndr : tv_name DCOLON akind { UfTyBinder $1 $3 }
+ | tv_name { UfTyBinder $1 mkTypeKind }
+
+core_tv_bndrs :: { [UfBinder RdrName] }
+core_tv_bndrs : { [] }
+ | core_tv_bndr core_tv_bndrs { $1 : $2 }
+
+ccall_string :: { FAST_STRING }
+ : STRING { $1 }
+ | VARID { $1 }
+ | CONID { $1 }
+
+prim_rep :: { Char }
+ : VARID { head (_UNPK_ $1) }
+ | CONID { head (_UNPK_ $1)
+
+---variable names-----------------------------------------------------
+ }
+var_occ :: { OccName }
+var_occ : VARID { VarOcc $1 }
+ | VARSYM { VarOcc $1 }
+ | BANG { VarOcc SLIT("!") {-sigh, double-sigh-} }
+
+qdata_name :: { RdrName }
+qdata_name : QCONID { varQual $1 }
+ | QCONSYM { varQual $1 }
+
+qvar_name :: { RdrName }
+ : QVARID { varQual $1 }
+ | QVARSYM { varQual $1 }
+
+var_name :: { RdrName }
+var_name : var_occ { Unqual $1 }
+
+any_var_name :: {RdrName}
+any_var_name : var_name { $1 }
+ | qvar_name { $1 }
+
+var_names :: { [RdrName] }
+var_names : { [] }
+ | var_name var_names { $1 : $2
+
+--productions-for-types--------------------------------
+ }
+forall : OBRACK tv_bndrs CBRACK { $2 }
+
+context :: { RdrNameContext }
+context : { [] }
+ | OCURLY context_list1 CCURLY { $2 }
+
+context_list1 :: { RdrNameContext }
+context_list1 : class { [$1] }
+ | class COMMA context_list1 { $1 : $3 }
+
+class :: { (RdrName, RdrNameHsType) }
+class : qtc_name atype { ($1, $2) }
+
+type :: { RdrNameHsType }
+type : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 }
+ | tautype { $1 }
+
+tautype :: { RdrNameHsType }
+tautype : btype { $1 }
+ | btype RARROW tautype { MonoFunTy $1 $3 }
+
+types2 :: { [RdrNameHsType] {- Two or more -} }
+types2 : type COMMA type { [$1,$3] }
+ | type COMMA types2 { $1 : $3 }
+
+btype :: { RdrNameHsType }
+btype : atype { $1 }
+ | btype atype { MonoTyApp $1 $2 }
+
+atype :: { RdrNameHsType }
+atype : qtc_name { MonoTyVar $1 }
+ | tv_name { MonoTyVar $1 }
+ | OPAREN types2 CPAREN { MonoTupleTy dummyRdrTcName $2 }
+ | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 }
+ | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 }
+ | OPAREN type CPAREN { $2 }
+
+atypes :: { [RdrNameHsType] {- Zero or more -} }
+atypes : { [] }
+ | atype atypes { $1 : $2
+---------------------------------------------------------------------
+ }
+
+tv_bndr :: { HsTyVar RdrName }
+tv_bndr : tv_name DCOLON akind { IfaceTyVar $1 $3 }
+ | tv_name { UserTyVar $1 }
+
+tv_bndrs :: { [HsTyVar RdrName] }
+ : { [] }
+ | tv_bndr tv_bndrs { $1 : $2 }
+
+kind :: { Kind }
+ : akind { $1 }
+ | akind RARROW kind { mkArrowKind $1 $3 }
+
+akind :: { Kind }
+ : VARSYM { mkTypeKind {- ToDo: check that it's "*" -} }
+ | OPAREN kind CPAREN { $2 }
+
+tv_name :: { RdrName }
+tv_name : VARID { Unqual (TvOcc $1) }
+
+tv_names :: { [RdrName] }
+ : { [] }
+ | tv_name tv_names { $1 : $2 }
+qtc_name :: { RdrName }
+qtc_name : QCONID { tcQual $1 }
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index d66596bc3f..81059c201e 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -21,8 +21,8 @@ import CmdLineOpts ( opt_HiMap )
import RnMonad
import RnNames ( getGlobalNames )
import RnSource ( rnDecl )
-import RnIfaces ( getImportedInstDecls, getDecl, getImportVersions, getSpecialInstModules,
- mkSearchPath, getWiredInDecl
+import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getSpecialInstModules,
+ mkSearchPath
)
import RnEnv ( availsToNameSet, addAvailToNameSet,
addImplicitOccsRn, lookupImplicitOccRn )
@@ -81,34 +81,11 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_
) `thenRn` \ rn_local_decls ->
-- SLURP IN ALL THE NEEDED DECLARATIONS
- -- Notice that the rnEnv starts empty
- closeDecls rn_local_decls (availsToNameSet local_avails) []
- `thenRn` \ (rn_all_decls1, all_names1, imp_avails1) ->
-
- -- SLURP IN ALL NEEDED INSTANCE DECLARATIONS
- -- We extract instance decls that only mention things (type constructors, classes) that are
- -- already imported. Those that don't can't possibly be useful to us.
- --
- -- We do another closeDecls, so that we can slurp info for the dictionary functions
- -- for the instance declaration. These are *not* optional because the version number on
- -- the dfun acts as the version number for the instance declaration itself; if the
- -- instance decl changes, so will its dfun version number.
- getImportedInstDecls `thenRn` \ imported_insts ->
- let
- all_big_names = mkNameSet [name | Avail name _ <- local_avails] `unionNameSets`
- mkNameSet [name | Avail name _ <- imp_avails1]
-
- rn_needed_insts = [ initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl (InstD inst_decl))
- | (inst_names, mod_name, inst_decl) <- imported_insts,
- all (`elemNameSet` all_big_names) inst_names
- ]
- in
- sequenceRn rn_needed_insts `thenRn` \ inst_decls ->
- closeDecls rn_all_decls1 all_names1 imp_avails1 `thenRn` \ (rn_all_decls2, all_names2, imp_avails2) ->
+ closeDecls rn_local_decls `thenRn` \ rn_all_decls ->
-- GENERATE THE VERSION/USAGE INFO
- getImportVersions imp_avails2 `thenRn` \ import_versions ->
+ getImportVersions mod_name exports `thenRn` \ import_versions ->
getNameSupplyRn `thenRn` \ name_supply ->
@@ -133,7 +110,7 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_
renamed_module = HsModule mod_name vers
trashed_exports trashed_imports trashed_fixities
- (inst_decls ++ rn_all_decls2)
+ rn_all_decls
loc
in
returnRn (Just (renamed_module,
@@ -169,62 +146,56 @@ addImplicits mod_name
\begin{code}
closeDecls :: [RenamedHsDecl] -- Declarations got so far
- -> NameSet -- Names bound by those declarations
- -> [AvailInfo] -- Available stuff generated by closeDecls so far
- -> RnMG ([RenamedHsDecl], -- input + extra decls slurped
- NameSet, -- input + names bound by extra decls
- [AvailInfo]) -- input + extra avails from extra decls
+ -> RnMG [RenamedHsDecl] -- input + extra decls slurped
-- The monad includes a list of possibly-unresolved Names
-- This list is empty when closeDecls returns
-closeDecls decls decl_names import_avails
+closeDecls decls
= popOccurrenceName `thenRn` \ maybe_unresolved ->
-
case maybe_unresolved of
- -- No more unresolved names; we're done
- Nothing -> returnRn (decls, decl_names, import_avails)
-
- -- An "unresolved" name that we've already dealt with
- Just (name,_) | name `elemNameSet` decl_names
- -> closeDecls decls decl_names import_avails
+ -- No more unresolved names
+ Nothing -> -- Slurp instance declarations
+ getImportedInstDecls `thenRn` \ inst_decls ->
+ traceRn (ppSep [ppPStr SLIT("Slurped"), ppInt (length inst_decls), ppPStr SLIT("instance decls")])
+ `thenRn_`
+
+ -- None? then at last we are done
+ if null inst_decls then
+ returnRn decls
+ else
+ mapRn rn_inst_decl inst_decls `thenRn` \ new_inst_decls ->
+
+ -- We *must* loop again here. Why? Two reasons:
+ -- (a) an instance decl will give rise to an unresolved dfun, whose
+ -- decl we must slurp to get its version number; that's the version
+ -- number for the whole instance decl.
+ -- (b) an instance decl might give rise to a new unresolved class,
+ -- whose decl we must slurp, which might let in some new instance decls,
+ -- and so on. Example: instance Foo a => Baz [a] where ...
- -- An unresolved name that's wired in. In this case there's no
- -- declaration to get, but we still want to record it as now available,
- -- so that we remember to look for instance declarations involving it.
- Just (name,_) | isWiredInName name
- -> getWiredInDecl name `thenRn` \ decl_avail ->
- closeDecls decls
- (addAvailToNameSet decl_names decl_avail)
- (decl_avail : import_avails)
-
- -- Genuinely unresolved name
- Just (name,necessity) | otherwise
- -> getDecl name `thenRn` \ (decl_avail,new_decl) ->
- case decl_avail of
-
- -- Can't find the declaration; check that it was optional
- NotAvailable -> case necessity of {
- Optional -> addWarnRn (getDeclWarn name);
- other -> addErrRn (getDeclErr name)
- } `thenRn_`
- closeDecls decls decl_names import_avails
-
- -- Found it
- other -> initRnMS emptyRnEnv mod_name InterfaceMode (
- rnDecl new_decl
- ) `thenRn` \ rn_decl ->
- closeDecls (rn_decl : decls)
- (addAvailToNameSet decl_names decl_avail)
- (decl_avail : import_avails)
+ closeDecls (new_inst_decls ++ decls)
+
+ -- An unresolved name
+ Just (name,necessity)
+ -> -- Slurp its declaration, if any
+-- traceRn (ppSep [ppPStr SLIT("Considering"), ppr PprDebug name]) `thenRn_`
+ importDecl name necessity `thenRn` \ maybe_decl ->
+ case maybe_decl of
+
+ -- No declaration... (wired in thing or optional)
+ Nothing -> closeDecls decls
+
+ -- Found a declaration... rename it
+ Just decl -> rn_iface_decl mod_name decl `thenRn` \ new_decl ->
+ closeDecls (new_decl : decls)
where
(mod_name,_) = modAndOcc name
+ where
+ -- Notice that the rnEnv starts empty
+ rn_iface_decl mod_name decl = initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl decl)
+ rn_inst_decl (mod_name,decl) = rn_iface_decl mod_name (InstD decl)
-getDeclErr name sty
- = ppSep [ppStr "Failed to find interface decl for", ppr sty name]
-
-getDeclWarn name sty
- = ppSep [ppStr "Warning: failed to find (optional) interface decl for", ppr sty name]
\end{code}
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index d4df584c22..d5183aed30 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -26,7 +26,7 @@ import RdrHsSyn
import RnHsSyn
import RnMonad
import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
-import RnEnv ( bindLocatedLocalsRn, lookupRn, lookupOccRn, isUnboundName )
+import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, isUnboundName )
import CmdLineOpts ( opt_SigsRequired )
import Digraph ( stronglyConnComp )
@@ -174,7 +174,7 @@ rnTopMonoBinds EmptyMonoBinds sigs
= returnRn EmptyBinds
rnTopMonoBinds mbinds sigs
- = mapRn lookupRn binder_rdr_names `thenRn` \ binder_names ->
+ = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
let
binder_set = mkNameSet binder_names
in
@@ -312,7 +312,7 @@ flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn)
= pushSrcLocRn locn $
mapRn (checkPrecMatch inf name) matches `thenRn_`
- lookupRn name `thenRn` \ name' ->
+ lookupBndrRn name `thenRn` \ name' ->
mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
let
fvs = unionManyNameSets fv_lists
@@ -346,13 +346,13 @@ rnMethodBinds (AndMonoBinds mb1 mb2)
rnMethodBinds (FunMonoBind occname inf matches locn)
= pushSrcLocRn locn $
mapRn (checkPrecMatch inf occname) matches `thenRn_`
- lookupRn occname `thenRn` \ op_name ->
+ lookupBndrRn occname `thenRn` \ op_name ->
mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
returnRn (FunMonoBind op_name inf new_matches locn)
rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
= pushSrcLocRn locn $
- lookupRn occname `thenRn` \ op_name ->
+ lookupBndrRn occname `thenRn` \ op_name ->
rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
@@ -503,13 +503,13 @@ rnBindSigs is_toplev binders sigs
renameSig (Sig v ty src_loc)
= pushSrcLocRn src_loc $
- lookupRn v `thenRn` \ new_v ->
+ lookupBndrRn v `thenRn` \ new_v ->
rnHsType ty `thenRn` \ new_ty ->
returnRn (Sig new_v new_ty src_loc)
renameSig (SpecSig v ty using src_loc)
= pushSrcLocRn src_loc $
- lookupRn v `thenRn` \ new_v ->
+ lookupBndrRn v `thenRn` \ new_v ->
rnHsType ty `thenRn` \ new_ty ->
rn_using using `thenRn` \ new_using ->
returnRn (SpecSig new_v new_ty new_using src_loc)
@@ -520,17 +520,17 @@ renameSig (SpecSig v ty using src_loc)
renameSig (InlineSig v src_loc)
= pushSrcLocRn src_loc $
- lookupRn v `thenRn` \ new_v ->
+ lookupBndrRn v `thenRn` \ new_v ->
returnRn (InlineSig new_v src_loc)
renameSig (DeforestSig v src_loc)
= pushSrcLocRn src_loc $
- lookupRn v `thenRn` \ new_v ->
+ lookupBndrRn v `thenRn` \ new_v ->
returnRn (DeforestSig new_v src_loc)
renameSig (MagicUnfoldingSig v str src_loc)
= pushSrcLocRn src_loc $
- lookupRn v `thenRn` \ new_v ->
+ lookupBndrRn v `thenRn` \ new_v ->
returnRn (MagicUnfoldingSig new_v str src_loc)
\end{code}
@@ -573,29 +573,29 @@ sig_name (MagicUnfoldingSig n _ _) = n
\begin{code}
dupSigDeclErr (sig:sigs)
= pushSrcLocRn loc $
- addErrRn (\sty -> ppSep [ppStr "more than one",
- ppStr what_it_is, ppStr "given for",
- ppQuote (ppr sty (sig_name sig))])
+ addErrRn (\sty -> ppSep [ppPStr SLIT("more than one"),
+ ppPStr what_it_is, ppPStr SLIT("given for"),
+ ppQuote (ppr sty (sig_name sig))])
where
(what_it_is, loc) = sig_doc sig
unknownSigErr sig
= pushSrcLocRn loc $
- addErrRn (\sty -> ppSep [ppStr flavour, ppStr "but no definition for",
+ addErrRn (\sty -> ppSep [ppPStr flavour, ppPStr SLIT("but no definition for"),
ppQuote (ppr sty (sig_name sig))])
where
(flavour, loc) = sig_doc sig
-sig_doc (Sig _ _ loc) = ("type signature",loc)
-sig_doc (ClassOpSig _ _ _ loc) = ("class-method type signature", loc)
-sig_doc (SpecSig _ _ _ loc) = ("SPECIALIZE pragma",loc)
-sig_doc (InlineSig _ loc) = ("INLINE pragma",loc)
-sig_doc (MagicUnfoldingSig _ _ loc) = ("MAGIC_UNFOLDING pragma",loc)
+sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
+sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
+sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALIZE pragma"),loc)
+sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc)
+sig_doc (MagicUnfoldingSig _ _ loc) = (SLIT("MAGIC_UNFOLDING pragma"),loc)
missingSigErr var sty
- = ppSep [ppStr "a definition but no type signature for", ppQuote (ppr sty var)]
+ = ppSep [ppPStr SLIT("a definition but no type signature for"), ppQuote (ppr sty var)]
methodBindErr mbind sty
- = ppHang (ppStr "Can't handle multiple methods defined by one pattern binding")
+ = ppHang (ppPStr SLIT("Can't handle multiple methods defined by one pattern binding"))
4 (ppr sty mbind)
\end{code}
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index da4fed92c0..1b348bccc1 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -10,18 +10,18 @@ module RnEnv where -- Export everything
IMP_Ubiq()
-import CmdLineOpts ( opt_WarnNameShadowing, opt_IgnoreIfacePragmas )
+import CmdLineOpts ( opt_WarnNameShadowing )
import HsSyn
import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameIE),
- rdrNameOcc, isQual, qual
+ rdrNameOcc, ieOcc, isQual, qual
)
import HsTypes ( getTyVarName, replaceTyVarName )
import RnMonad
import Name ( Name, OccName(..), Provenance(..), DefnInfo(..), ExportFlag(..),
occNameString, occNameFlavour,
SYN_IE(NameSet), emptyNameSet, addListToNameSet,
- mkLocalName, mkGlobalName, modAndOcc,
- isLocalName, isWiredInName, nameOccName, setNameProvenance,
+ mkLocalName, mkGlobalName, modAndOcc, isLocallyDefinedName,
+ isWiredInName, nameOccName, setNameProvenance, isVarOcc,
pprProvenance, pprOccName, pprModule, pprNonSymOcc, pprNameProvenance
)
import TyCon ( TyCon )
@@ -49,7 +49,8 @@ newGlobalName :: Module -> OccName -> RnM s d Name
newGlobalName mod occ
= -- First check the cache
getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
- case lookupFM cache (mod,occ) of
+ let key = (mod,occ) in
+ case lookupFM cache key of
-- A hit in the cache! Return it, but change the src loc
-- of the thing we've found if this is a second definition site
@@ -63,7 +64,7 @@ newGlobalName mod occ
(us', us1) = splitUniqSupply us
uniq = getUnique us1
name = mkGlobalName uniq mod occ VanillaDefn Implicit
- cache' = addToFM cache (mod,occ) name
+ cache' = addToFM cache key name
in
setNameSupplyRn (us', inst_ns, cache') `thenRn_`
returnRn name
@@ -86,28 +87,50 @@ newLocallyDefinedGlobalName mod occ rec_exp_fn loc
provenance = LocalDef (rec_exp_fn new_name) loc
(us', us1) = splitUniqSupply us
uniq = getUnique us1
- new_name = case lookupFM cache (mod,occ) of
- Just name -> setNameProvenance name provenance
- Nothing -> mkGlobalName uniq mod occ VanillaDefn provenance
- cache' = addToFM cache (mod,occ) new_name
+ key = (mod,occ)
+ new_name = case lookupFM cache key of
+ Just name -> setNameProvenance name provenance
+ Nothing -> mkGlobalName uniq mod occ VanillaDefn provenance
+ new_cache = addToFM cache key new_name
in
- setNameSupplyRn (us', inst_ns, cache') `thenRn_`
+ setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
returnRn new_name
--- newDfunName is used to allocate a name for the dictionary function for
--- a local instance declaration. No need to put it in the cache (I think!).
-newDfunName :: SrcLoc -> RnMS s Name
-newDfunName src_loc
- = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
- getModuleRn `thenRn` \ mod_name ->
+-- newSysName is used to create the names for
+-- a) default methods
+-- These are never mentioned explicitly in source code (hence no point in looking
+-- them up in the NameEnv), but when reading an interface file
+-- we may want to slurp in their pragma info. In the source file itself we
+-- need to create these names too so that we export them into the inferface file for this module.
+
+newSysName :: OccName -> ExportFlag -> SrcLoc -> RnMS s Name
+newSysName occ export_flag loc
+ = getModeRn `thenRn` \ mode ->
+ getModuleRn `thenRn` \ mod_name ->
+ case mode of
+ SourceMode -> newLocallyDefinedGlobalName
+ mod_name occ
+ (\_ -> export_flag)
+ loc
+ InterfaceMode -> newGlobalName mod_name occ
+
+-- newDfunName is a variant, specially for dfuns.
+-- When renaming derived definitions we are in *interface* mode (because we can trip
+-- over original names), but we still want to make the Dfun locally-defined.
+-- So we can't use whether or not we're in source mode to decide the locally-defined question.
+newDfunName :: Maybe RdrName -> SrcLoc -> RnMS s Name
+newDfunName Nothing src_loc -- Local instance decls have a "Nothing"
+ = getModuleRn `thenRn` \ mod_name ->
+ newInstUniq `thenRn` \ inst_uniq ->
let
- (us', us1) = splitUniqSupply us
- uniq = getUnique us1
- dfun_name = mkGlobalName uniq mod_name (VarOcc (_PK_ ("df" ++ show inst_ns)))
- VanillaDefn (LocalDef Exported src_loc)
- in
- setNameSupplyRn (us', inst_ns+1, cache) `thenRn_`
- returnRn dfun_name
+ dfun_occ = VarOcc (_PK_ ("$d" ++ show inst_uniq))
+ in
+ newLocallyDefinedGlobalName mod_name dfun_occ
+ (\_ -> Exported) src_loc
+
+newDfunName (Just n) src_loc -- Imported ones have "Just n"
+ = getModuleRn `thenRn` \ mod_name ->
+ newGlobalName mod_name (rdrNameOcc n)
newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name]
@@ -189,10 +212,9 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope
Looking up a name in the RnEnv.
\begin{code}
-lookupRn :: RdrName -> RnMS s Name
-lookupRn rdr_name
- = getNameEnv `thenRn` \ name_env ->
- case lookupFM name_env rdr_name of
+lookupRn :: NameEnv -> RdrName -> RnMS s Name
+lookupRn name_env rdr_name
+ = case lookupFM name_env rdr_name of
-- Found it!
Just name -> returnRn name
@@ -218,31 +240,37 @@ lookupRn rdr_name
newGlobalName mod_name occ
+lookupBndrRn rdr_name
+ = getNameEnv `thenRn` \ name_env ->
+ lookupRn name_env rdr_name
+
-- Just like lookupRn except that we record the occurrence too
-- Perhaps surprisingly, even wired-in names are recorded.
-- Why? So that we know which wired-in names are referred to when
-- deciding which instance declarations to import.
lookupOccRn :: RdrName -> RnMS s Name
lookupOccRn rdr_name
- = lookupRn rdr_name `thenRn` \ name ->
- if isLocalName name then
- returnRn name
- else
- addOccurrenceName Compulsory name `thenRn_`
- returnRn name
+ = getNameEnv `thenRn` \ name_env ->
+ lookupRn name_env rdr_name `thenRn` \ name ->
+ addOccurrenceName Compulsory name
+
+-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
+-- environment. It's used for record field names only.
+lookupGlobalOccRn :: RdrName -> RnMS s Name
+lookupGlobalOccRn rdr_name
+ = getGlobalNameEnv `thenRn` \ name_env ->
+ lookupRn name_env rdr_name `thenRn` \ name ->
+ addOccurrenceName Compulsory name
-- lookupOptionalOccRn is similar, but it's used in places where
-- we don't *have* to find a definition for the thing.
lookupOptionalOccRn :: RdrName -> RnMS s Name
lookupOptionalOccRn rdr_name
- = lookupRn rdr_name `thenRn` \ name ->
- if opt_IgnoreIfacePragmas || isLocalName name then
- -- Never look for optional things if we're
- -- ignoring optional input interface information
- returnRn name
- else
- addOccurrenceName Optional name `thenRn_`
- returnRn name
+ = getNameEnv `thenRn` \ name_env ->
+ lookupRn name_env rdr_name `thenRn` \ name ->
+ addOccurrenceName Optional name
+
+
-- lookupImplicitOccRn takes an RdrName representing an *original* name, and
-- adds it to the occurrence pool so that it'll be loaded later. This is
@@ -253,7 +281,7 @@ lookupOptionalOccRn rdr_name
-- This doesn't apply in interface mode, where everything is explicit, but
-- we don't check for this case: it does no harm to record an "extra" occurrence
-- and lookupImplicitOccRn isn't used much in interface mode (it's only the
--- Nothing clause of rnDerivs that calls it at all I think.
+-- Nothing clause of rnDerivs that calls it at all I think).
--
-- For List and Tuple types it's important to get the correct
-- isLocallyDefined flag, which is used in turn when deciding
@@ -263,10 +291,9 @@ lookupOptionalOccRn rdr_name
lookupImplicitOccRn :: RdrName -> RnMS s Name
lookupImplicitOccRn (Qual mod occ)
= newGlobalName mod occ `thenRn` \ name ->
- addOccurrenceName Compulsory name `thenRn_`
- returnRn name
+ addOccurrenceName Compulsory name
-addImplicitOccRn :: Name -> RnM s d ()
+addImplicitOccRn :: Name -> RnM s d Name
addImplicitOccRn name = addOccurrenceName Compulsory name
addImplicitOccsRn :: [Name] -> RnM s d ()
@@ -357,42 +384,112 @@ lookupModuleAvails = lookupFM
=============== AvailInfo ================
\begin{code}
-plusAvail (Avail n1 ns1) (Avail n2 ns2) = Avail n1 (nub (ns1 ++ ns2))
+plusAvail (Avail n1) (Avail n2) = Avail n1
+plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
plusAvail a NotAvailable = a
plusAvail NotAvailable a = a
addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
-addAvailToNameSet names NotAvailable = names
-addAvailToNameSet names (Avail n ns) = addListToNameSet names (n:ns)
+addAvailToNameSet names avail = addListToNameSet names (availNames avail)
availsToNameSet :: [AvailInfo] -> NameSet
availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
+availName :: AvailInfo -> Name
+availName (Avail n) = n
+availName (AvailTC n _) = n
+
availNames :: AvailInfo -> [Name]
-availNames NotAvailable = []
-availNames (Avail n ns) = n:ns
-
-filterAvail :: RdrNameIE -> AvailInfo -> AvailInfo
-filterAvail (IEThingWith _ wanted) NotAvailable = NotAvailable
-filterAvail (IEThingWith _ wanted) (Avail n ns)
- | sub_names_ok = Avail n (filter is_wanted ns)
- | otherwise = NotAvailable
+availNames NotAvailable = []
+availNames (Avail n) = [n]
+availNames (AvailTC n ns) = ns
+
+-- availEntityNames is used to extract the names that can appear on their own in
+-- an export or import list. For class decls, class methods can appear on their
+-- own, thus import A( op )
+-- but constructors cannot; thus
+-- import B( T )
+-- means import type T from B, not constructor T.
+
+availEntityNames :: AvailInfo -> [Name]
+availEntityNames NotAvailable = []
+availEntityNames (Avail n) = [n]
+availEntityNames (AvailTC n ns) = n : filter (isVarOcc . nameOccName) ns
+
+filterAvail :: RdrNameIE -- Wanted
+ -> AvailInfo -- Available
+ -> AvailInfo -- Resulting available;
+ -- NotAvailable if wanted stuff isn't there
+
+filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
+ | sub_names_ok = AvailTC n (filter is_wanted ns)
+ | otherwise = pprTrace "filterAvail" (ppCat [ppr PprDebug ie, pprAvail PprDebug avail]) $
+ NotAvailable
where
is_wanted name = nameOccName name `elem` wanted_occs
sub_names_ok = all (`elem` avail_occs) wanted_occs
- wanted_occs = map rdrNameOcc wanted
avail_occs = map nameOccName ns
+ wanted_occs = map rdrNameOcc (want:wants)
+
+filterAvail (IEThingAbs _) (AvailTC n ns)
+ | n `elem` ns = AvailTC n [n]
+
+filterAvail (IEThingAbs _) avail@(Avail n) = avail -- Type synonyms
+
+filterAvail (IEVar _) avail@(Avail n) = avail
+filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns)
+ where
+ wanted n = nameOccName n == occ
+ occ = rdrNameOcc v
+ -- The second equation happens if we import a class op, thus
+ -- import A( op )
+ -- where op is a class operation
+
+filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail
+
+filterAvail ie avail = NotAvailable
+
+
+hideAvail :: RdrNameIE -- Hide this
+ -> AvailInfo -- Available
+ -> AvailInfo -- Resulting available;
+-- Don't complain about hiding non-existent things; that's done elsewhere
+
+hideAvail ie NotAvailable
+ = NotAvailable
+
+hideAvail ie (Avail n)
+ | not (ieOcc ie == nameOccName n) = Avail n -- No match
+ | otherwise = NotAvailable -- Names match
+
+hideAvail ie (AvailTC n ns)
+ | not (ieOcc ie == nameOccName n) -- No match
+ = case ie of -- But in case we are faced with ...hiding( (+) )
+ -- we filter the "ns" anyhow
+ IEVar op -> AvailTC n (filter keep ns)
+ where
+ op_occ = rdrNameOcc op
+ keep n = nameOccName n /= op_occ
+
+ other -> AvailTC n ns
+ | otherwise -- Names match
+ = case ie of
+ IEThingAbs _ -> AvailTC n (filter (/= n) ns)
+ IEThingAll _ -> NotAvailable
+ IEThingWith hide hides -> AvailTC n (filter keep ns)
+ where
+ keep n = nameOccName n `notElem` hide_occs
+ hide_occs = map rdrNameOcc (hide : hides)
-filterAvail (IEThingAll _) avail = avail
-filterAvail ie (Avail n ns) = Avail n [] -- IEThingAbs and IEVar
-- pprAvail gets given the OccName of the "host" thing
-pprAvail sty NotAvailable = ppStr "NotAvailable"
-pprAvail sty (Avail n ns) = ppCat [pprOccName sty (nameOccName n),
- ppStr "(",
- ppInterleave ppComma (map (pprOccName sty.nameOccName) ns),
- ppStr ")"]
+pprAvail sty NotAvailable = ppPStr SLIT("NotAvailable")
+pprAvail sty (AvailTC n ns) = ppCat [pprOccName sty (nameOccName n),
+ ppChar '(',
+ ppInterleave ppComma (map (pprOccName sty.nameOccName) ns),
+ ppChar ')']
+pprAvail sty (Avail n) = pprOccName sty (nameOccName n)
\end{code}
@@ -436,33 +533,35 @@ conflictFM bad fm key elt
\begin{code}
nameClashErr (rdr_name, (name1,name2)) sty
- = ppHang (ppCat [ppStr "Conflicting definitions for: ", ppr sty rdr_name])
+ = ppHang (ppCat [ppPStr SLIT("Conflicting definitions for: "), ppr sty rdr_name])
4 (ppAboves [pprNameProvenance sty name1,
pprNameProvenance sty name2])
fixityClashErr (rdr_name, (fp1,fp2)) sty
- = ppHang (ppCat [ppStr "Conflicting fixities for: ", ppr sty rdr_name])
+ = ppHang (ppCat [ppPStr SLIT("Conflicting fixities for: "), ppr sty rdr_name])
4 (ppAboves [pprFixityProvenance sty fp1,
pprFixityProvenance sty fp2])
shadowedNameWarn shadow sty
- = ppBesides [ppStr "More than one value with the same name (shadowing): ", ppr sty shadow]
+ = ppBesides [ppPStr SLIT("This binding for"),
+ ppQuote (ppr sty shadow),
+ ppPStr SLIT("shadows an existing binding")]
unknownNameErr name sty
- = ppSep [ppStr flavour, ppStr "not in scope:", ppr sty name]
+ = ppSep [ppStr flavour, ppPStr SLIT("not in scope:"), ppr sty name]
where
flavour = occNameFlavour (rdrNameOcc name)
qualNameErr descriptor (name,loc)
= pushSrcLocRn loc $
- addErrRn (\sty -> ppBesides [ppStr "invalid use of qualified ",
- ppStr descriptor, ppStr ": ",
+ addErrRn (\sty -> ppBesides [ppPStr SLIT("invalid use of qualified "),
+ ppStr descriptor, ppPStr SLIT(": "),
pprNonSymOcc sty (rdrNameOcc name) ])
dupNamesErr descriptor ((name,loc) : dup_things)
= pushSrcLocRn loc $
- addErrRn (\sty -> ppBesides [ppStr "duplicate bindings of `",
- ppr sty name, ppStr "' in ",
+ addErrRn (\sty -> ppBesides [ppPStr SLIT("duplicate bindings of `"),
+ ppr sty name, ppPStr SLIT("' in "),
ppStr descriptor])
\end{code}
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 73b1c44692..e1e6fe23db 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -26,16 +26,18 @@ import RnHsSyn
import RnMonad
import RnEnv
import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR,
- creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR,
+ creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
negate_RDR
)
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon
)
import TyCon ( TyCon )
+import Id ( GenId )
import ErrUtils ( addErrLoc, addShortErrLocLine )
import Name
import Pretty
+import Unique ( Unique, otherwiseIdKey )
import UniqFM ( lookupUFM{-, ufmToList ToDo:rm-} )
import UniqSet ( emptyUniqSet, unitUniqSet,
unionUniqSets, unionManyUniqSets,
@@ -58,7 +60,7 @@ rnPat :: RdrNamePat -> RnMS s RenamedPat
rnPat WildPatIn = returnRn WildPatIn
rnPat (VarPatIn name)
- = lookupRn name `thenRn` \ vname ->
+ = lookupBndrRn name `thenRn` \ vname ->
returnRn (VarPatIn vname)
rnPat (LitPatIn lit)
@@ -72,17 +74,17 @@ rnPat (LazyPatIn pat)
rnPat (AsPatIn name pat)
= rnPat pat `thenRn` \ pat' ->
- lookupRn name `thenRn` \ vname ->
+ lookupBndrRn name `thenRn` \ vname ->
returnRn (AsPatIn vname pat')
rnPat (ConPatIn con pats)
- = lookupRn con `thenRn` \ con' ->
+ = lookupOccRn con `thenRn` \ con' ->
mapRn rnPat pats `thenRn` \ patslist ->
returnRn (ConPatIn con' patslist)
rnPat (ConOpPatIn pat1 con _ pat2)
= rnPat pat1 `thenRn` \ pat1' ->
- lookupRn con `thenRn` \ con' ->
+ lookupOccRn con `thenRn` \ con' ->
lookupFixity con `thenRn` \ fixity ->
rnPat pat2 `thenRn` \ pat2' ->
mkConOpPatRn pat1' con' fixity pat2'
@@ -105,6 +107,12 @@ rnPat (ParPatIn pat)
= rnPat pat `thenRn` \ pat' ->
returnRn (ParPatIn pat')
+rnPat (NPlusKPatIn name lit)
+ = litOccurrence lit `thenRn_`
+ lookupImplicitOccRn ordClass_RDR `thenRn_`
+ lookupBndrRn name `thenRn` \ name' ->
+ returnRn (NPlusKPatIn name' lit)
+
rnPat (ListPatIn pats)
= addImplicitOccRn listType_name `thenRn_`
mapRn rnPat pats `thenRn` \ patslist ->
@@ -116,7 +124,7 @@ rnPat (TuplePatIn pats)
returnRn (TuplePatIn patslist)
rnPat (RecPatIn con rpats)
- = lookupRn con `thenRn` \ con' ->
+ = lookupOccRn con `thenRn` \ con' ->
rnRpats rpats `thenRn` \ rpats' ->
returnRn (RecPatIn con' rpats')
\end{code}
@@ -168,7 +176,15 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
= pushSrcLocRn locn $
rnExpr guard `thenRn` \ (guard', fvsg) ->
rnExpr expr `thenRn` \ (expr', fvse) ->
- returnRn (GRHS guard' expr' locn, fvsg `unionNameSets` fvse)
+
+ -- Turn an "otherwise" guard into an OtherwiseGRHS.
+ -- This is the first moment that we can be sure we havn't got a shadowed binding
+ -- of "otherwise".
+ let grhs' = case guard' of
+ HsVar v | uniqueOf v == otherwiseIdKey -> OtherwiseGRHS expr' locn
+ other -> GRHS guard' expr' locn
+ in
+ returnRn (grhs', fvsg `unionNameSets` fvse)
rnGRHS (OtherwiseGRHS expr locn)
= pushSrcLocRn locn $
@@ -184,13 +200,15 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
\begin{code}
rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
-
-rnExprs [] = returnRn ([], emptyNameSet)
-
-rnExprs (expr:exprs)
- = rnExpr expr `thenRn` \ (expr', fvExpr) ->
- rnExprs exprs `thenRn` \ (exprs', fvExprs) ->
- returnRn (expr':exprs', fvExpr `unionNameSets` fvExprs)
+rnExprs ls =
+ rnExprs' ls [] `thenRn` \ (exprs, fvExprs) ->
+ returnRn (exprs, unionManyNameSets fvExprs)
+
+rnExprs' [] acc = returnRn ([], acc)
+rnExprs' (expr:exprs) acc
+ = rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ rnExprs' exprs (fvExpr:acc) `thenRn` \ (exprs', fvExprs) ->
+ returnRn (expr':exprs', fvExprs)
\end{code}
Variables. We look up the variable and return the resulting name. The
@@ -280,16 +298,11 @@ rnExpr (HsLet binds expr)
rnExpr expr `thenRn` \ (expr',fvExpr) ->
returnRn (HsLet binds' expr', fvExpr)
-rnExpr (HsDo stmts src_loc)
+rnExpr (HsDo do_or_lc stmts src_loc)
= pushSrcLocRn src_loc $
lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too
rnStmts stmts `thenRn` \ (stmts', fvStmts) ->
- returnRn (HsDo stmts' src_loc, fvStmts)
-
-rnExpr (ListComp expr quals)
- = addImplicitOccRn listType_name `thenRn_`
- rnQuals expr quals `thenRn` \ ((expr', quals'), fvs) ->
- returnRn (ListComp expr' quals', fvs)
+ returnRn (HsDo do_or_lc stmts' src_loc, fvStmts)
rnExpr (ExplicitList exps)
= addImplicitOccRn listType_name `thenRn_`
@@ -367,7 +380,7 @@ rnRbinds str rbinds
field_dup_err dups = addErrRn (dupFieldErr str dups)
rn_rbind (field, expr, pun)
- = lookupOccRn field `thenRn` \ fieldname ->
+ = lookupGlobalOccRn field `thenRn` \ fieldname ->
rnExpr expr `thenRn` \ (expr', fvExpr) ->
returnRn ((fieldname, expr', pun), fvExpr)
@@ -380,14 +393,14 @@ rnRpats rpats
field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
rn_rpat (field, pat, pun)
- = lookupOccRn field `thenRn` \ fieldname ->
+ = lookupGlobalOccRn field `thenRn` \ fieldname ->
rnPat pat `thenRn` \ pat' ->
returnRn (fieldname, pat', pun)
\end{code}
%************************************************************************
%* *
-\subsubsection{@Qualifier@s: in list comprehensions}
+\subsubsection{@Stmt@s: in @do@ expressions}
%* *
%************************************************************************
@@ -400,59 +413,9 @@ be @{r}@, and the free var set for the entire Quals will be @{r}@. This
Quals.
\begin{code}
-rnQuals :: RdrNameHsExpr -> [RdrNameQual]
- -> RnMS s ((RenamedHsExpr, [RenamedQual]), FreeVars)
-
-rnQuals expr [qual] -- must be at least one qual
- = rnQual qual $ \ new_qual ->
- rnExpr expr `thenRn` \ (expr', fvs) ->
- returnRn ((expr', [new_qual]), fvs)
-
-rnQuals expr (qual: quals)
- = rnQual qual $ \ qual' ->
- rnQuals expr quals `thenRn` \ ((expr', quals'), fv_quals) ->
- returnRn ((expr', qual' : quals'), fv_quals)
-
-
--- rnQual :: RdrNameQual
--- -> (RenamedQual -> RnMS s (a,FreeVars))
--- -> RnMS s (a,FreeVars)
--- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2]
-
-rnQual (GeneratorQual pat expr) thing_inside
- = rnExpr expr `thenRn` \ (expr', fv_expr) ->
- bindLocalsRn "pattern in list comprehension" binders $ \ new_binders ->
- rnPat pat `thenRn` \ pat' ->
-
- thing_inside (GeneratorQual pat' expr') `thenRn` \ (result, fvs) ->
- returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
- where
- binders = collectPatBinders pat
-
-rnQual (FilterQual expr) thing_inside
- = rnExpr expr `thenRn` \ (expr', fv_expr) ->
- thing_inside (FilterQual expr') `thenRn` \ (result, fvs) ->
- returnRn (result, fv_expr `unionNameSets` fvs)
-
-rnQual (LetQual binds) thing_inside
- = rnBinds binds $ \ binds' ->
- thing_inside (LetQual binds')
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{@Stmt@s: in @do@ expressions}
-%* *
-%************************************************************************
-
-\begin{code}
rnStmts :: [RdrNameStmt] -> RnMS s ([RenamedStmt], FreeVars)
-rnStmts [stmt@(ExprStmt expr src_loc)] -- last stmt must be ExprStmt
- = pushSrcLocRn src_loc $
- rnExpr expr `thenRn` \ (expr', fv_expr) ->
- returnRn ([ExprStmt expr' src_loc], fv_expr)
+rnStmts [] = returnRn ([], emptyNameSet)
rnStmts (stmt:stmts)
= rnStmt stmt $ \ stmt' ->
@@ -480,6 +443,17 @@ rnStmt (ExprStmt expr src_loc) thing_inside
thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
returnRn (result, fv_expr `unionNameSets` fvs)
+rnStmt (GuardStmt expr src_loc) thing_inside
+ = pushSrcLocRn src_loc $
+ rnExpr expr `thenRn` \ (expr', fv_expr) ->
+ thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) ->
+ returnRn (result, fv_expr `unionNameSets` fvs)
+
+rnStmt (ReturnStmt expr) thing_inside
+ = rnExpr expr `thenRn` \ (expr', fv_expr) ->
+ thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) ->
+ returnRn (result, fv_expr `unionNameSets` fvs)
+
rnStmt (LetStmt binds) thing_inside
= rnBinds binds $ \ binds' ->
thing_inside (LetStmt binds')
@@ -663,12 +637,10 @@ litOccurrence (HsStringPrim _)
= addImplicitOccRn (getName addrPrimTyCon)
litOccurrence (HsInt _)
- = lookupImplicitOccRn numClass_RDR `thenRn_` -- Int and Integer are forced in by Num
- returnRn ()
+ = lookupImplicitOccRn numClass_RDR -- Int and Integer are forced in by Num
litOccurrence (HsFrac _)
- = lookupImplicitOccRn fractionalClass_RDR `thenRn_` -- ... similarly Rational
- returnRn ()
+ = lookupImplicitOccRn fractionalClass_RDR -- ... similarly Rational
litOccurrence (HsIntPrim _)
= addImplicitOccRn (getName intPrimTyCon)
@@ -680,8 +652,7 @@ litOccurrence (HsDoublePrim _)
= addImplicitOccRn (getName doublePrimTyCon)
litOccurrence (HsLitLit _)
- = lookupImplicitOccRn ccallableClass_RDR `thenRn_`
- returnRn ()
+ = lookupImplicitOccRn ccallableClass_RDR
\end{code}
@@ -693,19 +664,23 @@ litOccurrence (HsLitLit _)
\begin{code}
dupFieldErr str (dup:rest) sty
- = ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str]
+ = ppBesides [ppPStr SLIT("duplicate field name `"),
+ ppr sty dup,
+ ppPStr SLIT("' in record "), ppStr str]
negPatErr pat sty
- = ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat]
+ = ppSep [ppPStr SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat]
precParseNegPatErr op sty
- = ppHang (ppStr "precedence parsing error")
- 4 (ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"])
+ = ppHang (ppPStr SLIT("precedence parsing error"))
+ 4 (ppBesides [ppPStr SLIT("prefix `-' has lower precedence than "),
+ pp_op sty op,
+ ppPStr SLIT(" in pattern")])
precParseErr op1 op2 sty
- = ppHang (ppStr "precedence parsing error")
- 4 (ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2,
- ppStr " in the same infix expression"])
+ = ppHang (ppPStr SLIT("precedence parsing error"))
+ 4 (ppBesides [ppPStr SLIT("cannot mix "), pp_op sty op1, ppPStr SLIT(" and "), pp_op sty op2,
+ ppPStr SLIT(" in the same infix expression")])
pp_op sty (op, fix) = ppBesides [pprSym sty op, ppLparen, ppr sty fix, ppRparen]
\end{code}
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index fab6dd1119..953d8add83 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -48,7 +48,6 @@ type RenamedMonoBinds = MonoBinds Fake Fake Name RenamedPat
type RenamedPat = InPat Name
type RenamedHsType = HsType Name
type RenamedRecordBinds = HsRecordBinds Fake Fake Name RenamedPat
-type RenamedQual = Qualifier Fake Fake Name RenamedPat
type RenamedSig = Sig Name
type RenamedSpecInstSig = SpecInstSig Name
type RenamedStmt = Stmt Fake Fake Name RenamedPat
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 8b804f279b..3024b8e6b3 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -10,8 +10,8 @@ module RnIfaces (
getInterfaceExports,
getImportedInstDecls,
getSpecialInstModules,
- getDecl, getWiredInDecl,
- getImportVersions,
+ importDecl, recordSlurp,
+ getImportVersions,
checkUpToDate,
@@ -22,26 +22,27 @@ module RnIfaces (
IMP_Ubiq()
--- import CmdLineOpts ( opt_HiSuffix )
-import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..),
- HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), HsType, BangType, IfaceSig(..),
- FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo
+import CmdLineOpts ( opt_HiSuffix, opt_HiSuffixPrelude )
+import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..), HsType(..),
+ HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), BangType, IfaceSig(..),
+ FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo,
+ IE(..)
)
import HsPragmas ( noGenPragmas )
import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl),
RdrName, rdrNameOcc
)
-import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn, availNames )
+import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn, availName, availNames, addAvailToNameSet )
import RnSource ( rnHsType )
import RnMonad
import ParseIface ( parseIface )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) )
-import FiniteMap ( FiniteMap, emptyFM, unitFM, lookupFM, addToFM, addListToFM, fmToList )
+import FiniteMap ( FiniteMap, emptyFM, unitFM, lookupFM, addToFM, addToFM_C, addListToFM, fmToList )
import Name ( Name {-instance NamedThing-}, Provenance, OccName(..),
modAndOcc, occNameString, moduleString, pprModule,
NameSet(..), emptyNameSet, unionNameSets, nameSetToList,
- minusNameSet, mkNameSet,
+ minusNameSet, mkNameSet, elemNameSet,
isWiredInName, maybeWiredInTyConName, maybeWiredInIdName
)
import Id ( GenId, Id(..), idType, dataConTyCon, isDataCon )
@@ -49,13 +50,15 @@ import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )
import Type ( namesOfType )
import TyVar ( GenTyVar )
import SrcLoc ( mkIfaceSrcLoc )
-import PrelMods ( gHC__ )
+import PrelMods ( gHC__, isPreludeModule )
import Bag
import Maybes ( MaybeErr(..), expectJust, maybeToBool )
import ListSetOps ( unionLists )
import Pretty
import PprStyle ( PprStyle(..) )
-import Util ( pprPanic )
+import Util ( pprPanic, pprTrace )
+import StringBuffer ( StringBuffer, hGetStringBuffer, freeStringBuffer )
+
\end{code}
@@ -71,10 +74,10 @@ loadInterface :: Pretty -> Module -> RnMG Ifaces
loadInterface doc_str load_mod
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers_map export_env_map vers_map decls_map inst_map inst_mods = ifaces
+ Ifaces this_mod mod_vers_map export_envs decls all_names imp_names insts inst_mods = ifaces
in
-- CHECK WHETHER WE HAVE IT ALREADY
- if maybeToBool (lookupFM export_env_map load_mod)
+ if maybeToBool (lookupFM export_envs load_mod)
then
returnRn ifaces -- Already in the cache; don't re-read it
else
@@ -86,21 +89,21 @@ loadInterface doc_str load_mod
Nothing -> -- Not found, so add an empty export env to the Ifaces map
-- so that we don't look again
let
- new_export_env_map = addToFM export_env_map load_mod ([],[])
- new_ifaces = Ifaces this_mod mod_vers_map
- new_export_env_map
- vers_map decls_map inst_map inst_mods
+ new_export_envs = addToFM export_envs load_mod ([],[])
+ new_ifaces = Ifaces this_mod mod_vers_map
+ new_export_envs
+ decls all_names imp_names insts inst_mods
in
setIfacesRn new_ifaces `thenRn_`
failWithRn new_ifaces (noIfaceErr load_mod) ;
-- Found and parsed!
- Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs decls insts) ->
+ Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs rd_decls rd_insts) ->
-- LOAD IT INTO Ifaces
- mapRn loadExport exports `thenRn` \ avails_s ->
- foldlRn (loadDecl load_mod) (decls_map,vers_map) decls `thenRn` \ (new_decls_map, new_vers_map) ->
- foldlRn (loadInstDecl load_mod) inst_map insts `thenRn` \ new_insts_map ->
+ mapRn loadExport exports `thenRn` \ avails_s ->
+ foldlRn (loadDecl load_mod) decls rd_decls `thenRn` \ new_decls ->
+ foldlRn (loadInstDecl load_mod) insts rd_insts `thenRn` \ new_insts ->
let
export_env = (concat avails_s, fixs)
@@ -109,10 +112,10 @@ loadInterface doc_str load_mod
new_ifaces = Ifaces this_mod
(addToFM mod_vers_map load_mod mod_vers)
- (addToFM export_env_map load_mod export_env)
- new_vers_map
- new_decls_map
- new_insts_map
+ (addToFM export_envs load_mod export_env)
+ new_decls
+ all_names imp_names
+ new_insts
new_inst_mods
in
setIfacesRn new_ifaces `thenRn_`
@@ -125,44 +128,57 @@ loadExport (mod, entities)
where
new_name occ = newGlobalName mod occ
+-- The communcation between this little code fragment and the "entity" rule
+-- in ParseIface.y is a bit gruesome. The idea is that things which are
+-- destined to be AvailTCs show up as (occ, [non-empty-list]), whereas
+-- things destined to be Avails show up as (occ, [])
+
load_entity (occ, occs)
= new_name occ `thenRn` \ name ->
- mapRn new_name occs `thenRn` \ names ->
- returnRn (Avail name names)
-
-loadVersion :: Module -> VersionMap -> (OccName,Version) -> RnMG VersionMap
-loadVersion mod vers_map (occ, version)
- = newGlobalName mod occ `thenRn` \ name ->
- returnRn (addToFM vers_map name version)
-
+ if null occs then
+ returnRn (Avail name)
+ else
+ mapRn new_name occs `thenRn` \ names ->
+ returnRn (AvailTC name names)
-loadDecl :: Module -> (DeclsMap, VersionMap)
+loadDecl :: Module -> DeclsMap
-> (Version, RdrNameHsDecl)
- -> RnMG (DeclsMap, VersionMap)
-loadDecl mod (decls_map, vers_map) (version, decl)
- = getDeclBinders new_implicit_name decl `thenRn` \ avail@(Avail name _) ->
+ -> RnMG DeclsMap
+loadDecl mod decls_map (version, decl)
+ = getDeclBinders new_implicit_name decl `thenRn` \ avail ->
returnRn (addListToFM decls_map
- [(name,(avail,decl)) | name <- availNames avail],
- addToFM vers_map name version
+ [(name,(version,avail,decl)) | name <- availNames avail]
)
where
new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name)
-loadInstDecl :: Module -> Bag IfaceInst -> RdrNameInstDecl -> RnMG (Bag IfaceInst)
+loadInstDecl :: Module
+ -> Bag IfaceInst
+ -> RdrNameInstDecl
+ -> RnMG (Bag IfaceInst)
loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
- = initRnMS emptyRnEnv mod_name InterfaceMode $
-
- -- Find out what type constructors and classes are mentioned in the
- -- instance declaration. We have to be a bit clever.
+ =
+ -- Find out what type constructors and classes are "gates" for the
+ -- instance declaration. If all these "gates" are slurped in then
+ -- we should slurp the instance decl too.
+ --
+ -- We *don't* want to count names in the context part as gates, though.
+ -- For example:
+ -- instance Foo a => Baz (T a) where ...
--
- -- We want to rename the type so that we can find what
- -- (free) type constructors are inside it. But we must *not* thereby
- -- put new occurrences into the global pool because otherwise we'll force
- -- them all to be loaded. We kill two birds with ones stone by renaming
- -- with a fresh occurrence pool.
- findOccurrencesRn (rnHsType inst_ty) `thenRn` \ ty_names ->
-
- returnRn ((ty_names, mod_name, decl) `consBag` insts)
+ -- Here the gates are Baz and T, but *not* Foo.
+ let
+ munged_inst_ty = case inst_ty of
+ HsForAllTy tvs cxt ty -> HsForAllTy tvs [] ty
+ HsPreForAllTy cxt ty -> HsPreForAllTy [] ty
+ other -> inst_ty
+ in
+ -- We find the gates by renaming the instance type with in a
+ -- and returning the occurrence pool.
+ initRnMS emptyRnEnv mod_name InterfaceMode (
+ findOccurrencesRn (rnHsType munged_inst_ty)
+ ) `thenRn` \ gate_names ->
+ returnRn (((mod_name, decl), gate_names) `consBag` insts)
\end{code}
@@ -177,8 +193,9 @@ checkUpToDate :: Module -> RnMG Bool -- True <=> no need to recompile
checkUpToDate mod_name
= findAndReadIface doc_str mod_name `thenRn` \ read_result ->
case read_result of
- Nothing -> -- Old interface file not found, so we'd better bale out
- traceRn (ppSep [ppStr "Didnt find old iface", pprModule PprDebug mod_name]) `thenRn_`
+ Nothing -> -- Old interface file not found, so we'd better bail out
+ traceRn (ppSep [ppPStr SLIT("Didnt find old iface"),
+ pprModule PprDebug mod_name]) `thenRn_`
returnRn False
Just (ParsedIface _ _ usages _ _ _ _ _)
@@ -186,7 +203,7 @@ checkUpToDate mod_name
checkModUsage usages
where
-- Only look in current directory, with suffix .hi
- doc_str = ppSep [ppStr "Need usage info from", pprModule PprDebug mod_name]
+ doc_str = ppSep [ppPStr SLIT("Need usage info from"), pprModule PprDebug mod_name]
checkModUsage [] = returnRn True -- Yes! Everything is up to date!
@@ -194,52 +211,54 @@ checkModUsage [] = returnRn True -- Yes! Everything is up to date!
checkModUsage ((mod, old_mod_vers, old_local_vers) : rest)
= loadInterface doc_str mod `thenRn` \ ifaces ->
let
- Ifaces _ mod_vers_map _ new_vers_map _ _ _ = ifaces
- maybe_new_mod_vers = lookupFM mod_vers_map mod
+ Ifaces _ mod_vers _ decls _ _ _ _ = ifaces
+ maybe_new_mod_vers = lookupFM mod_vers mod
Just new_mod_vers = maybe_new_mod_vers
in
-- If we can't find a version number for the old module then
- -- bale out saying things aren't up to date
+ -- bail out saying things aren't up to date
if not (maybeToBool maybe_new_mod_vers) then
returnRn False
else
-- If the module version hasn't changed, just move on
if new_mod_vers == old_mod_vers then
- traceRn (ppSep [ppStr "Module version unchanged:", pprModule PprDebug mod]) `thenRn_`
+ traceRn (ppSep [ppPStr SLIT("Module version unchanged:"), pprModule PprDebug mod]) `thenRn_`
checkModUsage rest
else
- traceRn (ppSep [ppStr "Module version has changed:", pprModule PprDebug mod]) `thenRn_`
+ traceRn (ppSep [ppPStr SLIT("Module version has changed:"), pprModule PprDebug mod]) `thenRn_`
-- New module version, so check entities inside
- checkEntityUsage mod new_vers_map old_local_vers `thenRn` \ up_to_date ->
+ checkEntityUsage mod decls old_local_vers `thenRn` \ up_to_date ->
if up_to_date then
- traceRn (ppStr "...but the bits I use havn't.") `thenRn_`
+ traceRn (ppPStr SLIT("...but the bits I use haven't.")) `thenRn_`
checkModUsage rest -- This one's ok, so check the rest
else
returnRn False -- This one failed, so just bail out now
where
- doc_str = ppSep [ppStr "need version info for", pprModule PprDebug mod]
+ doc_str = ppSep [ppPStr SLIT("need version info for"), pprModule PprDebug mod]
-checkEntityUsage mod new_vers_map []
+checkEntityUsage mod decls []
= returnRn True -- Yes! All up to date!
-checkEntityUsage mod new_vers_map ((occ_name,old_vers) : rest)
+checkEntityUsage mod decls ((occ_name,old_vers) : rest)
= newGlobalName mod occ_name `thenRn` \ name ->
- case lookupFM new_vers_map name of
+ case lookupFM decls name of
Nothing -> -- We used it before, but it ain't there now
- traceRn (ppSep [ppStr "...and this no longer exported:", ppr PprDebug name]) `thenRn_`
+ traceRn (ppSep [ppPStr SLIT("...and this no longer exported:"), ppr PprDebug name]) `thenRn_`
returnRn False
- Just new_vers -> -- It's there, but is it up to date?
- if new_vers == old_vers then
- -- Up to date, so check the rest
- checkEntityUsage mod new_vers_map rest
- else
- traceRn (ppSep [ppStr "...and this is out of date:", ppr PprDebug name]) `thenRn_`
- returnRn False -- Out of date, so bale out
+ Just (new_vers,_,_) -- It's there, but is it up to date?
+ | new_vers == old_vers
+ -- Up to date, so check the rest
+ -> checkEntityUsage mod decls rest
+
+ | otherwise
+ -- Out of date, so bale out
+ -> traceRn (ppSep [ppPStr SLIT("...and this is out of date:"), ppr PprDebug name]) `thenRn_`
+ returnRn False
\end{code}
@@ -250,24 +269,56 @@ checkEntityUsage mod new_vers_map ((occ_name,old_vers) : rest)
%*********************************************************
\begin{code}
-getDecl :: Name -> RnMG (AvailInfo, RdrNameHsDecl)
-getDecl name
- = traceRn doc_str `thenRn_`
- loadInterface doc_str mod `thenRn` \ (Ifaces _ _ _ _ decls_map _ _) ->
- case lookupFM decls_map name of
+importDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
+ -- Returns Nothing for a wired-in or already-slurped decl
+
+importDecl name necessity
+ = checkSlurped name `thenRn` \ already_slurped ->
+ if already_slurped then
+ returnRn Nothing -- Already dealt with
+ else
+ if isWiredInName name then
+ getWiredInDecl name
+ else
+ getIfacesRn `thenRn` \ ifaces ->
+ let
+ Ifaces this_mod _ _ _ _ _ _ _ = ifaces
+ (mod,_) = modAndOcc name
+ in
+ if mod == this_mod then -- Don't bring in decls from
+ pprTrace "importDecl wierdness:" (ppr PprDebug name) $
+ returnRn Nothing -- the renamed module's own interface file
+ --
+ else
+ getNonWiredInDecl name necessity
- Just avail_w_decl -> returnRn avail_w_decl
+\end{code}
- Nothing -> -- Can happen legitimately for "Optional" occurrences
- returnRn (NotAvailable, ValD EmptyBinds)
+\begin{code}
+getNonWiredInDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
+getNonWiredInDecl name necessity
+ = traceRn doc_str `thenRn_`
+ loadInterface doc_str mod `thenRn` \ (Ifaces _ _ _ decls _ _ _ _) ->
+ case lookupFM decls name of
+
+ Just (version,avail,decl) -> recordSlurp (Just version) avail `thenRn_`
+ returnRn (Just decl)
+
+ Nothing -> -- Can happen legitimately for "Optional" occurrences
+ case necessity of {
+ Optional -> addWarnRn (getDeclWarn name);
+ other -> addErrRn (getDeclErr name)
+ } `thenRn_`
+ returnRn Nothing
where
+ doc_str = ppSep [ppPStr SLIT("Need decl for"), ppr PprDebug name]
(mod,_) = modAndOcc name
- doc_str = ppSep [ppStr "Need decl for", ppr PprDebug name]
\end{code}
@getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
It behaves exactly as if the wired in decl were actually in an interface file.
Specifically,
+
* if the wired-in name is a data type constructor or a data constructor,
it brings in the type constructor and all the data constructors; and
marks as "occurrences" any free vars of the data con.
@@ -284,7 +335,6 @@ All this is necessary so that we know all types that are "in play", so
that we know just what instances to bring into scope.
\begin{code}
-getWiredInDecl :: Name -> RnMG AvailInfo
getWiredInDecl name
= -- Force in the home module in case it has instance decls for
-- the thing we are interested in
@@ -300,17 +350,13 @@ getWiredInDecl name
else
loadInterface doc_str mod `thenRn_`
returnRn ()
- ) `thenRn_`
-
- if is_tycon then
- get_wired_tycon the_tycon
- else -- Must be a wired-in-Id
- if (isDataCon the_id) then -- ... a wired-in data constructor
- get_wired_tycon (dataConTyCon the_id)
- else -- ... a wired-in non data-constructor
- get_wired_id the_id
+ ) `thenRn_`
+
+ get_wired `thenRn` \ avail ->
+ recordSlurp Nothing avail `thenRn_`
+ returnRn Nothing -- No declaration to process further
where
- doc_str = ppSep [ppStr "Need home module for wired in thing", ppr PprDebug name]
+ doc_str = ppSep [ppPStr SLIT("Need home module for wired in thing"), ppr PprDebug name]
(mod,_) = modAndOcc name
maybe_wired_in_tycon = maybeWiredInTyConName name
is_tycon = maybeToBool maybe_wired_in_tycon
@@ -318,16 +364,27 @@ getWiredInDecl name
Just the_tycon = maybe_wired_in_tycon
Just the_id = maybe_wired_in_id
+ get_wired | is_tycon -- ... a type constructor
+ = get_wired_tycon the_tycon
+ -- Else, must be a wired-in-Id
+
+ | (isDataCon the_id) -- ... a wired-in data constructor
+ = get_wired_tycon (dataConTyCon the_id)
+
+ | otherwise -- ... a wired-in non data-constructor
+ = get_wired_id the_id
+
+
get_wired_id id
= addImplicitOccsRn (nameSetToList id_mentioned) `thenRn_`
- returnRn (Avail (getName id) [])
+ returnRn (Avail (getName id))
where
- id_mentioned = namesOfType (idType id)
+ id_mentioned = namesOfType (idType id)
get_wired_tycon tycon
| isSynTyCon tycon
= addImplicitOccsRn (nameSetToList mentioned) `thenRn_`
- returnRn (Avail (getName tycon) [])
+ returnRn (Avail (getName tycon))
where
(tyvars,ty) = getSynTyConDefn tycon
mentioned = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars)
@@ -335,13 +392,38 @@ get_wired_tycon tycon
get_wired_tycon tycon
| otherwise -- data or newtype
= addImplicitOccsRn (nameSetToList mentioned) `thenRn_`
- returnRn (Avail (getName tycon) (map getName data_cons))
+ returnRn (AvailTC tycon_name (tycon_name : map getName data_cons))
where
- data_cons = tyConDataCons tycon
- mentioned = foldr (unionNameSets . namesOfType . idType) emptyNameSet data_cons
+ tycon_name = getName tycon
+ data_cons = tyConDataCons tycon
+ mentioned = foldr (unionNameSets . namesOfType . idType) emptyNameSet data_cons
\end{code}
+\begin{code}
+checkSlurped name
+ = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ slurped_names _ _ _) ->
+ returnRn (name `elemNameSet` slurped_names)
+
+recordSlurp maybe_version avail
+ = getIfacesRn `thenRn` \ ifaces ->
+ let
+ Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts inst_mods = ifaces
+ new_slurped_names = addAvailToNameSet slurped_names avail
+
+ new_imp_names = case maybe_version of
+ Just version -> (availName avail, version) : imp_names
+ Nothing -> imp_names
+
+ new_ifaces = Ifaces this_mod mod_vers export_envs decls
+ new_slurped_names
+ new_imp_names
+ insts
+ inst_mods
+ in
+ setIfacesRn new_ifaces
+\end{code}
+
%*********************************************************
%* *
\subsection{Getting other stuff}
@@ -351,7 +433,7 @@ get_wired_tycon tycon
\begin{code}
getInterfaceExports :: Module -> RnMG (Avails, [(OccName,Fixity)])
getInterfaceExports mod
- = loadInterface doc_str mod `thenRn` \ (Ifaces _ _ export_envs _ _ _ _) ->
+ = loadInterface doc_str mod `thenRn` \ (Ifaces _ _ export_envs _ _ _ _ _) ->
case lookupFM export_envs mod of
Nothing -> -- Not there; it must be that the interface file wasn't found;
-- the error will have been reported already.
@@ -361,66 +443,133 @@ getInterfaceExports mod
Just stuff -> returnRn stuff
where
- doc_str = ppSep [pprModule PprDebug mod, ppStr "is directly imported"]
+ doc_str = ppSep [pprModule PprDebug mod, ppPStr SLIT("is directly imported")]
-getImportedInstDecls :: RnMG [IfaceInst]
+getImportedInstDecls :: RnMG [(Module,RdrNameInstDecl)]
getImportedInstDecls
= -- First load any special-instance modules that aren't aready loaded
getSpecialInstModules `thenRn` \ inst_mods ->
mapRn load_it inst_mods `thenRn_`
-- Now we're ready to grab the instance declarations
- getIfacesRn `thenRn` \ ifaces ->
+ -- Find the un-gated ones and return them,
+ -- removing them from the bag kept in Ifaces
+ getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces _ _ _ _ _ insts _ = ifaces
+ Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts inst_mods = ifaces
+
+ -- An instance decl is ungated if all its gates have been slurped
+ select_ungated :: IfaceInst -- A gated inst decl
+
+ -> ([(Module, RdrNameInstDecl)], [IfaceInst]) -- Accumulator
+
+ -> ([(Module, RdrNameInstDecl)], -- The ungated ones
+ [IfaceInst]) -- Still gated, but with
+ -- depeleted gates
+ select_ungated (decl,gates) (ungated_decls, gated_decls)
+ | null remaining_gates
+ = (decl : ungated_decls, gated_decls)
+ | otherwise
+ = (ungated_decls, (decl, remaining_gates) : gated_decls)
+ where
+ remaining_gates = filter (not . (`elemNameSet` slurped_names)) gates
+
+ (un_gated_insts, still_gated_insts) = foldrBag select_ungated ([], []) insts
+
+ new_ifaces = Ifaces this_mod mod_vers export_envs decls slurped_names imp_names
+ (listToBag still_gated_insts)
+ inst_mods
in
- returnRn (bagToList insts)
+ setIfacesRn new_ifaces `thenRn_`
+ returnRn un_gated_insts
where
load_it mod = loadInterface (doc_str mod) mod
- doc_str mod = ppSep [pprModule PprDebug mod, ppStr "is a special-instance module"]
+ doc_str mod = ppSep [pprModule PprDebug mod, ppPStr SLIT("is a special-instance module")]
+
getSpecialInstModules :: RnMG [Module]
getSpecialInstModules
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces _ _ _ _ _ _ inst_mods = ifaces
+ Ifaces _ _ _ _ _ _ _ inst_mods = ifaces
in
returnRn inst_mods
\end{code}
+getImportVersions figures out what the "usage information" for this moudule is;
+that is, what it must record in its interface file as the things it uses.
+It records:
+ - anything reachable from its body code
+ - any module exported with a "module Foo".
+
+Why the latter? Because if Foo changes then this module's export list
+will change, so we must recompile this module at least as far as
+making a new interface file --- but in practice that means complete
+recompilation.
+
+What about this?
+ module A( f, g ) where module B( f ) where
+ import B( f ) f = h 3
+ g = ... h = ...
+
+Should we record B.f in A's usages? In fact we don't. Certainly, if
+anything about B.f changes than anyone who imports A should be recompiled;
+they'll get an early exit if they don't use B.f. However, even if B.f
+doesn't change at all, B.h may do so, and this change may not be reflected
+in f's version number. So there are two things going on when compiling module A:
+
+1. Are A.o and A.hi correct? Then we can bale out early.
+2. Should modules that import A be recompiled?
+
+For (1) it is slightly harmful to record B.f in A's usages, because a change in
+B.f's version will provoke full recompilation of A, producing an identical A.o,
+and A.hi differing only in its usage-version of B.f (which isn't used by any importer).
+
+For (2), because of the tricky B.h question above, we ensure that A.hi is touched
+(even if identical to its previous version) if A's recompilation was triggered by
+an imported .hi file date change. Given that, there's no need to record B.f in
+A's usages.
+
+On the other hand, if A exports "module B" then we *do* count module B among
+A's usages, because we must recompile A to ensure that A.hi changes appropriately.
+
\begin{code}
-getImportVersions :: [AvailInfo] -- Imported avails
+getImportVersions :: Module -- Name of this module
+ -> Maybe [IE any] -- Export list for this module
-> RnMG (VersionInfo Name) -- Version info for these names
-getImportVersions imported_avails
+getImportVersions this_mod exports
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces _ mod_versions_map _ version_map _ _ _ = ifaces
-
- -- import_versions is harder: we have to group together all the things imported
- -- from a particular module. We do this with yet another finite map
-
- mv_map :: FiniteMap Module [LocalVersion Name]
- mv_map = foldl add_mv emptyFM imported_avails
- add_mv mv_map (Avail name _)
- | isWiredInName name = mv_map -- Don't record versions for wired-in names
- | otherwise = case lookupFM mv_map mod of
- Just versions -> addToFM mv_map mod ((name,version):versions)
- Nothing -> addToFM mv_map mod [(name,version)]
- where
- (mod,_) = modAndOcc name
- version = case lookupFM version_map name of
- Just v -> v
- Nothing -> pprPanic "getVersionInfo:" (ppr PprDebug name)
-
- import_versions = [ (mod, expectJust "import_versions" (lookupFM mod_versions_map mod), local_versions)
- | (mod, local_versions) <- fmToList mv_map
- ]
-
- -- Question: should we filter the builtins out of import_versions?
+ Ifaces _ mod_versions_map _ _ _ imp_names _ _ = ifaces
+ mod_version mod = expectJust "import_versions" (lookupFM mod_versions_map mod)
+
+ -- mv_map groups together all the things imported from a particular module.
+ mv_map, mv_map_mod :: FiniteMap Module [LocalVersion Name]
+
+ mv_map_mod = foldl add_mod emptyFM export_mods
+ -- mv_map_mod records all the modules that have a "module M"
+ -- in this module's export list
+
+ mv_map = foldl add_mv mv_map_mod imp_names
+ -- mv_map adds the version numbers of things exported individually
in
- returnRn import_versions
+ returnRn [ (mod, mod_version mod, local_versions)
+ | (mod, local_versions) <- fmToList mv_map
+ ]
+
+ where
+ export_mods = case exports of
+ Nothing -> []
+ Just es -> [mod | IEModuleContents mod <- es, mod /= this_mod]
+
+ add_mv mv_map v@(name, version)
+ = addToFM_C (\ ls _ -> (v:ls)) mv_map mod [v]
+ where
+ (mod,_) = modAndOcc name
+
+ add_mod mv_map mod = addToFM mv_map mod []
\end{code}
%*********************************************************
@@ -444,25 +593,25 @@ getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function
getDeclBinders new_name (TyD (TyData _ tycon _ condecls _ _ src_loc))
= new_name tycon src_loc `thenRn` \ tycon_name ->
getConFieldNames new_name condecls `thenRn` \ sub_names ->
- returnRn (Avail tycon_name sub_names)
+ returnRn (AvailTC tycon_name (tycon_name : sub_names))
getDeclBinders new_name (TyD (TyNew _ tycon _ (NewConDecl con _ con_loc) _ _ src_loc))
= new_name tycon src_loc `thenRn` \ tycon_name ->
new_name con src_loc `thenRn` \ con_name ->
- returnRn (Avail tycon_name [con_name])
+ returnRn (AvailTC tycon_name [tycon_name, con_name])
getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc))
= new_name tycon src_loc `thenRn` \ tycon_name ->
- returnRn (Avail tycon_name [])
+ returnRn (Avail tycon_name)
getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ src_loc))
= new_name cname src_loc `thenRn` \ class_name ->
mapRn (getClassOpNames new_name) sigs `thenRn` \ sub_names ->
- returnRn (Avail class_name sub_names)
+ returnRn (AvailTC class_name (class_name : sub_names))
getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
= new_name var src_loc `thenRn` \ var_name ->
- returnRn (Avail var_name [])
+ returnRn (Avail var_name)
getDeclBinders new_name (DefD _) = returnRn NotAvailable
getDeclBinders new_name (InstD _) = returnRn NotAvailable
@@ -511,21 +660,28 @@ findAndReadIface doc_str mod
getSearchPathRn `thenRn` \ dirs ->
try dirs dirs
where
- trace_msg = ppHang (ppBesides [ppStr "Reading interface for ",
+ trace_msg = ppHang (ppBesides [ppPStr SLIT("Reading interface for "),
pprModule PprDebug mod, ppSemi])
- 4 (ppBesides [ppStr "reason: ", doc_str])
+ 4 (ppBesides [ppPStr SLIT("reason: "), doc_str])
- try all_dirs [] = traceRn (ppStr "...failed") `thenRn_`
+ mod_str = moduleString mod
+ hisuf =
+ if isPreludeModule mod then
+ case opt_HiSuffixPrelude of { Just hisuf -> hisuf; _ -> ".hi"}
+ else
+ case opt_HiSuffix of {Just hisuf -> hisuf; _ -> ".hi"}
+
+ try all_dirs [] = traceRn (ppPStr SLIT("...failed")) `thenRn_`
returnRn Nothing
try all_dirs (dir:dirs)
= readIface file_path `thenRn` \ read_result ->
case read_result of
Nothing -> try all_dirs dirs
- Just iface -> traceRn (ppStr "...done") `thenRn_`
+ Just iface -> traceRn (ppPStr SLIT("...done")) `thenRn_`
returnRn (Just iface)
where
- file_path = dir ++ "/" ++ moduleString mod ++ ".hi"
+ file_path = dir ++ "/" ++ moduleString mod ++ hisuf
\end{code}
@readIface@ trys just one file.
@@ -535,11 +691,14 @@ readIface :: String -> RnMG (Maybe ParsedIface)
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
readIface file_path
- = ioToRnMG (readFile file_path) `thenRn` \ read_result ->
+ = ioToRnMG (hGetStringBuffer file_path) `thenRn` \ read_result ->
+--OLD: = ioToRnMG (readFile file_path) `thenRn` \ read_result ->
case read_result of
Right contents -> case parseIface contents of
- Failed err -> failWithRn Nothing err
- Succeeded iface -> returnRn (Just iface)
+ Failed err -> --ioToRnMG (freeStringBuffer contents) `thenRn` \ _ ->
+ failWithRn Nothing err
+ Succeeded iface -> --ioToRnMG (freeStringBuffer contents) `thenRn` \ _ ->
+ returnRn (Just iface)
Left (NoSuchThing _) -> returnRn Nothing
@@ -573,9 +732,15 @@ mkSearchPath (Just s)
\begin{code}
noIfaceErr mod sty
- = ppBesides [ppStr "Could not find valid interface file for ", ppQuote (pprModule sty mod)]
+ = ppBesides [ppPStr SLIT("Could not find valid interface file for "), ppQuote (pprModule sty mod)]
-- , ppStr " in"]) 4 (ppAboves (map ppStr dirs))
cannaeReadFile file err sty
- = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)]
+ = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppPStr SLIT("; error="), ppStr (show err)]
+
+getDeclErr name sty
+ = ppSep [ppPStr SLIT("Failed to find interface decl for"), ppr sty name]
+
+getDeclWarn name sty
+ = ppSep [ppPStr SLIT("Warning: failed to find (optional) interface decl for"), ppr sty name]
\end{code}
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 62f789de81..5d29108b73 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1997
%
\section[RnMonad]{The monad used by the renamer}
@@ -7,24 +7,36 @@
#include "HsVersions.h"
module RnMonad(
- RnMonad..,
- SST_R
+ EXP_MODULE(RnMonad),
+ -- close it up (partly done to allow unfoldings)
+ EXP_MODULE(SST),
+ SYN_IE(Module),
+ FiniteMap,
+ Bag,
+ Name,
+ SYN_IE(RdrNameHsDecl),
+ SYN_IE(RdrNameInstDecl),
+ SYN_IE(Version),
+ SYN_IE(NameSet),
+ OccName,
+ Fixity
) where
IMP_Ubiq(){-uitous-}
import SST
-import PreludeGlaST ( SYN_IE(ST), thenST, returnST )
+import PreludeGlaST ( SYN_IE(ST), thenStrictlyST, returnStrictlyST )
import HsSyn
import RdrHsSyn
import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning)
)
-import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet),
+import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet), emptyNameSet,
+ isLocallyDefinedName,
modAndOcc, NamedThing(..)
)
-import CmdLineOpts ( opt_D_show_rn_trace )
+import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas )
import PrelInfo ( builtinNames )
import TyCon ( TyCon {- instance NamedThing -} )
import TysWiredIn ( boolTyCon )
@@ -58,8 +70,8 @@ infixr 9 `thenRn`, `thenRn_`
\begin{code}
sstToIO :: SST REAL_WORLD r -> IO r
sstToIO sst
- = sstToST sst `thenST` \ r ->
- returnST (Right r)
+ = sstToST sst `thenStrictlyST` \ r ->
+ returnStrictlyST (Right r)
ioToRnMG :: IO r -> RnMG (Either IOError13 r)
ioToRnMG io rn_down g_down = stToSST io
@@ -106,7 +118,9 @@ data GDown = GDown
-- For renaming source code
data SDown s = SDown
- RnEnv
+ RnEnv -- Global envt
+ NameEnv -- Local name envt (includes global name envt,
+ -- but may shadow it)
Module
RnSMode
@@ -152,7 +166,12 @@ type Fixities = [(OccName, (Fixity, Provenance))]
type ModuleAvails = FiniteMap Module Avails
-data AvailInfo = NotAvailable | Avail Name [Name]
+data AvailInfo = NotAvailable
+ | Avail Name -- An ordinary identifier
+ | AvailTC Name -- The name of the type or class
+ [Name] -- The available pieces of type/class. NB: If the type or
+ -- class is itself to be in scope, it must be in this list.
+ -- Thus, typically: Avail Eq [Eq, ==, /=]
\end{code}
===================================================
@@ -187,16 +206,27 @@ data Ifaces = Ifaces
Module -- Name of this module
(FiniteMap Module Version)
(FiniteMap Module (Avails, [(OccName,Fixity)])) -- Exports
- VersionMap
DeclsMap
- (Bag IfaceInst)
+
+ NameSet -- All the names (whether "big" or "small", whether wired-in or not,
+ -- whether locally defined or not) that have been slurped in so far.
+
+ [(Name,Version)] -- All the (a) non-wired-in (b) "big" (c) non-locally-defined names that
+ -- have been slurped in so far, with their versions. Subset of
+ -- the previous field. This is used to generate the "usage" information
+ -- for this module.
+
+ (Bag IfaceInst) -- Un-slurped instance decls; this bag is depleted when we
+ -- slurp an instance decl so that we don't slurp the same one twice.
+
[Module] -- Set of modules with "special" instance declarations
-- Excludes this module
-type DeclsMap = FiniteMap Name (AvailInfo, RdrNameHsDecl)
-type VersionMap = FiniteMap Name Version
-type IfaceInst = ([Name], Module, RdrNameInstDecl) -- The Names are those tycons and
- -- classes mentioned by the instance type
+type DeclsMap = FiniteMap Name (Version, AvailInfo, RdrNameHsDecl)
+type IfaceInst = ((Module, RdrNameInstDecl), -- Instance decl
+ [Name]) -- "Gate" names. Slurp this instance decl when this
+ -- list becomes empty. It's depleted whenever we
+ -- slurp another type or class decl.
\end{code}
@@ -230,15 +260,15 @@ initRn mod us dirs loc do_rn
initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r
-initRnMS env mod_name mode m rn_down g_down
+initRnMS rn_env@(RnEnv name_env _) mod_name mode m rn_down g_down
= let
- s_down = SDown env mod_name mode
+ s_down = SDown rn_env name_env mod_name mode
in
m rn_down s_down
emptyIfaces :: Module -> Ifaces
-emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyFM emptyBag []
+emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyNameSet [] emptyBag []
builtins :: FiniteMap (Module,OccName) Name
builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
@@ -280,7 +310,7 @@ renameSourceCode mod_name name_supply m
newMutVarSST [] `thenSST` \ occs_var ->
let
rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var
- s_down = SDown emptyRnEnv mod_name InterfaceMode
+ s_down = SDown emptyRnEnv emptyNameEnv mod_name InterfaceMode
in
m rn_down s_down `thenSST` \ result ->
@@ -417,20 +447,40 @@ getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down
setNameSupplyRn :: RnNameSupply -> RnM s d ()
setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
= writeMutVarSST names_var names'
+
+-- The "instance-decl unique supply", inst, is just an integer that's used to
+-- give a unique number for each instance declaration.
+newInstUniq :: RnM s d Int
+newInstUniq (RnDown loc names_var errs_var occs_var) l_down
+ = readMutVarSST names_var `thenSST` \ (us, inst, cache) ->
+ writeMutVarSST names_var (us, inst+1, cache) `thenSST_`
+ returnSST inst
\end{code}
================ Occurrences =====================
\begin{code}
-addOccurrenceName :: Necessity -> Name -> RnM s d ()
+addOccurrenceName :: Necessity -> Name -> RnM s d Name -- Same name returned as passed
addOccurrenceName necessity name (RnDown loc names_var errs_var occs_var) l_down
+ | isLocallyDefinedName name ||
+ not_necessary necessity
+ = returnSST name
+
+ | otherwise
= readMutVarSST occs_var `thenSST` \ occs ->
- writeMutVarSST occs_var ((name,necessity) : occs)
+-- pprTrace "Add occurrence:" (ppr PprDebug name) $
+ writeMutVarSST occs_var ((name,necessity) : occs) `thenSST_`
+ returnSST name
+ where
+ not_necessary Compulsory = False
+ not_necessary Optional = opt_IgnoreIfacePragmas
+ -- Never look for optional things if we're
+ -- ignoring optional input interface information
addOccurrenceNames :: Necessity -> [Name] -> RnM s d ()
addOccurrenceNames necessity names (RnDown loc names_var errs_var occs_var) l_down
= readMutVarSST occs_var `thenSST` \ occs ->
- writeMutVarSST occs_var ([(name,necessity) | name <- names] ++ occs)
+ writeMutVarSST occs_var ([(name,necessity) | name <- names, not (isLocallyDefinedName name)] ++ occs)
popOccurrenceName :: RnM s d (Maybe (Name,Necessity))
popOccurrenceName (RnDown loc names_var errs_var occs_var) l_down
@@ -464,34 +514,34 @@ findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down
================ RnEnv =====================
\begin{code}
+getGlobalNameEnv :: RnMS s NameEnv
+getGlobalNameEnv rn_down (SDown (RnEnv global_env fixity_env) local_env mod_name mode)
+ = returnSST global_env
+
getNameEnv :: RnMS s NameEnv
-getNameEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
- = returnSST name_env
+getNameEnv rn_down (SDown rn_env local_env mod_name mode)
+ = returnSST local_env
setNameEnv :: NameEnv -> RnMS s a -> RnMS s a
-setNameEnv name_env' m rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
- = m rn_down (SDown (RnEnv name_env' fixity_env) mod_name mode)
+setNameEnv local_env' m rn_down (SDown rn_env local_env mod_name mode)
+ = m rn_down (SDown rn_env local_env' mod_name mode)
getFixityEnv :: RnMS s FixityEnv
-getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
+getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) local_env mod_name mode)
= returnSST fixity_env
-
-setRnEnv :: RnEnv -> RnMS s a -> RnMS s a
-setRnEnv rn_env' m rn_down (SDown rn_env mod_name mode)
- = m rn_down (SDown rn_env' mod_name mode)
\end{code}
================ Module and Mode =====================
\begin{code}
getModuleRn :: RnMS s Module
-getModuleRn rn_down (SDown rn_env mod_name mode)
+getModuleRn rn_down (SDown rn_env local_env mod_name mode)
= returnSST mod_name
\end{code}
\begin{code}
getModeRn :: RnMS s RnSMode
-getModeRn rn_down (SDown rn_env mod_name mode)
+getModeRn rn_down (SDown rn_env local_env mod_name mode)
= returnSST mode
\end{code}
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 754dfd29b0..276cf5a40a 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -20,10 +20,10 @@ import HsBinds ( collectTopBinders )
import HsImpExp ( ieName )
import RdrHsSyn ( RdrNameHsDecl(..), RdrName(..), RdrNameIE(..), SYN_IE(RdrNameImportDecl),
SYN_IE(RdrNameHsModule), SYN_IE(RdrNameFixityDecl),
- rdrNameOcc
+ rdrNameOcc, ieOcc
)
import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
-import RnIfaces ( getInterfaceExports, getDeclBinders, checkUpToDate )
+import RnIfaces ( getInterfaceExports, getDeclBinders, checkUpToDate, recordSlurp )
import RnEnv
import RnMonad
import FiniteMap
@@ -83,6 +83,9 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc)
exportsFromAvail this_mod exports all_avails rn_env
`thenRn` \ (export_fn, export_env) ->
+ -- RECORD THAT LOCALLY DEFINED THINGS ARE AVAILABLE
+ mapRn (recordSlurp Nothing) local_avails `thenRn_`
+
returnRn (export_fn, Just (export_env, rn_env, local_avails))
) `thenRn` \ (_, result) ->
returnRn result
@@ -136,9 +139,7 @@ importsFromImportDecl (ImportDecl mod qual_only as_mod import_spec loc)
getInterfaceExports mod `thenRn` \ (avails, fixities) ->
filterImports mod import_spec avails `thenRn` \ filtered_avails ->
let
- filtered_avails' = [ Avail (set_name_prov n) (map set_name_prov ns)
- | Avail n ns <- filtered_avails
- ]
+ filtered_avails' = map set_avail_prov filtered_avails
fixities' = [ (occ,(fixity,provenance)) | (occ,fixity) <- fixities ]
in
qualifyImports mod
@@ -147,6 +148,9 @@ importsFromImportDecl (ImportDecl mod qual_only as_mod import_spec loc)
as_mod
(ExportEnv filtered_avails' fixities')
where
+ set_avail_prov NotAvailable = NotAvailable
+ set_avail_prov (Avail n) = Avail (set_name_prov n)
+ set_avail_prov (AvailTC n ns) = AvailTC (set_name_prov n) (map set_name_prov ns)
set_name_prov name = setNameProvenance name provenance
provenance = Imported mod loc
\end{code}
@@ -171,11 +175,13 @@ importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _)
getLocalDeclBinders avails decl
= getDeclBinders newLocalName decl `thenRn` \ avail ->
- returnRn (avail : avails)
+ case avail of
+ NotAvailable -> returnRn avails -- Instance decls and suchlike
+ other -> returnRn (avail : avails)
do_one (rdr_name, loc)
= newLocalName rdr_name loc `thenRn` \ name ->
- returnRn (Avail name [])
+ returnRn (Avail name)
\end{code}
%************************************************************************
@@ -199,47 +205,36 @@ filterImports mod Nothing imports
= returnRn imports
filterImports mod (Just (want_hiding, import_items)) avails
- = -- Check that each import item mentions things that are actually available
- mapRn check_import_item import_items `thenRn_`
-
- -- Return filtered environment; no need to filter fixities
- returnRn (map new_avail avails)
-
+ = foldlRn (filter_item want_hiding) initial_avails import_items
where
- import_fm :: FiniteMap OccName RdrNameIE
- import_fm = listToFM [(ieOcc ie, ie) | ie <- import_items]
-
- avail_fm :: FiniteMap OccName AvailInfo
- avail_fm = listToFM [(nameOccName name, avail) | avail@(Avail name ns) <- avails]
-
- new_avail NotAvailable = NotAvailable
- new_avail avail@(Avail name _)
- | not in_import_items && want_hiding = avail
- | not in_import_items && not want_hiding = NotAvailable
- | in_import_items && want_hiding = NotAvailable
- | in_import_items && not want_hiding = filtered_avail
- where
- maybe_import_item = lookupFM import_fm (nameOccName name)
- in_import_items = maybeToBool maybe_import_item
- Just import_item = maybe_import_item
- filtered_avail = filterAvail import_item avail
-
- check_import_item :: RdrNameIE -> RnMG ()
- check_import_item item
- = checkRn (maybeToBool maybe_matching_avail && sub_names_ok item avail)
- (badImportItemErr mod item)
- where
- item_name = ieOcc item
- maybe_matching_avail = lookupFM avail_fm item_name
- Just avail = maybe_matching_avail
-
- sub_names_ok (IEVar _) _ = True
- sub_names_ok (IEThingAbs _) _ = True
- sub_names_ok (IEThingAll _) _ = True
- sub_names_ok (IEThingWith _ wanted) (Avail _ has) = all ((`elem` has_list) . rdrNameOcc) wanted
- where
- has_list = map nameOccName has
- sub_names_ok other1 other2 = False
+ initial_avails | want_hiding = avails
+ | otherwise = []
+
+ import_fm :: FiniteMap OccName AvailInfo
+ import_fm = listToFM [ (nameOccName name, avail)
+ | avail <- avails,
+ name <- availEntityNames avail]
+
+ filter_item want_hiding avails_so_far item@(IEModuleContents _)
+ = addErrRn (badImportItemErr mod item) `thenRn_`
+ returnRn avails_so_far
+
+ filter_item want_hiding avails_so_far item
+ | not (maybeToBool maybe_in_import_avails) ||
+ (case filtered_avail of { NotAvailable -> True; other -> False })
+ = addErrRn (badImportItemErr mod item) `thenRn_`
+ returnRn avails_so_far
+
+ | want_hiding = returnRn (foldr hide_it [] avails_so_far)
+ | otherwise = returnRn (filtered_avail : avails_so_far) -- Explicit import list
+
+ where
+ maybe_in_import_avails = lookupFM import_fm (ieOcc item)
+ Just avail = maybe_in_import_avails
+ filtered_avail = filterAvail item avail
+ hide_it avail avails = case hideAvail item avail of
+ NotAvailable -> avails
+ avail' -> avail' : avails
\end{code}
@@ -277,8 +272,7 @@ qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities)
mod_avail_env = unitFM qual_mod avails
- add_name name_env NotAvailable = returnRn name_env
- add_name name_env (Avail n ns) = foldlRn add_one name_env (n : ns)
+ add_name name_env avail = foldlRn add_one name_env (availNames avail)
add_one :: NameEnv -> Name -> RnMG NameEnv
add_one env name = add_to_env addOneToNameEnvRn env occ_name name
@@ -347,10 +341,9 @@ type AvailEnv = FiniteMap OccName (RdrNameIE, AvailInfo)
emptyAvailEnv = emptyFM
unitAvailEnv :: RdrNameIE -> AvailInfo -> AvailEnv
-unitAvailEnv ie NotAvailable
- = emptyFM
-unitAvailEnv ie avail@(Avail n ns)
- = unitFM (nameOccName n) (ie,avail)
+unitAvailEnv ie NotAvailable = emptyFM
+unitAvailEnv ie (AvailTC _ []) = emptyFM
+unitAvailEnv ie avail = unitFM (nameOccName (availName avail)) (ie,avail)
plusAvailEnv a1 a2
= mapRn (addErrRn.availClashErr) (conflictsFM bad_avail a1 a2) `thenRn_`
@@ -360,10 +353,18 @@ listToAvailEnv :: RdrNameIE -> [AvailInfo] -> RnM s d AvailEnv
listToAvailEnv ie items
= foldlRn plusAvailEnv emptyAvailEnv (map (unitAvailEnv ie) items)
-bad_avail (ie1,Avail n1 _) (ie2,Avail n2 _) = n1 /= n2 -- Same OccName, different Name
+bad_avail (ie1,avail1) (ie2,avail2) = availName avail1 /= availName avail2 -- Same OccName, different Name
plus_avail (ie1,a1) (ie2,a2) = (ie1, a1 `plusAvail` a2)
\end{code}
+Processing the export list.
+
+You might think that we should record things that appear in the export list as
+``occurrences'' (using addOccurrenceName), but you'd be wrong. We do check (here)
+that they are in scope, but there is no need to slurp in their actual declaration
+(which is what addOccurrenceName forces). Indeed, doing so would big trouble when
+compiling PrelBase, because it re-exports GHC, which includes takeMVar#, whose type
+includes ConcBase.StateAndSynchVar#, and so on...
\begin{code}
exportsFromAvail :: Module
@@ -389,16 +390,18 @@ exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_
where
full_avail_env :: UniqFM AvailInfo
full_avail_env = addListToUFM_C plusAvail emptyUFM
- [(name,avail) | avail@(Avail name _) <- concat (eltsFM all_avails)]
- -- NB: full_avail_env won't contain bindings for data constructors and class ops,
- -- which is right and proper; attempts to export them on their own will provoke an error
+ [(name, avail) | avail <- concat (eltsFM all_avails),
+ name <- availEntityNames avail
+ ]
+
+ -- NB: full_avail_env will contain bindings for class ops but not constructors
+ -- (see defn of availEntityNames)
exports_from_item :: RdrNameIE -> RnMG AvailEnv
exports_from_item ie@(IEModuleContents mod)
= case lookupFM all_avails mod of
Nothing -> failWithRn emptyAvailEnv (modExportErr mod)
- Just avails -> addOccurrenceNames Compulsory [n | Avail n _ <- avails] `thenRn_`
- listToAvailEnv ie avails
+ Just avails -> listToAvailEnv ie avails
exports_from_item ie
| not (maybeToBool maybe_in_scope)
@@ -416,8 +419,7 @@ exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_
= failWithRn emptyAvailEnv (exportItemErr ie export_avail)
| otherwise -- Phew! It's OK!
- = addOccurrenceName Compulsory name `thenRn_`
- returnRn (unitAvailEnv ie export_avail)
+ = returnRn (unitAvailEnv ie export_avail)
where
maybe_in_scope = lookupNameEnv name_env (ieName ie)
Just name = maybe_in_scope
@@ -486,24 +488,22 @@ mk_export_fn avails
%************************************************************************
\begin{code}
-ieOcc ie = rdrNameOcc (ieName ie)
-
badImportItemErr mod ie sty
- = ppSep [ppStr "Module", pprModule sty mod, ppStr "does not export", ppr sty ie]
+ = ppSep [ppPStr SLIT("Module"), pprModule sty mod, ppPStr SLIT("does not export"), ppr sty ie]
modExportErr mod sty
- = ppCat [ ppStr "Unknown module in export list: module", ppPStr mod]
+ = ppCat [ ppPStr SLIT("Unknown module in export list: module"), ppPStr mod]
exportItemErr export_item NotAvailable sty
- = ppSep [ ppStr "Export item not in scope:", ppr sty export_item ]
+ = ppSep [ ppPStr SLIT("Export item not in scope:"), ppr sty export_item ]
exportItemErr export_item avail sty
- = ppHang (ppStr "Export item not fully in scope:")
- 4 (ppAboves [ppCat [ppStr "Wanted: ", ppr sty export_item],
- ppCat [ppStr "Available: ", ppr sty (ieOcc export_item), pprAvail sty avail]])
+ = ppHang (ppPStr SLIT("Export item not fully in scope:"))
+ 4 (ppAboves [ppCat [ppPStr SLIT("Wanted: "), ppr sty export_item],
+ ppCat [ppPStr SLIT("Available: "), ppr sty (ieOcc export_item), pprAvail sty avail]])
availClashErr (occ_name, ((ie1,avail1), (ie2,avail2))) sty
- = ppHang (ppCat [ppStr "Conflicting exports for local name: ", ppr sty occ_name])
+ = ppHang (ppCat [ppPStr SLIT("Conflicting exports for local name: "), ppr sty occ_name])
4 (ppAboves [ppr sty ie1, ppr sty ie2])
\end{code}
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 588619b2c0..65edce3177 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -21,12 +21,14 @@ import HsCore
import CmdLineOpts ( opt_IgnoreIfacePragmas )
import RnBinds ( rnTopBinds, rnMethodBinds )
-import RnEnv ( bindTyVarsRn, lookupRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
- lookupOptionalOccRn, newDfunName,
+import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
+ lookupOptionalOccRn, newSysName, newDfunName,
listType_RDR, tupleType_RDR )
import RnMonad
-import Name ( Name, isLocallyDefined, occNameString,
+import Name ( Name, isLocallyDefined,
+ OccName(..), occNameString, prefixOccName,
+ ExportFlag(..),
Provenance,
SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet,
elemNameSet
@@ -84,7 +86,7 @@ rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ new_binds ->
rnDecl (SigD (IfaceSig name ty id_infos loc))
= pushSrcLocRn loc $
- lookupRn name `thenRn` \ name' ->
+ lookupBndrRn name `thenRn` \ name' ->
rnHsType ty `thenRn` \ ty' ->
-- Get the pragma info, unless we should ignore it
@@ -118,7 +120,7 @@ checks at the same time.
\begin{code}
rnDecl (TyD (TyData context tycon tyvars condecls derivings pragmas src_loc))
= pushSrcLocRn src_loc $
- lookupRn tycon `thenRn` \ tycon' ->
+ lookupBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsRn "data declaration" tyvars $ \ tyvars' ->
rnContext context `thenRn` \ context' ->
mapRn rnConDecl condecls `thenRn` \ condecls' ->
@@ -128,7 +130,7 @@ rnDecl (TyD (TyData context tycon tyvars condecls derivings pragmas src_loc))
rnDecl (TyD (TyNew context tycon tyvars condecl derivings pragmas src_loc))
= pushSrcLocRn src_loc $
- lookupRn tycon `thenRn` \ tycon' ->
+ lookupBndrRn tycon `thenRn` \ tycon' ->
bindTyVarsRn "newtype declaration" tyvars $ \ tyvars' ->
rnContext context `thenRn` \ context' ->
rnConDecl condecl `thenRn` \ condecl' ->
@@ -138,7 +140,7 @@ rnDecl (TyD (TyNew context tycon tyvars condecl derivings pragmas src_loc))
rnDecl (TyD (TySynonym name tyvars ty src_loc))
= pushSrcLocRn src_loc $
- lookupRn name `thenRn` \ name' ->
+ lookupBndrRn name `thenRn` \ name' ->
bindTyVarsRn "type declaration" tyvars $ \ tyvars' ->
rnHsType ty `thenRn` \ ty' ->
returnRn (TyD (TySynonym name' tyvars' ty' src_loc))
@@ -159,15 +161,22 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
= pushSrcLocRn src_loc $
bindTyVarsRn "class declaration" [tyvar] $ \ [tyvar'] ->
rnContext context `thenRn` \ context' ->
- lookupRn cname `thenRn` \ cname' ->
+ lookupBndrRn cname `thenRn` \ cname' ->
mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' ->
rnMethodBinds mbinds `thenRn` \ mbinds' ->
ASSERT(isNoClassPragmas pragmas)
returnRn (ClD (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc))
where
- rn_op clas clas_tyvar sig@(ClassOpSig op ty pragmas locn)
+ rn_op clas clas_tyvar sig@(ClassOpSig op _ ty locn)
= pushSrcLocRn locn $
- lookupRn op `thenRn` \ op_name ->
+ let
+ dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op)
+ in
+ lookupBndrRn op `thenRn` \ op_name ->
+ newSysName dm_occ Exported locn `thenRn` \ dm_name ->
+ addOccurrenceName Optional dm_name `thenRn_`
+ -- Call up interface info for default method, if such info exists
+
rnHsType ty `thenRn` \ new_ty ->
let
(ctxt, op_ty) = case new_ty of
@@ -187,8 +196,8 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
(classTyVarInOpCtxtErr clas_tyvar sig)
`thenRn_`
- ASSERT(isNoClassOpPragmas pragmas)
- returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
+-- ASSERT(isNoClassOpPragmas pragmas)
+ returnRn (ClassOpSig op_name dm_name new_ty locn)
\end{code}
@@ -199,42 +208,39 @@ rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
%*********************************************************
\begin{code}
-rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_name src_loc))
+rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
= pushSrcLocRn src_loc $
- rnHsType inst_ty `thenRn` \ inst_ty' ->
- rnMethodBinds mbinds `thenRn` \ mbinds' ->
- mapRn rn_uprag uprags `thenRn` \ new_uprags ->
- rn_dfun maybe_dfun_name `thenRn` \ dfun_name' ->
+ rnHsType inst_ty `thenRn` \ inst_ty' ->
+ rnMethodBinds mbinds `thenRn` \ mbinds' ->
+ mapRn rn_uprag uprags `thenRn` \ new_uprags ->
- returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name' src_loc))
- where
- rn_dfun Nothing = newDfunName src_loc `thenRn` \ n' ->
- returnRn (Just n')
- rn_dfun (Just n) = lookupOccRn n `thenRn` \ n' ->
- -- The dfun is not optional, because we use its version number
- -- to identify the version of the instance declaration
- returnRn (Just n')
+ newDfunName maybe_dfun src_loc `thenRn` \ dfun_name ->
+ addOccurrenceName Compulsory dfun_name `thenRn_`
+ -- The dfun is not optional, because we use its version number
+ -- to identify the version of the instance declaration
+ returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags (Just dfun_name) src_loc))
+ where
rn_uprag (SpecSig op ty using locn)
= pushSrcLocRn src_loc $
- lookupRn op `thenRn` \ op_name ->
+ lookupBndrRn op `thenRn` \ op_name ->
rnHsType ty `thenRn` \ new_ty ->
rn_using using `thenRn` \ new_using ->
returnRn (SpecSig op_name new_ty new_using locn)
rn_uprag (InlineSig op locn)
= pushSrcLocRn locn $
- lookupRn op `thenRn` \ op_name ->
+ lookupBndrRn op `thenRn` \ op_name ->
returnRn (InlineSig op_name locn)
rn_uprag (DeforestSig op locn)
= pushSrcLocRn locn $
- lookupRn op `thenRn` \ op_name ->
+ lookupBndrRn op `thenRn` \ op_name ->
returnRn (DeforestSig op_name locn)
rn_uprag (MagicUnfoldingSig op str locn)
= pushSrcLocRn locn $
- lookupRn op `thenRn` \ op_name ->
+ lookupBndrRn op `thenRn` \ op_name ->
returnRn (MagicUnfoldingSig op_name str locn)
rn_using Nothing = returnRn Nothing
@@ -294,13 +300,13 @@ rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
rnConDecl (ConDecl name tys src_loc)
= pushSrcLocRn src_loc $
checkConName name `thenRn_`
- lookupRn name `thenRn` \ new_name ->
+ lookupBndrRn name `thenRn` \ new_name ->
mapRn rnBangTy tys `thenRn` \ new_tys ->
returnRn (ConDecl new_name new_tys src_loc)
rnConDecl (ConOpDecl ty1 op ty2 src_loc)
= pushSrcLocRn src_loc $
- lookupRn op `thenRn` \ new_op ->
+ lookupBndrRn op `thenRn` \ new_op ->
rnBangTy ty1 `thenRn` \ new_ty1 ->
rnBangTy ty2 `thenRn` \ new_ty2 ->
returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
@@ -308,18 +314,18 @@ rnConDecl (ConOpDecl ty1 op ty2 src_loc)
rnConDecl (NewConDecl name ty src_loc)
= pushSrcLocRn src_loc $
checkConName name `thenRn_`
- lookupRn name `thenRn` \ new_name ->
+ lookupBndrRn name `thenRn` \ new_name ->
rnHsType ty `thenRn` \ new_ty ->
returnRn (NewConDecl new_name new_ty src_loc)
rnConDecl (RecConDecl name fields src_loc)
= pushSrcLocRn src_loc $
- lookupRn name `thenRn` \ new_name ->
+ lookupBndrRn name `thenRn` \ new_name ->
mapRn rnField fields `thenRn` \ new_fields ->
returnRn (RecConDecl new_name new_fields src_loc)
rnField (names, ty)
- = mapRn lookupRn names `thenRn` \ new_names ->
+ = mapRn lookupBndrRn names `thenRn` \ new_names ->
rnBangTy ty `thenRn` \ new_ty ->
returnRn (new_names, new_ty)
@@ -542,6 +548,10 @@ rnCoreBndrs bndrs thing_inside -- Expect them all to be ValBinders
where
names = map (\ (UfValBinder name _) -> name) bndrs
tys = map (\ (UfValBinder _ ty) -> ty) bndrs
+
+rnCoreBndrNamess names thing_inside
+ = bindLocalsRn "unfolding value" names $ \ names' ->
+ thing_inside names'
\end{code}
\begin{code}
@@ -555,9 +565,9 @@ rnCoreAlts (UfAlgAlts alts deflt)
rnCoreDefault deflt `thenRn` \ deflt' ->
returnRn (UfAlgAlts alts' deflt')
where
- rn_alt (con, bndrs, rhs) = lookupOptionalOccRn con `thenRn` \ con' ->
- rnCoreBndrs bndrs $ \ bndrs' ->
- rnCoreExpr rhs `thenRn` \ rhs' ->
+ rn_alt (con, bndrs, rhs) = lookupOptionalOccRn con `thenRn` \ con' ->
+ bindLocalsRn "unfolding alt" bndrs $ \ bndrs' ->
+ rnCoreExpr rhs `thenRn` \ rhs' ->
returnRn (con', bndrs', rhs')
rnCoreAlts (UfPrimAlts alts deflt)
@@ -569,8 +579,8 @@ rnCoreAlts (UfPrimAlts alts deflt)
returnRn (lit, rhs')
rnCoreDefault UfNoDefault = returnRn UfNoDefault
-rnCoreDefault (UfBindDefault bndr rhs) = rnCoreBndr bndr $ \ bndr' ->
- rnCoreExpr rhs `thenRn` \ rhs' ->
+rnCoreDefault (UfBindDefault bndr rhs) = bindLocalsRn "unfolding default" [bndr] $ \ [bndr'] ->
+ rnCoreExpr rhs `thenRn` \ rhs' ->
returnRn (UfBindDefault bndr' rhs')
rnCoercion (UfIn n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfIn n')
@@ -594,23 +604,27 @@ rnCorePrim (UfCCallOp str casm gc arg_tys res_ty)
\begin{code}
derivingNonStdClassErr clas sty
- = ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
+ = ppCat [ppPStr SLIT("non-standard class in deriving:"), ppr sty clas]
classTyVarNotInOpTyErr clas_tyvar sig sty
- = ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
+ = ppHang (ppBesides [ppPStr SLIT("Class type variable `"),
+ ppr sty clas_tyvar,
+ ppPStr SLIT("' does not appear in method signature:")])
4 (ppr sty sig)
classTyVarInOpCtxtErr clas_tyvar sig sty
- = ppHang (ppBesides [ ppStr "Class type variable `", ppr sty clas_tyvar,
- ppStr "' present in method's local overloading context:"])
+ = ppHang (ppBesides [ ppPStr SLIT("Class type variable `"), ppr sty clas_tyvar,
+ ppPStr SLIT("' present in method's local overloading context:")])
4 (ppr sty sig)
dupClassAssertWarn ctxt dups sty
- = ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])
+ = ppHang (ppBesides [ppPStr SLIT("Duplicate class assertion `"),
+ ppr sty dups,
+ ppPStr SLIT("' in context:")])
4 (ppr sty ctxt)
badDataCon name sty
- = ppCat [ppStr "Illegal data constructor name:", ppr sty name]
+ = ppCat [ppPStr SLIT("Illegal data constructor name:"), ppr sty name]
\end{code}
View Lorry Controller Status