-- others:
import SpecEnv ( SpecEnv )
import RdrHsSyn ( RdrName(..), varQual, tcQual, qual )
+import BasicTypes ( IfaceFlavour )
import Id ( GenId, SYN_IE(Id) )
-import Name ( Name, OccName(..), DefnInfo(..), Provenance(..),
+import Name ( Name, OccName(..), Provenance(..),
getName, mkGlobalName, modAndOcc )
import Class ( Class(..), GenClass, classKey )
import TyCon ( tyConDataCons, mkFunTyCon, TyCon )
\begin{code}
mkKnownKeyGlobal :: (RdrName, Unique) -> Name
-mkKnownKeyGlobal (Qual mod occ, uniq) = mkGlobalName uniq mod occ VanillaDefn Implicit
+mkKnownKeyGlobal (Qual mod occ hif, uniq)
+ = mkGlobalName uniq mod occ (Implicit hif)
allClass_NAME = mkKnownKeyGlobal (allClass_RDR, allClassKey)
main_NAME = mkKnownKeyGlobal (main_RDR, mainKey)
id_info
= noIdInfo
`addArityInfo` exactArity 1
- `addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing
+ `addStrictnessInfo` mkStrictnessInfo [WwStrict] False
`addArgUsageInfo` mkArgUsageInfo [ArgUsage 1]
-- ABSOLUTELY NO UNFOLDING, e.g.: (mk_inline_unfolding run_ST_template)
-- see example below
= pcMiscPrelId buildIdKey gHC_ERR SLIT("build") buildTy
((((noIdInfo
{-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-})
- `addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing)
+ `addStrictnessInfo` mkStrictnessInfo [WwStrict] False)
`addArgUsageInfo` mkArgUsageInfo [ArgUsage 2])
`addSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
-- cheating, but since _build never actually exists ...
= pcMiscPrelId augmentIdKey gHC_ERR SLIT("augment") augmentTy
(((noIdInfo
{-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-})
- `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
+ `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
`addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
-- cheating, but since _augment never actually exists ...
where
idInfo = (((((noIdInfo
{-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-})
- `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
+ `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
`addArityInfo` exactArity 3)
`addUpdateInfo` mkUpdateInfo [2,2,1])
`addSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
idInfo = (((((noIdInfo
{-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-})
- `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
+ `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
`addArityInfo` exactArity 3)
`addUpdateInfo` mkUpdateInfo [2,2,1])
`addSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
(mkSigmaTy [alphaTyVar] []
(mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
idInfo = (((noIdInfo
- `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
+ `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
`addArityInfo` exactArity 2)
`addUpdateInfo` mkUpdateInfo [1,2])
-}
IMP_Ubiq()
import Type
+import TyVar ( alphaTyVar )
import CmdLineOpts ( opt_PprUserLength )
import CoreSyn
import Literal
SYN_IE(Id)
)
import IdInfo ( ArityInfo, exactArity )
-import Class ( GenClass, GenClassOp, classSig, classOpLocalType )
+import Class ( GenClass, classBigSig, classDictArgTys )
import TyCon ( isNewTyCon, isDataTyCon, isAlgTyCon )
import FieldLabel ( FieldLabel )
import PrelVals ( pAT_ERROR_ID )
\begin{code}
addStandardIdInfo sel_id
| maybeToBool maybe_sc_sel_id
- = sel_id `addIdUnfolding` unfolding
- -- The always-inline thing means we don't need any other IdInfo
+ = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id)
where
maybe_sc_sel_id = isSuperDictSelId_maybe sel_id
- Just (cls, the_sc) = maybe_sc_sel_id
-
- unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
- rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
-
- (tyvar, scs, ops) = classSig cls
- tyvar_ty = mkTyVarTy tyvar
- [dict_id] = mkTemplateLocals [mkDictTy cls tyvar_ty]
- arg_ids = mkTemplateLocals ([mkDictTy sc tyvar_ty | sc <- scs] ++
- map classOpLocalType ops)
- the_arg_id = assoc "StdIdInfoSC" (scs `zip` arg_ids) the_sc
+ Just (cls, _) = maybe_sc_sel_id
addStandardIdInfo sel_id
| maybeToBool maybe_meth_sel_id
- = sel_id `addIdUnfolding` unfolding
- -- The always-inline thing means we don't need any other IdInfo
+ = sel_id `addIdUnfolding` (mk_selector_unfolding cls sel_id)
where
maybe_meth_sel_id = isMethodSelId_maybe sel_id
- Just (cls, the_op) = maybe_meth_sel_id
-
- unfolding = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
- rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
-
- (tyvar, scs, ops) = classSig cls
- n_scs = length scs
- tyvar_ty = mkTyVarTy tyvar
- [dict_id] = mkTemplateLocals [mkDictTy cls tyvar_ty]
- arg_ids = mkTemplateLocals ([mkDictTy sc tyvar_ty | sc <- scs] ++
- map classOpLocalType ops)
-
- the_arg_id = assoc "StdIdInfoMeth" (ops `zip` (drop n_scs arg_ids)) the_op
+ Just cls = maybe_meth_sel_id
\end{code}
there's nothing to do.
\begin{code}
+mk_selector_unfolding clas sel_id
+ = mkUnfolding IWantToBeINLINEd {- Always inline selectors -} rhs
+ -- The always-inline thing means we don't need any other IdInfo
+ where
+ rhs = mk_dict_selector [alphaTyVar] dict_id arg_ids the_arg_id
+ tyvar_ty = mkTyVarTy alphaTyVar
+ [dict_id] = mkTemplateLocals [mkDictTy clas tyvar_ty]
+ arg_tys = classDictArgTys clas tyvar_ty
+ arg_ids = mkTemplateLocals arg_tys
+ the_arg_id = assoc "StdIdInfo:mk_sel" ((sc_sel_ids ++ op_sel_ids) `zip` arg_ids) sel_id
+
+ (_, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
+
mk_dict_selector tyvars dict_id [arg_id] the_arg_id
= mkLam tyvars [dict_id] (Var dict_id)
_exports_
TysWiredIn tupleCon tupleTyCon;
_declarations_
-1 tupleCon _:_ PrelBase.Int -> Id.Id ;;
-1 tupleTyCon _:_ PrelBase.Int -> TyCon.TyCon ;;
+1 tupleCon _:_ BasicTypes.Arity -> Id.Id ;;
+1 tupleTyCon _:_ BasicTypes.Arity -> TyCon.TyCon ;;
#else
import {-# SOURCE #-} Id ( Id, mkDataCon, mkTupleCon, StrictnessMark(..) )
import {-# SOURCE #-} SpecEnv ( SpecEnv, nullSpecEnv )
-import {-# SOURCE #-} Type ( Type )
-import {-# SOURCE #-} TyVar ( TyVar )
#endif
-- friends:
import TysPrim
-- others:
+import FieldLabel () --
import Kind ( mkBoxedTypeKind, mkArrowKind )
-import Name --( mkWiredInTyConName, mkWiredInIdName, mkTupNameStr )
+import Name ( mkWiredInTyConName, mkWiredInIdName )
import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
TyCon, SYN_IE(Arity)
)
-import BasicTypes ( NewOrData(..) )
-import Type ( mkTyConTy, applyTyCon, mkSigmaTy, mkTyVarTys,
+import BasicTypes ( SYN_IE(Module), NewOrData(..) )
+import Type ( SYN_IE(Type), mkTyConTy, applyTyCon, mkSigmaTy, mkTyVarTys,
mkFunTy, mkFunTys, maybeAppTyCon,
GenType(..), SYN_IE(ThetaType), SYN_IE(TauType) )
-import TyVar ( tyVarKind, alphaTyVars, alphaTyVar, betaTyVar )
+import TyVar ( SYN_IE(TyVar), tyVarKind, alphaTyVars, alphaTyVar, betaTyVar )
import Lex ( mkTupNameStr )
import Unique
import Util ( assoc, panic )
import CmdLineOpts ( opt_IgnoreIfacePragmas )
import Demand ( Demand(..) {- instance Read -} )
import UniqFM ( UniqFM, listToUFM, lookupUFM)
-import BasicTypes ( NewOrData(..) )
+import BasicTypes ( NewOrData(..), IfaceFlavour(..) )
#if __GLASGOW_HASKELL__ >= 202
import Maybes ( MaybeErr(..) )
| ITconid FAST_STRING
| ITvarsym FAST_STRING
| ITconsym FAST_STRING
- | ITqvarid (FAST_STRING,FAST_STRING)
- | ITqconid (FAST_STRING,FAST_STRING)
- | ITqvarsym (FAST_STRING,FAST_STRING)
- | ITqconsym (FAST_STRING,FAST_STRING)
+ | ITqvarid (FAST_STRING,FAST_STRING,IfaceFlavour)
+ | ITqconid (FAST_STRING,FAST_STRING,IfaceFlavour)
+ | ITqvarsym (FAST_STRING,FAST_STRING,IfaceFlavour)
+ | ITqconsym (FAST_STRING,FAST_STRING,IfaceFlavour)
| ITidinfo [IfaceToken] -- lazily return the stream of tokens for
-- the info attached to an id.
case expandWhile (is_mod_char) buf of
buf' ->
case currentChar# buf' of
- '.'# ->
+ '.'# -> munch buf' HiFile
+ '!'# -> munch buf' HiBootFile
+ _ -> lex_id2 Nothing buf'
+ where
+ munch buf' hif =
if not (emptyLexeme buf') then
-- _trace ("lex_id: "++(C# (currentChar# (stepOverLexeme buf'))):show (lexemeToFastString buf')) $
case lexemeToFastString buf' of
- l@(FastString u# l# ba#) -> lex_id2 (Just (FastString u# l# ba#))
+ l@(FastString u# l# ba#) -> lex_id2 (Just (FastString u# l# ba#, hif))
(stepOn (stepOverLexeme buf'))
else
lex_id2 Nothing buf'
- _ -> lex_id2 Nothing buf'
+
-- Dealt with the Module.part
lex_id2 module_dot buf =
-}
end_lex_id Nothing token buf = token : lexIface buf
-end_lex_id (Just m) token buf =
+end_lex_id (Just (m,hif)) token buf =
case token of
- ITconid n -> ITqconid (m,n) : lexIface buf
- ITvarid n -> ITqvarid (m,n) : lexIface buf
- ITconsym n -> ITqconsym (m,n) : lexIface buf
- ITvarsym n -> ITqvarsym (m,n) : lexIface buf
- ITbang -> ITqvarsym (m,SLIT("!")) : lexIface buf
- _ -> ITunknown (show token) : lexIface buf
+ ITconid n -> ITqconid (m,n,hif) : lexIface buf
+ ITvarid n -> ITqvarid (m,n,hif) : lexIface buf
+ ITconsym n -> ITqconsym (m,n,hif) : lexIface buf
+ ITvarsym n -> ITqvarsym (m,n,hif) : lexIface buf
+ ITbang -> ITqvarsym (m,SLIT("!"),hif) : lexIface buf
+ _ -> ITunknown (show token) : lexIface buf
------------
ifaceKeywordsFM :: UniqFM IfaceToken
import HsSyn
import RdrHsSyn
+import BasicTypes ( IfaceFlavour )
import Util ( panic )
import SrcLoc ( SrcLoc )
= [ Sig v poly_ty src_loc | v <- vars ]
cvClassOpSig (RdrTySig vars poly_ty src_loc)
- = [ ClassOpSig v v poly_ty src_loc | v <- vars ]
+ = [ ClassOpSig v Nothing poly_ty src_loc | v <- vars ]
cvInstDeclSig (RdrSpecValSig sigs) = sigs
cvInstDeclSig (RdrInlineValSig sig) = [ sig ]
extractHsTyVars,
RdrName(..),
- qual, varQual, tcQual, varUnqual,
+ qual, varQual, tcQual, varUnqual, lexVarQual, lexTcQual,
dummyRdrVarName, dummyRdrTcName,
isUnqual, isQual,
showRdr, rdrNameOcc, ieOcc,
import HsSyn
import Lex
import PrelMods ( pRELUDE )
-import BasicTypes ( Module(..), NewOrData )
+import BasicTypes ( Module(..), NewOrData, IfaceFlavour(..) )
import Name ( ExportFlag(..), pprModule,
OccName(..), pprOccName,
prefixOccName, SYN_IE(NamedThing) )
where
locals = map getTyVarName tvs
- insert (Qual _ _) acc = acc
+ insert (Qual _ _ _) acc = acc
insert (Unqual (TCOcc _)) acc = acc
insert other acc | other `elem` acc = acc
| otherwise = other : acc
\begin{code}
data RdrName
= Unqual OccName
- | Qual Module OccName
+ | Qual Module OccName IfaceFlavour -- HiBootFile for M!.t (interface files only),
+ -- HiFile for the common M.t
-qual (m,n) = Qual m n
-tcQual (m,n) = Qual m (TCOcc n)
-varQual (m,n) = Qual m (VarOcc n)
+qual (m,n) = Qual m n HiFile
+tcQual (m,n) = Qual m (TCOcc n) HiFile
+varQual (m,n) = Qual m (VarOcc n) HiFile
+
+lexTcQual (m,n,hif) = Qual m (TCOcc n) hif
+lexVarQual (m,n,hif) = Qual m (VarOcc n) hif
-- This guy is used by the reader when HsSyn has a slot for
-- an implicit name that's going to be filled in by
varUnqual n = Unqual (VarOcc n)
-isUnqual (Unqual _) = True
-isUnqual (Qual _ _) = False
+isUnqual (Unqual _) = True
+isUnqual (Qual _ _ _) = False
-isQual (Unqual _) = False
-isQual (Qual _ _) = True
+isQual (Unqual _) = False
+isQual (Qual _ _ _) = True
-- Used for adding a prefix to a RdrName
prefixRdrName :: FAST_STRING -> RdrName -> RdrName
-prefixRdrName prefix (Qual m n) = Qual m (prefixOccName prefix n)
-prefixRdrName prefix (Unqual n) = Unqual (prefixOccName prefix n)
+prefixRdrName prefix (Qual m n hif) = Qual m (prefixOccName prefix n) hif
+prefixRdrName prefix (Unqual n) = Unqual (prefixOccName prefix n)
-cmpRdr (Unqual n1) (Unqual n2) = n1 `cmp` n2
-cmpRdr (Unqual n1) (Qual m2 n2) = LT_
-cmpRdr (Qual m1 n1) (Unqual n2) = GT_
-cmpRdr (Qual m1 n1) (Qual m2 n2) = (n1 `cmp` n2) `thenCmp` (_CMP_STRING_ m1 m2)
+cmpRdr (Unqual n1) (Unqual n2) = n1 `cmp` n2
+cmpRdr (Unqual n1) (Qual m2 n2 _) = LT_
+cmpRdr (Qual m1 n1 _) (Unqual n2) = GT_
+cmpRdr (Qual m1 n1 _) (Qual m2 n2 _) = (n1 `cmp` n2) `thenCmp` (_CMP_STRING_ m1 m2)
-- always compare module-names *second*
rdrNameOcc :: RdrName -> OccName
-rdrNameOcc (Unqual occ) = occ
-rdrNameOcc (Qual _ occ) = occ
+rdrNameOcc (Unqual occ) = occ
+rdrNameOcc (Qual _ occ _) = occ
ieOcc :: RdrNameIE -> OccName
ieOcc ie = rdrNameOcc (ieName ie)
cmp = cmpRdr
instance Outputable RdrName where
- ppr sty (Unqual n) = pprQuote sty $ \ sty -> pprOccName sty n
- ppr sty (Qual m n) = pprQuote sty $ \ sty -> hcat [pprModule sty m, char '.', pprOccName sty n]
+ ppr sty (Unqual n) = pprQuote sty $ \ sty -> pprOccName sty n
+ ppr sty (Qual m n _) = pprQuote sty $ \ sty -> hcat [pprModule sty m, char '.', pprOccName sty n]
instance NamedThing RdrName where -- Just so that pretty-printing of expressions works
getOccName = rdrNameOcc
import HsTypes ( HsTyVar(..) )
import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
import RdrHsSyn
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
+import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
import PrefixToHs
import CmdLineOpts ( opt_PprUserLength )
wlkQid mk_occ_name (U_noqual name)
= returnUgn (Unqual (mk_occ_name name))
wlkQid mk_occ_name (U_aqual mod name)
- = returnUgn (Qual mod (mk_occ_name name))
+ = returnUgn (Qual mod (mk_occ_name name) HiFile)
-- I don't understand this one! It is what shows up when we meet (), [], or (,,,).
wlkQid mk_occ_name (U_gid n name)
mkSrcLocUgn srcline $ \ src_loc ->
wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
- returnUgn (ImportDecl imod (cvFlag iqual) (cvFlag isrc) maybe_as maybe_spec src_loc)
+ returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc)
where
rd_spec pt = rdU_either pt `thenUgn` \ spec ->
case spec of
returnUgn (False, ents)
U_right pt -> rdEntities pt `thenUgn` \ ents ->
returnUgn (True, ents)
+
+cvIfaceFlavour 0 = HiFile -- No pragam
+cvIfaceFlavour 1 = HiBootFile -- {-# SOURCE #-}
\end{code}
\begin{code}
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
-import HsDecls ( HsIdInfo(..) )
+import HsDecls ( HsIdInfo(..), HsStrictnessInfo )
import HsTypes ( mkHsForAllTy )
import HsCore
import Literal
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), Version(..) )
+import BasicTypes ( IfaceFlavour(..), Fixity(..), FixityDirection(..), NewOrData(..), Version(..) )
import HsPragmas ( noDataPragmas, noClassPragmas )
import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
import IdInfo ( ArgUsageInfo, FBTypeInfo )
import Lex
import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
- SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
+ SYN_IE(RdrNamePragma), SYN_IE(ExportItem), SYN_IE(RdrAvailInfo), GenAvailInfo(..)
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
| module_stuff_pair module_stuff_pairs { $1 : $2 }
module_stuff_pair :: { ImportVersion OccName }
-module_stuff_pair : mod_name INTEGER DCOLON name_version_pairs SEMI
- { ($1, fromInteger $2, $4) }
+module_stuff_pair : mod_name opt_bang INTEGER DCOLON name_version_pairs SEMI
+ { ($1, $2, fromInteger $3, $5) }
versions_part :: { [LocalVersion OccName] }
versions_part : VERSIONS_PART name_version_pairs { $2 }
export_items :: { [ExportItem] }
export_items : { [] }
- | mod_name entities SEMI export_items { ($1,$2) : $4 }
+ | opt_bang mod_name entities SEMI export_items { ($2,$1,$3) : $5 }
-entities :: { [(OccName, [OccName])] }
+opt_bang :: { IfaceFlavour }
+opt_bang : { HiFile }
+ | BANG { HiBootFile }
+
+entities :: { [RdrAvailInfo] }
entities : { [] }
| entity entities { $1 : $2 }
-entity :: { (OccName, [OccName]) }
-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 -} }
+entity :: { RdrAvailInfo }
+entity : entity_occ { if isTCOcc $1
+ then AvailTC $1 [$1]
+ else Avail $1 }
+ | entity_occ stuff_inside { AvailTC $1 ($1:$2) }
+ | entity_occ VBAR stuff_inside { AvailTC $1 $3 }
stuff_inside :: { [OccName] }
-stuff_inside : OPAREN val_occs1 CPAREN { $2
+stuff_inside : OPAREN val_occs1 CPAREN { $2
--------------------------------------------------------------------------
- }
+ }
inst_modules_part :: { [Module] }
inst_modules_part : { [] }
| csig SEMI csigs1 { $1 : $3 }
csig :: { RdrNameSig }
-csig : var_name DCOLON type { ClassOpSig $1 $1 $3 mkIfaceSrcLoc
+csig : var_name DCOLON type { ClassOpSig $1 Nothing $3 mkIfaceSrcLoc }
+ | var_name EQUAL DCOLON type { ClassOpSig $1 (Just (error "Un-filled-in default method"))
+ $4 mkIfaceSrcLoc
----------------------------------------------------------------
}
qvar_name :: { RdrName }
- : QVARID { varQual $1 }
- | QVARSYM { varQual $1 }
+ : QVARID { lexVarQual $1 }
+ | QVARSYM { lexVarQual $1 }
var_name :: { RdrName }
var_name : var_occ { Unqual $1 }
| qvar_name { $1 }
qdata_name :: { RdrName }
-qdata_name : QCONID { varQual $1 }
- | QCONSYM { varQual $1 }
+qdata_name : QCONID { lexVarQual $1 }
+ | QCONSYM { lexVarQual $1 }
data_name :: { RdrName }
data_name : CONID { Unqual (VarOcc $1) }
tc_name :: { RdrName }
tc_name : tc_occ { Unqual $1 }
- | QCONID { tcQual $1 }
+ | QCONID { lexTcQual $1 }
tv_name :: { RdrName }
tv_name : VARID { Unqual (TvOcc $1) }
+ | VARSYM { Unqual (TvOcc $1) {- Allow $t2 as a tyvar -} }
tv_names :: { [RdrName] }
: { [] }
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
-import HsDecls ( HsIdInfo(..) )
+import HsDecls ( HsIdInfo(..), HsStrictnessInfo )
import HsTypes ( mkHsForAllTy )
import HsCore
import Literal
import Lex
import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
- SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
+ SYN_IE(RdrNamePragma), SYN_IE(ExportItem), GenAvailInfo
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
tv_name :: { RdrName }
tv_name : VARID { Unqual (TvOcc $1) }
+ | VARSYM { Unqual (TvOcc $1) {- Allow $t2 as a tyvar -} }
tv_names :: { [RdrName] }
: { [] }
| tv_name tv_names { $1 : $2 }
tc_name :: { RdrName }
-tc_name : QCONID { tcQual $1 }
+tc_name : QCONID { lexTcQual $1 }
| CONID { Unqual (TCOcc $1) }
| CONSYM { Unqual (TCOcc $1) }
| OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) }
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
-import HsDecls ( HsIdInfo(..) )
+import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
import HsTypes ( mkHsForAllTy )
import HsCore
import Literal
import Lex
import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
- SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
+ SYN_IE(RdrNamePragma), SYN_IE(ExportItem), GenAvailInfo
)
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
id_info_item :: { HsIdInfo RdrName }
id_info_item : ARITY_PART arity_info { HsArity $2 }
| STRICT_PART strict_info { HsStrictness $2 }
- | BOTTOM { HsStrictness mkBottomStrictnessInfo }
+ | BOTTOM { HsStrictness HsBottom }
| UNFOLD_PART core_expr { HsUnfold $1 $2 }
arity_info :: { ArityInfo }
arity_info : INTEGER { exactArity (fromInteger $1) }
-strict_info :: { StrictnessInfo RdrName }
-strict_info : DEMAND any_var_name OCURLY data_names CCURLY { mkStrictnessInfo $1 (Just ($2,$4)) }
- | DEMAND any_var_name { mkStrictnessInfo $1 (Just ($2,[])) }
- | DEMAND { mkStrictnessInfo $1 Nothing }
+strict_info :: { HsStrictnessInfo RdrName }
+strict_info : DEMAND any_var_name OCURLY data_names CCURLY { HsStrictnessInfo $1 (Just ($2,$4)) }
+ | DEMAND any_var_name { HsStrictnessInfo $1 (Just ($2,[])) }
+ | DEMAND { HsStrictnessInfo $1 Nothing }
core_expr :: { UfExpr RdrName }
core_expr : any_var_name { UfVar $1 }
| BANG { VarOcc SLIT("!") {-sigh, double-sigh-} }
data_name :: { RdrName }
-data_name : QCONID { varQual $1 }
- | QCONSYM { varQual $1 }
+data_name : QCONID { lexVarQual $1 }
+ | QCONSYM { lexVarQual $1 }
| CONID { Unqual (VarOcc $1) }
| CONSYM { Unqual (VarOcc $1) }
qvar_name :: { RdrName }
- : QVARID { varQual $1 }
- | QVARSYM { varQual $1 }
+ : QVARID { lexVarQual $1 }
+ | QVARSYM { lexVarQual $1 }
var_name :: { RdrName }
var_name : var_occ { Unqual $1 }
tv_name :: { RdrName }
tv_name : VARID { Unqual (TvOcc $1) }
+ | VARSYM { Unqual (TvOcc $1) {- Allow $t2 as a tyvar -} }
tv_names :: { [RdrName] }
: { [] }
| tv_name tv_names { $1 : $2 }
tc_name :: { RdrName }
-tc_name : QCONID { tcQual $1 }
+tc_name : QCONID { lexTcQual $1 }
| CONID { Unqual (TCOcc $1) }
| CONSYM { Unqual (TCOcc $1) }
| OPAREN RARROW CPAREN { Unqual (TCOcc SLIT("->")) }
-- An unresolved name
Just name
-> -- Slurp its declaration, if any
- traceRn (sep [ptext SLIT("Considering"), ppr PprDebug name]) `thenRn_`
+-- traceRn (sep [ptext SLIT("Considering"), ppr PprDebug name]) `thenRn_`
importDecl name necessity `thenRn` \ maybe_decl ->
case maybe_decl of
rdrNameOcc, ieOcc, isQual, qual
)
import HsTypes ( getTyVarName, replaceTyVarName )
-import BasicTypes ( Fixity(..), FixityDirection(..) )
+import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..), pprModule )
import RnMonad
-import Name ( Name, OccName(..), Provenance(..), DefnInfo(..), ExportFlag(..), NamedThing(..),
+import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..),
occNameString, occNameFlavour,
SYN_IE(NameSet), emptyNameSet, addListToNameSet,
mkLocalName, mkGlobalName, modAndOcc, isLocallyDefinedName,
import TyCon ( TyCon )
import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon )
import FiniteMap
-import Outputable
import Unique ( Unique, Uniquable(..), unboundKey )
import UniqFM ( listToUFM, plusUFM_C )
import Maybes ( maybeToBool )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
import Pretty
-import Outputable ( PprStyle(..) )
-import Util --( panic, removeDups, pprTrace, assertPanic )
+import Outputable ( Outputable(..), PprStyle(..) )
+import Util ( Ord3(..), panic, removeDups, pprTrace, assertPanic )
\end{code}
%*********************************************************
\begin{code}
-newGlobalName :: Module -> OccName -> RnM s d Name
-newGlobalName mod occ
+newGlobalName :: Module -> OccName -> IfaceFlavour -> RnM s d Name
+newGlobalName mod occ iface_flavour
= -- First check the cache
getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
let key = (mod,occ) in
Just name -> returnRn name
-- Miss in the cache, so build a new original name,
- -- and put it in the cache
+ -- And put it in the cache
Nothing ->
let
(us', us1) = splitUniqSupply us
uniq = getUnique us1
- name = mkGlobalName uniq mod occ VanillaDefn Implicit
+ name = mkGlobalName uniq mod occ (Implicit iface_flavour)
cache' = addToFM cache key name
in
setNameSupplyRn (us', inst_ns, cache') `thenRn_`
key = (mod,occ)
new_name = case lookupFM cache key of
Just name -> setNameProvenance name provenance
- other -> mkGlobalName uniq mod occ VanillaDefn provenance
+ other -> mkGlobalName uniq mod occ provenance
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
returnRn new_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.
newDfunName (Just n) src_loc -- Imported ones have "Just n"
= getModuleRn `thenRn` \ mod_name ->
- newGlobalName mod_name (rdrNameOcc n)
+ newGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -}
newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name]
returnRn ()
where
(_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `cmp` n2) rdr_names_w_loc
+
+
+-- Yuk!
+ifaceFlavour name = case getNameProvenance name of
+ Imported _ _ hif -> hif
+ Implicit hif -> hif
+ other -> HiFile -- Shouldn't happen
\end{code}
InterfaceMode _ ->
case rdr_name of
- Qual mod_name occ -> newGlobalName mod_name occ
+ Qual mod_name occ hif -> newGlobalName mod_name occ hif
-- An Unqual is allowed; interface files contain
-- unqualified names for locally-defined things, such as
-- constructors of a data type.
Unqual occ -> getModuleRn `thenRn ` \ mod_name ->
- newGlobalName mod_name occ
+ newGlobalName mod_name occ HiFile
lookupBndrRn rdr_name
-- The name cache should have the correct provenance, though.
lookupImplicitOccRn :: RdrName -> RnMS s Name
-lookupImplicitOccRn (Qual mod occ)
- = newGlobalName mod occ `thenRn` \ name ->
+lookupImplicitOccRn (Qual mod occ hif)
+ = newGlobalName mod occ hif `thenRn` \ name ->
addOccurrenceName name
addImplicitOccRn :: Name -> RnMS s Name
-> addErrRn (nameClashErr (rdr_name, (name, name2))) `thenRn_`
returnRn env
- Nothing -> returnRn (addToFM env rdr_name name)
+ other -> returnRn (addToFM env rdr_name name)
-conflicting_name n1 n2 = (n1 /= n2) || (isLocallyDefinedName n1 && isLocallyDefinedName n2)
+conflicting_name n1 n2 = (n1 /= n2) ||
+ (isLocallyDefinedName n1 && isLocallyDefinedName n2)
-- We complain of a conflict if one RdrName maps to two different Names,
-- OR if one RdrName maps to the same *locally-defined* Name. The latter
-- case is to catch two separate, local definitions of the same thing.
#endif
import Id ( GenId, SYN_IE(Id) )
-import BasicTypes ( NewOrData )
+import BasicTypes ( NewOrData, IfaceFlavour )
import Name ( Name )
import Outputable ( PprStyle(..), Outputable(..){-instance * []-} )
import PprType ( GenType, GenTyVar, TyCon )
IE(..), hsDeclName
)
import HsPragmas ( noGenPragmas )
-import BasicTypes ( SYN_IE(Version), NewOrData(..) )
+import BasicTypes ( SYN_IE(Version), NewOrData(..), IfaceFlavour(..) )
import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), SYN_IE(RdrNameTyDecl),
RdrName, rdrNameOcc
)
-import RnEnv ( newGlobalName, addImplicitOccsRn,
+import RnEnv ( newGlobalName, addImplicitOccsRn, ifaceFlavour,
availName, availNames, addAvailToNameSet, pprAvail
)
import RnSource ( rnHsSigType )
getRnStats all_decls
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers_map export_envs decls_fm all_names imp_names (unslurped_insts,_) deferred_data_decls inst_mods = ifaces
- n_mods = sizeFM mod_vers_map
+ Ifaces this_mod mod_map decls_fm all_names imp_names (unslurped_insts,_) deferred_data_decls inst_mods = ifaces
+ n_mods = sizeFM mod_map
decls_imported = filter is_imported_decl all_decls
decls_read = [decl | (name, (_, avail, decl)) <- fmToList decls_fm,
%*********************************************************
\begin{code}
-loadInterface :: Doc -> Module -> Bool -> RnMG Ifaces
+loadInterface :: Doc -> Module -> IfaceFlavour -> RnMG Ifaces
loadInterface doc_str load_mod as_source
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers_map export_envs decls
+ Ifaces this_mod mod_map decls
all_names imp_names (insts, tycls_names)
deferred_data_decls inst_mods = ifaces
in
-- CHECK WHETHER WE HAVE IT ALREADY
- if maybeToBool (lookupFM export_envs load_mod)
- then
- returnRn ifaces -- Already in the cache; don't re-read it
- else
+ case lookupFM mod_map load_mod of {
+ Just (hif, _, _, _) | hif `as_good_as` as_source
+ -> -- Already in the cache; don't re-read it
+ returnRn ifaces ;
+ other ->
-- READ THE MODULE IN
- findAndReadIface doc_str load_mod `thenRn` \ read_result ->
+ findAndReadIface doc_str load_mod as_source `thenRn` \ read_result ->
case read_result of {
-- Check for not found
Nothing -> -- Not found, so add an empty export env to the Ifaces map
-- so that we don't look again
let
- 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, tycls_names) deferred_data_decls inst_mods
+ new_mod_map = addToFM mod_map load_mod (HiFile, 0, [],[])
+ new_ifaces = Ifaces this_mod new_mod_map
+ decls all_names imp_names (insts, tycls_names)
+ deferred_data_decls inst_mods
in
setIfacesRn new_ifaces `thenRn_`
failWithRn new_ifaces (noIfaceErr load_mod) ;
Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs rd_decls rd_insts) ->
-- LOAD IT INTO Ifaces
- mapRn loadExport exports `thenRn` \ avails_s ->
+ mapRn (loadExport as_source) exports `thenRn` \ avails_s ->
foldlRn (loadDecl load_mod as_source) decls rd_decls `thenRn` \ new_decls ->
foldlRn (loadInstDecl load_mod) insts rd_insts `thenRn` \ new_insts ->
let
- export_env = (concat avails_s, fixs)
+ mod_details = (as_source, mod_vers, concat avails_s, fixs)
-- Exclude this module from the "special-inst" modules
new_inst_mods = inst_mods `unionLists` (filter (/= this_mod) rd_inst_mods)
new_ifaces = Ifaces this_mod
- (addToFM mod_vers_map load_mod mod_vers)
- (addToFM export_envs load_mod export_env)
+ (addToFM mod_map load_mod mod_details)
new_decls
all_names imp_names
(new_insts, tycls_names)
in
setIfacesRn new_ifaces `thenRn_`
returnRn new_ifaces
- }
+ }}
+
+as_good_as HiFile any = True
+as_good_as any HiBootFile = True
+as_good_as _ _ = False
+
-loadExport :: ExportItem -> RnMG [AvailInfo]
-loadExport (mod, entities)
+loadExport :: IfaceFlavour -> ExportItem -> RnMG [AvailInfo]
+loadExport as_source (mod, hif, entities)
= mapRn load_entity entities
where
- new_name occ = newGlobalName mod occ
+ new_name occ = newGlobalName mod occ hif
--- 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)
+ load_entity (Avail occ)
+ = new_name occ `thenRn` \ name ->
+ returnRn (Avail name)
+ load_entity (AvailTC occ occs)
= new_name occ `thenRn` \ name ->
- if null occs then
- returnRn (Avail name)
- else
- mapRn new_name occs `thenRn` \ names ->
- returnRn (AvailTC name names)
+ mapRn new_name occs `thenRn` \ names ->
+ returnRn (AvailTC name names)
loadDecl :: Module
- -> Bool
+ -> IfaceFlavour
-> DeclsMap
-> (Version, RdrNameHsDecl)
-> RnMG DeclsMap
-}
decl' =
case decl of
- SigD (IfaceSig name tp ls loc) | as_source || opt_IgnoreIfacePragmas ->
+ SigD (IfaceSig name tp ls loc) | from_hi_boot || opt_IgnoreIfacePragmas ->
SigD (IfaceSig name tp [] loc)
_ -> decl
- new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name)
+ new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name) as_source
+ from_hi_boot = case as_source of
+ HiBootFile -> True
+ other -> False
loadInstDecl :: Module
-> Bag IfaceInst
\begin{code}
checkUpToDate :: Module -> RnMG Bool -- True <=> no need to recompile
checkUpToDate mod_name
- = findAndReadIface doc_str mod_name `thenRn` \ read_result ->
+ = findAndReadIface doc_str mod_name HiFile `thenRn` \ read_result ->
+
+ -- CHECK WHETHER WE HAVE IT ALREADY
case read_result of
Nothing -> -- Old interface file not found, so we'd better bail out
traceRn (sep [ptext SLIT("Didnt find old iface"),
checkModUsage [] = returnRn True -- Yes! Everything is up to date!
-checkModUsage ((mod, old_mod_vers, old_local_vers) : rest)
- = loadInterface doc_str mod False{-not as source-} `thenRn` \ ifaces ->
+checkModUsage ((mod, hif, old_mod_vers, old_local_vers) : rest)
+ = loadInterface doc_str mod hif `thenRn` \ ifaces ->
let
- Ifaces _ mod_vers _ decls _ _ _ _ _ = ifaces
- maybe_new_mod_vers = lookupFM mod_vers mod
- Just new_mod_vers = maybe_new_mod_vers
+ Ifaces _ mod_map decls _ _ _ _ _ = ifaces
+ maybe_new_mod_vers = lookupFM mod_map mod
+ Just (_, new_mod_vers, _, _) = maybe_new_mod_vers
in
-- If we can't find a version number for the old module then
-- bail out saying things aren't up to date
if not (maybeToBool maybe_new_mod_vers) then
+ traceRn (sep [ptext SLIT("Can't find version number for module"), pprModule PprDebug mod]) `thenRn_`
returnRn False
else
= returnRn True -- Yes! All up to date!
checkEntityUsage mod decls ((occ_name,old_vers) : rest)
- = newGlobalName mod occ_name `thenRn` \ name ->
+ = newGlobalName mod occ_name HiFile {- ?? -} `thenRn` \ name ->
case lookupFM decls name of
Nothing -> -- We used it before, but it ain't there now
importDecl name necessity
= checkSlurped name `thenRn` \ already_slurped ->
if already_slurped then
- traceRn (sep [text "Already slurped:", ppr PprDebug name]) `thenRn_`
+-- traceRn (sep [text "Already slurped:", ppr PprDebug name]) `thenRn_`
returnRn Nothing -- Already dealt with
else
if isWiredInName name then
else
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod _ _ _ _ _ _ _ _ = ifaces
+ Ifaces this_mod _ _ _ _ _ _ _ = ifaces
mod = nameModule name
in
if mod == this_mod then -- Don't bring in decls from
\begin{code}
getNonWiredInDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl)
getNonWiredInDecl needed_name necessity
- = traceRn doc_str `thenRn_`
- loadInterface doc_str mod False{-not as source -} `thenRn` \ (Ifaces _ _ _ decls _ _ _ _ _) ->
+ = traceRn doc_str `thenRn_`
+ loadInterface doc_str mod (ifaceFlavour needed_name) `thenRn` \ (Ifaces _ _ decls _ _ _ _ _) ->
case lookupFM decls needed_name of
-- Special case for data/newtype type declarations
is_data_or_newtype (TyData _ _ _ _ _ _ _ _) = True
is_data_or_newtype other = False
+
\end{code}
@getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
(if not main_is_tc || mod == gHC__ then
returnRn ()
else
- loadInterface doc_str mod False{-not as source-} `thenRn_`
+ loadInterface doc_str mod (ifaceFlavour main_name) `thenRn_`
returnRn ()
) `thenRn_`
get_wired_id id
- = addImplicitOccsRn (nameSetToList id_mentioned) `thenRn_`
+ = addImplicitOccsRn id_mentions `thenRn_`
returnRn (Avail (getName id))
where
- id_mentioned = namesOfType (idType id)
+ id_mentions = nameSetToList (namesOfType ty)
+ ty = idType id
get_wired_tycon tycon
| isSynTyCon tycon
%*********************************************************
\begin{code}
-getInterfaceExports :: Module -> Bool -> RnMG (Avails, [(OccName,Fixity)])
+getInterfaceExports :: Module -> IfaceFlavour -> RnMG (Avails, [(OccName,Fixity)])
getInterfaceExports mod as_source
- = loadInterface doc_str mod as_source `thenRn` \ (Ifaces _ _ export_envs _ _ _ _ _ _) ->
- case lookupFM export_envs mod of
+ = loadInterface doc_str mod as_source `thenRn` \ (Ifaces _ mod_map _ _ _ _ _ _) ->
+ case lookupFM mod_map mod of
Nothing -> -- Not there; it must be that the interface file wasn't found;
-- the error will have been reported already.
-- (Actually loadInterface should put the empty export env in there
-- anyway, but this does no harm.)
returnRn ([],[])
- Just stuff -> returnRn stuff
+ Just (_, _, avails, fixities) -> returnRn (avails, fixities)
where
doc_str = sep [pprModule PprDebug mod, ptext SLIT("is directly imported")]
\end{code}
= -- Need the type constructor; so put it in the deferred set for now
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
- new_ifaces = Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods
+ Ifaces this_mod mod_map decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
+ new_ifaces = Ifaces this_mod mod_map decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods
no_constr_ty_decl = TyData new_or_data [] tycon tyvars [] derivings pragmas src_loc
new_deferred_data_decls = addToFM deferred_data_decls tycon_name no_constr_ty_decl
= -- Need a data constructor, so delete the data decl from the deferred set if it's there
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
- new_ifaces = Ifaces this_mod mod_vers_map export_envs decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods
+ Ifaces this_mod mod_map decls_fm slurped_names imp_names unslurped_insts deferred_data_decls inst_mods = ifaces
+ new_ifaces = Ifaces this_mod mod_map decls_fm slurped_names imp_names unslurped_insts new_deferred_data_decls inst_mods
new_deferred_data_decls = delFromFM deferred_data_decls tycon_name
in
\begin{code}
getDeferredDataDecls :: RnMG [(Name, RdrNameTyDecl)]
getDeferredDataDecls
- = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ _ _ _ deferred_data_decls _) ->
+ = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ _ _ deferred_data_decls _) ->
let
deferred_list = fmToList deferred_data_decls
trace_msg = hang (text "Slurping abstract data/newtype decls for: ")
-- removing them from the bag kept in Ifaces
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers export_envs decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
+ Ifaces this_mod mod_map decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
-- An instance decl is ungated if all its gates have been slurped
select_ungated :: IfaceInst -- A gated inst decl
(un_gated_insts, still_gated_insts) = foldrBag select_ungated ([], []) insts
- new_ifaces = Ifaces this_mod mod_vers export_envs decls slurped_names imp_names
+ new_ifaces = Ifaces this_mod mod_map decls slurped_names imp_names
((listToBag still_gated_insts), tycls_names)
-- NB: don't throw away tycls_names; we may comre across more instance decls
deferred_data_decls
setIfacesRn new_ifaces `thenRn_`
returnRn un_gated_insts
where
- load_it mod = loadInterface (doc_str mod) mod False{- not as source-}
+ load_it mod = loadInterface (doc_str mod) mod HiFile
doc_str mod = sep [pprModule PprDebug mod, ptext SLIT("is a special-instance module")]
getSpecialInstModules
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces _ _ _ _ _ _ _ _ inst_mods = ifaces
+ Ifaces _ _ _ _ _ _ _ inst_mods = ifaces
in
returnRn inst_mods
\end{code}
getImportVersions this_mod exports
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces _ mod_versions_map _ _ _ imp_names _ _ _ = ifaces
- mod_version mod = expectJust "import_versions" (lookupFM mod_versions_map mod)
+ Ifaces _ mod_map _ _ imp_names _ _ _ = ifaces
-- mv_map groups together all the things imported from a particular module.
mv_map, mv_map_mod :: FiniteMap Module [LocalVersion Name]
mv_map = foldl add_mv mv_map_mod imp_names
-- mv_map adds the version numbers of things exported individually
- in
- returnRn [ (mod, mod_version mod, local_versions)
- | (mod, local_versions) <- fmToList mv_map
- ]
+ mk_version_info (mod, local_versions)
+ = case lookupFM mod_map mod of
+ Just (hif, version, _, _) -> (mod, hif, version, local_versions)
+ in
+ returnRn (map mk_version_info (fmToList mv_map))
where
export_mods = case exports of
Nothing -> []
\begin{code}
checkSlurped name
- = getIfacesRn `thenRn` \ (Ifaces _ _ _ _ slurped_names _ _ _ _) ->
+ = getIfacesRn `thenRn` \ (Ifaces _ _ _ slurped_names _ _ _ _) ->
returnRn (name `elemNameSet` slurped_names)
getSlurpedNames :: RnMG NameSet
getSlurpedNames
= getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces _ _ _ _ slurped_names _ _ _ _ = ifaces
+ Ifaces _ _ _ slurped_names _ _ _ _ = ifaces
in
returnRn slurped_names
recordSlurp maybe_version necessity avail
- = traceRn (hsep [text "Record slurp:", pprAvail (PprForUser opt_PprUserLength) avail,
+ = {- traceRn (hsep [text "Record slurp:", pprAvail (PprForUser opt_PprUserLength) avail,
-- NB PprForDebug prints export flag, which is too
-- strict; it's a knot-tied thing in RnNames
- case necessity of {Compulsory -> text "comp"; Optional -> text "opt"}]) `thenRn_`
+ case necessity of {Compulsory -> text "comp"; Optional -> text "opt" } ]) `thenRn_`
+ -}
getIfacesRn `thenRn` \ ifaces ->
let
- Ifaces this_mod mod_vers export_envs decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
+ Ifaces this_mod mod_map decls slurped_names imp_names (insts, tycls_names) deferred_data_decls inst_mods = ifaces
new_slurped_names = addAvailToNameSet slurped_names avail
new_imp_names = case maybe_version of
-> tycls_names `addOneToNameSet` tc
otherwise -> tycls_names
- new_ifaces = Ifaces this_mod mod_vers export_envs decls
+ new_ifaces = Ifaces this_mod mod_map decls
new_slurped_names
new_imp_names
(insts, new_tycls_names)
%*********************************************************
\begin{code}
-findAndReadIface :: Doc -> Module -> RnMG (Maybe ParsedIface)
+findAndReadIface :: Doc -> Module
+ -> IfaceFlavour
+ -> RnMG (Maybe ParsedIface)
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
-findAndReadIface doc_str filename
+findAndReadIface doc_str mod_name as_source
= traceRn trace_msg `thenRn_`
getSearchPathRn `thenRn` \ dirs ->
try dirs dirs
where
- trace_msg = hang (hcat [ptext SLIT("Reading interface for "),
- ptext filename, semi])
- 4 (hcat [ptext SLIT("reason: "), doc_str])
+ trace_msg = sep [hsep [ptext SLIT("Reading"),
+ case as_source of { HiBootFile -> ptext SLIT("[boot]"); other -> empty},
+ ptext SLIT("interface for"),
+ ptext mod_name,
+ semi],
+ nest 4 (ptext SLIT("reason:") <> doc_str)]
+
+ -- For import {-# SOURCE #-} Foo, "as_source" will be True
+ -- and we read Foo.hi-boot, not Foo.hi. This is used to break
+ -- loops among modules.
+ boot_suffix = case as_source of
+ HiBootFile -> "-boot"
+ HiFile -> ""
try all_dirs [] = traceRn (ptext SLIT("...failed")) `thenRn_`
returnRn Nothing
Just iface -> traceRn (ptext SLIT("...done")) `thenRn_`
returnRn (Just iface)
where
- file_path = dir ++ '/':moduleString filename ++ hisuf
+ file_path = dir ++ '/' : moduleString mod_name ++ hisuf ++ boot_suffix
\end{code}
@readIface@ trys just one file.
-- not constructors (see defn of availEntityNames)
-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
+data GenAvailInfo name = 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: AvailTC Eq [Eq, ==, /=]
+type AvailInfo = GenAvailInfo Name
+type RdrAvailInfo = GenAvailInfo OccName
\end{code}
===================================================
===================================================
\begin{code}
-type ExportItem = (Module, [(OccName, [OccName])])
+type ExportItem = (Module, IfaceFlavour, [RdrAvailInfo])
type VersionInfo name = [ImportVersion name]
-type ImportVersion name = (Module, Version, [LocalVersion name])
+type ImportVersion name = (Module, IfaceFlavour, Version, [LocalVersion name])
type LocalVersion name = (name, Version)
data ParsedIface
-------------------
data Ifaces = Ifaces
- Module -- Name of this module
- (FiniteMap Module Version)
- (FiniteMap Module (Avails, [(OccName,Fixity)])) -- Exports
+ Module -- Name of this module
+ (FiniteMap Module (IfaceFlavour, -- Exports
+ Version,
+ Avails,
+ [(OccName,Fixity)]))
DeclsMap
NameSet -- All the names (whether "big" or "small", whether wired-in or not,
emptyIfaces :: Module -> Ifaces
-emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyNameSet [] (emptyBag, emptyNameSet) emptyFM []
+emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyNameSet [] (emptyBag, emptyNameSet) emptyFM []
builtins :: FiniteMap (Module,OccName) Name
builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
)
import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
import RnIfaces ( getInterfaceExports, getDeclBinders, checkUpToDate, recordSlurp )
+import BasicTypes ( IfaceFlavour(..) )
import RnEnv
import RnMonad
import FiniteMap
| otherwise = [ImportDecl pRELUDE
False {- Not qualified -}
- False {- Not source imported -}
+ HiFile {- Not source imported -}
Nothing {- No "as" -}
Nothing {- No import list -}
mod_loc]
traceRn (text "Considering whether compilation is required...") `thenRn_`
(if not opt_SourceUnchanged then
-- Source code changed and no errors yet... carry on
- traceRn (nest 4 (text "source file changed")) `thenRn_`
+ traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_`
returnRn False
else
-- Unchanged source, and no errors yet; see if usage info
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
+ set_name_prov name | isWiredInName name = name
+ | otherwise = setNameProvenance name provenance
+ provenance = Imported mod loc as_source
\end{code}
Just another_name -> another_name
add_avail env avail = foldlRn add_name env (availNames avail)
- add_name env name = add qual_imp env (Qual qual_mod occ) `thenRn` \ env1 ->
+ add_name env name = add qual_imp env (Qual qual_mod occ err_hif) `thenRn` \ env1 ->
add unqual_imp env1 (Unqual occ)
where
add False env rdr_name = returnRn env
add_fixity name_env fix_env (occ_name, (fixity, provenance))
= add qual $ add unqual $ fix_env
where
- qual = Qual qual_mod occ_name
+ qual = Qual qual_mod occ_name err_hif
unqual = Unqual occ_name
add rdr_name fix_env | maybeToBool (lookupFM name_env rdr_name)
= addOneToFixityEnv fix_env rdr_name (fixity,provenance)
| otherwise
= fix_env
+
+err_hif = error "qualifyImports: hif" -- Not needed in key to mapping
\end{code}
unQualify adds an Unqual binding for every existing Qual binding.
\begin{code}
unQualify :: FiniteMap RdrName elt -> FiniteMap RdrName elt
-unQualify fm = addListToFM fm [(Unqual occ, elt) | (Qual _ occ, elt) <- fmToList fm]
+unQualify fm = addListToFM fm [(Unqual occ, elt) | (Qual _ occ _, elt) <- fmToList fm]
\end{code}
%************************************************************************
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking
#else
-import {-# SOURCE #-} RnExpr
+import RnExpr
+--import {-# SOURCE #-} RnExpr
#endif
import HsSyn
-import HsDecls ( HsIdInfo(..) )
+import HsDecls ( HsIdInfo(..), HsStrictnessInfo(..) )
import HsPragmas
import HsTypes ( getTyVarName )
import RdrHsSyn
import RnBinds ( rnTopBinds, rnMethodBinds )
import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
- newSysName, newDfunName, checkDupOrQualNames, checkDupNames,
+ newDfunName, checkDupOrQualNames, checkDupNames,
+ newLocallyDefinedGlobalName, newGlobalName, ifaceFlavour,
listType_RDR, tupleType_RDR )
import RnMonad
import Name ( Name, isLocallyDefined,
OccName(..), occNameString, prefixOccName,
ExportFlag(..),
- Provenance,
+ Provenance(..), getNameProvenance,
SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet,
elemNameSet
)
\begin{code}
rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
= pushSrcLocRn src_loc $
+
bindTyVarsRn cls_doc [tyvar] ( \ [tyvar'] ->
rnContext context `thenRn` \ context' ->
lookupBndrRn cname `thenRn` \ cname' ->
-- Check the signatures
- checkDupOrQualNames sig_doc sig_names `thenRn_`
- mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' ->
+ checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_`
+ mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' ->
returnRn (tyvar', context', cname', sigs')
) `thenRn` \ (tyvar', context', cname', sigs') ->
-- Check the methods
- checkDupOrQualNames meth_doc meth_names `thenRn_`
+ checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
rnMethodBinds mbinds `thenRn` \ mbinds' ->
-- Typechecker is responsible for checking that we only
sig_doc sty = text "the signatures for class" <+> ppr sty cname
meth_doc sty = text "the default-methods for class" <+> ppr sty cname
- sig_names = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
- meth_names = bagToList (collectMonoBinders mbinds)
+ sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
+ meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
+ meth_rdr_names = map fst meth_rdr_names_w_locs
- rn_op clas clas_tyvar sig@(ClassOpSig op _ ty locn)
+ rn_op clas clas_tyvar sig@(ClassOpSig op maybe_dm ty locn)
= pushSrcLocRn locn $
lookupBndrRn op `thenRn` \ op_name ->
rnHsSigType (\sty -> ppr sty op) ty `thenRn` \ new_ty ->
- -- Call up interface info for default method, if such info exists
+ -- Make the default-method name
let
dm_occ = prefixOccName SLIT("$m") (rdrNameOcc op)
in
- newSysName dm_occ Exported locn `thenRn` \ dm_name ->
- setModeRn (InterfaceMode Optional) (
- addOccurrenceName dm_name
- ) `thenRn_`
+ getModuleRn `thenRn` \ mod_name ->
+ getModeRn `thenRn` \ mode ->
+ (case (mode, maybe_dm) of
+ (SourceMode, _) | op `elem` meth_rdr_names
+ -> -- There's an explicit method decl
+ newLocallyDefinedGlobalName mod_name dm_occ
+ (\_ -> Exported) locn `thenRn` \ dm_name ->
+ returnRn (Just dm_name)
+
+ (InterfaceMode _, Just _)
+ -> -- Imported class that has a default method decl
+ newGlobalName mod_name dm_occ (ifaceFlavour clas) `thenRn` \ dm_name ->
+ addOccurrenceName dm_name `thenRn_`
+ returnRn (Just dm_name)
+
+ other -> returnRn Nothing
+ ) `thenRn` \ maybe_dm_name ->
-- Checks.....
let
(classTyVarNotInOpTyErr clas_tyvar sig)
`thenRn_`
- returnRn (ClassOpSig op_name dm_name new_ty locn)
+ returnRn (ClassOpSig op_name maybe_dm_name new_ty locn)
\end{code}
rnIdInfo (HsArgUsage au) = returnRn (HsArgUsage au)
rnIdInfo (HsDeforest df) = returnRn (HsDeforest df)
-rnStrict (StrictnessInfo demands (Just (worker,cons)))
+rnStrict (HsStrictnessInfo demands (Just (worker,cons)))
-- The sole purpose of the "cons" field is so that we can mark the constructors
-- needed to build the wrapper as "needed", so that their data type decl will be
-- slurped in. After that their usefulness is o'er, so we just put in the empty list.
= lookupOccRn worker `thenRn` \ worker' ->
mapRn lookupOccRn cons `thenRn_`
- returnRn (StrictnessInfo demands (Just (worker',[])))
+ returnRn (HsStrictnessInfo demands (Just (worker',[])))
-- Boring, but necessary for the type checker.
-rnStrict (StrictnessInfo demands Nothing) = returnRn (StrictnessInfo demands Nothing)
-rnStrict BottomGuaranteed = returnRn BottomGuaranteed
-rnStrict NoStrictnessInfo = returnRn NoStrictnessInfo
+rnStrict (HsStrictnessInfo demands Nothing) = returnRn (HsStrictnessInfo demands Nothing)
+rnStrict HsBottom = returnRn HsBottom
\end{code}
UfCore expressions.
4 (ppr sty sig)
dupClassAssertWarn ctxt ((clas,ty) : dups) sty
- = hang (hcat [ptext SLIT("Duplicated class assertion"),
- pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty,
- ptext SLIT("in context:")])
- 4 (pprContext sty ctxt)
+ = sep [hsep [ptext SLIT("Duplicated class assertion"),
+ pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty,
+ ptext SLIT("in context:")],
+ nest 4 (pprQuote sty $ \ sty -> pprContext sty ctxt)]
badDataCon name sty
= hsep [ptext SLIT("Illegal data constructor name"), ppr sty name]
import Digraph ( stronglyConnComp, stronglyConnCompR, SCC(..) )
import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
idType, idUnique, SYN_IE(Id),
- isConstMethodId,
emptyIdSet, unionIdSets, mkIdSet,
unitIdSet, elementOfIdSet,
addOneToIdSet, SYN_IE(IdSet),
keepBecauseConjurable :: OccEnv -> Id -> Bool
keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _ _) binder
- = keep_conjurable && isConstMethodId binder
+ = False
+ {- keep_conjurable && isConstMethodId binder -}
type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
projects / ghc-hetmet.git / commitdiff