Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
0d8269cc
Commit
0d8269cc
authored
May 18, 1999
by
simonpj
Browse files
[project @ 1999-05-18 14:56:06 by simonpj]
msg_rn
parent
ab8279d6
Changes
14
Expand all
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/rename/ParseIface.y
View file @
0d8269cc
...
...
@@ -5,7 +5,6 @@ module ParseIface ( parseIface, IfaceStuff(..) ) where
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
import HsTypes ( mkHsForAllTy )
import HsCore
import Const ( Literal(..), mkMachInt_safe )
...
...
@@ -19,7 +18,7 @@ import IdInfo ( ArityInfo, exactArity, CprInfo(..) )
import Lex
import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..),
RdrNamePragma, ExportItem, RdrAvailInfo, GenAvailInfo(..)
RdrNamePragma, ExportItem, RdrAvailInfo, GenAvailInfo(..)
, WhetherHasOrphans
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
...
...
@@ -29,7 +28,7 @@ import OccName ( mkSysOccFS,
tcName, varName, dataName, clsName, tvName,
EncodedFS
)
import Module ( Module, mkSysModuleFS
, IfaceFlavour, hiFile, hiBootFile
)
import Module ( Module
Name
, mkSysModuleFS )
import PrelMods ( mkTupNameStr, mkUbxTupNameStr )
import PrelInfo ( mkTupConRdrName, mkUbxTupConRdrName )
import SrcLoc ( SrcLoc )
...
...
@@ -76,11 +75,12 @@ import Ratio ( (%) )
'__interface' { ITinterface } -- GHC-extension keywords
'__export' { ITexport }
'__
instimport' { ITinstimport
}
'__
depends' { ITdepends
}
'__forall' { ITforall }
'__letrec' { ITletrec }
'__coerce' { ITcoerce }
'__inline' { ITinline }
'__inline_call'{ ITinlineCall }
'__inline_me' { ITinlineMe }
'__DEFAULT' { ITdefaultbranch }
'__bot' { ITbottom }
'__integer' { ITinteger_lit }
...
...
@@ -101,6 +101,7 @@ import Ratio ( (%) )
'__C' { ITnocaf }
'__U' { ITunfold $$ }
'__S' { ITstrict $$ }
'__R' { ITrules }
'__M' { ITcprinfo $$ }
'..' { ITdotdot } -- reserved symbols
...
...
@@ -157,25 +158,26 @@ iface_stuff :: { IfaceStuff }
iface_stuff : iface { let (nm, iff) = $1 in PIface nm iff }
| type { PType $1 }
| id_info { PIdInfo $1 }
| '__R' rules { PRules $2 }
iface :: { (EncodedFS, ParsedIface) }
iface : '__interface' mod_fs INTEGER checkVersion 'where'
import_part
instance_import_part
iface :: { (ModuleName, ParsedIface) }
iface : '__interface' mod_fs INTEGER orphans checkVersion 'where'
exports_part
import_part
instance_decl_part
decls_part
rules_part
{ ( $2 -- Module name
, ParsedIface
(
fromInteger $3
)
-- Module version
(reverse $6) -- Usages
(reverse $8)
-- Exports
(reverse $7) -- Instance import modul
es
(reverse $10) -- Decl
s
(reverse $9) -- Local instance
s
)
}
, ParsedIface
{
pi_mod =
fromInteger $3
,
-- Module version
pi_orphan = $4,
pi_exports = $7,
-- Exports
pi_usages = $8, -- Usag
es
pi_insts = $9, -- Local instance
s
pi_decls = $10, -- Decl
s
pi_rules = $11 -- Rules
} )
}
--------------------------------------------------------------------------
...
...
@@ -184,12 +186,19 @@ import_part : { [] }
| import_part import_decl { $2 : $1 }
import_decl :: { ImportVersion OccName }
import_decl : 'import' mod_fs opt_bang INTEGER '::' whats_imported ';'
{ (mkSysModuleFS $2 $3, fromInteger $4, $6) }
import_decl : 'import' mod_fs INTEGER orphans whats_imported ';'
{ (mkSysModuleFS $2, fromInteger $3, $4, $5) }
-- import Foo 3 :: a 1 b 3 c 7 ; means import a,b,c from Foo
-- import Foo 3 ; means import all of Foo
-- import Foo 3 ! :: ...stuff... ; the ! means that Foo contains orphans
orphans :: { WhetherHasOrphans }
orphans : { False }
| '!' { True }
whats_imported :: { WhatsImported OccName }
whats_imported : { Everything }
|
name_version_pair
name_version_pairs { Specifically
($1:
$2
)
}
|
'::'
name_version_pairs
{ Specifically $2 }
name_version_pairs :: { [LocalVersion OccName] }
name_version_pairs : { [] }
...
...
@@ -199,21 +208,13 @@ name_version_pair :: { LocalVersion OccName }
name_version_pair : var_occ INTEGER { ($1, fromInteger $2) }
| tc_occ INTEGER { ($1, fromInteger $2) }
instance_import_part :: { [Module] }
instance_import_part : { [] }
| instance_import_part '__instimport' mod_name ';'
{ $3 : $1 }
--------------------------------------------------------------------------
exports_part :: { [ExportItem] }
exports_part : { [] }
| exports_part '__export' opt_bang mod_fs entities ';'
{ (mkSysModuleFS $4 $3,$5) : $1 }
opt_bang :: { IfaceFlavour }
opt_bang : { hiFile }
| '!' { hiBootFile }
| exports_part '__export'
mod_fs entities ';' { (mkSysModuleFS $3, $4) : $1 }
entities :: { [RdrAvailInfo] }
entities : { [] }
...
...
@@ -259,11 +260,8 @@ csigs1 : csig { [$1] }
| csig ';' csigs1 { $1 : $3 }
csig :: { RdrNameSig }
csig : src_loc var_name '::' type { ClassOpSig $2 Nothing $4 $1 }
| src_loc var_name '=' '::' type
{ ClassOpSig $2
(Just (error "Un-filled-in default method"))
$5 $1 }
csig : src_loc var_name '::' type { mkClassOpSig False $2 $4 $1 }
| src_loc var_name '=' '::' type { mkClassOpSig True $2 $5 $1 }
--------------------------------------------------------------------------
...
...
@@ -276,7 +274,7 @@ inst_decl : src_loc 'instance' type '=' var_name ';'
{ InstDecl $3
EmptyMonoBinds {- No bindings -}
[] {- No user pragmas -}
(Just
$5
)
{- Dfun id -}
$5
{- Dfun id -}
$1
}
...
...
@@ -313,6 +311,26 @@ maybe_idinfo : {- empty -} { \_ -> [] }
-----------------------------------------------------------------------------
rules_part :: { [RdrNameRuleDecl] }
rules_part : {- empty -} { [] }
| src_loc PRAGMA { case parseIface $2 $1 of
Succeeded (PRules rules) -> rules
Failed err -> pprPanic "Rules parse failed" err
}
rules :: { [RdrNameRuleDecl] }
: {- empty -} { [] }
| rule ';' rules { $1:$3 }
rule :: { RdrNameRuleDecl }
rule : src_loc STRING rule_forall qvar_name
core_args '=' core_expr { IfaceRuleDecl $4 (UfRuleBody $2 $3 $5 $7) $1 }
rule_forall :: { [UfBinder RdrName] }
rule_forall : '__forall' '{' core_bndrs '}' { $3 }
-----------------------------------------------------------------------------
version :: { Version }
version : INTEGER { fromInteger $1 }
...
...
@@ -414,8 +432,8 @@ atypes : { [] }
mod_fs :: { EncodedFS }
: CONID { $1 }
mod_name :: { Module }
: mod_fs { mkSysModuleFS $1
hiFile
}
mod_name :: { Module
Name
}
: mod_fs { mkSysModuleFS $1 }
---------------------------------------------------
...
...
@@ -426,7 +444,7 @@ var_fs :: { EncodedFS }
| '!' { SLIT("!") }
qvar_fs :: { (EncodedFS, EncodedFS
, IfaceFlavour
) }
qvar_fs :: { (EncodedFS, EncodedFS) }
: QVARID { $1 }
| QVARSYM { $1 }
...
...
@@ -457,7 +475,7 @@ data_fs :: { EncodedFS }
: CONID { $1 }
| CONSYM { $1 }
qdata_fs :: { (EncodedFS, EncodedFS
, IfaceFlavour
) }
qdata_fs :: { (EncodedFS, EncodedFS) }
: QCONID { $1 }
| QCONSYM { $1 }
...
...
@@ -539,11 +557,8 @@ id_info_item :: { HsIdInfo RdrName }
: '__A' arity_info { HsArity $2 }
| '__U' core_expr { HsUnfold $1 (Just $2) }
| '__U' { HsUnfold $1 Nothing }
| '__P' spec_tvs
atypes '=' core_expr { HsSpecialise $2 $3 $5 }
| '__C' { HsNoCafRefs }
strict_info :: { [HsIdInfo RdrName] }
: cpr worker { ($1:$2) }
| strict worker { ($1:$2) }
...
...
@@ -553,17 +568,12 @@ cpr :: { HsIdInfo RdrName }
: '__M' { HsCprInfo $1 }
strict :: { HsIdInfo RdrName }
: '__S' { HsStrictness (HsStrictnessInfo $1) }
: '__S'
{ HsStrictness (HsStrictnessInfo $1) }
worker :: { [HsIdInfo RdrName] }
: qvar_name '{' qdata_names '}' { [HsWorker $1 $3] }
| qvar_name { [HsWorker $1 []] }
: qvar_name { [HsWorker $1] }
| {- nothing -} { [] }
spec_tvs :: { [HsTyVar RdrName] }
: '[' tv_bndrs ']' { $2 }
arity_info :: { ArityInfo }
: INTEGER { exactArity (fromInteger $1) }
...
...
@@ -581,7 +591,8 @@ core_expr : '\\' core_bndrs '->' core_expr { foldr UfLam $4 $2 }
| con_or_primop '{' core_args '}' { UfCon $1 $3 }
| '__litlit' STRING atype { UfCon (UfLitLitCon $2 $3) [] }
| '__inline' core_expr { UfNote UfInlineCall $2 }
| '__inline_me' core_expr { UfNote UfInlineMe $2 }
| '__inline_call' core_expr { UfNote UfInlineCall $2 }
| '__coerce' atype core_expr { UfNote (UfCoerce $2) $3 }
| scc core_expr { UfNote (UfSCC $1) $2 }
| fexpr { $1 }
...
...
@@ -733,6 +744,7 @@ checkVersion :: { () }
data IfaceStuff = PIface EncodedFS{-.hi module name-} ParsedIface
| PIdInfo [HsIdInfo RdrName]
| PType RdrNameHsType
| PRules [RdrNameRuleDecl]
mkConDecl name (ex_tvs, ex_ctxt) details loc = ConDecl name ex_tvs ex_ctxt details loc
}
ghc/compiler/rename/Rename.lhs
View file @
0d8269cc
This diff is collapsed.
Click to expand it.
ghc/compiler/rename/RnBinds.hi-boot
View file @
0d8269cc
...
...
@@ -2,4 +2,4 @@ _interface_ RnBinds 1
_exports_
RnBinds rnBinds;
_declarations_
1 rnBinds _:_ _forall_ [
a
b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS
a
(b, RnEnv.FreeVars)) -> RnMonad.RnMS
a
(b, RnEnv.FreeVars) ;;
1 rnBinds _:_ _forall_ [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, RnEnv.FreeVars)) -> RnMonad.RnMS (b, RnEnv.FreeVars) ;;
ghc/compiler/rename/RnBinds.hi-boot-5
View file @
0d8269cc
__interface RnBinds 1 0 where
__export RnBinds rnBinds;
1 rnBinds :: __forall [
_a
_b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS
_a
(_b, RnEnv.FreeVars)) -> RnMonad.RnMS
_a
(_b, RnEnv.FreeVars) ;
1 rnBinds :: __forall [_b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (_b, RnEnv.FreeVars)) -> RnMonad.RnMS (_b, RnEnv.FreeVars) ;
ghc/compiler/rename/RnBinds.lhs
View file @
0d8269cc
...
...
@@ -26,10 +26,10 @@ import RdrHsSyn
import RnHsSyn
import RnMonad
import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn,
lookupOccRn,
lookupGlobalOccRn,
isUnboundName,
warnUnusedLocalBinds,
FreeVars, emptyFVs, plusFV, plusFVs, unitFV,
failUnbound
NameErr
Rn
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn,
warnUnusedLocalBinds,
mapFvRn,
FreeVars, emptyFVs, plusFV, plusFVs, unitFV,
addOneFV,
unknown
NameErr
)
import CmdLineOpts ( opt_WarnMissingSigs )
import Digraph ( stronglyConnComp, SCC(..) )
...
...
@@ -41,7 +41,7 @@ import Util ( thenCmp, removeDups )
import List ( partition )
import ListSetOps ( minusList )
import Bag ( bagToList )
import FiniteMap (
emptyFM, addListToFM, lookup
FM )
import FiniteMap (
lookupFM, listTo
FM )
import Maybe ( isJust )
import Outputable
\end{code}
...
...
@@ -161,7 +161,7 @@ it expects the global environment to contain bindings for the binders
contains bindings for the binders of this particular binding.
\begin{code}
rnTopBinds :: RdrNameHsBinds -> RnMS
s
(RenamedHsBinds, FreeVars)
rnTopBinds :: RdrNameHsBinds -> RnMS (RenamedHsBinds, FreeVars)
rnTopBinds EmptyBinds = returnRn (EmptyBinds, emptyFVs)
rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
...
...
@@ -174,23 +174,23 @@ rnTopMonoBinds EmptyMonoBinds sigs
rnTopMonoBinds mbinds sigs
= mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
let
binder_set = mkNameSet binder_names
binder_occ_fm = addListToFM emptyFM (map (\ x -> (nameOccName x,x)) binder_names)
-- the names appearing in the sigs have to be bound by
-- this group's binders.
lookup_occ_rn_sig rdr_name =
case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of
Nothing -> failUnboundNameErrRn rdr_name
Just x -> returnRn x
binder_set = mkNameSet binder_names
binder_occ_fm = listToFM [(nameOccName x,x) | x <- binder_names]
in
renameSigs opt_WarnMissingSigs binder_set
lookup_occ_rn_sig sigs
`thenRn` \ (siglist, sig_fvs) ->
rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) ->
renameSigs opt_WarnMissingSigs binder_set
(lookupSigOccRn binder_occ_fm) sigs
`thenRn` \ (siglist, sig_fvs) ->
rn_mono_binds siglist mbinds
`thenRn` \ (final_binds, bind_fvs) ->
returnRn (final_binds, bind_fvs `plusFV` sig_fvs)
where
binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
-- the names appearing in the sigs have to be bound by
-- this group's binders.
lookupSigOccRn binder_occ_fm rdr_name
= case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of
Nothing -> failWithRn (mkUnboundName rdr_name)
(unknownNameErr rdr_name)
Just x -> returnRn x
\end{code}
%************************************************************************
...
...
@@ -207,8 +207,8 @@ rnTopMonoBinds mbinds sigs
\begin{code}
rnBinds :: RdrNameHsBinds
-> (RenamedHsBinds -> RnMS
s
(result, FreeVars))
-> RnMS
s
(result, FreeVars)
-> (RenamedHsBinds -> RnMS (result, FreeVars))
-> RnMS (result, FreeVars)
rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
...
...
@@ -217,8 +217,8 @@ rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
rnMonoBinds :: RdrNameMonoBinds
-> [RdrNameSig]
-> (RenamedHsBinds -> RnMS
s
(result, FreeVars))
-> RnMS
s
(result, FreeVars)
-> (RenamedHsBinds -> RnMS (result, FreeVars))
-> RnMS (result, FreeVars)
rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds
...
...
@@ -238,28 +238,22 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
isJust (lookupFM binder_occ_fm (rdrNameOcc name))
forLocalBind _ = True
binder_occ_fm =
addL
istToFM
emptyFM (map (\ x ->
(nameOccName x,x)
)
new_mbinders
)
binder_occ_fm =
l
istToFM
[
(nameOccName x,x)
| x <-
new_mbinders
]
-- the names appearing in the sigs have to be bound by
-- this group's binders.
lookup_occ_rn_sig rdr_name =
case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of
Nothing -> failUnboundNameErrRn rdr_name
Just x -> returnRn x
in
--
-- Report the fixity declarations in this group that
-- don't refer to any of the group's binders.
--
mapRn_ (unknownSigErr) fixes_not_for_me `thenRn_`
renameSigs False binder_set
lookup_occ_rn_sig sigs_for_me
`thenRn` \ (siglist, sig_fvs) ->
renameSigs False binder_set
(lookupSigOccRn binder_occ_fm) sigs_for_me
`thenRn` \ (siglist, sig_fvs) ->
let
fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ]
in
-- Install the fixity declarations that do apply here and go.
extendFixityEnv fixity_sigs (
rn_mono_binds siglist mbinds ) `thenRn` \ (binds, bind_fvs) ->
extendFixityEnv fixity_sigs (
rn_mono_binds siglist mbinds
) `thenRn` \ (binds, bind_fvs) ->
-- Now do the "thing inside", and deal with the free-variable calculations
thing_inside binds `thenRn` \ (result,result_fvs) ->
...
...
@@ -288,7 +282,7 @@ This is done *either* by pass 3 (for the top-level bindings), *or* by
\begin{code}
rn_mono_binds :: [RenamedSig] -- Signatures attached to this group
-> RdrNameMonoBinds
-> RnMS
s
(RenamedHsBinds, --
-> RnMS (RenamedHsBinds, --
FreeVars) -- Free variables
rn_mono_binds siglist mbinds
...
...
@@ -319,7 +313,7 @@ in case any of them
\begin{code}
flattenMonoBinds :: [RenamedSig] -- Signatures
-> RdrNameMonoBinds
-> RnMS
s
[FlatMonoBindsInfo]
-> RnMS [FlatMonoBindsInfo]
flattenMonoBinds sigs EmptyMonoBinds = returnRn []
...
...
@@ -336,12 +330,11 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn)
let
names_bound_here = mkNameSet (collectPatBinders pat')
sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs
sigs_fvs = foldr sig_fv emptyFVs sigs_for_me
in
rnGRHSs grhss `thenRn` \ (grhss', fvs) ->
returnRn
[(names_bound_here,
fvs `plusFV`
sigs_fvs `plusFV`
pat_fvs,
fvs `plusFV` pat_fvs,
PatMonoBind pat' grhss' locn,
sigs_for_me
)]
...
...
@@ -351,13 +344,12 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn)
lookupBndrRn name `thenRn` \ new_name ->
let
sigs_for_me = sigsForMe (new_name ==) sigs
sigs_fvs = foldr sig_fv emptyFVs sigs_for_me
in
map
AndUnzip
Rn rnMatch matches `thenRn` \ (new_matches, fv
_list
s) ->
map
Fv
Rn rnMatch matches
`thenRn` \ (new_matches, fvs) ->
mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_`
returnRn
[(unitNameSet new_name,
plusFVs fv_lists `plusFV` sigs_
fvs,
fvs,
FunMonoBind new_name inf new_matches locn,
sigs_for_me
)]
...
...
@@ -368,7 +360,7 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn)
declaration. like @rnMonoBinds@ but without dependency analysis.
\begin{code}
rnMethodBinds :: RdrNameMonoBinds -> RnMS
s
(RenamedMonoBinds, FreeVars)
rnMethodBinds :: RdrNameMonoBinds -> RnMS (RenamedMonoBinds, FreeVars)
rnMethodBinds EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs)
...
...
@@ -383,13 +375,13 @@ rnMethodBinds (FunMonoBind name inf matches locn)
lookupGlobalOccRn name `thenRn` \ sel_name ->
-- We use the selector name as the binder
map
AndUnzip
Rn rnMatch matches `thenRn` \ (new_matches, fvs
_s
) ->
map
Fv
Rn rnMatch matches
`thenRn` \ (new_matches, fvs) ->
mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_`
returnRn (FunMonoBind sel_name inf new_matches locn,
plusFVs fvs_
s)
returnRn (FunMonoBind sel_name inf new_matches locn,
fv
s)
rnMethodBinds (PatMonoBind (VarPatIn name) grhss locn)
= pushSrcLocRn locn $
lookupGlobalOccRn name
`thenRn` \ sel_name ->
lookupGlobalOccRn name `thenRn` \ sel_name ->
rnGRHSs grhss `thenRn` \ (grhss', fvs) ->
returnRn (PatMonoBind (VarPatIn sel_name) grhss' locn, fvs)
...
...
@@ -399,18 +391,6 @@ rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind)
\end{code}
\begin{code}
-- If a SPECIALIZE pragma is of the "... = blah" form,
-- then we'd better make sure "blah" is taken into
-- acct in the dependency analysis (or we get an
-- unexpected out-of-scope error)! WDP 95/07
-- This is only necessary for the dependency analysis. The free vars
-- of the types in the signatures is gotten from renameSigs
sig_fv (SpecSig _ _ (Just blah) _) acc = acc `plusFV` unitFV blah
sig_fv _ acc = acc
\end{code}
%************************************************************************
%* *
...
...
@@ -485,13 +465,13 @@ signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code}
renameSigs :: Bool -- True => warn if (required) type signatures are missing.
-> NameSet -- Set of names bound in this group
-> (RdrName -> RnMS
s
Name)
-> (RdrName -> RnMS Name)
-> [RdrNameSig]
-> RnMS
s
([RenamedSig], FreeVars) -- List of Sig constructors
-> RnMS ([RenamedSig], FreeVars) -- List of Sig constructors
renameSigs sigs_required binders lookup_occ_nm sigs
= -- Rename the signatures
map
AndUnzip
Rn (renameSig lookup_occ_nm) sigs `thenRn` \ (sigs', fvs
_s
) ->
map
Fv
Rn (renameSig lookup_occ_nm) sigs `thenRn` \ (sigs', fvs) ->
-- Check for (a) duplicate signatures
-- (b) signatures for things not in this group
...
...
@@ -506,7 +486,7 @@ renameSigs sigs_required binders lookup_occ_nm sigs
mapRn_ dupSigDeclErr dups `thenRn_`
mapRn_ unknownSigErr not_this_group `thenRn_`
mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_`
returnRn (sigs',
plusFVs fvs_
s)
returnRn (sigs',
fv
s)
-- bad ones and all:
-- we need bindings of *some* sort for every name
...
...
@@ -523,38 +503,33 @@ renameSig lookup_occ_nm (Sig v ty src_loc)
= pushSrcLocRn src_loc $
lookup_occ_nm v `thenRn` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) ->
returnRn (Sig new_v new_ty src_loc, fvs)
returnRn (Sig new_v new_ty src_loc, fvs
`addOneFV` new_v
)
renameSig _ (SpecInstSig ty src_loc)
= pushSrcLocRn src_loc $
rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) ->
returnRn (SpecInstSig new_ty src_loc, fvs)
renameSig lookup_occ_nm (SpecSig v ty
using
src_loc)
renameSig lookup_occ_nm (SpecSig v ty src_loc)
= pushSrcLocRn src_loc $
lookup_occ_nm v `thenRn` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs1) ->
rn_using using `thenRn` \ (new_using,fvs2) ->
returnRn (SpecSig new_v new_ty new_using src_loc, fvs1 `plusFV` fvs2)
where
rn_using Nothing = returnRn (Nothing, emptyFVs)
rn_using (Just x) = lookupOccRn x `thenRn` \ new_x ->
returnRn (Just new_x, unitFV new_x)
rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) ->
returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v)
renameSig lookup_occ_nm (InlineSig v src_loc)
= pushSrcLocRn src_loc $
lookup_occ_nm v `thenRn` \ new_v ->
returnRn (InlineSig new_v src_loc,
emptyFVs
)
returnRn (InlineSig new_v src_loc,
unitFV new_v
)
renameSig lookup_occ_nm (FixSig (FixitySig v fix src_loc))
= pushSrcLocRn src_loc $
lookup_occ_nm v `thenRn` \ new_v ->
returnRn (FixSig (FixitySig new_v fix src_loc),
emptyFVs
)
returnRn (FixSig (FixitySig new_v fix src_loc),
unitFV new_v
)
renameSig lookup_occ_nm (NoInlineSig v src_loc)
= pushSrcLocRn src_loc $
lookup_occ_nm v `thenRn` \ new_v ->
returnRn (NoInlineSig new_v src_loc,
emptyFVs
)
returnRn (NoInlineSig new_v src_loc,
unitFV new_v
)
\end{code}
Checking for distinct signatures; oh, so boring
...
...
@@ -565,9 +540,9 @@ cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2
cmp_sig (NoInlineSig n1 _) (NoInlineSig n2 _) = n1 `compare` n2
cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
cmp_sig (SpecSig n1 ty1 _
_)
(SpecSig n2 ty2
_
_)
cmp_sig (SpecSig n1 ty1 _
)
(SpecSig n2 ty2 _)
= -- may have many specialisations for one value;
-- but not ones that are exactly the same...
-- but not ones that are exactly the same...
thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
cmp_sig other_1 other_2 -- Tags *must* be different
...
...
@@ -575,7 +550,7 @@ cmp_sig other_1 other_2 -- Tags *must* be different
| otherwise = GT
sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
sig_tag (SpecSig n1 _
_
_) = ILIT(2)
sig_tag (SpecSig n1 _ _) = ILIT(2)
sig_tag (InlineSig n1 _) = ILIT(3)
sig_tag (NoInlineSig n1 _) = ILIT(4)
sig_tag (SpecInstSig _ _) = ILIT(5)
...
...
@@ -592,8 +567,7 @@ sig_tag _ = panic# "tag(RnBinds)"
\begin{code}
dupSigDeclErr (sig:sigs)
= pushSrcLocRn loc $
addErrRn (sep [ptext SLIT("Duplicate"),
ptext what_it_is <> colon,
addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon,
ppr sig])
where
(what_it_is, loc) = sig_doc sig
...
...
@@ -608,7 +582,7 @@ unknownSigErr sig
sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
sig_doc (SpecSig _ _
_
loc) = (SLIT("SPECIALISE pragma"),loc)
sig_doc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc)
sig_doc (NoInlineSig _ loc) = (SLIT("NOINLINE pragma"),loc)
sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
...
...
ghc/compiler/rename/RnEnv.lhs
View file @
0d8269cc
This diff is collapsed.
Click to expand it.
ghc/compiler/rename/RnExpr.lhs
View file @
0d8269cc
...
...
@@ -11,7 +11,7 @@ free variables.
\begin{code}
module RnExpr (
rnMatch, rnGRHSs, rnPat,
rnMatch, rnGRHSs, rnPat,
rnExpr, rnExprs,
checkPrecMatch
) where
...
...
@@ -25,8 +25,9 @@ import RdrHsSyn
import RnHsSyn
import RnMonad
import RnEnv
import RnIfaces ( lookupFixity )
import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts )
import BasicTypes ( Fixity(..), FixityDirection(..) )
import BasicTypes ( Fixity(..), FixityDirection(..)
, defaultFixity
)
import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR,
ccallableClass_RDR, creturnableClass_RDR,
monadClass_RDR, enumClass_RDR, ordClass_RDR,
...
...
@@ -58,7 +59,7 @@ import Outputable
*********************************************************
\begin{code}
rnPat :: RdrNamePat -> RnMS
s
(RenamedPat, FreeVars)
rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars)
rnPat WildPatIn = returnRn (WildPatIn, emptyFVs)
...
...
@@ -79,9 +80,9 @@ rnPat (SigPatIn pat ty)
doc = text "a pattern type-signature"
rnPat (LitPatIn lit)
= litOccurrence lit `thenRn
_
`
lookupImplicitOccRn eqClass_RDR `thenRn
_
` -- Needed to find equality on pattern
returnRn (LitPatIn lit,
emptyFVs
)
= litOccurrence lit `thenRn`
\ fvs1 ->
lookupImplicitOccRn eqClass_RDR `thenRn`
\ eq ->
-- Needed to find equality on pattern
returnRn (LitPatIn lit,
fvs1 `addOneFV` eq
)
rnPat (LazyPatIn pat)
= rnPat pat `thenRn` \ (pat', fvs) ->
...
...
@@ -94,15 +95,21 @@ rnPat (AsPatIn name pat)
rnPat (ConPatIn con pats)
= lookupOccRn con `thenRn` \ con' ->
map
AndUnzip
Rn rnPat pats `thenRn` \ (patslist, fvs
_s
) ->
returnRn (ConPatIn con' patslist,
plusFVs fvs_
s `addOneFV` con')
map
Fv
Rn rnPat pats `thenRn` \ (patslist, fvs) ->
returnRn (ConPatIn con' patslist,
fv
s `addOneFV` con')
rnPat (ConOpPatIn pat1 con _ pat2)
= rnPat pat1 `thenRn` \ (pat1', fvs1) ->
lookupOccRn con `thenRn` \ con' ->
lookupFixity con' `thenRn` \ fixity ->
rnPat pat2 `thenRn` \ (pat2', fvs2) ->
mkConOpPatRn pat1' con' fixity pat2' `thenRn` \ pat' ->
getModeRn `thenRn` \ mode ->
-- See comments with rnExpr (OpApp ...)
(case mode of
InterfaceMode -> returnRn (ConOpPatIn pat1' con' defaultFixity pat2')