Skip to content

GitLab

Commit 0d8269cc authored by simonpj's avatar simonpj
Browse files

[project @ 1999-05-18 14:56:06 by simonpj] 

msg_rn
parent ab8279d6
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 ( ModuleName, 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 modules
(reverse $10) -- Decls
(reverse $9) -- Local instances
)
}
, ParsedIface {
pi_mod = fromInteger $3, -- Module version
pi_orphan = $4,
pi_exports = $7, -- Exports
pi_usages = $8, -- Usages
pi_insts = $9, -- Local instances
pi_decls = $10, -- Decls
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 :: { ModuleName }
: 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.
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,
failUnboundNameErrRn
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn,
warnUnusedLocalBinds, mapFvRn,
FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV,
unknownNameErr
)
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, lookupFM )
import FiniteMap ( lookupFM, listToFM )
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 = addListToFM emptyFM (map (\ x -> (nameOccName x,x)) new_mbinders)
binder_occ_fm = listToFM [(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
mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
mapFvRn 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
mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fvs_s) ->
mapFvRn 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, fvs)
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
mapAndUnzipRn (renameSig lookup_occ_nm) sigs `thenRn` \ (sigs', fvs_s) ->
mapFvRn (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', fvs)
-- 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.
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' ->
mapAndUnzipRn rnPat pats `thenRn` \ (patslist, fvs_s) ->
returnRn (ConPatIn con' patslist, plusFVs fvs_s `addOneFV` con')
mapFvRn rnPat pats `thenRn` \ (patslist, fvs) ->
returnRn (ConPatIn con' patslist, fvs `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')
SourceMode -> lookupFixity con' `thenRn` \ fixity ->