parser/U_constr.hs \
parser/U_binding.hs \
parser/U_pbinding.hs \
-parser/U_coresyn.hs \
parser/U_entidt.hs \
-parser/U_hpragma.hs \
parser/U_list.hs \
parser/U_literal.hs \
parser/U_maybe.hs \
parser/UgenUtil.lhs \
parser/UgenAll.lhs \
reader/ReadPrefix.lhs \
-reader/ReadPragmas.lhs \
\
reader/PrefixSyn.lhs \
reader/PrefixToHs.lhs \
basicTypes/IdUtils.lhs \
basicTypes/Literal.lhs \
basicTypes/Name.lhs \
-basicTypes/NameTypes.lhs \
basicTypes/PprEnv.lhs \
basicTypes/PragmaInfo.lhs \
-basicTypes/ProtoName.lhs \
basicTypes/SrcLoc.lhs \
basicTypes/UniqSupply.lhs \
basicTypes/Unique.lhs \
#define RENAMERSRCS_LHS \
-rename/RnPass1.lhs \
-rename/RnPass2.lhs \
-rename/RnPass3.lhs \
-rename/RnPass4.lhs \
rename/RnHsSyn.lhs \
-rename/RnUtils.lhs \
-rename/RnMonad12.lhs \
-rename/RnMonad3.lhs \
-rename/RnMonad4.lhs \
-rename/RnBinds4.lhs \
-rename/RnExpr4.lhs \
-rename/Rename.lhs
+rename/RnMonad.lhs \
+rename/Rename.lhs \
+rename/RnNames.lhs \
+rename/RnSource.lhs \
+rename/RnBinds.lhs \
+rename/RnExpr.lhs \
+rename/RnIfaces.lhs \
+rename/RnUtils.lhs
#define TCSRCS_LHS \
typecheck/TcHsSyn.lhs \
UTILSRCS_LHS \
MAIN_SRCS_LHS \
READERSRCS_LHS \
-RENAMERSRCS_LHS \
-TCSRCS_LHS \
+RENAMERSRCS_LHS \
+TCSRCS_LHS \
DSSRCS_LHS \
SIMPL_SRCS_LHS \
STG_SRCS_LHS \
BACKSRCS_LHS NATIVEGEN_SRCS_LHS
/*
+\
*/
/* NB: all the ones that may be empty (e.g., NATIVEGEN_SRCS_LHS)
need to be on the last line.
$(GHC_UNLIT) absCSyn/AbsCLoop.lhi absCSyn/AbsCLoop.hi
basicTypes/IdLoop.hi : basicTypes/IdLoop.lhi
$(GHC_UNLIT) basicTypes/IdLoop.lhi basicTypes/IdLoop.hi
-basicTypes/NameLoop.hi : basicTypes/NameLoop.lhi
- $(GHC_UNLIT) basicTypes/NameLoop.lhi basicTypes/NameLoop.hi
codeGen/CgLoop1.hi : codeGen/CgLoop1.lhi
$(GHC_UNLIT) codeGen/CgLoop1.lhi codeGen/CgLoop1.hi
codeGen/CgLoop2.hi : codeGen/CgLoop2.lhi
$(GHC_UNLIT) nativeGen/NcgLoop.lhi nativeGen/NcgLoop.hi
prelude/PrelLoop.hi : prelude/PrelLoop.lhi
$(GHC_UNLIT) prelude/PrelLoop.lhi prelude/PrelLoop.hi
-reader/RdrLoop.hi : reader/RdrLoop.lhi
- $(GHC_UNLIT) reader/RdrLoop.lhi reader/RdrLoop.hi
rename/RnLoop.hi : rename/RnLoop.lhi
$(GHC_UNLIT) rename/RnLoop.lhi rename/RnLoop.hi
simplCore/SmplLoop.hi : simplCore/SmplLoop.lhi
compile(basicTypes/IdUtils,lhs,)
compile(basicTypes/Literal,lhs,)
compile(basicTypes/Name,lhs,)
-compile(basicTypes/NameTypes,lhs,)
compile(basicTypes/PprEnv,lhs,)
compile(basicTypes/PragmaInfo,lhs,)
-compile(basicTypes/ProtoName,lhs,)
compile(basicTypes/SrcLoc,lhs,)
compile(basicTypes/UniqSupply,lhs,)
compile(basicTypes/Unique,lhs,)
compile(reader/PrefixSyn,lhs,)
compile(reader/PrefixToHs,lhs,)
compile(reader/ReadPrefix,lhs,if_ghc(-fvia-C -I$(COMPINFO_DIR) -Iparser '-#include"hspincl.h"'))
-compile(reader/ReadPragmas,lhs,)
compile(reader/RdrHsSyn,lhs,)
+compile(rename/RnHsSyn,lhs,)
+compile(rename/RnMonad,lhs,)
compile(rename/Rename,lhs,)
-compile(rename/RnPass1,lhs,)
-compile(rename/RnPass2,lhs,)
-compile(rename/RnPass3,lhs,)
-compile(rename/RnPass4,lhs,)
+compile(rename/RnNames,lhs,)
+compile(rename/RnSource,lhs,)
+compile(rename/RnBinds,lhs,)
+compile(rename/RnExpr,lhs,)
+compile(rename/RnIfaces,lhs,)
compile(rename/RnUtils,lhs,)
-compile(rename/RnHsSyn,lhs,)
-compile(rename/RnBinds4,lhs,)
-compile(rename/RnExpr4,lhs,)
-compile(rename/RnMonad12,lhs,)
-compile(rename/RnMonad3,lhs,)
-compile(rename/RnMonad4,lhs,)
compile(simplCore/BinderInfo,lhs,)
compile(simplCore/ConFold,lhs,)
HSP_SRCS_C = parser/constr.c \
parser/binding.c \
parser/pbinding.c \
- parser/coresyn.c \
parser/entidt.c \
- parser/hpragma.c \
parser/hslexer.c \
parser/hsparser.tab.c \
parser/id.c \
HSP_OBJS_O = parser/constr.o \
parser/binding.o \
parser/pbinding.o \
- parser/coresyn.o \
parser/entidt.o \
- parser/hpragma.o \
parser/hslexer.o \
parser/hsparser.tab.o \
parser/id.o \
InstallBinaryTarget(hsp,$(INSTLIBDIR_GHC))
#endif /* DoInstall... */
-YaccRunWithExpectMsg(parser/hsparser,16,0)
+YaccRunWithExpectMsg(parser/hsparser,14,0)
UgenTarget(parser/constr)
UgenTarget(parser/binding)
UgenTarget(parser/pbinding)
-UgenTarget(parser/coresyn)
UgenTarget(parser/entidt)
-UgenTarget(parser/hpragma)
UgenTarget(parser/list)
UgenTarget(parser/literal)
UgenTarget(parser/maybe)
UGENS_C = parser/constr.c \
parser/binding.c \
parser/pbinding.c \
- parser/coresyn.c \
parser/entidt.c \
parser/literal.c \
parser/list.c \
parser/maybe.c \
parser/either.c \
parser/qid.c \
- parser/hpragma.c \
parser/tree.c \
parser/ttype.c
compile(parser/U_constr,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
compile(parser/U_binding,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
compile(parser/U_pbinding,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
-compile(parser/U_coresyn,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
compile(parser/U_entidt,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
-compile(parser/U_hpragma,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
compile(parser/U_list,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
compile(parser/U_literal,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
compile(parser/U_maybe,hs,$(PARSER_HS_OPTS) '-#include"hspincl.h"')
instance Outputable FieldLabel where
ppr sty (FieldLabel n _ _) = ppr sty n
-instance NamedThing FieldLabel
- -- ToDo: fill this in
+instance NamedThing FieldLabel where
+ getName (FieldLabel n _ _) = n
\end{code}
import Ubiq
import IdLoop -- for paranoia checking
import TyLoop -- for paranoia checking
-import NameLoop -- for paranoia checking
import Bag
import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
import CStrings ( identToC, cSEP )
import IdInfo
import Maybes ( maybeToBool )
-import NameTypes ( mkShortName, fromPrelude, FullName, ShortName )
+import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
+ isLocallyDefinedName, isPreludeDefinedName,
+ nameOrigName,
+ RdrName(..), Name
+ )
import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
-import Name ( Name(..) )
import Outputable ( isAvarop, isAconop, getLocalName,
- isExported, ExportFlag(..) )
+ isLocallyDefined, isPreludeDefined,
+ getOrigName, getOccName,
+ isExported, ExportFlag(..)
+ )
import PragmaInfo ( PragmaInfo(..) )
import PrelMods ( pRELUDE_BUILTIN )
import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
---------------- Local values
- = LocalId ShortName -- mentioned by the user
+ = LocalId Name -- Local name; mentioned by the user
Bool -- True <=> no free type vars
- | SysLocalId ShortName -- made up by the compiler
+ | SysLocalId Name -- Local name; made up by the compiler
Bool -- as for LocalId
- | SpecPragmaId ShortName -- introduced by the compiler
+ | SpecPragmaId Name -- Local name; introduced by the compiler
(Maybe Id) -- for explicit specid in pragma
Bool -- as for LocalId
---------------- Global values
- | ImportedId FullName -- Id imported from an interface
+ | ImportedId Name -- Global name (Imported or Implicit); Id imported from an interface
- | PreludeId FullName -- things < Prelude that compiler "knows" about
+ | PreludeId Name -- Global name (Builtin); Builtin prelude Ids
- | TopLevId FullName -- Top-level in the orig source pgm
+ | TopLevId Name -- Global name (LocalDef); Top-level in the orig source pgm
-- (not moved there by transformations).
-- a TopLevId's type may contain free type variables, if
---------------- Data constructors
- | DataConId FullName
+ | DataConId Name
ConTag
[StrictnessMark] -- Strict args; length = arity
[FieldLabel] -- Field labels for this constructor
-- forall tyvars . theta_ty =>
-- unitype_1 -> ... -> unitype_n -> tycon tyvars
- | TupleConId Int -- Its arity
+ | TupleConId Name
+ Int -- Its arity
- | RecordSelectorId FieldLabel
+ | RecordSelId FieldLabel
---------------- Things to do with overloading
-- actually do comparisons that way, we kindly supply
-- a Unique for that purpose.
Bool -- True <=> from an instance decl in this mod
- FAST_STRING -- module where instance came from
+ (Maybe Module) -- module where instance came from; Nothing => Prelude
-- see below
| ConstMethodId -- A method which depends only on the type of the
Class -- Uniquely identified by:
Type -- (class, type, classop) triple
ClassOp
- Bool -- True <=> from an instance decl in this mod
- FAST_STRING -- module where instance came from
+ Bool -- True => from an instance decl in this mod
+ (Maybe Module) -- module where instance came from; Nothing => Prelude
- | InstId ShortName -- An instance of a dictionary, class operation,
- -- or overloaded value
+ | InstId Name -- An instance of a dictionary, class operation,
+ -- or overloaded value (Local name)
Bool -- as for LocalId
| SpecId -- A specialisation of another Id
%----------------------------------------------------------------------
\item[@TopLevId@:] These are values defined at the top-level in this
module; i.e., those which {\em might} be exported (hence, a
-@FullName@). It does {\em not} include those which are moved to the
+@Name@). It does {\em not} include those which are moved to the
top-level through program transformations.
We also guarantee that @TopLevIds@ will {\em stay} at top-level.
isDataCon id = is_data (unsafeGenId2Id id)
where
is_data (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = True
- is_data (Id _ _ (TupleConId _) _ _) = True
+ is_data (Id _ _ (TupleConId _ _) _ _) = True
is_data (Id _ _ (SpecId unspec _ _) _ _) = is_data unspec
is_data other = False
isTupleCon id = is_tuple (unsafeGenId2Id id)
where
- is_tuple (Id _ _ (TupleConId _) _ _) = True
+ is_tuple (Id _ _ (TupleConId _ _) _ _) = True
is_tuple (Id _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
is_tuple other = False
= chk details
where
chk (DataConId _ _ _ _ _ _ _ _) = True
- chk (TupleConId _) = True
- chk (RecordSelectorId _) = True
+ chk (TupleConId _ _) = True
+ chk (RecordSelId _) = True
chk (ImportedId _) = True
chk (PreludeId _) = True
chk (TopLevId _) = True -- NB: see notes
= chk details
where
chk (DataConId _ _ _ _ _ _ _ _) = True
- chk (TupleConId _) = True
- chk (RecordSelectorId _) = True
+ chk (TupleConId _ _) = True
+ chk (RecordSelId _) = True
chk (ImportedId _) = True
chk (PreludeId _) = True
chk (TopLevId _) = True
in
-- local vars first:
if v `elementOfUniqSet` in_scopes then
- pprUnique (getItsUnique v)
+ pprUnique (idUnique v)
-- ubiquitous Ids with special syntax:
else if v == nilDataCon then
TopLevId _ -> pp_full_name
DataConId _ _ _ _ _ _ _ _ -> pp_full_name
- RecordSelectorId lbl -> ppr sty lbl
+ RecordSelId lbl -> ppr sty lbl
-- class-ish things: class already recorded as "mentioned"
SuperDictSelId c sc
else
ppPStr n_str
in
- if fromPreludeCore v then
+ if isPreludeDefined v then
pp_n
else
ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
-}
weird_datacon not_a_datacon_therefore_not_weird = False
- weird_tuplecon (TupleConId arity)
+ weird_tuplecon (TupleConId _ arity)
= arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
weird_tuplecon _ = False
\end{code}
get (Id u _ details _ _)
= case details of
DataConId n _ _ _ _ _ _ _ ->
- case (getOrigName n) of { (mod, name) ->
- if fromPrelude mod then [name] else [mod, name] }
+ case (nameOrigName n) of { (mod, name) ->
+ if isPreludeDefinedName n then [name] else [mod, name] }
- TupleConId 0 -> [SLIT("()")]
- TupleConId a -> [_PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )]
+ TupleConId n _ -> [snd (nameOrigName n)]
- RecordSelectorId lbl -> panic "getIdNamePieces:RecordSelectorId"
+ RecordSelId lbl -> panic "getIdNamePieces:RecordSelId"
ImportedId n -> get_fullname_pieces n
PreludeId n -> get_fullname_pieces n
case (getOrigName c) of { (c_mod, c_name) ->
case (getOrigName sc) of { (sc_mod, sc_name) ->
let
- c_bits = if fromPreludeCore c
+ c_bits = if isPreludeDefined c
then [c_name]
else [c_mod, c_name]
- sc_bits= if fromPreludeCore sc
+ sc_bits= if isPreludeDefined sc
then [sc_name]
else [sc_mod, sc_name]
in
MethodSelId clas op ->
case (getOrigName clas) of { (c_mod, c_name) ->
case (getClassOpString op) of { op_name ->
- if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name]
+ if isPreludeDefined clas
+ then [op_name]
+ else [c_mod, c_name, op_name]
} }
DefaultMethodId clas op _ ->
case (getOrigName clas) of { (c_mod, c_name) ->
case (getClassOpString op) of { op_name ->
- if fromPreludeCore clas
+ if isPreludeDefined clas
then [SLIT("defm"), op_name]
else [SLIT("defm"), c_mod, c_name, op_name] }}
DictFunId c ty _ _ ->
case (getOrigName c) of { (c_mod, c_name) ->
let
- c_bits = if fromPreludeCore c
+ c_bits = if isPreludeDefined c
then [c_name]
else [c_mod, c_name]
in
[SLIT("dfun")] ++ c_bits ++ ty_bits }
-
ConstMethodId c ty o _ _ ->
case (getOrigName c) of { (c_mod, c_name) ->
case (getTypeString ty) of { ty_bits ->
case (getClassOpString o) of { o_name ->
- case (if fromPreludeCore c
- then []
- else [c_mod, c_name]) of { c_bits ->
+ case (if isPreludeDefined c
+ then [c_name]
+ else [c_mod, c_name]) of { c_bits ->
[SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
-- if the unspecialised equiv is "top-level",
SysLocalId n _ -> [getLocalName n, showUnique u]
SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
-get_fullname_pieces :: FullName -> [FAST_STRING]
+get_fullname_pieces :: Name -> [FAST_STRING]
get_fullname_pieces n
- = BIND (getOrigName n) _TO_ (mod, name) ->
- if fromPrelude mod
+ = BIND (nameOrigName n) _TO_ (mod, name) ->
+ if isPreludeDefinedName n
then [name]
else [mod, name]
BEND
mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
-mkDictFunId u c ity full_ty from_here modname info
- = Id u full_ty (DictFunId c ity from_here modname) NoPragmaInfo info
+mkDictFunId u c ity full_ty from_here mod info
+ = Id u full_ty (DictFunId c ity from_here mod) NoPragmaInfo info
-mkConstMethodId u c op ity full_ty from_here modname info
- = Id u full_ty (ConstMethodId c ity op from_here modname) NoPragmaInfo info
+mkConstMethodId u c op ity full_ty from_here mod info
+ = Id u full_ty (ConstMethodId c ity op from_here mod) NoPragmaInfo info
mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info
%************************************************************************
\begin{code}
-mkImported u n ty info = Id u ty (ImportedId n) NoPragmaInfo info
-mkPreludeId u n ty info = Id u ty (PreludeId n) NoPragmaInfo info
+mkImported n ty info = Id (nameUnique n) ty (ImportedId n) NoPragmaInfo info
+mkPreludeId n ty info = Id (nameUnique n) ty (PreludeId n) NoPragmaInfo info
{-LATER:
updateIdType :: Id -> Type -> Id
mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
mkSysLocal str uniq ty loc
- = Id uniq ty (SysLocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
+ = Id uniq ty (SysLocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
mkUserLocal str uniq ty loc
- = Id uniq ty (LocalId (mkShortName str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
+ = Id uniq ty (LocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo
-- mkUserId builds a local or top-level Id, depending on the name given
mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
-mkUserId (Short uniq short) ty pragma_info
- = Id uniq ty (LocalId short (no_free_tvs ty)) pragma_info noIdInfo
-mkUserId (ValName uniq full) ty pragma_info
- = Id uniq ty
- (if isLocallyDefined full then TopLevId full else ImportedId full)
- pragma_info noIdInfo
+mkUserId name ty pragma_info
+ | isLocalName name
+ = Id (nameUnique name) ty (LocalId name (no_free_tvs ty)) pragma_info noIdInfo
+ | otherwise
+ = Id (nameUnique name) ty
+ (if isLocallyDefinedName name then TopLevId name else ImportedId name)
+ pragma_info noIdInfo
\end{code}
localiseId id@(Id u ty info details)
= Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty))
where
- name = getOccurrenceName id
+ name = getOccName id
loc = getSrcLoc id
-}
%************************************************************************
\begin{code}
-mkDataCon :: Unique{-DataConKey-}
- -> FullName
+mkDataCon :: Name
-> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> ThetaType -> [TauType] -> TyCon
--ToDo: -> SpecEnv
-> Id
-- can get the tag and all the pieces of the type from the Type
-mkDataCon k n stricts fields tvs ctxt args_tys tycon
+mkDataCon n stricts fields tvs ctxt args_tys tycon
= ASSERT(length stricts == length args_tys)
data_con
where
-- NB: data_con self-recursion; should be OK as tags are not
-- looked at until late in the game.
data_con
- = Id k
+ = Id (nameUnique n)
type_of_constructor
(DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon)
NoPragmaInfo
mkTupleCon :: Arity -> Id
mkTupleCon arity
- = Id unique ty (TupleConId arity) NoPragmaInfo tuplecon_info
+ = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info
where
+ n = panic "mkTupleCon: its Name (Id)"
unique = mkTupleDataConUnique arity
ty = mkSigmaTy tyvars []
(mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
\begin{code}
dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
dataConTag (Id _ _ (DataConId _ tag _ _ _ _ _ _) _ _) = tag
-dataConTag (Id _ _ (TupleConId _) _ _) = fIRST_TAG
+dataConTag (Id _ _ (TupleConId _ _) _ _) = fIRST_TAG
dataConTag (Id _ _ (SpecId unspec _ _) _ _) = dataConTag unspec
dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon
-dataConTyCon (Id _ _ (TupleConId a) _ _) = mkTupleTyCon a
+dataConTyCon (Id _ _ (TupleConId _ a) _ _) = mkTupleTyCon a
dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
-- will panic if not a DataCon
dataConSig (Id _ _ (DataConId _ _ _ _ tyvars theta_ty arg_tys tycon) _ _)
= (tyvars, theta_ty, arg_tys, tycon)
-dataConSig (Id _ _ (TupleConId arity) _ _)
+dataConSig (Id _ _ (TupleConId _ arity) _ _)
= (tyvars, [], tyvar_tys, mkTupleTyCon arity)
where
tyvars = take arity alphaTyVars
\end{code}
\begin{code}
-mkRecordSelectorId field_label selector_ty
- = Id (getItsUnique name)
+mkRecordSelId field_label selector_ty
+ = Id (nameUnique name)
selector_ty
- (RecordSelectorId field_label)
+ (RecordSelId field_label)
NoPragmaInfo
noIdInfo
where
name = fieldLabelName field_label
recordSelectorFieldLabel :: Id -> FieldLabel
-recordSelectorFieldLabel (Id _ _ (RecordSelectorId lbl) _ _) = lbl
+recordSelectorFieldLabel (Id _ _ (RecordSelId lbl) _ _) = lbl
\end{code}
{- LATER
-}
\end{code}
-Do we consider an ``instance type'' (as on a @DictFunId@) to be ``from
-PreludeCore''? True if the outermost TyCon is fromPreludeCore.
-\begin{code}
-is_prelude_core_ty :: Type -> Bool
-
-is_prelude_core_ty inst_ty
- = panic "Id.is_prelude_core_ty"
-{- LATER
- = case maybeAppDataTyCon inst_ty of
- Just (tycon,_,_) -> fromPreludeCore tycon
- Nothing -> panic "Id: is_prelude_core_ty"
--}
-\end{code}
-
Default printing code (not used for interfaces):
\begin{code}
pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty
case other_sty of
PprForC -> for_code
PprForAsm _ _ -> for_code
- PprInterface -> ppPStr occur_name
- PprForUser -> ppPStr occur_name
+ PprInterface -> ppr other_sty occur_name
+ PprForUser -> ppr other_sty occur_name
PprUnfolding -> qualified_name pieces
PprDebug -> qualified_name pieces
PprShowAll -> ppBesides [qualified_name pieces,
(\x->x) nullIdEnv (getIdInfo id),
ppPStr SLIT("-}") ])]
where
- occur_name = getOccurrenceName id _APPEND_
- ( _PK_ (if not (isSysLocalId id)
- then ""
- else "." ++ (_UNPK_ (showUnique (getItsUnique id)))))
+ occur_name = getOccName id `appendRdr`
+ (if not (isSysLocalId id)
+ then SLIT("")
+ else SLIT(".") _APPEND_ (showUnique (idUnique id)))
qualified_name pieces
= ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id)
pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add
pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = ppNil
- pp_uniq (Id _ _ (TupleConId _) _ _) = ppNil
+ pp_uniq (Id _ _ (TupleConId _ _) _ _) = ppNil
pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere
pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil
pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil
pp_uniq (Id _ _ (InstId _ _) _ _) = ppNil
- pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (getItsUnique other_id), ppPStr SLIT("-}")]
+ pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (idUnique other_id), ppPStr SLIT("-}")]
-- print PprDebug Ids with # afterwards if they are of primitive type.
pp_ubxd pretty = pretty
\end{code}
\begin{code}
+idUnique (Id u _ _ _ _) = u
+
+instance Uniquable (GenId ty) where
+ uniqueOf = idUnique
+
instance NamedThing (GenId ty) where
- getExportFlag (Id _ _ details _ _)
- = get details
- where
- get (DataConId _ _ _ _ _ _ _ tc)= getExportFlag tc -- NB: don't use the FullName
- get (TupleConId _) = NotExported
- get (RecordSelectorId l) = getExportFlag l
- get (ImportedId n) = getExportFlag n
- get (PreludeId n) = getExportFlag n
- get (TopLevId n) = getExportFlag n
- get (SuperDictSelId c _) = getExportFlag c
- get (MethodSelId c _) = getExportFlag c
- get (DefaultMethodId c _ _) = getExportFlag c
- get (DictFunId c ty from_here _) = instance_export_flag c ty from_here
- get (ConstMethodId c ty _ from_here _) = instance_export_flag c ty from_here
- get (SpecId unspec _ _) = getExportFlag unspec
- get (WorkerId unwrkr) = getExportFlag unwrkr
- get (InstId _ _) = NotExported
- get (LocalId _ _) = NotExported
- get (SysLocalId _ _) = NotExported
- get (SpecPragmaId _ _ _) = NotExported
-
- isLocallyDefined this_id@(Id _ _ details _ _)
+ getName this_id@(Id u _ details _ _)
= get details
where
- get (DataConId _ _ _ _ _ _ _ tc)= isLocallyDefined tc -- NB: don't use the FullName
- get (TupleConId _) = False
- get (ImportedId _) = False
- get (PreludeId _) = False
- get (RecordSelectorId l) = isLocallyDefined l
- get (TopLevId n) = isLocallyDefined n
- get (SuperDictSelId c _) = isLocallyDefined c
- get (MethodSelId c _) = isLocallyDefined c
- get (DefaultMethodId c _ _) = isLocallyDefined c
- get (DictFunId c tyc from_here _) = from_here
- -- For DictFunId and ConstMethodId things, you really have to
- -- know whether it came from an imported instance or one
- -- really here; no matter where the tycon and class came from.
-
- get (ConstMethodId c tyc _ from_here _) = from_here
- get (SpecId unspec _ _) = isLocallyDefined unspec
- get (WorkerId unwrkr) = isLocallyDefined unwrkr
- get (InstId _ _) = True
- get (LocalId _ _) = True
- get (SysLocalId _ _) = True
- get (SpecPragmaId _ _ _) = True
-
- getOrigName this_id@(Id u _ details _ _)
- = get details
- where
- get (DataConId n _ _ _ _ _ _ _) = getOrigName n
- get (TupleConId 0) = (pRELUDE_BUILTIN, SLIT("()"))
- get (TupleConId a) = (pRELUDE_BUILTIN, _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" ))
- get (RecordSelectorId l)= getOrigName l
- get (ImportedId n) = getOrigName n
- get (PreludeId n) = getOrigName n
- get (TopLevId n) = getOrigName n
+ get (LocalId n _) = n
+ get (SysLocalId n _) = n
+ get (SpecPragmaId n _ _)= n
+ get (ImportedId n) = n
+ get (PreludeId n) = n
+ get (TopLevId n) = n
+ get (InstId n _) = n
+ get (DataConId n _ _ _ _ _ _ _) = n
+ get (TupleConId n _) = n
+ get (RecordSelId l) = getName l
+-- get _ = pprPanic "Id.Id.NamedThing.getName:" (pprId PprDebug this_id)
+{- LATER:
get (MethodSelId c op) = case (getOrigName c) of -- ToDo; better ???
(mod, _) -> (mod, getClassOpString op)
-{- LATER:
get (SpecId unspec ty_maybes _)
= BIND getOrigName unspec _TO_ (mod, unspec_nm) ->
BIND specMaybeTysSuffix ty_maybes _TO_ tys_suffix ->
else SLIT(".wrk"))
)
BEND
--}
-
- get (InstId n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
- getLocalName n)
- get (LocalId n _) = (panic "NamedThing.Id.getOrigName (LocalId)",
- getLocalName n)
- get (SysLocalId n _) = (panic "NamedThing.Id.getOrigName (SysLocal)",
- getLocalName n)
- get (SpecPragmaId n _ _)= (panic "NamedThing.Id.getOrigName (SpecPragmaId)",
- getLocalName n)
get other_details
-- the remaining internally-generated flavours of
BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
(_NIL_, _CONCAT_ (piece1 : dotted_pieces))
BEND BEND
-
- getOccurrenceName this_id@(Id _ _ details _ _)
- = get details
- where
- get (DataConId n _ _ _ _ _ _ _) = getOccurrenceName n
- get (TupleConId 0) = SLIT("()")
- get (TupleConId a) = _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
- get (RecordSelectorId l)= getOccurrenceName l
- get (ImportedId n) = getOccurrenceName n
- get (PreludeId n) = getOccurrenceName n
- get (TopLevId n) = getOccurrenceName n
- get (MethodSelId _ op) = getClassOpString op
- get _ = snd (getOrigName this_id)
-
- getInformingModules id = panic "getInformingModule:Id"
-
- getSrcLoc (Id _ _ details _ id_info)
- = get details
- where
- get (DataConId n _ _ _ _ _ _ _) = getSrcLoc n
- get (TupleConId _) = mkBuiltinSrcLoc
- get (RecordSelectorId l)= getSrcLoc l
- get (ImportedId n) = getSrcLoc n
- get (PreludeId n) = getSrcLoc n
- get (TopLevId n) = getSrcLoc n
- get (SuperDictSelId c _)= getSrcLoc c
- get (MethodSelId c _) = getSrcLoc c
- get (SpecId unspec _ _) = getSrcLoc unspec
- get (WorkerId unwrkr) = getSrcLoc unwrkr
- get (InstId n _) = getSrcLoc n
- get (LocalId n _) = getSrcLoc n
- get (SysLocalId n _) = getSrcLoc n
- get (SpecPragmaId n _ _)= getSrcLoc n
- -- well, try the IdInfo
- get something_else = getSrcLocIdInfo id_info
-
- getItsUnique (Id u _ _ _ _) = u
-
- fromPreludeCore (Id _ _ details _ _)
- = get details
- where
- get (DataConId _ _ _ _ _ _ _ tc)= fromPreludeCore tc -- NB: not from the FullName
- get (TupleConId _) = True
- get (RecordSelectorId l) = fromPreludeCore l
- get (ImportedId n) = fromPreludeCore n
- get (PreludeId n) = fromPreludeCore n
- get (TopLevId n) = fromPreludeCore n
- get (SuperDictSelId c _) = fromPreludeCore c
- get (MethodSelId c _) = fromPreludeCore c
- get (DefaultMethodId c _ _) = fromPreludeCore c
- get (DictFunId c t _ _) = fromPreludeCore c && is_prelude_core_ty t
- get (ConstMethodId c t _ _ _) = fromPreludeCore c && is_prelude_core_ty t
- get (SpecId unspec _ _) = fromPreludeCore unspec
- get (WorkerId unwrkr) = fromPreludeCore unwrkr
- get (InstId _ _) = False
- get (LocalId _ _) = False
- get (SysLocalId _ _) = False
- get (SpecPragmaId _ _ _) = False
+-}
\end{code}
-Reason for @getItsUnique@: The code generator doesn't carry a
-@UniqueSupply@, so it wants to use the @Uniques@ out of local @Ids@
-given to it.
+Note: The code generator doesn't carry a @UniqueSupply@, so it uses
+the @Uniques@ out of local @Ids@ given to it.
%************************************************************************
%* *
-- ToDo: SrcLoc is in FullNames too (could rm?) but it
-- is needed here too for things like ConstMethodIds and the
-- like, which don't have full-names of their own Mind you,
- -- perhaps the FullName for a constant method could give the
+ -- perhaps the Name for a constant method could give the
-- class/type involved?
\end{code}
import CoreUnfold ( UnfoldingGuidance(..) )
import Id ( mkPreludeId )
import IdInfo -- quite a few things
-import Name ( Name(..) )
-import NameTypes ( mkPreludeCoreName )
+import Name ( mkBuiltinName )
import PrelMods ( pRELUDE_BUILTIN )
import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
- PrimOpInfo(..), PrimOpResultInfo(..)
- )
+ PrimOpInfo(..), PrimOpResultInfo(..) )
+import RnHsSyn ( RnName(..) )
import Type ( mkForAllTys, mkFunTys, applyTyCon )
import TysWiredIn ( boolTy )
import Unique ( mkPrimOpIdUnique )
\end{code}
\begin{code}
-primOpNameInfo :: PrimOp -> (FAST_STRING, Name)
+primOpNameInfo :: PrimOp -> (FAST_STRING, RnName)
primOpId :: PrimOp -> Id
-primOpNameInfo op = (primOp_str op, WiredInVal (primOpId op))
+primOpNameInfo op = (primOp_str op, WiredInId (primOpId op))
primOpId op
= case (primOpInfo op) of
(length arg_tys) -- arity
where
mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity
- = mkPreludeId
- (mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op)))
- (mkPreludeCoreName mod name)
- ty
- (noIdInfo
- `addInfo` (mkArityInfo arity)
- `addInfo_UF` (mkUnfolding EssentialUnfolding
- (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
+ = mkPreludeId (mkBuiltinName key mod name) ty
+ (noIdInfo `addInfo` (mkArityInfo arity)
+ `addInfo_UF` (mkUnfolding EssentialUnfolding
+ (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
+ where
+ key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
\end{code}
= panic "IdUtils.mk_prim_unfold"
{-
= let
- (inst_env, tyvars, tyvar_tys) = instantiateTyVars tvs (map getItsUnique tvs)
+ (inst_env, tyvars, tyvar_tys) = instantiateTyVars tvs (map uniqueOf tvs)
inst_arg_tys = map (instantiateTauTy inst_env) arg_tys
vars = mkTemplateLocals inst_arg_tys
in
#include "HsVersions.h"
module Name (
- -- things for the Name NON-abstract type
- Name(..),
-
- isTyConName, isClassName, isClassOpName,
- isUnboundName, invisibleName,
-
- getTagFromClassOpName, getSynNameArity,
-
- getNameShortName, getNameFullName
-
+ Module(..),
+
+ RdrName(..),
+ isUnqual,
+ isQual,
+ isConopRdr,
+ appendRdr,
+ rdrToOrig,
+ showRdr,
+ cmpRdr,
+
+ Name,
+ Provenance,
+ mkLocalName, isLocalName,
+ mkTopLevName, mkImportedName,
+ mkImplicitName, isImplicitName,
+ mkBuiltinName,
+
+ nameUnique,
+ nameOrigName,
+ nameOccName,
+ nameExportFlag,
+ nameSrcLoc,
+ isLocallyDefinedName,
+ isPreludeDefinedName
) where
-import Ubiq{-uitous-}
+import Ubiq
-import NameLoop -- break Name/Id loop, Name/PprType/Id loop
-
-import NameTypes
-import Outputable ( ExportFlag(..) )
+import CStrings ( identToC, cSEP )
+import Outputable ( Outputable(..), ExportFlag(..), isConop )
+import PprStyle ( PprStyle(..), codeStyle )
import Pretty
-import PprStyle ( PprStyle(..) )
+import PrelMods ( pRELUDE )
import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc )
-import TyCon ( TyCon, synTyConArity )
-import TyVar ( GenTyVar )
import Unique ( pprUnique, Unique )
-import Util ( panic, panic#, pprPanic )
+import Util ( thenCmp, _CMP_STRING_, panic )
\end{code}
%************************************************************************
%* *
-\subsection[Name-datatype]{The @Name@ datatype}
+\subsection[RdrName]{The @RdrName@ datatype; names read from files}
%* *
%************************************************************************
\begin{code}
-data Name
- = Short Unique -- Local ids and type variables
- ShortName
-
- -- Nano-prelude things; truly wired in.
- -- Includes all type constructors and their associated data constructors
- | WiredInTyCon TyCon
- | WiredInVal Id
-
- | TyConName Unique -- TyCons other than Prelude ones; need to
- FullName -- separate these because we want to pin on
- Arity -- their arity.
- Bool -- False <=> `type',
- -- True <=> `data' or `newtype'
- [Name] -- List of user-visible data constructors;
- -- NB: for `data' types only.
- -- Used in checking import/export lists.
-
- | ClassName Unique
- FullName
- [Name] -- List of class methods; used for checking
- -- import/export lists.
-
- | ValName Unique -- Top level id
- FullName
-
- | ClassOpName Unique
- Name -- Name associated w/ the defined class
- -- (can get unique and export info, etc., from this)
- FAST_STRING -- The class operation
- Int -- Unique tag within the class
-
- -- Miscellaneous
- | Unbound FAST_STRING -- Placeholder for a name which isn't in scope
- -- Used only so that the renamer can carry on after
- -- finding an unbound identifier.
- -- The string is grabbed from the unbound name, for
- -- debugging information only.
-\end{code}
+type Module = FAST_STRING
-These @is..@ functions are used in the renamer to check that (eg) a tycon
-is seen in a context which demands one.
+data RdrName = Unqual FAST_STRING
+ | Qual Module FAST_STRING
-\begin{code}
-isTyConName, isClassName, isUnboundName :: Name -> Bool
+isUnqual (Unqual _) = True
+isUnqual (Qual _ _) = False
-isTyConName (TyConName _ _ _ _ _) = True
-isTyConName (WiredInTyCon _) = True
-isTyConName other = False
+isQual (Unqual _) = False
+isQual (Qual _ _) = True
-isClassName (ClassName _ _ _) = True
-isClassName other = False
+isConopRdr (Unqual n) = isConop n
+isConopRdr (Qual m n) = isConop n
-isUnboundName (Unbound _) = True
-isUnboundName other = False
-\end{code}
+appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
+appendRdr (Qual m n) str = Qual m (n _APPEND_ str)
-@isClassOpName@ is a little cleverer: it checks to see whether the
-class op comes from the correct class.
+rdrToOrig (Unqual n) = (pRELUDE, n)
+rdrToOrig (Qual m n) = (m, n)
-\begin{code}
-isClassOpName :: Name -- The name of the class expected for this op
- -> Name -- The name of the thing which should be a class op
- -> Bool
+cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2
+cmpRdr (Unqual n1) (Qual m2 n2) = LT_
+cmpRdr (Qual m1 n1) (Unqual n2) = GT_
+cmpRdr (Qual m1 n1) (Qual m2 n2) = thenCmp (_CMP_STRING_ m1 m2) (_CMP_STRING_ n1 n2)
+
+instance Eq RdrName where
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
-isClassOpName (ClassName uniq1 _ _) (ClassOpName _ (ClassName uniq2 _ _) _ _)
- = uniq1 == uniq2
-isClassOpName other_class other_op = False
+instance Ord RdrName where
+ a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+
+instance Ord3 RdrName where
+ cmp = cmpRdr
+
+instance NamedThing RdrName where
+ -- We're sorta faking it here
+ getName rdr_name
+ = Global u rdr_name prov ex [rdr_name]
+ where
+ u = panic "NamedThing.RdrName:Unique"
+ prov = panic "NamedThing.RdrName:Provenance"
+ ex = panic "NamedThing.RdrName:ExportFlag"
+
+instance Outputable RdrName where
+ ppr sty (Unqual n) = pp_name sty n
+ ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n)
+
+pp_mod PprInterface m = ppNil
+pp_mod PprForC m = ppBesides [identToC m, ppPStr cSEP]
+pp_mod (PprForAsm False _) m = ppBesides [identToC m, ppPStr cSEP]
+pp_mod (PprForAsm True _) m = ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
+pp_mod _ m = ppBesides [ppPStr m, ppChar '.']
+
+pp_name sty n | codeStyle sty = identToC n
+ | otherwise = ppPStr n
+
+showRdr sty rdr = ppShow 100 (ppr sty rdr)
\end{code}
-A Name is ``invisible'' if the user has no business seeing it; e.g., a
-data-constructor for an abstract data type (but whose constructors are
-known because of a pragma).
+%************************************************************************
+%* *
+\subsection[Name-datatype]{The @Name@ datatype}
+%* *
+%************************************************************************
+
\begin{code}
-invisibleName :: Name -> Bool
+data Name
+ = Local Unique
+ FAST_STRING
+ SrcLoc
+
+ | Global Unique
+ RdrName -- original name; Unqual => prelude
+ Provenance -- where it came from
+ ExportFlag -- is it exported?
+ [RdrName] -- ordered occurrence names (usually just one);
+ -- first may be *un*qual.
+
+data Provenance
+ = LocalDef SrcLoc -- locally defined; give its source location
+
+ | Imported SrcLoc -- imported; give the *original* source location
+ -- [SrcLoc] -- any import source location(s)
-invisibleName (TyConName _ n _ _ _) = invisibleFullName n
-invisibleName (ClassName _ n _) = invisibleFullName n
-invisibleName (ValName _ n) = invisibleFullName n
-invisibleName _ = False
+ | Implicit
+ | Builtin
\end{code}
\begin{code}
-getTagFromClassOpName :: Name -> Int
-getTagFromClassOpName (ClassOpName _ _ _ tag) = tag
+mkLocalName = Local
-getSynNameArity :: Name -> Maybe Arity
-getSynNameArity (TyConName _ _ arity False{-syn-} _) = Just arity
-getSynNameArity (WiredInTyCon tycon) = synTyConArity tycon
-getSynNameArity other_name = Nothing
+mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs
+mkImportedName u orig locn exp occs = Global u orig (Imported locn) exp occs
-getNameShortName :: Name -> ShortName
-getNameShortName (Short _ sn) = sn
+mkImplicitName :: Unique -> RdrName -> Name
+mkImplicitName u o = Global u o Implicit NotExported []
-getNameFullName :: Name -> FullName
-getNameFullName n = get_nm "getNameFullName" n
+mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
+mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported []
+
+ -- ToDo: what about module ???
+ -- ToDo: exported when compiling builtin ???
+
+isLocalName (Local _ _ _) = True
+isLocalName _ = False
+
+isImplicitName (Global _ _ Implicit _ _) = True
+isImplicitName _ = False
+
+isBuiltinName (Global _ _ Builtin _ _) = True
+isBuiltinName _ = False
\end{code}
+
%************************************************************************
%* *
\subsection[Name-instances]{Instance declarations}
\begin{code}
cmpName n1 n2 = c n1 n2
where
- c (Short u1 _) (Short u2 _) = cmp u1 u2
-
- c (WiredInTyCon tc1) (WiredInTyCon tc2) = cmp tc1 tc2
- c (WiredInVal id1) (WiredInVal id2) = cmp id1 id2
-
- c (TyConName u1 _ _ _ _) (TyConName u2 _ _ _ _) = cmp u1 u2
- c (ClassName u1 _ _) (ClassName u2 _ _) = cmp u1 u2
- c (ValName u1 _) (ValName u2 _) = cmp u1 u2
-
- c (ClassOpName u1 _ _ _) (ClassOpName u2 _ _ _) = cmp u1 u2
- c (Unbound a) (Unbound b) = panic# "Eq.Name.Unbound"
+ c (Local u1 _ _) (Local u2 _ _) = cmp u1 u2
+ c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2
c other_1 other_2 -- the tags *must* be different
= let tag1 = tag_Name n1
in
if tag1 _LT_ tag2 then LT_ else GT_
- tag_Name (Short _ _) = (ILIT(1) :: FAST_INT)
- tag_Name (WiredInTyCon _) = ILIT(2)
- tag_Name (WiredInVal _) = ILIT(3)
- tag_Name (TyConName _ _ _ _ _) = ILIT(7)
- tag_Name (ClassName _ _ _) = ILIT(8)
- tag_Name (ValName _ _) = ILIT(9)
- tag_Name (ClassOpName _ _ _ _) = ILIT(10)
- tag_Name (Unbound _) = ILIT(11)
+ tag_Name (Local _ _ _) = (ILIT(1) :: FAST_INT)
+ tag_Name (Global _ _ _ _ _) = ILIT(2)
\end{code}
\begin{code}
instance Ord3 Name where
cmp = cmpName
-\end{code}
-\begin{code}
+instance Uniquable Name where
+ uniqueOf = nameUnique
+
instance NamedThing Name where
- getExportFlag (Short _ _) = NotExported
- getExportFlag (WiredInTyCon _) = NotExported -- compiler always know about these
- getExportFlag (WiredInVal _) = NotExported
- getExportFlag (ClassOpName _ c _ _) = getExportFlag c
- getExportFlag other = getExportFlag (get_nm "getExportFlag" other)
-
- isLocallyDefined (Short _ _) = True
- isLocallyDefined (WiredInTyCon _) = False
- isLocallyDefined (WiredInVal _) = False
- isLocallyDefined (ClassOpName _ c _ _) = isLocallyDefined c
- isLocallyDefined other = isLocallyDefined (get_nm "isLocallyDefined" other)
-
- getOrigName (Short _ sn) = getOrigName sn
- getOrigName (WiredInTyCon tc) = getOrigName tc
- getOrigName (WiredInVal id) = getOrigName id
- getOrigName (ClassOpName _ c op _) = (fst (getOrigName c), op)
- getOrigName other = getOrigName (get_nm "getOrigName" other)
-
- getOccurrenceName (Short _ sn) = getOccurrenceName sn
- getOccurrenceName (WiredInTyCon tc) = getOccurrenceName tc
- getOccurrenceName (WiredInVal id) = getOccurrenceName id
- getOccurrenceName (ClassOpName _ _ op _) = op
- getOccurrenceName (Unbound s) = s _APPEND_ SLIT("<unbound>")
- getOccurrenceName other = getOccurrenceName (get_nm "getOccurrenceName" other)
-
- getInformingModules thing = panic "getInformingModule:Name"
-
- getSrcLoc (Short _ sn) = getSrcLoc sn
- getSrcLoc (WiredInTyCon tc) = mkBuiltinSrcLoc
- getSrcLoc (WiredInVal id) = mkBuiltinSrcLoc
- getSrcLoc (ClassOpName _ c _ _) = getSrcLoc c
- getSrcLoc (Unbound _) = mkUnknownSrcLoc
- getSrcLoc other = getSrcLoc (get_nm "getSrcLoc" other)
-
- getItsUnique (Short u _) = u
- getItsUnique (WiredInTyCon t) = getItsUnique t
- getItsUnique (WiredInVal i) = getItsUnique i
- getItsUnique (TyConName u _ _ _ _) = u
- getItsUnique (ClassName u _ _) = u
- getItsUnique (ValName u _) = u
- getItsUnique (ClassOpName u _ _ _) = u
-
- fromPreludeCore (WiredInTyCon _) = True
- fromPreludeCore (WiredInVal _) = True
- fromPreludeCore (ClassOpName _ c _ _) = fromPreludeCore c
- fromPreludeCore other = False
+ getName n = n
\end{code}
-A useful utility; most emphatically not for export! (but see
-@getNameFullName@...):
\begin{code}
-get_nm :: String -> Name -> FullName
+nameUnique (Local u _ _) = u
+nameUnique (Global u _ _ _ _) = u
-get_nm msg (TyConName _ n _ _ _) = n
-get_nm msg (ClassName _ n _) = n
-get_nm msg (ValName _ n) = n
-#ifdef DEBUG
-get_nm msg other = pprPanic ("get_nm:"++msg) (ppr PprShowAll other)
--- If match failure, probably on a ClassOpName or Unbound :-(
-#endif
+nameOrigName (Local _ n _) = (panic "NamedThing.Local.nameOrigName", n)
+nameOrigName (Global _ orig _ _ _) = rdrToOrig orig
+
+nameOccName (Local _ n _) = Unqual n
+nameOccName (Global _ orig _ _ [] ) = orig
+nameOccName (Global _ orig _ _ occs) = head occs
+
+nameExportFlag (Local _ _ _) = NotExported
+nameExportFlag (Global _ _ _ exp _) = exp
+
+nameSrcLoc (Local _ _ loc) = loc
+nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc
+nameSrcLoc (Global _ _ (Imported loc) _ _) = loc
+nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc
+nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc
+
+isLocallyDefinedName (Local _ _ _) = True
+isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True
+isLocallyDefinedName (Global _ _ (Imported _) _ _) = False
+isLocallyDefinedName (Global _ _ Implicit _ _) = False
+isLocallyDefinedName (Global _ _ Builtin _ _) = False
+
+isPreludeDefinedName (Local _ n _) = False
+isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig
\end{code}
\begin{code}
instance Outputable Name where
#ifdef DEBUG
- ppr PprDebug (Short u s) = pp_debug u s
-
- ppr PprDebug (TyConName u n _ _ _) = pp_debug u n
- ppr PprDebug (ClassName u n _) = pp_debug u n
- ppr PprDebug (ValName u n) = pp_debug u n
+ ppr PprDebug (Local u n _) = pp_debug u (ppPStr n)
+ ppr PprDebug (Global u o _ _ _) = pp_debug u (ppr PprDebug o)
#endif
- ppr sty (Short u s) = ppr sty s
+ ppr sty (Local u n _) = pp_name sty n
+ ppr PprForUser (Global u o _ _ [] ) = ppr PprForUser o
+ ppr PprForUser (Global u o _ _ occs) = ppr PprForUser (head occs)
+ ppr PprShowAll (Global u o prov exp occs) = pp_all o prov exp occs
+ ppr sty (Global u o _ _ _) = ppr sty o
- ppr sty (WiredInTyCon tc) = ppr sty tc
- ppr sty (WiredInVal id) = ppr sty id
+pp_debug uniq thing
+ = ppBesides [thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
- ppr sty (TyConName u n a b c) = ppr sty n
- ppr sty (ClassName u n c) = ppr sty n
- ppr sty (ValName u n) = ppr sty n
+pp_all orig prov exp occs
+ = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
- ppr sty (ClassOpName u c s i)
- = let
- ps = ppPStr s
- in
- case sty of
- PprForUser -> ps
- PprInterface -> ps
- PprDebug -> ps
- other -> ppBesides [ps, ppChar '{',
- ppSep [pprUnique u,
- ppStr "op", ppInt i,
- ppStr "cls", ppr sty c],
- ppChar '}']
-
- ppr sty (Unbound s) = ppStr ("*UNBOUND*"++ _UNPK_ s)
+pp_exp NotExported = ppNil
+pp_exp ExportAll = ppPStr SLIT("/EXP(..)")
+pp_exp ExportAbs = ppPStr SLIT("/EXP")
-pp_debug uniq thing
- = ppBesides [ppr PprDebug thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
+pp_prov Implicit = ppPStr SLIT("/IMPLICIT")
+pp_prov Builtin = ppPStr SLIT("/BUILTIN")
+pp_prov _ = ppNil
\end{code}
+
+++ /dev/null
-Breaks the Name/Id loop, and the Name/Id/PprType loop.
-
-\begin{code}
-interface NameLoop where
-
-import Id ( GenId )
-import Outputable ( NamedThing, Outputable )
-import TyCon ( TyCon )
-import Type ( GenType )
-import TyVar ( GenTyVar )
-import Util ( Ord3(..) )
-
-instance NamedThing (GenId a)
-instance Ord3 (GenId a)
-instance (Outputable a) => Outputable (GenId a)
-
-instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b)
-instance Outputable (GenTyVar a)
-instance Outputable TyCon
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-%************************************************************************
-%* *
-\section[NameTypes]{@NameTypes@: The flavours of names that we stick on things}
-%* *
-%************************************************************************
-
-\begin{code}
-#include "HsVersions.h"
-
-module NameTypes (
- ShortName, FullName, -- abstract types
- Provenance(..),
-
- fromPrelude,
-
- mkShortName,
-
- mkFullName, mkPrivateFullName, mkPreludeCoreName,
-
- invisibleFullName,
-
- unlocaliseFullName, unlocaliseShortName,
-
- -- and to make the interface self-sufficient....
- ExportFlag, Unique, SrcLoc
- ) where
-
-CHK_Ubiq() -- debugging consistency check
-import PrelLoop -- for paranoia checking
-
-import PrelMods ( pRELUDE, pRELUDE_CORE ) -- NB: naughty import
-
-import CStrings ( identToC, cSEP )
-import Outputable
-import Pretty
-import PprStyle ( PprStyle(..), codeStyle )
-
-import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
-import Unique ( showUnique, Unique )
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[NameTypes-flavours]{Datatypes for names}
-%* *
-%************************************************************************
-
-Here are the types; see the notes that follow.
-\begin{code}
-data ShortName
- = ShortName FAST_STRING -- entity's name in this module
- SrcLoc -- defining location (only one possible)
-
-data FullName
- = FullName FAST_STRING -- original module name
- FAST_STRING -- entity's name in original module
- Provenance -- where this thing came from
- -- (also records its local name, if any)
- ExportFlag -- where this thing is going (from here)
- Bool -- True <=> invisible to the user
- SrcLoc -- defining location (just one)
-\end{code}
-(@FullNames@ don't have fast-comparison keys; the things with
-@FullNames@ do.)
-
-\begin{description}
-%----------------------------------------------------------------------
-\item[@ShortName@:]
-
-These are used for entities local to the module being compiled; for
-example, function parameters, where- and let-bound things. These are
-@TyVars@ (ToDo: what if imported???) and local @Ids@. They have
-@Uniques@ for fast comparison.
-
-%----------------------------------------------------------------------
-\item[@FullName@:]
-These are used for things that either have, or may be required to
-have, full-blown original names. All @Classes@ and @TyCons@ have full
-names. All data-constructor and top-level @Ids@ (things that were
-top-level in the original source) have fullnames.
-\end{description}
-
-%************************************************************************
-%* *
-\subsection[NameTypes-Provenance]{Where a name(d thing) came from}
-%* *
-%************************************************************************
-
-The ``provenance'' of a name says something about where it came from.
-This is used:
-\begin{itemize}
-\item
-to decide whether to generate the code fragments for constructors
-(only done for @ThisModule@).
-\item
-to detect when a thing is from @PreludeCore@, in which case we
-use shorter target-code names.
-\end{itemize}
-
-\begin{code}
-data Provenance
- = ThisModule
-
- | InventedInThisModule -- for workers/wrappers, specialized
- -- versions, etc: anything "conjured up"
- -- on the compiler's initiative.
-
- | ExportedByPreludeCore -- these are the immutable, unrenamable
- -- things the compiler knows about
-
- | OtherPrelude FAST_STRING -- the FullName gave the *original*
- -- name; this says what it was renamed
- -- to (if anything); really just for
- -- pretty-printing
-
- | OtherModule FAST_STRING -- as for OtherPrelude, just the occurrence
- -- name
- [FAST_STRING]-- The modules from whose interface we
- -- got the information about this thing
-
- | HereInPreludeCore -- used when compiling PreludeCore bits:
- -- == ThisModule + ExportedByPreludeCore
-
- | OtherInstance -- For imported instances.
- FAST_STRING -- The module where this instance supposedly
- -- was declared; "" if we don't know.
- [FAST_STRING] -- The modules whose interface told us about
- -- this instance.
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[NameTypes-access-fns]{Access functions for names}
-%* *
-%************************************************************************
-
-Things to make 'em:
-\begin{code}
-mkShortName = ShortName
-
-mkFullName m n p e l = FullName m n p e False{-not invisible-} l
-
-mkPrivateFullName m n p e l = FullName m n p e True{-invisible-} l
-
-mkPreludeCoreName mod name
- = FullName mod name ExportedByPreludeCore ExportAll False mkBuiltinSrcLoc
- -- Mark them as Exported; mkInterface may decide against it
- -- later. (Easier than marking them NotExported, then later
- -- deciding it would be a good idea...)
-\end{code}
-
-\begin{code}
-unlocaliseShortName :: FAST_STRING -> Unique -> ShortName -> FullName
-
-{- We now elucidate Simon's favourite piece of code:
-
- When we are told to "unlocalise" a ShortName, we really really want
- the resulting monster to be unique (across the entire universe).
- We can't count on the module name being printed (for Prelude
- things, it isn't), so we brutally force the module-name into the
- regular-name component.
-
- We change the provenance to InventedInThisModule, because
- that's what it is.
--}
-unlocaliseShortName mod u (ShortName nm loc)
- = FullName mod
- (mod _APPEND_ nm _APPEND_ (showUnique u))
- InventedInThisModule
- ExportAll False loc
-
--- FullNames really can't be mangled; someone out there
--- *expects* the thing to have this name.
--- We only change the export status.
-
-unlocaliseFullName (FullName m n p _ i l)
- = FullName m n p ExportAll i l
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[NameTypes-instances]{Instance declarations for various names}
-%* *
-%************************************************************************
-
-We don't have equality and ordering; that's defined for the things
-that have @ShortNames@ and @FullNames@ in them.
-
-\begin{code}
-instance NamedThing ShortName where
- getExportFlag a = NotExported
- isLocallyDefined a = True
- getOrigName (ShortName s l) = (panic "NamedThing.ShortName.getOrigName", s)
- getOccurrenceName (ShortName s l) = s
- getSrcLoc (ShortName s l) = l
- fromPreludeCore _ = False
-#ifdef DEBUG
- getItsUnique (ShortName s l) = panic "NamedThing.ShortName.getItsUnique"
- getInformingModules a = panic "NamedThing.ShortName.getInformingModule"
-#endif
-\end{code}
-
-\begin{code}
-instance NamedThing FullName where
-
- getExportFlag (FullName m s p e i l) = e
- getOrigName (FullName m s p e i l) = (m, s)
- getSrcLoc (FullName m s p e i l) = l
-
- isLocallyDefined (FullName m s p e i l)
- = case p of
- ThisModule -> True
- InventedInThisModule -> True
- HereInPreludeCore -> True
- _ -> False
-
- getOccurrenceName (FullName _ s p _ _ _)
- = case p of
- OtherPrelude o -> o
- OtherModule o _ -> o
- _ -> s
-
- fromPreludeCore (FullName _ _ p _ _ _)
- = case p of
- ExportedByPreludeCore -> True
- HereInPreludeCore -> True
- _ -> False
-
- getInformingModules (FullName _ _ p _ _ _)
- = case p of
- ThisModule -> [] -- Urgh. ToDo
- InventedInThisModule -> []
- OtherModule _ ms -> ms
- OtherInstance _ ms -> ms
- ExportedByPreludeCore -> [pRELUDE_CORE]
- HereInPreludeCore -> [pRELUDE_CORE]
- OtherPrelude _ -> [pRELUDE]
-
-#ifdef DEBUG
- getItsUnique = panic "NamedThing.FullName.getItsUnique"
-#endif
-\end{code}
-
-A hack (ToDo?):
-\begin{code}
-fromPrelude :: FAST_STRING -> Bool
-
-fromPrelude s = (_SUBSTR_ s 0 6 == SLIT("Prelude"))
-
-invisibleFullName (FullName m s p e i l) = i
-\end{code}
-
-Forcing and printing:
-\begin{code}
-instance Outputable ShortName where
- ppr sty (ShortName s loc) = ppPStr s
-
-instance Outputable FullName where
- ppr sty name@(FullName m s p e i l)
- = let pp_name =
- ppBeside (if fromPreludeCore name
- then ppNil
- else case sty of
- PprForUser -> ppNil
- PprDebug -> ppNil
- PprInterface -> ppNil
- PprUnfolding -> ppNil -- ToDo: something diff later?
- PprForC -> ppBeside (identToC m) (ppPStr cSEP)
- PprForAsm False _ -> ppBeside (identToC m) (ppPStr cSEP)
- PprForAsm True _ -> ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
- _ -> ppBeside (ppPStr m) (ppChar '.'))
- (if codeStyle sty
- then identToC s
- else case sty of
- PprInterface -> pp_local_name s p
- PprForUser -> pp_local_name s p
- _ -> ppPStr s)
-
- pp_debug = ppBeside pp_name (pp_occur_name s p)
- in
- case sty of
- PprShowAll -> ppBesides [pp_debug, pp_exp e] -- (ppr sty loc)
- PprDebug -> pp_debug
- PprUnfolding -> pp_debug
- _ -> pp_name
- where
- pp_exp NotExported = ppNil
- pp_exp ExportAll = ppPStr SLIT("/EXP(..)")
- pp_exp ExportAbs = ppPStr SLIT("/EXP")
-
--- little utility gizmos...
-pp_occur_name, pp_local_name :: FAST_STRING -> Provenance -> Pretty
-
-pp_occur_name s (OtherPrelude o) | s /= o = ppBesides [ppChar '{', ppPStr o, ppChar '}']
-pp_occur_name s (OtherModule o ms)| s /= o = ppBesides [ppChar '{', ppPStr o, ppChar '}']
- -- ToDo: print the "informant modules"?
-pp_occur_name _ _ = ppNil
-
-pp_local_name s (OtherPrelude o) | s /= o = ppPStr o
-pp_local_name s (OtherModule o ms)| s /= o = ppPStr o
-pp_local_name s _ = ppPStr s
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[ProtoName]{@ProtoName@: name type used early in the compiler}
-
-\begin{code}
-#include "HsVersions.h"
-
-module ProtoName (
- ProtoName(..),
-
- mkPreludeProtoName,
-
- cmpProtoName, eqProtoName, elemProtoNames,
- cmpByLocalName, eqByLocalName, elemByLocalNames,
-
- isConopPN
-
- -- and to make the module self-sufficient...
- ) where
-
-import Ubiq{-uitous-}
-
-import Name ( Name )
-import Outputable ( ifPprShowAll, isConop )
-import Pretty
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The main type declaration}
-%* *
-%************************************************************************
-
-\begin{code}
-data ProtoName
- = Unk FAST_STRING -- local name in module
-
- | Qunk FAST_STRING -- qualified name
- FAST_STRING
-
- | Imp FAST_STRING -- name of defining module
- FAST_STRING -- name used in defining name
- [FAST_STRING] -- name of the module whose interfaces
- -- told me about this thing
- FAST_STRING -- occurrence name;
- | Prel Name
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Construction}
-%* *
-%************************************************************************
-
-\begin{code}
-mkPreludeProtoName :: Name -> ProtoName
-
-mkPreludeProtoName prel_name = Prel prel_name
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Ordering}
-%* *
-%************************************************************************
-
-Comparing @ProtoNames@. These functions are used to bring together
-duplicate declarations for things, and eliminate all but one.
-
-In general, the things thus manipulated are not prelude things, but we
-still need to be able to compare prelude classes and type constructors
-so that we can compare instance declarations. However, since all
-Prelude classes and type constructors come from @PreludeCore@, and
-hence can't not be in scope, they will always be of the form (@Prel@
-n), so we don't need to compare @Prel@ things against @Imp@ or @Unk@
-things.
-
-(Later the same night...: but, oh yes, you do:
-
-Given two instance decls
-
-\begin{verbatim}
-instance Eq {-PreludeCore-} Foo
-instance Bar {-user-defined-} Foo
-\end{verbatim}
-
-you will get a comparison of "Eq" (a Prel) with "Bar" (an {Unk,Imp}))
-
-@cmp_name@ compares either by ``local name'' (the string by which
-the entity is known in this module) or by original
-name, in which case the module name is also taken into account.
-(Just watch what happens on @Imps@...)
-
-\begin{code}
-cmp_name :: Bool -> ProtoName -> ProtoName -> TAG_
-
-cmp_name by_local (Unk n1) (Unk n2) = _CMP_STRING_ n1 n2
-cmp_name by_local (Unk n1) (Imp m n2 _ o2) = _CMP_STRING_ n1 (if by_local then o2 else n2)
-cmp_name by_local (Unk n1) (Prel nm)
- = let (_, n2) = getOrigName nm in
- _CMP_STRING_ n1 n2
-
-cmp_name by_local (Prel n1) (Prel n2) = cmp n1 n2
-
--- in ordering these things, it's *most* important to have "names" (vs "modules")
--- as the primary comparison key; otherwise, a list of ProtoNames like...
---
--- Imp H.T , Imp P.I , Unk T
---
--- will *not* be re-ordered to bring the "Imp H.T" and "Unk T" `next to each other'...
---
-
-cmp_name True (Imp _ _ _ o1) (Imp _ _ _ o2) = _CMP_STRING_ o1 o2
-
-cmp_name False (Imp m1 n1 _ _) (Imp m2 n2 _ _)
- = case _CMP_STRING_ n1 n2 of {
- LT_ -> LT_;
- EQ_ -> case _CMP_STRING_ m1 m2 of {
- EQ_ -> EQ_;
- xxx -> if _NULL_ m1 || _NULL_ m2
- then EQ_
- else xxx
- };
- GT__ -> GT_
- }
- -- That's a real **HACK** on comparing "original module" names!
- -- The thing is: we `make up' ProtoNames for instances for
- -- sorting-out-interfaces purposes, but we *may* not know the
- -- original module, so it will be Nil. This is the *ONLY* way
- -- that a "" `module name' can arise! Rather than say "not equal",
- -- we want that Nil to compare as a `wildcard', matching anything.
- --
- -- We could do this elsewhere in the compiler, but there is
- -- an efficiency issue -- we plow through *piles* of instances.
-
-cmp_name True (Imp _ _ _ o1) (Prel nm)
- = let
- n2 = case (getOrigName nm) of { (_, x) -> x } -- stricter for speed
- in
- _CMP_STRING_ o1 n2
-
-cmp_name False (Imp m1 n1 _ _) (Prel nm)
- = case getOrigName nm of { (m2, n2) ->
- case _CMP_STRING_ n1 n2 of { LT_ -> LT_; EQ_ -> _CMP_STRING_ m1 m2; GT__ -> GT_ }}
-
-cmp_name by_local other_p1 other_p2
- = case cmp_name by_local other_p2 other_p1 of -- compare the other way around
- LT_ -> GT_
- EQ_ -> EQ_
- GT__ -> LT_
-\end{code}
-
-\begin{code}
-eqProtoName, eqByLocalName :: ProtoName -> ProtoName -> Bool
-
-eqProtoName a b
- = case cmp_name False a b of { EQ_ -> True; _ -> False }
-
-cmpProtoName a b = cmp_name False a b
-
-eqByLocalName a b
- = case cmp_name True a b of { EQ_ -> True; _ -> False }
-
-cmpByLocalName a b = cmp_name True a b
-\end{code}
-
-\begin{code}
-elemProtoNames, elemByLocalNames :: ProtoName -> [ProtoName] -> Bool
-
-elemProtoNames _ [] = False
-elemProtoNames x (y:ys)
- = case cmp_name False x y of
- LT_ -> elemProtoNames x ys
- EQ_ -> True
- GT__ -> elemProtoNames x ys
-
-elemByLocalNames _ [] = False
-elemByLocalNames x (y:ys)
- = case cmp_name True x y of
- LT_ -> elemByLocalNames x ys
- EQ_ -> True
- GT__ -> elemByLocalNames x ys
-
-isConopPN :: ProtoName -> Bool
-isConopPN (Unk s) = isConop s
-isConopPN (Qunk _ s) = isConop s
-isConopPN (Imp _ n _ _) = isConop n -- ToDo: should use occurrence name???
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Instances}
-%* *
-%************************************************************************
-
-\begin{code}
-{- THESE INSTANCES ARE TOO DELICATE TO BE USED!
-Use eqByLocalName, ...., etc. instead
-
-instance Eq ProtoName where
- a == b = case cmp_name False a b of { EQ_ -> True; _ -> False }
-
-instance Ord ProtoName where
- a < b = case cmp_name False a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a <= b = case cmp_name False a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
--}
-\end{code}
-
-\begin{code}
-instance NamedThing ProtoName where
-
- getOrigName (Unk _) = panic "NamedThing.ProtoName.getOrigName (Unk)"
- getOrigName (Qunk _ _) = panic "NamedThing.ProtoName.getOrigName (Qunk)"
- getOrigName (Imp m s _ _) = (m, s)
- getOrigName (Prel name) = getOrigName name
-
- getOccurrenceName (Unk s) = s
- getOccurrenceName (Qunk _ s) = s
- getOccurrenceName (Imp m s _ o) = o
- getOccurrenceName (Prel name) = getOccurrenceName name
-
-#ifdef DEBUG
- getSrcLoc pn = panic "NamedThing.ProtoName.getSrcLoc"
- getInformingModules pn = panic "NamedThing.ProtoName.getInformingModule"
- getItsUnique pn = panic "NamedThing.ProtoName.getItsUnique"
- fromPreludeCore pn = panic "NamedThing.ProtoName.fromPreludeCore"
- getExportFlag pn = panic "NamedThing.ProtoName.getExportFlag"
- isLocallyDefined pn = panic "NamedThing.ProtoName.isLocallyDefined"
-#endif
-\end{code}
-
-\begin{code}
-instance Outputable ProtoName where
- ppr sty (Unk s) = ppPStr s
- ppr sty (Qunk m s) = ppBesides [ppPStr m, ppChar '.', ppPStr s]
- ppr sty (Prel name) = ppBeside (ppr sty name) (ifPprShowAll sty (ppPStr SLIT("/PREL")))
- ppr sty (Imp mod dec imod loc)
- = ppBesides [ppPStr mod, ppChar '.', ppPStr dec, pp_occur_name dec loc ]
- -- ToDo: print "informant modules" if high debugging level
- where
- pp_occur_name s o | s /= o = ppBesides [ppChar '{', ppPStr o, ppChar '}']
- | otherwise = ppNil
-\end{code}
mkBuiltinUnique :: Int -> Unique
mkBuiltinUnique i = mkUnique 'B' i
-mkPseudoUnique1 i = mkUnique 'C' i -- used for getItsUnique on Regs
+mkPseudoUnique1 i = mkUnique 'C' i -- used for uniqueOf on Regs
mkPseudoUnique2 i = mkUnique 'D' i -- ditto
mkPseudoUnique3 i = mkUnique 'E' i -- ditto
--<mkdependHS:friends> UniqSupply
module Unique (
- Unique,
+ Unique, Uniquable(..),
u2i, -- hack: used in UniqFM
pprUnique, pprUnique10, showUnique,
monadZeroClassKey,
mutableArrayPrimTyConKey,
mutableByteArrayPrimTyConKey,
- negateClassOpKey,
nilDataConKey,
numClassKey,
ordClassKey,
instance Ord3 Unique where
cmp = cmpUnique
+-----------------
+class Uniquable a where
+ uniqueOf :: a -> Unique
+
+instance Uniquable Unique where
+ uniqueOf u = u
\end{code}
We do sometimes make strings with @Uniques@ in them:
instance Text Unique where
showsPrec p uniq rest = _UNPK_ (showUnique uniq)
readsPrec p = panic "no readsPrec for Unique"
-
-instance NamedThing Unique where
- getItsUnique u = u
\end{code}
%************************************************************************
enumFromThenToClassOpKey= mkPreludeMiscIdUnique 39
eqClassOpKey = mkPreludeMiscIdUnique 40
geClassOpKey = mkPreludeMiscIdUnique 41
-negateClassOpKey = mkPreludeMiscIdUnique 42
\end{code}
GenId{-instance NamedThing-}
)
import Maybes ( catMaybes )
+import Outputable ( isLocallyDefined )
import PprAbsC ( pprAmode )
import PprStyle ( PprStyle(..) )
import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) )
newTempAmodeAndIdInfo name lf_info
= (temp_amode, temp_idinfo)
where
- uniq = getItsUnique name
+ uniq = uniqueOf name
temp_amode = CTemp uniq (idPrimRep name)
temp_idinfo = tempIdInfo name uniq lf_info
import Id ( idPrimRep, toplevelishId,
dataConTag, fIRST_TAG, ConTag(..),
isDataCon, DataCon(..),
- idSetToList, GenId{-instance NamedThing,Eq-}
+ idSetToList, GenId{-instance Uniquable,Eq-}
)
import Maybes ( catMaybes )
import PprStyle ( PprStyle(..) )
-- Turn them into amodes
arg_amodes = concat (map mk_amodes sorted_alts)
mk_amodes (con, args, use_mask, rhs)
- = [ CTemp (getItsUnique arg) (idPrimRep arg) | arg <- args ]
+ = [ CTemp (uniqueOf arg) (idPrimRep arg) | arg <- args ]
\end{code}
The situation is simpler for primitive
emptyIdSet,
GenId{-instance NamedThing-}
)
+import Outputable ( getLocalName )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import TyCon ( tyConDataCons, mkSpecTyCon )
import Type ( typePrimRep )
body_code))
entry_addr = CLbl entry_label CodePtrRep
- con_descr = _UNPK_ (getOccurrenceName data_con)
+ con_descr = _UNPK_ (getLocalName data_con)
closure_code = CClosureInfoAndCode closure_info body Nothing
stdUpd con_descr
phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
- con_descr = _UNPK_ (getOccurrenceName data_con)
+ con_descr = _UNPK_ (getLocalName data_con)
con_arity = dataConArity data_con
)
import IdInfo ( arityMaybe )
import Maybes ( assocMaybe, maybeToBool )
+import Outputable ( isLocallyDefined, getLocalName )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
import PrimRep ( getPrimRepSize, separateByPtrFollowness )
closureTypeDescr :: ClosureInfo -> String
closureTypeDescr (MkClosureInfo id lf _)
= if (isDataCon id) then -- DataCon has function types
- _UNPK_ (getOccurrenceName (dataConTyCon id)) -- We want the TyCon not the ->
+ _UNPK_ (getLocalName (dataConTyCon id)) -- We want the TyCon not the ->
else
getTyDescription (idType id)
\end{code}
nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..),
GenId{-instances-}
)
+import Outputable ( isLocallyDefined, getSrcLoc )
import PrelInfo ( liftDataCon, mkLiftTy, statePrimTyCon )
import TyCon ( isBoxedTyCon, TyCon{-instance-} )
import Type ( maybeAppDataTyCon, eqTy )
= ASSERT (isUnboxedButNotState unlifted_ty)
(lifted_id, unlifted_id)
where
- id_name = getOccurrenceName id
+ id_name = panic "CoreLift.mkLiftedId:id_name" --LATER: getOccName id
lifted_id = updateIdType id lifted_ty
unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
getInstantiatedDataConSig, GenId{-instances-}
)
import Maybes ( catMaybes )
-import Outputable ( Outputable(..) )
+import Outputable ( isLocallyDefined, getSrcLoc,
+ Outputable(..){-instance * []-}
+ )
import PprCore
import PprStyle ( PprStyle(..) )
import PprType ( GenType, GenTyVar, TyCon )
module HsBinds where
-import Ubiq{-uitous-}
+import Ubiq
-- friends:
import HsLoop
-
import HsMatches ( pprMatches, pprGRHSsAndBinds,
- Match, GRHSsAndBinds
- )
+ Match, GRHSsAndBinds )
import HsPat ( collectPatBinders, InPat )
import HsPragmas ( GenPragmas, ClassOpPragmas )
import HsTypes ( PolyType )
#include "HsVersions.h"
module HsCore (
- -- types:
UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
UnfoldingCoreAtom(..), UfId(..), UnfoldingType(..),
- UnfoldingPrimOp(..), UfCostCentre(..),
-
- -- function:
- eqUfExpr
+ UnfoldingPrimOp(..), UfCostCentre(..)
) where
-import Ubiq{-uitous-}
+import Ubiq
-- friends:
-import HsTypes ( cmpPolyType, MonoType(..), PolyType(..) )
+import HsTypes ( MonoType, PolyType )
import PrimOp ( PrimOp, tagOf_PrimOp )
-- others:
import Literal ( Literal )
-import Outputable ( Outputable(..) {-instances-} )
+import Outputable ( Outputable(..) )
import Pretty
-import ProtoName ( cmpProtoName, eqProtoName, ProtoName )
import Util ( panic )
\end{code}
= ppBesides [ppStr "({-wrkr-}", pprUfId sty unwrkr, ppStr ")"]
\end{code}
-%************************************************************************
-%* *
-\subsection[HsCore-equality]{Comparing Core unfoldings}
-%* *
-%************************************************************************
-
-We want to check that they are {\em exactly} the same.
-
-\begin{code}
---eqUfExpr :: ProtoNameCoreExpr -> ProtoNameCoreExpr -> Bool
-
-eqUfExpr (UfVar v1) (UfVar v2) = eqUfId v1 v2
-eqUfExpr (UfLit l1) (UfLit l2) = l1 == l2
-
-eqUfExpr (UfCon c1 tys1 as1) (UfCon c2 tys2 as2)
- = eq_name c1 c2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
-eqUfExpr (UfPrim o1 tys1 as1) (UfPrim o2 tys2 as2)
- = eq_op o1 o2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
- where
- eq_op (UfCCallOp _ _ _ _ _) (UfCCallOp _ _ _ _ _) = True
- eq_op (UfOtherOp o1) (UfOtherOp o2)
- = tagOf_PrimOp o1 _EQ_ tagOf_PrimOp o2
-
-eqUfExpr (UfLam bs1 body1) (UfLam bs2 body2)
- = eq_binder bs1 bs2 && eqUfExpr body1 body2
-
-eqUfExpr (UfApp fun1 arg1) (UfApp fun2 arg2)
- = eqUfExpr fun1 fun2 && eq_atom arg1 arg2
-
-eqUfExpr (UfCase scrut1 alts1) (UfCase scrut2 alts2)
- = eqUfExpr scrut1 scrut2 && eq_alts alts1 alts2
- where
- eq_alts (UfCoAlgAlts alts1 deflt1) (UfCoAlgAlts alts2 deflt2)
- = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
- where
- eq_alt (c1,bs1,rhs1) (c2,bs2,rhs2)
- = eq_name c1 c2 && eq_lists eq_binder bs1 bs2 && eqUfExpr rhs1 rhs2
-
- eq_alts (UfCoPrimAlts alts1 deflt1) (UfCoPrimAlts alts2 deflt2)
- = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
- where
- eq_alt (l1,rhs1) (l2,rhs2)
- = l1 == l2 && eqUfExpr rhs1 rhs2
-
- eq_alts _ _ = False -- catch-all
-
- eq_deflt UfCoNoDefault UfCoNoDefault = True
- eq_deflt (UfCoBindDefault b1 rhs1) (UfCoBindDefault b2 rhs2)
- = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
- eq_deflt _ _ = False
-
-eqUfExpr (UfLet (UfCoNonRec b1 rhs1) body1) (UfLet (UfCoNonRec b2 rhs2) body2)
- = eq_binder b1 b2 && eqUfExpr rhs1 rhs2 && eqUfExpr body1 body2
-
-eqUfExpr (UfLet (UfCoRec pairs1) body1) (UfLet (UfCoRec pairs2) body2)
- = eq_lists eq_pair pairs1 pairs2 && eqUfExpr body1 body2
- where
- eq_pair (b1,rhs1) (b2,rhs2) = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
-
-eqUfExpr (UfSCC cc1 body1) (UfSCC cc2 body2)
- = {-trace "eqUfExpr: not comparing cost-centres!"-} (eqUfExpr body1 body2)
-
-eqUfExpr _ _ = False -- Catch-all
-\end{code}
-
-\begin{code}
-eqUfId (BoringUfId n1) (BoringUfId n2)
- = eq_name n1 n2
-eqUfId (SuperDictSelUfId a1 b1) (SuperDictSelUfId a2 b2)
- = eq_name a1 a2 && eq_name b1 b2
-eqUfId (ClassOpUfId a1 b1) (ClassOpUfId a2 b2)
- = eq_name a1 a2 && eq_name b1 b2
-eqUfId (DictFunUfId c1 t1) (DictFunUfId c2 t2)
- = eq_name c1 c2 && eq_tycon t1 t2 -- NB: **** only compare TyCons ******
- where
- eq_tycon = panic "HsCore:eqUfId:eq_tycon:ToDo"
-{- LATER:
- eq_tycon (UnoverloadedTy ty1) (UnoverloadedTy ty2)
- = case (cmpInstanceTypes ty1 ty2) of { EQ_ -> True; _ -> False }
- eq_tycon ty1 ty2
- = trace "eq_tycon" (eq_type ty1 ty2) -- desperately try something else
--}
-
-eqUfId (ConstMethodUfId a1 b1 t1) (ConstMethodUfId a2 b2 t2)
- = eq_name a1 a2 && eq_name b1 b2 && eq_type t1 t2
-eqUfId (DefaultMethodUfId a1 b1) (DefaultMethodUfId a2 b2)
- = eq_name a1 a2 && eq_name b1 b2
-eqUfId (SpecUfId id1 tms1) (SpecUfId id2 tms2)
- = eqUfId id1 id2 && eq_lists eq_ty_maybe tms1 tms2
- where
- eq_ty_maybe = panic "HsCore:eqUfId:eq_ty_maybe:ToDo"
-{-
- eq_ty_maybe Nothing Nothing = True
- eq_ty_maybe (Just ty1) (Just ty2)
- = eq_type (UnoverloadedTy ty1) (UnoverloadedTy ty2)
- -- a HACKy way to compare MonoTypes (ToDo) [WDP 94/05/02]
- eq_ty_maybe _ _ = False
--}
-eqUfId (WorkerUfId id1) (WorkerUfId id2)
- = eqUfId id1 id2
-eqUfId _ _ = False -- catch-all
-\end{code}
-
-\begin{code}
-eq_atom (UfCoVarAtom id1) (UfCoVarAtom id2) = eqUfId id1 id2
-eq_atom (UfCoLitAtom l1) (UfCoLitAtom l2) = l1 == l2
-eq_atom _ _ = False
-
-eq_binder (n1, ty1) (n2, ty2) = eq_name n1 n2 && eq_type ty1 ty2
-
-eq_name :: ProtoName -> ProtoName -> Bool
-eq_name pn1 pn2 = eqProtoName pn1 pn2 -- uses original names
-
-eq_type ty1 ty2
- = case (cmpPolyType cmpProtoName ty1 ty2) of { EQ_ -> True; _ -> False }
-\end{code}
-
-\begin{code}
-eq_lists :: (a -> a -> Bool) -> [a] -> [a] -> Bool
-
-eq_lists eq [] [] = True
-eq_lists eq [] _ = False
-eq_lists eq _ [] = False
-eq_lists eq (x:xs) (y:ys) = eq x y && eq_lists eq xs ys
-\end{code}
module HsDecls where
-import Ubiq{-uitous-}
+import Ubiq
-- friends:
import HsLoop ( nullMonoBinds, MonoBinds, Sig )
import HsPragmas ( DataPragmas, ClassPragmas,
- InstancePragmas, ClassOpPragmas
- )
+ InstancePragmas, ClassOpPragmas )
import HsTypes
-- others:
import Outputable
import Pretty
-import ProtoName ( cmpProtoName, ProtoName )
import SrcLoc ( SrcLoc )
import Util ( cmpList, panic#{-ToDo:rm eventually-} )
\end{code}
%* *
%************************************************************************
-These are only used in generating interfaces at the moment. They are
-not used in pretty-printing.
-
\begin{code}
data FixityDecl name
= InfixL name Int
| Unbanged (MonoType name)
\end{code}
-In checking interfaces, we need to ``compare'' @ConDecls@. Use with care!
-\begin{code}
-eqConDecls cons1 cons2
- = case (cmpList cmp cons1 cons2) of { EQ_ -> True; _ -> False }
- where
- cmp (ConDecl n1 tys1 _) (ConDecl n2 tys2 _)
- = case cmpProtoName n1 n2 of
- EQ_ -> cmpList cmp_bang_ty tys1 tys2
- xxx -> xxx
- cmp (ConOpDecl _ _ _ _) _ = panic# "eqConDecls:ConOpDecl"
- cmp (RecConDecl _ _ _) _ = panic# "eqConDecls:RecConDecl"
- cmp (NewConDecl _ _ _) _ = panic# "eqConDecls:NewConDecl"
- -------------
-
- cmp_ty = cmpMonoType cmpProtoName
- -------------
- cmp_bang_ty (Banged ty1) (Banged ty2) = cmp_ty ty1 ty2
- cmp_bang_ty (Unbanged ty1) (Unbanged ty2) = cmp_ty ty1 ty2
- cmp_bang_ty (Banged _) _ = LT_
- cmp_bang_ty _ _ = GT_
-\end{code}
-
\begin{code}
instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
=> Outputable (ClassDecl tyvar uvar name pat) where
ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc)
- = ppAboves [ppCat [ppStr "class", pprContext sty context, ppr sty clas,
- ppr sty tyvar, ppStr "where"],
- -- ToDo: really shouldn't print "where" unless there are sigs
- ppNest 4 (ppAboves (map (ppr sty) sigs)),
- ppNest 4 (ppr sty methods),
- ppNest 4 (ppr sty pragmas)]
+ = let
+ top_matter = ppCat [ppStr "class", pprContext sty context,
+ ppr sty clas, ppr sty tyvar]
+ in
+ if null sigs && nullMonoBinds methods then
+ ppAbove top_matter (ppNest 4 (ppr sty pragmas))
+ else
+ ppAboves [ppCat [top_matter, ppStr "where"],
+ ppNest 4 (ppAboves (map (ppr sty) sigs)),
+ ppNest 4 (ppr sty methods),
+ ppNest 4 (ppr sty pragmas) ]
\end{code}
%************************************************************************
-- module being compiled; False <=> It is from
-- an imported interface.
- FAST_STRING -- The name of the module where the instance decl
- -- originally came from; easy enough if it's
- -- the module being compiled; otherwise, the
- -- info comes from a pragma.
+ (Maybe Module) -- The name of the module where the instance decl
+ -- originally came from; Nothing => Prelude
[Sig name] -- actually user-supplied pragmatic info
(InstancePragmas name) -- interface-supplied pragmatic info
if nullMonoBinds binds && null uprags then
ppAbove top_matter (ppNest 4 (ppr sty pragmas))
else
- ppAboves [
- ppCat [top_matter, ppStr "where"],
- if null uprags then ppNil else ppNest 4 (ppr sty uprags),
- ppNest 4 (ppr sty binds),
- ppNest 4 (ppr sty pragmas) ]
+ ppAboves [ppCat [top_matter, ppStr "where"],
+ if null uprags then ppNil else ppNest 4 (ppr sty uprags),
+ ppNest 4 (ppr sty binds),
+ ppNest 4 (ppr sty pragmas) ]
\end{code}
A type for recording what instances the user wants to specialise;
| HsApp (HsExpr tyvar uvar id pat) -- application
(HsExpr tyvar uvar id pat)
- -- Operator applications and sections.
+ -- Operator applications:
-- NB Bracketed ops such as (+) come out as Vars.
+ -- NB We need an expr for the operator in an OpApp/Section since
+ -- the typechecker may need to apply the operator to a few types.
+
| OpApp (HsExpr tyvar uvar id pat) -- left operand
(HsExpr tyvar uvar id pat) -- operator
(HsExpr tyvar uvar id pat) -- right operand
- -- ADR Question? Why is the "op" in a section an expr when it will
- -- have to be of the form (HsVar op) anyway?
- -- WDP Answer: But when the typechecker gets ahold of it, it may
- -- apply the var to a few types; it will then be an expression.
+ -- We preserve prefix negation and parenthesis for the precedence parser.
+
+ | NegApp (HsExpr tyvar uvar id pat) -- negated expr
+ | HsPar (HsExpr tyvar uvar id pat) -- parenthesised expr
| SectionL (HsExpr tyvar uvar id pat) -- operand
(HsExpr tyvar uvar id pat) -- operator
collect_args (HsApp fun arg) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
+
pprExpr sty (OpApp e1 op e2)
= case op of
HsVar v -> pp_infixly v
pp_infixly v
= ppSep [pp_e1, ppCat [pprOp sty v, pp_e2]]
+pprExpr sty (NegApp e)
+ = ppBeside (ppChar '-') (ppParens (pprExpr sty e))
+
+pprExpr sty (HsPar e)
+ = ppParens (pprExpr sty e)
+
+
pprExpr sty (SectionL expr op)
= case op of
HsVar v -> pp_infixly v
module HsImpExp where
-import Ubiq{-uitous-}
+import Ubiq
--- friends:
-import HsDecls ( FixityDecl, TyDecl, ClassDecl, InstDecl )
-import HsBinds ( Sig )
-
--- others:
import Outputable
import PprStyle ( PprStyle(..) )
import Pretty
-import SrcLoc ( SrcLoc{-instances-} )
+import SrcLoc ( SrcLoc )
\end{code}
%************************************************************************
One per \tr{import} declaration in a module.
\begin{code}
-data ImportedInterface tyvar uvar name pat
- = ImportMod (Interface tyvar uvar name pat)
+data ImportDecl name
+ = ImportDecl Module -- module name
Bool -- qualified?
- (Maybe FAST_STRING) -- as Modid
+ (Maybe Module) -- as Module
(Maybe (Bool, [IE name])) -- (hiding?, names)
+ SrcLoc
\end{code}
\begin{code}
-instance (NamedThing name, Outputable name, Outputable pat,
- Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
- => Outputable (ImportedInterface tyvar uvar name pat) where
-
- ppr sty (ImportMod iface qual as spec)
- = ppAbove (ppHang (ppCat [ppStr "import", pp_qual qual, ppr PprForUser iface, pp_as as])
- 4 (pp_spec spec))
- (case sty of {PprForUser -> ppNil; _ -> ppr sty iface})
+instance (Outputable name) => Outputable (ImportDecl name) where
+ ppr sty (ImportDecl mod qual as spec _)
+ = ppHang (ppCat [ppStr "import", pp_qual qual, ppPStr mod, pp_as as])
+ 4 (pp_spec spec)
where
pp_qual False = ppNil
pp_qual True = ppStr "qualified"
| IEThingAbs name -- Constructor/Type/Class (can't tell)
| IEThingAll name -- Class/Type plus all methods/constructors
| IEThingWith name [name] -- Class/Type plus some methods/constructors
- | IEModuleContents FAST_STRING -- (Export Only)
+ | IEModuleContents Module -- (Export Only)
\end{code}
\begin{code}
ppr sty (IEModuleContents mod)
= ppBeside (ppPStr SLIT("module ")) (ppPStr mod)
\end{code}
-
-%************************************************************************
-%* *
-\subsection{Interfaces}
-%* *
-%************************************************************************
-
-\begin{code}
-data Interface tyvar uvar name pat
- = Interface FAST_STRING -- module name
- [IfaceImportDecl name]
- [FixityDecl name]
- [TyDecl name] -- data decls may have no constructors
- [ClassDecl tyvar uvar name pat] -- without default methods
- [InstDecl tyvar uvar name pat] -- without method defns
- [Sig name]
- SrcLoc
-\end{code}
-
-\begin{code}
-instance (NamedThing name, Outputable name, Outputable pat,
- Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
- => Outputable (Interface tyvar uvar name pat) where
-
- ppr PprForUser (Interface name _ _ _ _ _ _ _) = ppPStr name
-
- ppr sty (Interface name iimpdecls fixities tydecls classdecls instdecls sigs anns)
- = ppAboves [ppStr "{-",
- ifPprShowAll sty (ppr sty anns),
- ppCat [ppStr "interface", ppPStr name, ppStr "where"],
- ppNest 4 (ppAboves [
- pp_nonnull iimpdecls,
- pp_nonnull fixities,
- pp_nonnull tydecls,
- pp_nonnull classdecls,
- pp_nonnull instdecls,
- pp_nonnull sigs]),
- ppStr "-}"]
- where
- pp_nonnull [] = ppNil
- pp_nonnull xs = ppAboves (map (ppr sty) xs)
-\end{code}
-
-\begin{code}
-data IfaceImportDecl name
- = IfaceImportDecl FAST_STRING -- module we're being told about
- [IE name] -- things we're being told about
- SrcLoc
-\end{code}
-
-\begin{code}
-instance Outputable name => Outputable (IfaceImportDecl name) where
-
- ppr sty (IfaceImportDecl mod names src_loc)
- = ppHang (ppCat [ppPStr SLIT("import"), ppPStr mod, ppLparen])
- 4 (ppSep [ppCat [interpp'SP sty names, ppRparen]])
-\end{code}
| ConOpPatIn (InPat name)
name
(InPat name)
+
+ -- We preserve prefix negation and parenthesis for the precedence parser.
+
+ | NegPatIn (InPat name) -- negated pattern
+ | ParPatIn (InPat name) -- parenthesised pattern
+
| ListPatIn [InPat name] -- syntactic list
-- must have >= 1 elements
| TuplePatIn [InPat name] -- tuple
pprInPat sty (ConOpPatIn pat1 op pat2)
= ppBesides [ppLparen, ppr sty pat1, ppSP, ppr sty op, ppSP, ppr sty pat2, ppRparen]
--- ToDo: use pprOp to print op (but this involves fiddling various
--- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP)
+ -- ToDo: use pprOp to print op (but this involves fiddling various
+ -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP)
+
+pprInPat sty (NegPatIn pat)
+ = ppBeside (ppChar '-') (ppParens (pprInPat sty pat))
+
+pprInPat sty (ParPatIn pat)
+ = ppParens (pprInPat sty pat)
+
pprInPat sty (ListPatIn pats)
= ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
ppBesides [ppBracket (interpp'SP sty methods), ppRparen]]
pprConPatTy sty ty
- = ppBesides [ppLparen, ppr sty ty, ppRparen]
+ = ppParens (ppr sty ty)
\end{code}
%************************************************************************
See also: @Sig@ (``signatures'') which is where user-supplied pragmas
for values show up; ditto @SpecInstSig@ (for instances) and
-@SpecDataSig@ (for data types and type synonyms).
+@SpecDataSig@ (for data types).
\begin{code}
#include "HsVersions.h"
module HsPragmas where
-import Ubiq{-uitous-}
+import Ubiq
-- friends:
-import HsLoop ( ConDecl )
import HsCore ( UnfoldingCoreExpr )
import HsTypes ( MonoType )
-- others:
import IdInfo
-import Outputable ( Outputable(..){-instances-} )
+import Outputable ( Outputable(..) )
import Pretty
\end{code}
Pragma types may be parameterised, just as with any other
abstract-syntax type.
-For a @data@ declaration---makes visible the constructors for an
-abstract @data@ type and indicates which specialisations exist.
+For a @data@ declaration---indicates which specialisations exist.
\begin{code}
data DataPragmas name
- = DataPragmas [ConDecl name] -- hidden data constructors
- [[Maybe (MonoType name)]] -- types to which specialised
+ = NoDataPragmas
+ | DataPragmas [[Maybe (MonoType name)]] -- types to which specialised
+
+noDataPragmas = NoDataPragmas
+
+isNoDataPragmas NoDataPragmas = True
+isNoDataPragmas _ = False
\end{code}
These are {\em general} things you can know about any value:
noGenPragmas = NoGenPragmas
+isNoGenPragmas NoGenPragmas = True
+isNoGenPragmas _ = False
+
data ImpUnfolding name
= NoImpUnfolding
| ImpMagicUnfolding FAST_STRING -- magic "unfolding"
data ClassPragmas name
= NoClassPragmas
| SuperDictPragmas [GenPragmas name] -- list mustn't be empty
+
+noClassPragmas = NoClassPragmas
+
+isNoClassPragmas NoClassPragmas = True
+isNoClassPragmas _ = False
\end{code}
For a class's method selectors:
| ClassOpPragmas (GenPragmas name) -- for method selector
(GenPragmas name) -- for default method
+
noClassOpPragmas = NoClassOpPragmas
+
+isNoClassOpPragmas NoClassOpPragmas = True
+isNoClassOpPragmas _ = False
\end{code}
\begin{code}
[([Maybe (MonoType name)], -- specialised instance; type...
Int, -- #dicts to ignore
InstancePragmas name)] -- (no SpecialisedInstancePragma please!)
+
+noInstancePragmas = NoInstancePragmas
+
+isNoInstancePragmas NoInstancePragmas = True
+isNoInstancePragmas _ = False
\end{code}
Some instances for printing (just for debugging, really)
) where
-import Ubiq{-uitous-}
+import Ubiq
-- friends:
import HsBinds
import HsPat
import HsTypes
import HsPragmas ( ClassPragmas, ClassOpPragmas,
- DataPragmas, GenPragmas, InstancePragmas
- )
+ DataPragmas, GenPragmas, InstancePragmas )
-- others:
import FiniteMap ( FiniteMap )
-import Outputable ( ifPprShowAll, interpp'SP, Outputable(..){-instances-} )
+import Outputable ( ifPprShowAll, ifnotPprForUser, interpp'SP, Outputable(..) )
import Pretty
-import SrcLoc ( SrcLoc{-instances-} )
+import SrcLoc ( SrcLoc )
\end{code}
@Fake@ is a placeholder type; for when tyvars and uvars aren't used.
All we actually declare here is the top-level structure for a module.
\begin{code}
+type Version = Int
+
data HsModule tyvar uvar name pat
= HsModule
- FAST_STRING -- module name
+ Module -- module name
+ (Maybe Version) -- source interface version number
(Maybe [IE name]) -- export list; Nothing => export everything
-- Just [] => export *nothing* (???)
-- Just [...] => as you would expect...
- [ImportedInterface tyvar uvar name pat]
- -- We snaffle interesting stuff out of the
+ [ImportDecl name] -- We snaffle interesting stuff out of the
-- imported interfaces early on, adding that
-- info to TyDecls/etc; so this list is
-- often empty, downstream.
[FixityDecl name]
[TyDecl name]
- [SpecDataSig name] -- user pragmas that modify TyDecls
+ [SpecDataSig name] -- user pragmas that modify TyDecls
[ClassDecl tyvar uvar name pat]
[InstDecl tyvar uvar name pat]
- [SpecInstSig name] -- user pragmas that modify InstDecls
+ [SpecInstSig name] -- user pragmas that modify InstDecls
[DefaultDecl name]
- (HsBinds tyvar uvar name pat) -- the main stuff!
- [Sig name] -- "Sigs" are folded into the "HsBinds"
- -- pretty early on, so this list is
- -- often either empty or just the
- -- interface signatures.
+ (HsBinds tyvar uvar name pat) -- the main stuff, includes source sigs
+ [Sig name] -- interface sigs
SrcLoc
\end{code}
Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
=> Outputable (HsModule tyvar uvar name pat) where
- ppr sty (HsModule name exports imports fixities
+ ppr sty (HsModule name iface_version exports imports fixities
typedecls typesigs classdecls instdecls instsigs
defdecls binds sigs src_loc)
= ppAboves [
ifPprShowAll sty (ppr sty src_loc),
+ ifnotPprForUser sty (pp_iface_version iface_version),
case exports of
Nothing -> ppCat [ppPStr SLIT("module"), ppPStr name, ppPStr SLIT("where")]
Just es -> ppAboves [
ppNest 8 (interpp'SP sty es),
ppNest 4 (ppPStr SLIT(") where"))
],
- pp_nonnull imports, pp_nonnull fixities,
- pp_nonnull typedecls, pp_nonnull typesigs,
+ pp_nonnull imports,
+ pp_nonnull fixities,
+ pp_nonnull typedecls,
+ pp_nonnull typesigs,
pp_nonnull classdecls,
- pp_nonnull instdecls, pp_nonnull instsigs,
+ pp_nonnull instdecls,
+ pp_nonnull instsigs,
pp_nonnull defdecls,
- ppr sty binds, pp_nonnull sigs
+ ppr sty binds,
+ pp_nonnull sigs
]
where
pp_nonnull [] = ppNil
pp_nonnull xs = ppAboves (map (ppr sty) xs)
+
+ pp_iface_version Nothing = ppNil
+ pp_iface_version (Just n) = ppCat [ppStr "{-# INTERFACE", ppInt n, ppStr "#-}"]
\end{code}
Context(..), ClassAssertion(..)
#ifdef COMPILING_GHC
- , cmpPolyType, cmpMonoType
, pprParendMonoType, pprContext
, extractMonoTyNames, extractCtxtTyNames
+ , cmpPolyType, cmpMonoType, cmpContext
#endif
) where
#ifdef COMPILING_GHC
-import Ubiq{-uitous-}
+import Ubiq
import Outputable ( interppSP, ifnotPprForUser )
import Pretty
-import ProtoName ( cmpProtoName, ProtoName )
import Type ( Kind )
-import Util ( cmpList, panic# )
+import Util ( thenCmp, cmpList, isIn, panic# )
#endif {- COMPILING_GHC -}
\end{code}
#endif {- COMPILING_GHC -}
\end{code}
-We do define a specialised equality for these \tr{*Type} types; used
-in checking interfaces. Most any other use is likely to be {\em
-wrong}, so be careful!
-\begin{code}
-#ifdef COMPILING_GHC
-
-cmpPolyType :: (a -> a -> TAG_) -> PolyType a -> PolyType a -> TAG_
-cmpMonoType :: (a -> a -> TAG_) -> MonoType a -> MonoType a -> TAG_
-cmpContext :: (a -> a -> TAG_) -> Context a -> Context a -> TAG_
-
--- We assume that HsPreForAllTys have been smashed by now.
-# ifdef DEBUG
-cmpPolyType _ (HsPreForAllTy _ _) _ = panic# "cmpPolyType:HsPreForAllTy:1st arg"
-cmpPolyType _ _ (HsPreForAllTy _ _) = panic# "cmpPolyType:HsPreForAllTy:2nd arg"
-# endif
-
-cmpPolyType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
- = case (cmp_tvs tvs1 tvs2) of
- EQ_ -> case (cmpContext cmp c1 c2) of
- EQ_ -> cmpMonoType cmp t1 t2
- xxx -> xxx
- xxx -> xxx
- where
- cmp_tvs [] [] = EQ_
- cmp_tvs [] _ = LT_
- cmp_tvs _ [] = GT_
- cmp_tvs (a:as) (b:bs)
- = case cmp a b of { EQ_ -> cmp_tvs as bs; xxx -> xxx }
- cmp_tvs _ _ = panic# "cmp_tvs"
-
------------
-cmpMonoType cmp (MonoTyVar n1) (MonoTyVar n2)
- = cmp n1 n2
-
-cmpMonoType cmp (MonoTupleTy tys1) (MonoTupleTy tys2)
- = cmpList (cmpMonoType cmp) tys1 tys2
-cmpMonoType cmp (MonoListTy ty1) (MonoListTy ty2)
- = cmpMonoType cmp ty1 ty2
-
-cmpMonoType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2)
- = case cmp tc1 tc2 of { EQ_ -> cmpList (cmpMonoType cmp) tys1 tys2; xxx -> xxx }
-
-cmpMonoType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
- = case cmpMonoType cmp a1 a2 of { EQ_ -> cmpMonoType cmp b1 b2; xxx -> xxx }
-
-cmpMonoType cmp (MonoDictTy c1 ty1) (MonoDictTy c2 ty2)
- = case cmp c1 c2 of { EQ_ -> cmpMonoType cmp ty1 ty2; xxx -> xxx }
-
-cmpMonoType cmp ty1 ty2 -- tags must be different
- = let tag1 = tag ty1
- tag2 = tag ty2
- in
- if tag1 _LT_ tag2 then LT_ else GT_
- where
- tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT)
- tag (MonoTupleTy tys1) = ILIT(2)
- tag (MonoListTy ty1) = ILIT(3)
- tag (MonoTyApp tc1 tys1) = ILIT(4)
- tag (MonoFunTy a1 b1) = ILIT(5)
- tag (MonoDictTy c1 ty1) = ILIT(7)
-
--------------------
-cmpContext cmp a b
- = cmpList cmp_ctxt a b
- where
- cmp_ctxt (c1, tv1) (c2, tv2)
- = case cmp c1 c2 of { EQ_ -> cmp tv1 tv2; xxx -> xxx }
-
--------------------
-\end{code}
-
This is used in various places:
\begin{code}
+#ifdef COMPILING_GHC
pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty
pprContext sty [] = ppNil
#endif {- COMPILING_GHC -}
\end{code}
-Get the type variable names from a @MonoType@. Don't use class @Eq@
-because @ProtoNames@ aren't in it.
-
\begin{code}
#ifdef COMPILING_GHC
-extractCtxtTyNames :: (name -> name -> Bool) -> Context name -> [name]
-extractMonoTyNames :: (name -> name -> Bool) -> MonoType name -> [name]
+extractCtxtTyNames :: Eq name => Context name -> [name]
+extractMonoTyNames :: Eq name => MonoType name -> [name]
-extractCtxtTyNames eq ctxt
+extractCtxtTyNames ctxt
= foldr get [] ctxt
where
get (clas, tv) acc
- | is_elem eq tv acc = acc
- | otherwise = tv : acc
+ | tv `is_elem` acc = acc
+ | otherwise = tv : acc
-extractMonoTyNames eq ty
+ is_elem = isIn "extractCtxtTyNames"
+
+extractMonoTyNames ty
= get ty []
where
get (MonoTyApp con tys) acc = foldr get acc tys
get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc)
get (MonoDictTy _ ty) acc = get ty acc
get (MonoTupleTy tys) acc = foldr get acc tys
- get (MonoTyVar name) acc
- | is_elem eq name acc = acc
- | otherwise = name : acc
+ get (MonoTyVar tv) acc
+ | tv `is_elem` acc = acc
+ | otherwise = tv : acc
+
+ is_elem = isIn "extractMonoTyNames"
+
+#endif {- COMPILING_GHC -}
+\end{code}
+
+We do define a specialised equality for these \tr{*Type} types; used
+in checking interfaces. Most any other use is likely to be {\em
+wrong}, so be careful!
+\begin{code}
+#ifdef COMPILING_GHC
+
+cmpPolyType :: (a -> a -> TAG_) -> PolyType a -> PolyType a -> TAG_
+cmpMonoType :: (a -> a -> TAG_) -> MonoType a -> MonoType a -> TAG_
+cmpContext :: (a -> a -> TAG_) -> Context a -> Context a -> TAG_
+
+-- We assume that HsPreForAllTys have been smashed by now.
+# ifdef DEBUG
+cmpPolyType _ (HsPreForAllTy _ _) _ = panic# "cmpPolyType:HsPreForAllTy:1st arg"
+cmpPolyType _ _ (HsPreForAllTy _ _) = panic# "cmpPolyType:HsPreForAllTy:2nd arg"
+# endif
+
+cmpPolyType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
+ = thenCmp (cmp_tvs tvs1 tvs2)
+ (thenCmp (cmpContext cmp c1 c2) (cmpMonoType cmp t1 t2))
+ where
+ cmp_tvs [] [] = EQ_
+ cmp_tvs [] _ = LT_
+ cmp_tvs _ [] = GT_
+ cmp_tvs (a:as) (b:bs)
+ = thenCmp (cmp a b) (cmp_tvs as bs)
+ cmp_tvs _ _ = panic# "cmp_tvs"
+
+-----------
+cmpMonoType cmp (MonoTyVar n1) (MonoTyVar n2)
+ = cmp n1 n2
+
+cmpMonoType cmp (MonoTupleTy tys1) (MonoTupleTy tys2)
+ = cmpList (cmpMonoType cmp) tys1 tys2
+cmpMonoType cmp (MonoListTy ty1) (MonoListTy ty2)
+ = cmpMonoType cmp ty1 ty2
+
+cmpMonoType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2)
+ = thenCmp (cmp tc1 tc2) (cmpList (cmpMonoType cmp) tys1 tys2)
+
+cmpMonoType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
+ = thenCmp (cmpMonoType cmp a1 a2) (cmpMonoType cmp b1 b2)
+
+cmpMonoType cmp (MonoDictTy c1 ty1) (MonoDictTy c2 ty2)
+ = thenCmp (cmp c1 c2) (cmpMonoType cmp ty1 ty2)
-is_elem eq n [] = False
-is_elem eq n (x:xs) = n `eq` x || is_elem eq n xs
+cmpMonoType cmp ty1 ty2 -- tags must be different
+ = let tag1 = tag ty1
+ tag2 = tag ty2
+ in
+ if tag1 _LT_ tag2 then LT_ else GT_
+ where
+ tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT)
+ tag (MonoTupleTy tys1) = ILIT(2)
+ tag (MonoListTy ty1) = ILIT(3)
+ tag (MonoTyApp tc1 tys1) = ILIT(4)
+ tag (MonoFunTy a1 b1) = ILIT(5)
+ tag (MonoDictTy c1 ty1) = ILIT(7)
+
+-------------------
+cmpContext cmp a b
+ = cmpList cmp_ctxt a b
+ where
+ cmp_ctxt (c1, tv1) (c2, tv2)
+ = thenCmp (cmp c1 c2) (cmp tv1 tv2)
#endif {- COMPILING_GHC -}
\end{code}
opt_IgnoreStrictnessPragmas = lookup SLIT("-fignore-strictness-pragmas")
opt_IrrefutableEverything = lookup SLIT("-firrefutable-everything")
opt_IrrefutableTuples = lookup SLIT("-firrefutable-tuples")
-opt_NameShadowingNotOK = lookup SLIT("-fname-shadowing-not-ok")
+opt_WarnNameShadowing = lookup SLIT("-fwarn-name-shadowing")
opt_NumbersStrict = lookup SLIT("-fnumbers-strict")
opt_OmitBlackHoling = lookup SLIT("-dno-black-holing")
opt_OmitDefaultInstanceMethods = lookup SLIT("-fomit-default-instance-methods")
#include "HsVersions.h"
module ErrUtils (
-
- Error(..),
- addErrLoc, addShortErrLocLine,
- dontAddErrLoc, pprBagOfErrors
-
+ Error(..), Warning(..), Message(..),
+ addErrLoc,
+ addShortErrLocLine,
+ dontAddErrLoc,
+ pprBagOfErrors
) where
import Ubiq{-uitous-}
\begin{code}
type Error = PprStyle -> Pretty
+type Warning = PprStyle -> Pretty
+type Message = PprStyle -> Pretty
addErrLoc :: SrcLoc -> String -> Error -> Error
addErrLoc locn title rest_of_err_msg sty
= let pretties = map ( \ e -> e sty ) (bagToList bag_of_errors) in
ppAboves (map (\ p -> ppAbove ppSP p) pretties)
\end{code}
-
import Pretty
import Id ( GenId ) -- instances
-import Name ( Name ) -- instances
-import ProtoName ( ProtoName ) -- instances
+import Name ( Name, RdrName ) -- instances
import PprType ( GenType, GenTyVar ) -- instances
+import RnHsSyn ( RnName ) -- instances
import TyVar ( GenTyVar ) -- instances
-import Unique ( Unique) -- instances
+import Unique ( Unique ) -- instances
{-
--import MkIface ( mkInterface )
-
-}
\end{code}
show_pass "Reader" `thenMn_`
rdModule `thenMn`
- \ (mod_name, export_list_fns, absyn_tree) ->
+ \ (mod_name, rdr_module) ->
let
-- reader things used much later
cc_mod_name = mod_name
in
doDump opt_D_dump_rdr "Reader:"
- (pp_show (ppr pprStyle absyn_tree)) `thenMn_`
+ (pp_show (ppr pprStyle rdr_module)) `thenMn_`
doDump opt_D_source_stats "\nSource Statistics:"
- (pp_show (ppSourceStats absyn_tree)) `thenMn_`
+ (pp_show (ppSourceStats rdr_module)) `thenMn_`
-- UniqueSupplies for later use (these are the only lower case uniques)
getSplitUniqSupplyMn 'r' `thenMn` \ rn_uniqs -> -- renamer
show_pass "Renamer" `thenMn_`
case builtinNameInfo
- of { (init_val_lookup_fn, init_tc_lookup_fn) ->
+ of { (wiredin_fm, key_fm, idinfo_fm) ->
- case (renameModule (init_val_lookup_fn, init_tc_lookup_fn)
- absyn_tree
- rn_uniqs)
- of { (mod4, import_names, final_name_funs, rn_errs_bag) ->
- let
- -- renamer things used much later
- cc_import_names = import_names
- in
+ renameModule wiredin_fm key_fm rn_uniqs rdr_module `thenMn`
+ \ (rn_mod, import_names,
+ version_info, instance_modules,
+ rn_errs_bag, rn_warns_bag) ->
if (not (isEmptyBag rn_errs_bag)) then
writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag))
- `thenMn_` writeMn stderr "\n"
- `thenMn_` exitMn 1
+ `thenMn_` writeMn stderr "\n" `thenMn_`
+ writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
+ `thenMn_` writeMn stderr "\n" `thenMn_`
+ exitMn 1
else -- No renaming errors ...
+ (if (isEmptyBag rn_warns_bag) then
+ returnMn ()
+ else
+ writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
+ `thenMn_` writeMn stderr "\n"
+ ) `thenMn_`
+
doDump opt_D_dump_rn "Renamer:"
- (pp_show (ppr pprStyle mod4)) `thenMn_`
+ (pp_show (ppr pprStyle rn_mod)) `thenMn_`
+
+ exitMn 0
+{- LATER ...
-- ******* TYPECHECKER
show_pass "TypeCheck" `thenMn_`
- case (case (typecheckModule tc_uniqs final_name_funs mod4) of
+ case (case (typecheckModule tc_uniqs idinfo_fm rn_info rn_mod) of
Succeeded (stuff, warns)
-> (emptyBag, warns, stuff)
Failed (errs, warns)
of { (tc_errs_bag, tc_warns_bag, tc_results) ->
+ if (not (isEmptyBag tc_errs_bag)) then
+ writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
+ `thenMn_` writeMn stderr "\n" `thenMn_`
+ writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag))
+ `thenMn_` writeMn stderr "\n" `thenMn_`
+ exitMn 1
+
+ else ( -- No typechecking errors ...
+
(if (isEmptyBag tc_warns_bag) then
returnMn ()
else
- writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
+ writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag))
`thenMn_` writeMn stderr "\n"
) `thenMn_`
- if (not (isEmptyBag tc_errs_bag)) then
- writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
- `thenMn_` writeMn stderr "\n"
- `thenMn_` exitMn 1
-
- else ( -- No typechecking errors ...
-
case tc_results
of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds),
interface_stuff@(_,_,_,_,_), -- @-pat just for strictness...
let
abstractC = codeGen cc_mod_name -- module name for CC labelling
cost_centre_info
- cc_import_names -- import names for CC registering
+ import_names -- import names for CC registering
gen_tycons -- type constructors generated locally
all_tycon_specs -- tycon specialisations
stg_binds2
doDump opt_D_dump_realC "" c_output_d `thenMn_`
doOutput opt_ProduceC c_output_w `thenMn_`
+
exitMn 0
- } ) } } }
+ } ) }
+
+LATER -}
+
+ }
where
-------------------------------------------------------------
-- ****** printing styles and column width:
else returnMn ()
-ppSourceStats (HsModule name exports imports fixities typedecls typesigs
+ppSourceStats (HsModule name version exports imports fixities typedecls typesigs
classdecls instdecls instsigs defdecls binds
[{-no sigs-}] src_loc)
= ppAboves (map pp_val
sig_info (InlineSig _ _) = (0,0,0,1)
sig_info _ = (0,0,0,0)
- import_info (ImportMod _ qual as spec)
+ import_info (ImportDecl _ qual as spec _)
= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
qual_info False = 0
qual_info True = 1
generic_pair thing
= case (getOrigName thing) of { (orig_mod, orig_nm) ->
- case (getOccurrenceName thing) of { occur_name ->
+ case (getOccName thing) of { occur_name ->
(orig_mod, orig_nm) }}
\end{code}
= let
sty = PprInterface
better_val = better_id_fn val
- name_str = getOccurrenceName better_val -- NB: not orig name!
+ name_str = getOccName better_val -- NB: not orig name!
id_info = getIdInfo better_val
export_list_fns tc
in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc
- = if in_export_list (getOccurrenceName tc) then
+ = if in_export_list (getOccName tc) then
True
else
--- pprTrace "in_export:" (ppAbove (ppr PprDebug ignore_Mdotdots) (ppPStr (getOccurrenceName tc))) (
+-- pprTrace "in_export:" (ppAbove (ppr PprDebug ignore_Mdotdots) (ppPStr (getOccName tc))) (
if ignore_Mdotdots then
False
else
a > b = case cmpReg a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
_tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-instance NamedThing Reg where
- -- the *only* method that should be defined is "getItsUnique"!
- -- (so we can use UniqFMs/UniqSets on Regs
- getItsUnique (UnmappedReg u _) = u
- getItsUnique (FixedReg i) = mkPseudoUnique1 IBOX(i)
- getItsUnique (MappedReg i) = mkPseudoUnique2 IBOX(i)
- getItsUnique (MemoryReg i _) = mkPseudoUnique3 i
+instance Uniquable Reg where
+ uniqueOf (UnmappedReg u _) = u
+ uniqueOf (FixedReg i) = mkPseudoUnique1 IBOX(i)
+ uniqueOf (MappedReg i) = mkPseudoUnique2 IBOX(i)
+ uniqueOf (MemoryReg i _) = mkPseudoUnique3 i
\end{code}
\begin{code}
-- re-exported ugen-generated stuff
U_binding.. ,
U_constr.. ,
- U_coresyn.. ,
U_entidt.. ,
- U_hpragma.. ,
U_list.. ,
U_literal.. ,
U_maybe.. ,
-- friends:
import U_binding
import U_constr
-import U_coresyn
import U_entidt
-import U_hpragma
import U_list
import U_literal
import U_maybe
returnPrimIO, thenPrimIO,
-- stuff defined here
- UgenUtil..,
-
- -- complete interface
- ProtoName
+ UgenUtil..
) where
import PreludeGlaST
-import Ubiq{-uitous-}
+import Ubiq
import MainMonad ( MainIO(..) )
-import ProtoName ( ProtoName(..) )
-import SrcLoc ( mkSrcLoc2 )
-
---import ProtoName
---import Outputable
---import Util
+import Name ( RdrName(..) )
+import SrcLoc ( mkSrcLoc2, mkUnknownSrcLoc )
\end{code}
\begin{code}
type UgnM a
- = FAST_STRING -- source file name; carried down
+ = (FAST_STRING,Module,SrcLoc) -- file, module and src_loc carried down
-> PrimIO a
{-# INLINE returnUgn #-}
{-# INLINE thenUgn #-}
-returnUgn x mod = returnPrimIO x
+returnUgn x stuff = returnPrimIO x
-thenUgn x y mod
- = x mod `thenPrimIO` \ z ->
- y z mod
+thenUgn x y stuff
+ = x stuff `thenPrimIO` \ z ->
+ y z stuff
-initUgn :: FAST_STRING -> UgnM a -> MainIO a
-initUgn srcfile action
- = action srcfile `thenPrimIO` \ result ->
+initUgn :: UgnM a -> MainIO a
+initUgn action
+ = action (SLIT(""),SLIT(""),mkUnknownSrcLoc) `thenPrimIO` \ result ->
return result
ioToUgnM :: PrimIO a -> UgnM a
-ioToUgnM x mod = x
+ioToUgnM x stuff = x
\end{code}
\begin{code}
type U_long = Int
rdU_long :: Int -> UgnM U_long
-rdU_long x = returnUgn x -- (A# x) = returnUgn (I# (addr2Int# x))
-
-type U_unkId = ProtoName
-rdU_unkId :: _Addr -> UgnM U_unkId
-rdU_unkId x
- = rdU_stringId x `thenUgn` \ y ->
- returnUgn (Unk y)
+rdU_long x = returnUgn x
type U_stringId = FAST_STRING
rdU_stringId :: _Addr -> UgnM U_stringId
\end{code}
\begin{code}
-setSrcFileUgn :: FAST_STRING{-filename-} -> UgnM a -> UgnM a
-setSrcFileUgn file action _ = action file
+setSrcFileUgn :: FAST_STRING -> UgnM a -> UgnM a
+setSrcFileUgn file action stuff@(_,mod,loc) = action (file,mod,loc)
+
+getSrcFileUgn :: UgnM FAST_STRING
+getSrcFileUgn stuff@(file,mod,loc) = returnUgn file stuff
+
+setSrcModUgn :: Module -> UgnM a -> UgnM a
+setSrcModUgn mod action stuff@(file,_,loc) = action (file,mod,loc)
+
+getSrcModUgn :: UgnM Module
+getSrcModUgn stuff@(file,mod,loc) = returnUgn mod stuff
-getSrcFileUgn :: UgnM FAST_STRING{-filename-}
-getSrcFileUgn mod = returnUgn mod mod
+mkSrcLocUgn :: U_long -> (SrcLoc -> UgnM a) -> UgnM a
+mkSrcLocUgn ln action (file,mod,_)
+ = action loc (file,mod,loc)
+ where
+ loc = mkSrcLoc2 file ln
-mkSrcLocUgn :: U_long -> UgnM SrcLoc
-mkSrcLocUgn ln mod
- = returnUgn (mkSrcLoc2 mod ln) mod
+getSrcLocUgn :: UgnM SrcLoc
+getSrcLocUgn stuff@(file,mod,loc) = returnUgn loc stuff
\end{code}
import UgenUtil
import U_constr
-import U_coresyn ( U_coresyn ) -- for interfaces only
-import U_hpragma
import U_list
-import U_literal ( U_literal ) -- for interfaces only
import U_maybe
import U_qid
import U_ttype
gtbindid : ttype; /* applied tycon */
gtbindl : list; /* [constr] */
gtbindd : maybe; /* Maybe [deriving] */
- gtline : long;
- gtpragma : hpragma; >;
+ gtline : long; >;
ntbind : < gntbindc : list; /* [context entries] */
gntbindid : ttype; /* applied tycon */
gntbindcty : list; /* [constr] (only 1 constrnew) */
gntbindd : maybe; /* Maybe [deriving] */
- gntline : long;
- gntpragma : hpragma; >;
+ gntline : long; >;
nbind : < gnbindid : ttype;
gnbindas : ttype;
gnline : long; >;
gfline : long; >;
abind : < gabindfst : binding;
gabindsnd : binding; >;
- ibind : < gibindsrc : long; /* 1 => source; 0 => interface */
- gibindmod : stringId; /* the original module */
- gibindc : list;
+ ibind : < gibindc : list;
gibindid : qid;
gibindi : ttype;
gibindw : binding;
- giline : long;
- gipragma : hpragma; >;
+ giline : long; >;
dbind : < gdbindts : list;
gdline : long; >;
cbind : < gcbindc : list;
gcbindid : ttype;
gcbindw : binding;
- gcline : long;
- gcpragma : hpragma; >;
+ gcline : long; >;
sbind : < gsbindids : list;
gsbindid : ttype;
- gsline : long;
- gspragma : hpragma; >;
-
- mbind : < gmbindmodn : stringId; /* import (in an interface) <mod> <entities> */
- gmbindimp : list; /* [entity] */
- gmline : long; >;
- mfbind : < gmfixes : list; >; /* fixites in an import: [fixop] */
+ gsline : long; >;
nullbind : < >;
- import : < gibindiface : stringId;
- gibindfile : stringId;
- gibinddef : binding;
- gibindimod : stringId;
+ import : < gibindimod : stringId;
gibindqual : long;
gibindas : maybe;
gibindspec : maybe;
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_coresyn where
-import Ubiq -- debugging consistency check
-import UgenUtil
-
-import U_list
-import U_literal
-import U_qid ( U_qid ) -- for interfaces only
-import U_ttype
-%}}
-type coresyn;
- /* binders: simple Id, plus a type */
- cobinder : < gcobinder_v : unkId;
- gcobinder_ty : ttype; >;
-
- /* atoms */
- colit : < gcolit : literal; >;
- colocal : < gcolocal_v : coresyn; >;
-
- cononrec : <gcononrec_b : coresyn;
- gcononrec_rhs : coresyn; >;
- corec : <gcorec : list; >;
- corec_pair: <gcorec_b : coresyn;
- gcorec_rhs : coresyn; >;
-
- covar : < gcovar : coresyn; >;
- coliteral :< gcoliteral : literal; >;
- cocon : < gcocon_con : coresyn;
- gcocon_tys : list;
- gcocon_args : list; >;
- coprim : < gcoprim_op : coresyn; /* primop or something */
- gcoprim_tys : list;
- gcoprim_args: list; >;
- colam : < gcolam_vars : list;
- gcolam_body : coresyn; >;
- cotylam : < gcotylam_tvs: list;
- gcotylam_body : coresyn; >;
- coapp : < gcoapp_fun : coresyn;
- gcoapp_args : list; >;
- cotyapp : < gcotyapp_e : coresyn;
- gcotyapp_t : ttype; >;
- cocase : < gcocase_s : coresyn;
- gcocase_alts : coresyn; >;
- colet : < gcolet_bind : coresyn;
- gcolet_body : coresyn; >;
- coscc : < gcoscc_scc : coresyn;
- gcoscc_body : coresyn; >;
-
- coalg_alts : < gcoalg_alts : list;
- gcoalg_deflt : coresyn; >;
- coalg_alt : < gcoalg_con : coresyn;
- gcoalg_bs : list;
- gcoalg_rhs : coresyn; >;
-
- coprim_alts : < gcoprim_alts : list;
- gcoprim_deflt : coresyn; >;
- coprim_alt : < gcoprim_lit : literal;
- gcoprim_rhs : coresyn; >;
-
- conodeflt : < >;
- cobinddeflt : < gcobinddeflt_v : coresyn;
- gcobinddeflt_rhs : coresyn; >;
-
- co_primop : < gco_primop : stringId;>;
- co_ccall : < gco_ccall : stringId;
- gco_ccall_may_gc : long;
- gco_ccall_arg_tys : list;
- gco_ccall_res_ty : ttype; >;
- co_casm : < gco_casm : literal;
- gco_casm_may_gc : long;
- gco_casm_arg_tys : list;
- gco_casm_res_ty : ttype; >;
-
- /* various flavours of cost-centres */
- co_preludedictscc : < gco_preludedictscc_dupd : coresyn; >;
- co_alldictscc : < gco_alldictscc_m : hstring;
- gco_alldictscc_g : hstring;
- gco_alldictscc_dupd : coresyn; >;
- co_usercc : < gco_usercc_n : hstring;
- gco_usercc_m : hstring;
- gco_usercc_g : hstring;
- gco_usercc_dupd : coresyn;
- gco_usercc_cafd : coresyn; >;
- co_autocc : < gco_autocc_i : coresyn;
- gco_autocc_m : hstring;
- gco_autocc_g : hstring;
- gco_autocc_dupd : coresyn;
- gco_autocc_cafd : coresyn; >;
- co_dictcc : < gco_dictcc_i : coresyn;
- gco_dictcc_m : hstring;
- gco_dictcc_g : hstring;
- gco_dictcc_dupd : coresyn;
- gco_dictcc_cafd : coresyn; >;
-
- co_scc_noncaf : < >;
- co_scc_caf : < >;
- co_scc_nondupd : < >;
- co_scc_dupd : < >;
-
- /* various flavours of Ids */
- co_id : < gco_id : stringId; >;
- co_orig_id : < gco_orig_id_m : stringId;
- gco_orig_id_n : stringId; >;
- co_sdselid : < gco_sdselid_c : unkId;
- gco_sdselid_sc : unkId; >;
- co_classopid : < gco_classopid_c : unkId;
- gco_classopid_o : unkId; >;
- co_defmid : < gco_defmid_c : unkId;
- gco_defmid_op : unkId; >;
- co_dfunid : < gco_dfunid_c : unkId;
- gco_dfunid_ty : ttype; >;
- co_constmid : < gco_constmid_c : unkId;
- gco_constmid_op : unkId;
- gco_constmid_ty : ttype; >;
- co_specid : < gco_specid_un : coresyn;
- gco_specid_tys : list; >;
- co_wrkrid : < gco_wrkrid_un : coresyn; >;
-end;
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_hpragma where
-import Ubiq -- debugging consistency check
-import UgenUtil
-
-import U_coresyn
-import U_list
-import U_literal ( U_literal ) -- ditto
-import U_ttype ( U_ttype ) -- interface only
-%}}
-type hpragma;
- no_pragma: < > ;
-
- idata_pragma: < gprag_data_constrs : list; /*of con decls*/
- gprag_data_specs : list; /*specialisations*/ >;
-
- itype_pragma: < >;
-
- iclas_pragma: < gprag_clas : list; /*of gen pragmas*/ >;
-
- iclasop_pragma: < gprag_dsel : hpragma; /* gen pragma: dict selector */
- gprag_defm : hpragma; /* gen pragma: default method */ >;
-
- iinst_simpl_pragma: < gprag_dfun_simpl : hpragma; /* gen pragma: of dfun */ >;
-
- iinst_const_pragma: < gprag_dfun_const : hpragma; /* gen pragma: of dfun */
- gprag_constms : list; /* (name, gen pragma) pairs */ >;
-
- igen_pragma: < gprag_arity : hpragma; /* arity */
- gprag_update : hpragma; /* update info */
- gprag_deforest : hpragma; /* deforest info */
- gprag_strictness : hpragma; /* strictness info */
- gprag_unfolding : hpragma; /* unfolding */
- gprag_specs : list; /* (type, gen pragma) pairs */ >;
-
- iarity_pragma: < gprag_arity_val : numId; >;
- iupdate_pragma: < gprag_update_val : stringId; >;
- ideforest_pragma: < >;
- istrictness_pragma: < gprag_strict_spec : hstring;
- gprag_strict_wrkr : hpragma; /*about worker*/ >;
- imagic_unfolding_pragma: < gprag_magic_str : stringId; >;
-
- iunfolding_pragma: < gprag_unfold_guide : hpragma; /* guidance */
- gprag_unfold_core : coresyn; >;
-
- iunfold_always: < >;
- iunfold_if_args: < gprag_unfold_if_t_args : numId;
- gprag_unfold_if_v_args : numId;
- gprag_unfold_if_con_args : stringId;
- gprag_unfold_if_size : numId; >;
-
- iname_pragma_pr: < gprag_name_pr1 : unkId;
- gprag_name_pr2 : hpragma; >;
- itype_pragma_pr: < gprag_type_pr1 : list; /* of maybe types */
- gprag_type_pr2 : numId; /* # dicts to ignore */
- gprag_type_pr3 : hpragma; >;
-
- idata_pragma_4s: < gprag_data_spec : list; /* of maybe types */ >;
-
-end;
hspcolno_save = 0; /* Left Indentation */
static short icontexts_save = 0; /* Indent Context Level */
-static BOOLEAN etags_save; /* saved: whether doing etags stuff or not */
-extern BOOLEAN etags; /* that which is saved */
+static BOOLEAN etags_save; /* saved: whether doing etags stuff or not */
+extern BOOLEAN etags; /* that which is saved */
-extern BOOLEAN nonstandardFlag; /* Glasgow extensions allowed */
+extern BOOLEAN nonstandardFlag; /* Glasgow extensions allowed */
-static BOOLEAN in_interface = FALSE; /* TRUE if we are reading a .hi file */
+static BOOLEAN in_interface = FALSE; /* TRUE if we are reading a .hi file */
extern BOOLEAN ignorePragmas; /* True when we should ignore pragmas */
extern int minAcceptablePragmaVersion; /* see documentation in main.c */
list of start states.
*/
-%x Char CharEsc Code Comment GlaExt GhcPragma UserPragma String StringEsc
+%x Char CharEsc Code Comment GlaExt UserPragma String StringEsc
isoS [\xa1-\xbf\xd7\xf7]
isoL [\xc0-\xd6\xd8-\xde]
new_filename(tempf);
hsplineno = hslineno; hscolno = 0; hspcolno = 0;
}
-<Code,GlaExt>"{-# GHC_PRAGMA INTERFACE VERSION "{D}+" #-}" {
- sscanf(yytext+33,"%d ",&thisIfacePragmaVersion);
- }
-<Code,GlaExt>"{-# GHC_PRAGMA " {
- if ( ignorePragmas ||
- thisIfacePragmaVersion < minAcceptablePragmaVersion ||
- thisIfacePragmaVersion > maxAcceptablePragmaVersion) {
- nested_comments = 1;
- PUSH_STATE(Comment);
- } else {
- PUSH_STATE(GhcPragma);
- RETURN(GHC_PRAGMA);
- }
- }
-<GhcPragma>"_N_" { RETURN(NO_PRAGMA); }
-<GhcPragma>"_NI_" { RETURN(NOINFO_PRAGMA); }
-<GhcPragma>"_DEFOREST_" { RETURN(DEFOREST_PRAGMA); }
-<GhcPragma>"_SPECIALISE_" { RETURN(SPECIALISE_PRAGMA); }
-<GhcPragma>"_A_" { RETURN(ARITY_PRAGMA); }
-<GhcPragma>"_U_" { RETURN(UPDATE_PRAGMA); }
-<GhcPragma>"_S_" { RETURN(STRICTNESS_PRAGMA); }
-<GhcPragma>"_K_" { RETURN(KIND_PRAGMA); }
-<GhcPragma>"_MF_" { RETURN(MAGIC_UNFOLDING_PRAGMA); }
-<GhcPragma>"_F_" { RETURN(UNFOLDING_PRAGMA); }
-
-<GhcPragma>"_!_" { RETURN(COCON); }
-<GhcPragma>"_#_" { RETURN(COPRIM); }
-<GhcPragma>"_APP_" { RETURN(COAPP); }
-<GhcPragma>"_TYAPP_" { RETURN(COTYAPP); }
-<GhcPragma>"_ALG_" { RETURN(CO_ALG_ALTS); }
-<GhcPragma>"_PRIM_" { RETURN(CO_PRIM_ALTS); }
-<GhcPragma>"_NO_DEFLT_" { RETURN(CO_NO_DEFAULT); }
-<GhcPragma>"_LETREC_" { RETURN(CO_LETREC); }
-
-<GhcPragma>"_PRELUDE_DICTS_CC_" { RETURN(CO_PRELUDE_DICTS_CC); }
-<GhcPragma>"_ALL_DICTS_CC_" { RETURN(CO_ALL_DICTS_CC); }
-<GhcPragma>"_USER_CC_" { RETURN(CO_USER_CC); }
-<GhcPragma>"_AUTO_CC_" { RETURN(CO_AUTO_CC); }
-<GhcPragma>"_DICT_CC_" { RETURN(CO_DICT_CC); }
-
-<GhcPragma>"_DUPD_CC_" { RETURN(CO_DUPD_CC); }
-<GhcPragma>"_CAF_CC_" { RETURN(CO_CAF_CC); }
-
-<GhcPragma>"_SDSEL_" { RETURN(CO_SDSEL_ID); }
-<GhcPragma>"_METH_" { RETURN(CO_METH_ID); }
-<GhcPragma>"_DEFM_" { RETURN(CO_DEFM_ID); }
-<GhcPragma>"_DFUN_" { RETURN(CO_DFUN_ID); }
-<GhcPragma>"_CONSTM_" { RETURN(CO_CONSTM_ID); }
-<GhcPragma>"_SPEC_" { RETURN(CO_SPEC_ID); }
-<GhcPragma>"_WRKR_" { RETURN(CO_WRKR_ID); }
-<GhcPragma>"_ORIG_" { RETURN(CO_ORIG_NM); /* fully-qualified original name*/ }
-
-<GhcPragma>"_ALWAYS_" { RETURN(UNFOLD_ALWAYS); }
-<GhcPragma>"_IF_ARGS_" { RETURN(UNFOLD_IF_ARGS); }
-
-<GhcPragma>"_NOREP_I_" { RETURN(NOREP_INTEGER); }
-<GhcPragma>"_NOREP_R_" { RETURN(NOREP_RATIONAL); }
-<GhcPragma>"_NOREP_S_" { RETURN(NOREP_STRING); }
-
-<GhcPragma>" #-}" { POP_STATE; RETURN(END_PRAGMA); }
+<Code,GlaExt>"{-#"{WS}*"INTERFACE" {
+ PUSH_STATE(UserPragma);
+ RETURN(INTERFACE_UPRAGMA);
+ }
<Code,GlaExt>"{-#"{WS}*"SPECIALI"[SZ]E {
PUSH_STATE(UserPragma);
RETURN(SPECIALISE_UPRAGMA);
*/
%}
-<Code,GlaExt,GhcPragma>"case" { RETURN(CASE); }
+<Code,GlaExt>"case" { RETURN(CASE); }
<Code,GlaExt>"class" { RETURN(CLASS); }
<Code,GlaExt,UserPragma>"data" { RETURN(DATA); }
<Code,GlaExt>"default" { RETURN(DEFAULT); }
<Code,GlaExt>"else" { RETURN(ELSE); }
<Code,GlaExt>"if" { RETURN(IF); }
<Code,GlaExt>"import" { RETURN(IMPORT); }
-<Code,GlaExt,GhcPragma>"in" { RETURN(IN); }
+<Code,GlaExt>"in" { RETURN(IN); }
<Code,GlaExt>"infix" { RETURN(INFIX); }
<Code,GlaExt>"infixl" { RETURN(INFIXL); }
<Code,GlaExt>"infixr" { RETURN(INFIXR); }
<Code,GlaExt,UserPragma>"instance" { RETURN(INSTANCE); }
-<Code,GlaExt,GhcPragma>"let" { RETURN(LET); }
+<Code,GlaExt>"let" { RETURN(LET); }
<Code,GlaExt>"module" { RETURN(MODULE); }
<Code,GlaExt>"newtype" { RETURN(NEWTYPE); }
-<Code,GlaExt,GhcPragma>"of" { RETURN(OF); }
+<Code,GlaExt>"of" { RETURN(OF); }
<Code,GlaExt>"then" { RETURN(THEN); }
<Code,GlaExt>"type" { RETURN(TYPE); }
<Code,GlaExt>"where" { RETURN(WHERE); }
<Code,GlaExt>"as" { RETURN(AS); }
<Code,GlaExt>"hiding" { RETURN(HIDING); }
<Code,GlaExt>"qualified" { RETURN(QUALIFIED); }
-<Code,GlaExt>"interface" { RETURN(INTERFACE); }
-<Code,GlaExt,GhcPragma>"_scc_" { RETURN(SCC); }
-<GlaExt,GhcPragma>"_ccall_" { RETURN(CCALL); }
-<GlaExt,GhcPragma>"_ccall_GC_" { RETURN(CCALL_GC); }
-<GlaExt,GhcPragma>"_casm_" { RETURN(CASM); }
-<GlaExt,GhcPragma>"_casm_GC_" { RETURN(CASM_GC); }
-<GhcPragma>"_forall_" { RETURN(FORALL); }
+<Code,GlaExt>"_scc_" { RETURN(SCC); }
+<GlaExt>"_ccall_" { RETURN(CCALL); }
+<GlaExt>"_ccall_GC_" { RETURN(CCALL_GC); }
+<GlaExt>"_casm_" { RETURN(CASM); }
+<GlaExt>"_casm_GC_" { RETURN(CASM_GC); }
%{
/*
*/
%}
-<Code,GlaExt,GhcPragma,UserPragma>"(" { RETURN(OPAREN); }
-<Code,GlaExt,GhcPragma,UserPragma>")" { RETURN(CPAREN); }
-<Code,GlaExt,GhcPragma,UserPragma>"[" { RETURN(OBRACK); }
-<Code,GlaExt,GhcPragma,UserPragma>"]" { RETURN(CBRACK); }
-<Code,GlaExt,GhcPragma>"{" { RETURN(OCURLY); }
-<Code,GlaExt,GhcPragma>"}" { RETURN(CCURLY); }
-<Code,GlaExt,GhcPragma,UserPragma>"," { RETURN(COMMA); }
-<Code,GlaExt,GhcPragma>";" { RETURN(SEMI); }
-<Code,GlaExt,GhcPragma>"`" { RETURN(BQUOTE); }
-<Code,GlaExt>"_" { RETURN(WILDCARD); }
-
-<Code,GlaExt>".." { RETURN(DOTDOT); }
-<Code,GlaExt,GhcPragma,UserPragma>"::" { RETURN(DCOLON); }
-<Code,GlaExt,GhcPragma,UserPragma>"=" { RETURN(EQUAL); }
-<Code,GlaExt,GhcPragma>"\\" { RETURN(LAMBDA); }
-<Code,GlaExt,GhcPragma>"|" { RETURN(VBAR); }
-<Code,GlaExt>"<-" { RETURN(LARROW); }
-<Code,GlaExt,GhcPragma,UserPragma>"->" { RETURN(RARROW); }
-<Code,GlaExt>"-" { RETURN(MINUS); }
-
-<Code,GlaExt,GhcPragma,UserPragma>"=>" { RETURN(DARROW); }
-<Code,GlaExt>"@" { RETURN(AT); }
-<Code,GlaExt>"!" { RETURN(BANG); }
-<Code,GlaExt>"~" { RETURN(LAZY); }
-
-<GhcPragma>"_/\\_" { RETURN(TYLAMBDA); }
+<Code,GlaExt,UserPragma>"(" { RETURN(OPAREN); }
+<Code,GlaExt,UserPragma>")" { RETURN(CPAREN); }
+<Code,GlaExt,UserPragma>"[" { RETURN(OBRACK); }
+<Code,GlaExt,UserPragma>"]" { RETURN(CBRACK); }
+<Code,GlaExt>"{" { RETURN(OCURLY); }
+<Code,GlaExt>"}" { RETURN(CCURLY); }
+<Code,GlaExt,UserPragma>"," { RETURN(COMMA); }
+<Code,GlaExt>";" { RETURN(SEMI); }
+<Code,GlaExt>"`" { RETURN(BQUOTE); }
+<Code,GlaExt>"_" { RETURN(WILDCARD); }
+
+<Code,GlaExt>".." { RETURN(DOTDOT); }
+<Code,GlaExt,UserPragma>"::" { RETURN(DCOLON); }
+<Code,GlaExt,UserPragma>"=" { RETURN(EQUAL); }
+<Code,GlaExt>"\\" { RETURN(LAMBDA); }
+<Code,GlaExt>"|" { RETURN(VBAR); }
+<Code,GlaExt>"<-" { RETURN(LARROW); }
+<Code,GlaExt,UserPragma>"->" { RETURN(RARROW); }
+<Code,GlaExt>"-" { RETURN(MINUS); }
+
+<Code,GlaExt,UserPragma>"=>" { RETURN(DARROW); }
+<Code,GlaExt>"@" { RETURN(AT); }
+<Code,GlaExt>"!" { RETURN(BANG); }
+<Code,GlaExt>"~" { RETURN(LAZY); }
%{
/*
yylval.uid = xstrndup(yytext, yyleng);
RETURN(INTEGER);
}
-<GlaExt,GhcPragma>("-")?{N}"#" {
+<GlaExt>("-")?{N}"#" {
yylval.uid = xstrndup(yytext, yyleng - 1);
RETURN(INTPRIM);
}
-<Code,GlaExt,GhcPragma>{N} {
+<Code,GlaExt,UserPragma>{N} {
yylval.uid = xstrndup(yytext, yyleng);
RETURN(INTEGER);
}
*/
%}
-<GlaExt,GhcPragma>("-")?{F}"##" {
+<GlaExt>("-")?{F}"##" {
yylval.uid = xstrndup(yytext, yyleng - 2);
RETURN(DOUBLEPRIM);
}
-<GlaExt,GhcPragma>("-")?{F}"#" {
+<GlaExt>("-")?{F}"#" {
yylval.uid = xstrndup(yytext, yyleng - 1);
RETURN(FLOATPRIM);
}
*/
%}
-<GlaExt,GhcPragma>"``"[^']+"''" {
+<GlaExt>"``"[^']+"''" {
hsnewid(yytext + 2, yyleng - 4);
RETURN(CLITLIT);
}
*/
%}
-<GhcPragma>"_NIL_" { hsnewid(yytext, yyleng); RETURN(CONID); }
-<GhcPragma>"_TUP_"{D}+ { hsnewid(yytext, yyleng); RETURN(CONID); }
-<GhcPragma>[a-z]{i}*"$"[a-z]{i}* { hsnewid(yytext, yyleng); RETURN(TYVAR_TEMPLATE_ID); }
%{
/* These SHOULDNAE work in "Code" (sigh) */
%}
-<Code,GlaExt,GhcPragma,UserPragma>{Id}"#" {
+<Code,GlaExt,UserPragma>{Id}"#" {
if (! (nonstandardFlag || in_interface)) {
char errbuf[ERR_BUF_SIZE];
sprintf(errbuf, "Non-standard identifier (trailing `#'): %s\n", yytext);
hsnewid(yytext, yyleng);
RETURN(_isconstr(yytext) ? CONID : VARID);
}
-<Code,GlaExt,GhcPragma,UserPragma>_+{Id} {
+<Code,GlaExt,UserPragma>_+{Id} {
if (! (nonstandardFlag || in_interface)) {
char errbuf[ERR_BUF_SIZE];
sprintf(errbuf, "Non-standard identifier (leading underscore): %s\n", yytext);
RETURN(isconstr(yytext) ? CONID : VARID);
/* NB: ^^^^^^^^ : not the macro! */
}
-<Code,GlaExt,GhcPragma,UserPragma>{Id} {
+<Code,GlaExt,UserPragma>{Id} {
hsnewid(yytext, yyleng);
RETURN(_isconstr(yytext) ? CONID : VARID);
}
-<Code,GlaExt,GhcPragma,UserPragma>{SId} {
+<Code,GlaExt,UserPragma>{SId} {
hsnewid(yytext, yyleng);
RETURN(_isconstr(yytext) ? CONSYM : VARSYM);
}
-<Code,GlaExt,GhcPragma,UserPragma>{Mod}"."{Id} {
+<Code,GlaExt,UserPragma>{Mod}"."{Id} {
BOOLEAN isconstr = hsnewqid(yytext, yyleng);
RETURN(isconstr ? QCONID : QVARID);
}
-<Code,GlaExt,GhcPragma,UserPragma>{Mod}"."{SId} {
+<Code,GlaExt,UserPragma>{Mod}"."{SId} {
BOOLEAN isconstr = hsnewqid(yytext, yyleng);
RETURN(isconstr ? QCONSYM : QVARSYM);
}
*/
%}
-<GlaExt,GhcPragma,UserPragma>"`"{Id}"#`" {
+<GlaExt,UserPragma>"`"{Id}"#`" {
hsnewid(yytext + 1, yyleng - 2);
RETURN(_isconstr(yytext+1) ? CONSYM : VARSYM);
}
*/
%}
-<GlaExt,GhcPragma>'({CHAR}|"\"")"'#" {
+<GlaExt>'({CHAR}|"\"")"'#" {
yylval.uhstring = installHstring(1, yytext+1);
RETURN(CHARPRIM);
}
sprintf(errbuf, "'' is not a valid character (or string) literal\n");
hsperror(errbuf);
}
-<Code,GlaExt,GhcPragma>'({CHAR}|"\"")* {
+<Code,GlaExt>'({CHAR}|"\"")* {
hsmlcolno = hspcolno;
cleartext();
addtext(yytext+1, yyleng-1);
*/
%}
-<GlaExt,GhcPragma>"\""({CHAR}|"'")*"\""# {
+<GlaExt>"\""({CHAR}|"'")*"\""# {
yylval.uhstring = installHstring(yyleng-3, yytext+1);
/* the -3 accounts for the " on front, "# on the end */
RETURN(STRINGPRIM);
}
-<Code,GlaExt,GhcPragma>"\""({CHAR}|"'")*"\"" {
+<Code,GlaExt>"\""({CHAR}|"'")*"\"" {
yylval.uhstring = installHstring(yyleng-2, yytext+1);
RETURN(STRING);
}
-<Code,GlaExt,GhcPragma>"\""({CHAR}|"'")* {
+<Code,GlaExt>"\""({CHAR}|"'")* {
hsmlcolno = hspcolno;
cleartext();
addtext(yytext+1, yyleng-1);
%}
<Code,GlaExt,StringEsc>"--".*{NL}?{WS}* |
-<Code,GlaExt,GhcPragma,UserPragma,StringEsc>{WS}+ { noGap = FALSE; }
+<Code,GlaExt,UserPragma,StringEsc>{WS}+ { noGap = FALSE; }
%{
/*
*/
%}
-<Code,GlaExt,GhcPragma,UserPragma,StringEsc>"{-" {
+<Code,GlaExt,UserPragma,StringEsc>"{-" {
noGap = FALSE; nested_comments = 1; PUSH_STATE(Comment);
}
*/
%}
-<INITIAL,Code,GlaExt,GhcPragma,UserPragma>(.|\n) {
+<INITIAL,Code,GlaExt,UserPragma>(.|\n) {
fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
input_filename, hsplineno, hspcolno + 1);
format_string(stderr, (unsigned char *) yytext, 1);
hsplineno = hslineno; hspcolno = hscolno;
hsperror("unterminated string literal");
}
-<GhcPragma><<EOF>> {
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated interface pragma");
- }
<UserPragma><<EOF>> {
hsplineno = hslineno; hspcolno = hscolno;
hsperror("unterminated user-specified pragma");
fprintf(stderr, "finished reading interface (%d:%d:%d)\n", hscolno, hspcolno, INDENTPT);
#endif
eof = FALSE;
- RETURN(LEOF);
+
+ /* RETURN(LEOF); */
+ hsperror("No longer using yacc to parse interface files");
+
} else {
yyterminate();
}
/**********************************************************************
* *
* *
-* Input Processing for Interfaces *
+* Input Processing for Interfaces -- Not currently used !!! *
* *
* *
**********************************************************************/
**********************************************************************/
static BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */
-
-extern BOOLEAN nonstandardFlag;
extern BOOLEAN etags;
-extern VOID find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *));
-
extern char *input_filename;
static char *the_module_name;
-static char *iface_name;
-static char iface_filename[FILENAME_SIZE];
+static maybe module_exports;
-static maybe module_exports; /* Exported entities */
-static list prelude_core_import, prelude_imports;
- /* Entities imported from the Prelude */
-
-extern tree niltree;
extern list Lnil;
-
extern tree root;
/* For FN, PREVPATT and SAMEFN macros */
* *
**********************************************************************/
-/* OLD 95/08: list fixlist; */
static int Fixity = 0, Precedence = 0;
-struct infix;
char *ineg PROTO((char *));
-int importlineno = 0; /* The line number where an import starts */
+long source_version = 0;
-long inimport; /* Info about current import */
-id importmod;
-long importas;
-id asmod;
-long importqual;
-long importspec;
-long importhide;
-list importlist;
-
-extern BOOLEAN inpat; /* True when parsing a pattern */
-extern BOOLEAN implicitPrelude; /* True when we should read the Prelude if not given */
-extern BOOLEAN haskell1_2Flag; /* True if we are attempting (proto)Haskell 1.3 */
-
-extern int thisIfacePragmaVersion;
+BOOLEAN inpat;
%}
%union {
float ufloat;
char *ustring;
hstring uhstring;
- hpragma uhpragma;
- coresyn ucoresyn;
}
%token MODULE NEWTYPE OF
%token THEN TYPE WHERE
-%token INTERFACE SCC
+%token SCC
%token CCALL CCALL_GC CASM CASM_GC
* *
**********************************************************************/
-%token LEOF
-%token GHC_PRAGMA END_PRAGMA NO_PRAGMA NOINFO_PRAGMA SPECIALISE_PRAGMA
-%token ARITY_PRAGMA UPDATE_PRAGMA STRICTNESS_PRAGMA KIND_PRAGMA
-%token UNFOLDING_PRAGMA MAGIC_UNFOLDING_PRAGMA DEFOREST_PRAGMA
-%token SPECIALISE_UPRAGMA INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
+%token INTERFACE_UPRAGMA SPECIALISE_UPRAGMA
+%token INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
%token DEFOREST_UPRAGMA END_UPRAGMA
-%token TYLAMBDA COCON COPRIM COAPP COTYAPP FORALL TYVAR_TEMPLATE_ID
-%token CO_ALG_ALTS CO_PRIM_ALTS CO_NO_DEFAULT CO_LETREC
-%token CO_SDSEL_ID CO_METH_ID CO_DEFM_ID CO_DFUN_ID CO_CONSTM_ID
-%token CO_SPEC_ID CO_WRKR_ID CO_ORIG_NM
-%token UNFOLD_ALWAYS UNFOLD_IF_ARGS
-%token NOREP_INTEGER NOREP_RATIONAL NOREP_STRING
-%token CO_PRELUDE_DICTS_CC CO_ALL_DICTS_CC CO_USER_CC CO_AUTO_CC CO_DICT_CC
-%token CO_CAF_CC CO_DUPD_CC
/**********************************************************************
* *
dtyclses dtycls_list
gdrhs gdpat valrhs
lampats cexps
- idata_pragma_specs idata_pragma_specslist
- gen_pragma_list type_pragma_pairs
- type_pragma_pairs_maybe name_pragma_pairs
- type_maybes
- core_binders core_tyvars core_tv_templates
- core_types core_type_list
- core_atoms core_atom_list
- core_alg_alts core_prim_alts corec_binds
- core_type_maybes
-
-%type <umaybe> maybeexports impas maybeimpspec
- type_maybe core_type_maybe
+%type <umaybe> maybeexports impas maybeimpspec deriving
%type <ueither> impspec
%type <uid> MINUS DARROW AS LAZY
VARID CONID VARSYM CONSYM
- TYVAR_TEMPLATE_ID
var con varop conop op
vark varid varsym varsym_nominus
tycon modid impmod ccallid
%type <ubinding> topdecl topdecls letdecls
typed datad newtd classd instd defaultd
decl decls valdef instdef instdefs
- maybeifixes iimport iimports maybeiimports
- ityped idatad inewtd iclassd iinstd ivarsd
- itopdecl itopdecls
- maybe_where
- interface dointerface readinterface ibody
- cbody rinst
- type_and_maybe_id
+ maybe_where cbody rinst type_and_maybe_id
%type <upbinding> valrhs1 altrest
gtyconapp ntyconapp ntycon gtyconvars
bbtype batype btyconapp
class restrict_inst general_inst tyvar
- core_type
%type <uconstr> constr field
%type <uentid> export import
-%type <uhpragma> idata_pragma inewt_pragma idata_pragma_spectypes
- iclas_pragma iclasop_pragma
- iinst_pragma gen_pragma ival_pragma arity_pragma
- update_pragma strictness_pragma worker_info
- deforest_pragma
- unfolding_pragma unfolding_guidance type_pragma_pair
- name_pragma_pair
-
-%type <ucoresyn> core_expr core_case_alts core_id core_binder core_atom
- core_alg_alt core_prim_alt core_default corec_bind
- co_primop co_scc co_caf co_dupd
-
%type <ulong> commas impqual
/**********************************************************************
* *
**********************************************************************/
-%start pmodule
-
+%start module
%%
-
-pmodule : {
- inimport = 1;
- importmod = install_literal("Prelude");
- importas = 0;
- asmod = NULL;
- importqual = 0;
- importspec = 0;
- importhide = 0;
- importlist = Lnil;
- }
- readpreludecore readprelude
- {
- inimport = 0;
- importmod = NULL;
-
- modulelineno = 0;
- }
- module
- ;
-
module : modulekey modid maybeexports
{
+ modulelineno = startlineno;
the_module_name = $2;
module_exports = $3;
}
WHERE body
| {
+ modulelineno = 0;
the_module_name = install_literal("Main");
module_exports = mknothing();
}
body
;
-body : ocurly { setstartlineno(); } orestm
- | vocurly vrestm
+body : ocurly { setstartlineno(); } interface_pragma orestm
+ | vocurly interface_pragma vrestm
;
+interface_pragma : /* empty */
+ | INTERFACE_UPRAGMA INTEGER END_UPRAGMA SEMI
+ {
+ source_version = atoi($2);
+ }
+ ;
+
orestm : maybeimpdecls maybefixes topdecls ccurly
{
- root = mkhmodule(the_module_name,lconc(prelude_imports,$1),module_exports,$2,$3,modulelineno);
+ root = mkhmodule(the_module_name,$1,module_exports,
+ $2,$3,source_version,modulelineno);
}
| impdecls ccurly
{
- root = mkhmodule(the_module_name,lconc(prelude_imports,$1),module_exports,Lnil,mknullbind(),modulelineno);
+ root = mkhmodule(the_module_name,$1,module_exports,
+ Lnil,mknullbind(),source_version,modulelineno);
}
vrestm : maybeimpdecls maybefixes topdecls vccurly
{
- root = mkhmodule(the_module_name,lconc(prelude_imports,$1),module_exports,$2,$3,modulelineno);
+ root = mkhmodule(the_module_name,$1,module_exports,
+ $2,$3,source_version,modulelineno);
}
| impdecls vccurly
{
- root = mkhmodule(the_module_name,lconc(prelude_imports,$1),module_exports,Lnil,mknullbind(),modulelineno);
+ root = mkhmodule(the_module_name,$1,module_exports,
+ Lnil,mknullbind(),source_version,modulelineno);
}
-
maybeexports : /* empty */ { $$ = mknothing(); }
| OPAREN export_list CPAREN { $$ = mkjust($2); }
| OPAREN export_list COMMA CPAREN { $$ = mkjust($2); }
;
-impdecl : importkey
- {
- inimport = 1;
- importlineno = startlineno;
- }
- impqual impmod dointerface impas maybeimpspec
+impdecl : importkey impqual impmod impas maybeimpspec
{
- $$ = lsing(mkimport(iface_name,xstrdup(iface_filename),$5,
- $4,$3,$6,$7,importlineno));
- inimport = 0;
- importmod = NULL;
- importas = 0;
- asmod = NULL;
- importqual = 0;
- importspec = 0;
- importhide = 0;
- importlist = Lnil;
+ $$ = lsing(mkimport($3,$2,$4,$5,startlineno));
}
;
-impmod : modid { $$ = importmod = $1; }
+impmod : modid { $$ = $1; }
;
-impqual : /* noqual */ { $$ = importqual = 0; }
- | QUALIFIED { $$ = importqual = 1; }
+impqual : /* noqual */ { $$ = 0; }
+ | QUALIFIED { $$ = 1; }
;
-impas : /* noas */ { $$ = mknothing(); importas = 0; asmod = NULL; }
- | AS modid { $$ = mkjust($2); importas = 1; asmod = $2; }
+impas : /* noas */ { $$ = mknothing(); }
+ | AS modid { $$ = mkjust($2); }
;
-maybeimpspec : /* empty */ { $$ = mknothing(); importspec = 0; }
- | impspec { $$ = mkjust($1); importspec = 1; }
+maybeimpspec : /* empty */ { $$ = mknothing(); }
+ | impspec { $$ = mkjust($1); }
;
-impspec : OPAREN CPAREN { $$ = mkleft(Lnil); importhide = 0; importlist = Lnil; }
- | OPAREN import_list CPAREN { $$ = mkleft($2); importhide = 0; importlist = $2; }
- | OPAREN import_list COMMA CPAREN { $$ = mkleft($2); importhide = 0; importlist = $2; }
- | HIDING OPAREN import_list CPAREN { $$ = mkright($3); importhide = 1; importlist = $3; }
- | HIDING OPAREN import_list COMMA CPAREN { $$ = mkright($3); importhide = 1; importlist = $3; }
+impspec : OPAREN CPAREN { $$ = mkleft(Lnil); }
+ | OPAREN import_list CPAREN { $$ = mkleft($2); }
+ | OPAREN import_list COMMA CPAREN { $$ = mkleft($2); }
+ | HIDING OPAREN import_list CPAREN { $$ = mkright($3); }
+ | HIDING OPAREN import_list COMMA CPAREN { $$ = mkright($3); }
;
import_list:
| con { $$ = mknoqual($1); }
;
-
-/**********************************************************************
-* *
-* *
-* Reading interface files *
-* *
-* *
-**********************************************************************/
-
-dointerface : { /* filename returned in "iface_filename" */
- char *module_name = id_to_string(importmod);
- if ( ! etags ) {
- find_module_on_imports_dirlist(
- (haskell1_2Flag && strcmp(module_name, "Prelude") == 0)
- ? "Prel12" : module_name,
- FALSE, iface_filename);
- } else {
- find_module_on_imports_dirlist("PreludeNull_",TRUE,iface_filename);
- }
- if (strcmp(module_name,"PreludeCore")==0) {
- hsperror("Cannot explicitly import `PreludeCore'");
-
- } else if (strcmp(module_name,"Prelude")==0) {
- prelude_imports = prelude_core_import; /* unavoidable */
- }
- thisIfacePragmaVersion = 0;
- setyyin(iface_filename);
- }
- readinterface
- { $$ = $2; }
- ;
-
-readpreludecore:{
- if ( implicitPrelude && !etags ) {
- /* we try to avoid reading interfaces when etagging */
- find_module_on_imports_dirlist(
- (haskell1_2Flag) ? "PrelCore12" : "PreludeCore",
- TRUE,iface_filename);
- } else {
- find_module_on_imports_dirlist("PreludeNull_",TRUE,iface_filename);
- }
- thisIfacePragmaVersion = 0;
- setyyin(iface_filename);
- }
- readinterface
- {
- binding prelude_core = mkimport(iface_name,xstrdup(iface_filename),$2,
- install_literal("PreludeCore"),
- 0,mknothing(),mknothing(),0);
- prelude_core_import = (! implicitPrelude) ? Lnil : lsing(prelude_core);
- }
- ;
-
-readprelude : {
- if ( implicitPrelude && !etags ) {
- find_module_on_imports_dirlist(
- ( haskell1_2Flag ) ? "Prel12" : "Prelude",
- TRUE,iface_filename);
- } else {
- find_module_on_imports_dirlist("PreludeNull_",TRUE,iface_filename);
- }
- thisIfacePragmaVersion = 0;
- setyyin(iface_filename);
- }
- readinterface
- {
- binding prelude = mkimport(iface_name,xstrdup(iface_filename),$2,
- install_literal("Prelude"),
- 0,mknothing(),mknothing(),0);
- prelude_imports = (! implicitPrelude) ? Lnil
- : lconc(prelude_core_import,lsing(prelude));
- }
- ;
-
-readinterface:
- interface LEOF
- {
- $$ = $1;
- }
- ;
-
-interface:
- INTERFACE modid
- {
- iface_name = $2;
- }
- WHERE ibody
- {
- $$ = $5;
- }
- ;
-
-ibody : ocurly maybeiimports maybeifixes itopdecls ccurly
- {
- $$ = mkabind($2,mkabind($3,$4));
- }
- | ocurly iimports ccurly
- {
- $$ = $2;
- }
- | vocurly maybeiimports maybeifixes itopdecls vccurly
- {
- $$ = mkabind($2,mkabind($3,$4));
- }
- | vocurly iimports vccurly
- {
- $$ = $2;
- }
- ;
-
-maybeifixes: /* empty */ { $$ = mknullbind(); }
- | fixes SEMI { $$ = mkmfbind($1); }
- ;
-
-maybeiimports : /* empty */ { $$ = mknullbind(); }
- | iimports SEMI { $$ = $1; }
- ;
-
-iimports : iimport { $$ = $1; }
- | iimports SEMI iimport { $$ = mkabind($1,$3); }
- ;
-
-iimport : importkey modid OPAREN import_list CPAREN
- { $$ = mkmbind($2,$4,startlineno); }
- ;
-
-
-itopdecls : itopdecl { $$ = $1; }
- | itopdecls SEMI itopdecl { $$ = mkabind($1,$3); }
- ;
-
-itopdecl: ityped { $$ = $1; }
- | idatad { $$ = $1; }
- | inewtd { $$ = $1; }
- | iclassd { $$ = $1; }
- | iinstd { $$ = $1; }
- | ivarsd { $$ = $1; }
- | /* empty */ { $$ = mknullbind(); }
- ;
-
-ivarsd : qvarsk DCOLON ctype ival_pragma
- { $$ = mksbind($1,$3,startlineno,$4); }
- ;
-
-ityped : typekey simple EQUAL type
- { $$ = mknbind($2,$4,startlineno); }
- ;
-
-idatad : datakey simple idata_pragma
- { $$ = mktbind(Lnil,$2,Lnil,mknothing(),startlineno,$3); }
- | datakey simple EQUAL constrs idata_pragma
- { $$ = mktbind(Lnil,$2,$4,mknothing(),startlineno,$5); }
- | datakey context DARROW simple idata_pragma
- { $$ = mktbind($2,$4,Lnil,mknothing(),startlineno,$5); }
- | datakey context DARROW simple EQUAL constrs idata_pragma
- { $$ = mktbind($2,$4,$6,mknothing(),startlineno,$7); }
- ;
-
-inewtd : newtypekey simple inewt_pragma
- { $$ = mkntbind(Lnil,$2,Lnil,mknothing(),startlineno,$3); }
- | newtypekey simple EQUAL constr1 inewt_pragma
- { $$ = mkntbind(Lnil,$2,$4,mknothing(),startlineno,$5); }
- | newtypekey context DARROW simple inewt_pragma
- { $$ = mkntbind($2,$4,Lnil,mknothing(),startlineno,$5); }
- | newtypekey context DARROW simple EQUAL constr1 inewt_pragma
- { $$ = mkntbind($2,$4,$6,mknothing(),startlineno,$7); }
- ;
-
-iclassd : classkey context DARROW class iclas_pragma cbody
- { $$ = mkcbind($2,$4,$6,startlineno,$5); }
- | classkey class iclas_pragma cbody
- { $$ = mkcbind(Lnil,$2,$4,startlineno,$3); }
- ;
-
-iinstd : instkey modid context DARROW gtycon general_inst iinst_pragma
- { $$ = mkibind(0/*not source*/,$2,$3,$5,$6,mknullbind(),startlineno,$7); }
- | instkey modid gtycon general_inst iinst_pragma
- { $$ = mkibind(0/*not source*/,$2,Lnil,$3,$4,mknullbind(),startlineno,$5); }
- ;
-
-
-/**********************************************************************
-* *
-* *
-* Interface pragma stuff *
-* *
-* *
-**********************************************************************/
-
-idata_pragma:
- GHC_PRAGMA constrs idata_pragma_specs END_PRAGMA
- { $$ = mkidata_pragma($2, $3); }
- | GHC_PRAGMA idata_pragma_specs END_PRAGMA
- { $$ = mkidata_pragma(Lnil, $2); }
- | /* empty */ { $$ = mkno_pragma(); }
- ;
-
-inewt_pragma:
- GHC_PRAGMA constr1 idata_pragma_specs END_PRAGMA
- { $$ = mkidata_pragma($2, $3); }
- | GHC_PRAGMA idata_pragma_specs END_PRAGMA
- { $$ = mkidata_pragma(Lnil, $2); }
- | /* empty */ { $$ = mkno_pragma(); }
- ;
-
-idata_pragma_specs :
- SPECIALISE_PRAGMA idata_pragma_specslist
- { $$ = $2; }
- | /* empty */ { $$ = Lnil; }
- ;
-
-idata_pragma_specslist:
- idata_pragma_spectypes { $$ = lsing($1); }
- | idata_pragma_specslist COMMA idata_pragma_spectypes
- { $$ = lapp($1, $3); }
- ;
-
-idata_pragma_spectypes:
- OBRACK type_maybes CBRACK { $$ = mkidata_pragma_4s($2); }
- ;
-
-iclas_pragma:
- GHC_PRAGMA gen_pragma_list END_PRAGMA { $$ = mkiclas_pragma($2); }
- | /* empty */ { $$ = mkno_pragma(); }
- ;
-
-iclasop_pragma:
- GHC_PRAGMA gen_pragma gen_pragma END_PRAGMA
- { $$ = mkiclasop_pragma($2, $3); }
- | /* empty */
- { $$ = mkno_pragma(); }
- ;
-
-iinst_pragma:
- GHC_PRAGMA gen_pragma END_PRAGMA
- { $$ = mkiinst_simpl_pragma($2); }
-
- | GHC_PRAGMA gen_pragma name_pragma_pairs END_PRAGMA
- { $$ = mkiinst_const_pragma($2, $3); }
-
- | /* empty */
- { $$ = mkno_pragma(); }
- ;
-
-ival_pragma:
- GHC_PRAGMA gen_pragma END_PRAGMA
- { $$ = $2; }
- | /* empty */
- { $$ = mkno_pragma(); }
- ;
-
-gen_pragma:
- NOINFO_PRAGMA
- { $$ = mkno_pragma(); }
- | arity_pragma update_pragma deforest_pragma strictness_pragma unfolding_pragma type_pragma_pairs_maybe
- { $$ = mkigen_pragma($1, $2, $3, $4, $5, $6); }
- ;
-
-arity_pragma:
- NO_PRAGMA { $$ = mkno_pragma(); }
- | ARITY_PRAGMA INTEGER { $$ = mkiarity_pragma($2); }
- ;
-
-update_pragma:
- NO_PRAGMA { $$ = mkno_pragma(); }
- | UPDATE_PRAGMA INTEGER { $$ = mkiupdate_pragma($2); }
- ;
-
-deforest_pragma:
- NO_PRAGMA { $$ = mkno_pragma(); }
- | DEFOREST_PRAGMA { $$ = mkideforest_pragma(); }
- ;
-
-strictness_pragma:
- NO_PRAGMA { $$ = mkno_pragma(); }
- | STRICTNESS_PRAGMA COCON { $$ = mkistrictness_pragma(installHstring(1, "B"),
- /* _!_ = COCON = bottom */ mkno_pragma());
- }
- | STRICTNESS_PRAGMA STRING worker_info
- { $$ = mkistrictness_pragma($2, $3); }
- ;
-
-worker_info:
- OCURLY gen_pragma CCURLY { $$ = $2; }
- | /* empty */ { $$ = mkno_pragma(); }
-
-unfolding_pragma:
- NO_PRAGMA { $$ = mkno_pragma(); }
- | MAGIC_UNFOLDING_PRAGMA vark
- { $$ = mkimagic_unfolding_pragma($2); }
- | UNFOLDING_PRAGMA unfolding_guidance core_expr
- { $$ = mkiunfolding_pragma($2, $3); }
- ;
-
-unfolding_guidance:
- UNFOLD_ALWAYS
- { $$ = mkiunfold_always(); }
- | UNFOLD_IF_ARGS INTEGER INTEGER CONID INTEGER
- { $$ = mkiunfold_if_args($2, $3, $4, $5); }
- ;
-
-gen_pragma_list:
- gen_pragma { $$ = lsing($1); }
- | gen_pragma_list COMMA gen_pragma { $$ = lapp($1, $3); }
- ;
-
-type_pragma_pairs_maybe:
- NO_PRAGMA { $$ = Lnil; }
- | SPECIALISE_PRAGMA type_pragma_pairs { $$ = $2; }
- ;
-
-/* 1 S/R conflict at COMMA -> shift */
-type_pragma_pairs:
- type_pragma_pair { $$ = lsing($1); }
- | type_pragma_pairs COMMA type_pragma_pair { $$ = lapp($1, $3); }
- ;
-
-type_pragma_pair:
- OBRACK type_maybes CBRACK INTEGER worker_info
- { $$ = mkitype_pragma_pr($2, $4, $5); }
- ;
-
-type_maybes:
- type_maybe { $$ = lsing($1); }
- | type_maybes COMMA type_maybe { $$ = lapp($1, $3); }
- ;
-
-type_maybe:
- NO_PRAGMA { $$ = mknothing(); }
- | type { $$ = mkjust($1); }
- ;
-
-name_pragma_pairs:
- name_pragma_pair { $$ = lsing($1); }
- | name_pragma_pairs COMMA name_pragma_pair { $$ = lapp($1, $3); }
- ;
-
-name_pragma_pair:
- /* if the gen_pragma concludes with a *comma*-separated SPECs list,
- we get a parse error --- we have to bracket the gen_pragma
- */
-
- var EQUAL OCURLY gen_pragma CCURLY
- { $$ = mkiname_pragma_pr($1, $4); }
- ;
-
-/**********************************************************************
-* *
-* *
-* Core syntax stuff *
-* *
-* *
-**********************************************************************/
-
-core_expr:
- LAMBDA core_binders RARROW core_expr
- { $$ = mkcolam($2, $4); }
- | TYLAMBDA core_tyvars RARROW core_expr
- { $$ = mkcotylam($2, $4); }
- | COCON con core_types core_atoms
- { $$ = mkcocon(mkco_id($2), $3, $4); }
- | COCON CO_ORIG_NM modid con core_types core_atoms
- { $$ = mkcocon(mkco_orig_id($3,$4), $5, $6); }
- | COPRIM co_primop core_types core_atoms
- { $$ = mkcoprim($2, $3, $4); }
- | COAPP core_expr core_atoms
- { $$ = mkcoapp($2, $3); }
- | COTYAPP core_expr OCURLY core_type CCURLY
- { $$ = mkcotyapp($2, $4); }
- | CASE core_expr OF OCURLY core_case_alts CCURLY
- { $$ = mkcocase($2, $5); }
- | LET OCURLY core_binder EQUAL core_expr CCURLY IN core_expr
- { $$ = mkcolet(mkcononrec($3, $5), $8); }
- | CO_LETREC OCURLY corec_binds CCURLY IN core_expr
- { $$ = mkcolet(mkcorec($3), $6); }
- | SCC OCURLY co_scc CCURLY core_expr
- { $$ = mkcoscc($3, $5); }
- | lit_constant { $$ = mkcoliteral($1); }
- | core_id { $$ = mkcovar($1); }
- ;
-
-core_case_alts :
- CO_ALG_ALTS core_alg_alts core_default
- { $$ = mkcoalg_alts($2, $3); }
- | CO_PRIM_ALTS core_prim_alts core_default
- { $$ = mkcoprim_alts($2, $3); }
- ;
-
-core_alg_alts :
- /* empty */ { $$ = Lnil; }
- | core_alg_alts core_alg_alt { $$ = lapp($1, $2); }
- ;
-
-core_alg_alt:
- core_id core_binders RARROW core_expr SEMI { $$ = mkcoalg_alt($1, $2, $4); }
- /* core_id is really too generous */
- ;
-
-core_prim_alts :
- /* empty */ { $$ = Lnil; }
- | core_prim_alts core_prim_alt { $$ = lapp($1, $2); }
- ;
-
-core_prim_alt:
- lit_constant RARROW core_expr SEMI { $$ = mkcoprim_alt($1, $3); }
- ;
-
-core_default:
- CO_NO_DEFAULT { $$ = mkconodeflt(); }
- | core_binder RARROW core_expr { $$ = mkcobinddeflt($1, $3); }
- ;
-
-corec_binds:
- corec_bind { $$ = lsing($1); }
- | corec_binds SEMI corec_bind { $$ = lapp($1, $3); }
- ;
-
-corec_bind:
- core_binder EQUAL core_expr { $$ = mkcorec_pair($1, $3); }
- ;
-
-co_scc :
- CO_PRELUDE_DICTS_CC co_dupd { $$ = mkco_preludedictscc($2); }
- | CO_ALL_DICTS_CC STRING STRING co_dupd { $$ = mkco_alldictscc($2,$3,$4); }
- | CO_USER_CC STRING STRING STRING co_dupd co_caf
- { $$ = mkco_usercc($2,$3,$4,$5,$6); }
- | CO_AUTO_CC core_id STRING STRING co_dupd co_caf
- { $$ = mkco_autocc($2,$3,$4,$5,$6); }
- | CO_DICT_CC core_id STRING STRING co_dupd co_caf
- { $$ = mkco_dictcc($2,$3,$4,$5,$6); }
-
-co_caf : NO_PRAGMA { $$ = mkco_scc_noncaf(); }
- | CO_CAF_CC { $$ = mkco_scc_caf(); }
-
-co_dupd : NO_PRAGMA { $$ = mkco_scc_nondupd(); }
- | CO_DUPD_CC { $$ = mkco_scc_dupd(); }
-
-core_id: /* more to come?? */
- CO_SDSEL_ID tycon tycon { $$ = mkco_sdselid($2, $3); }
- | CO_METH_ID tycon var { $$ = mkco_classopid($2, $3); }
- | CO_DEFM_ID tycon var { $$ = mkco_defmid($2, $3); }
- | CO_DFUN_ID tycon OPAREN core_type CPAREN
- { $$ = mkco_dfunid($2, $4); }
- | CO_CONSTM_ID tycon var OPAREN core_type CPAREN
- { $$ = mkco_constmid($2, $3, $5); }
- | CO_SPEC_ID core_id OBRACK core_type_maybes CBRACK
- { $$ = mkco_specid($2, $4); }
- | CO_WRKR_ID core_id { $$ = mkco_wrkrid($2); }
- | CO_ORIG_NM modid var { $$ = mkco_orig_id($2, $3); }
- | CO_ORIG_NM modid con { $$ = mkco_orig_id($2, $3); }
- | var { $$ = mkco_id($1); }
- | con { $$ = mkco_id($1); }
- ;
-
-co_primop :
- OPAREN CCALL ccallid OCURLY core_types core_type CCURLY CPAREN
- { $$ = mkco_ccall($3,0,$5,$6); }
- | OPAREN CCALL_GC ccallid OCURLY core_types core_type CCURLY CPAREN
- { $$ = mkco_ccall($3,1,$5,$6); }
- | OPAREN CASM lit_constant OCURLY core_types core_type CCURLY CPAREN
- { $$ = mkco_casm($3,0,$5,$6); }
- | OPAREN CASM_GC lit_constant OCURLY core_types core_type CCURLY CPAREN
- { $$ = mkco_casm($3,1,$5,$6); }
- | VARID { $$ = mkco_primop($1); }
- ;
-
-core_binders :
- /* empty */ { $$ = Lnil; }
- | core_binders core_binder { $$ = lapp($1, $2); }
- ;
-
-core_binder :
- OPAREN VARID DCOLON core_type CPAREN { $$ = mkcobinder($2, $4); }
-
-core_atoms :
- OBRACK CBRACK { $$ = Lnil; }
- | OBRACK core_atom_list CBRACK { $$ = $2; }
- ;
-
-core_atom_list :
- core_atom { $$ = lsing($1); }
- | core_atom_list COMMA core_atom { $$ = lapp($1, $3); }
- ;
-
-core_atom :
- lit_constant { $$ = mkcolit($1); }
- | core_id { $$ = mkcolocal($1); }
- ;
-
-core_tyvars :
- VARID { $$ = lsing($1); }
- | core_tyvars VARID { $$ = lapp($1, $2); }
- ;
-
-core_tv_templates :
- TYVAR_TEMPLATE_ID { $$ = lsing($1); }
- | core_tv_templates COMMA TYVAR_TEMPLATE_ID { $$ = lapp($1, $3); }
- ;
-
-core_types :
- OBRACK CBRACK { $$ = Lnil; }
- | OBRACK core_type_list CBRACK { $$ = $2; }
- ;
-
-core_type_list :
- core_type { $$ = lsing($1); }
- | core_type_list COMMA core_type { $$ = lapp($1, $3); }
- ;
-
-core_type :
- type { $$ = $1; }
- ;
-
-/*
-core_type :
- FORALL core_tv_templates DARROW core_type
- { $$ = mkuniforall($2, $4); }
- | OCURLY OCURLY CONID core_type CCURLY CCURLY RARROW core_type
- { $$ = mktfun(mkunidict($3, $4), $8); }
- | OCURLY OCURLY CONID core_type CCURLY CCURLY
- { $$ = mkunidict($3, $4); }
- | OPAREN OCURLY OCURLY CONID core_type CCURLY CCURLY COMMA core_type_list CPAREN RARROW core_type
- { $$ = mktfun(mkttuple(mklcons(mkunidict($4, $5), $9)), $12); }
- | OPAREN OCURLY OCURLY CONID core_type CCURLY CCURLY COMMA core_type_list CPAREN
- { $$ = mkttuple(mklcons(mkunidict($4,$5), $9)); }
- | type { $$ = $1; }
- ;
-*/
-
-core_type_maybes:
- core_type_maybe { $$ = lsing($1); }
- | core_type_maybes COMMA core_type_maybe { $$ = lapp($1, $3); }
- ;
-
-core_type_maybe:
- NO_PRAGMA { $$ = mknothing(); }
- | core_type { $$ = mkjust($1); }
- ;
-
-
/**********************************************************************
* *
* *
ops { $$ = $3; }
;
-ops : op { makeinfix($1,Fixity,Precedence,the_module_name,
- inimport,importas,importmod,asmod,importqual,
- importspec,importhide,importlist);
- $$ = lsing(mkfixop($1,infixint(Fixity),Precedence));
- }
- | ops COMMA op { makeinfix($3,Fixity,Precedence,the_module_name,
- inimport,importas,importmod,asmod,importqual,
- importspec,importhide,importlist);
- $$ = lapp($1,mkfixop($3,infixint(Fixity),Precedence));
- }
+ops : op { $$ = lsing(mkfixop(mknoqual($1),infixint(Fixity),Precedence)); }
+ | ops COMMA op { $$ = lapp($1,mkfixop(mknoqual($3),infixint(Fixity),Precedence)); }
;
topdecls: topdecl
$$ = $3;
SAMEFN = 0;
}
- ;
+ ;
topdecl : typed { $$ = $1; }
| datad { $$ = $1; }
;
-datad : datakey simple EQUAL constrs
- { $$ = mktbind(Lnil,$2,$4,mknothing(),startlineno,mkno_pragma()); }
- | datakey simple EQUAL constrs DERIVING dtyclses
- { $$ = mktbind(Lnil,$2,$4,mkjust($6),startlineno,mkno_pragma()); }
- | datakey context DARROW simple EQUAL constrs
- { $$ = mktbind($2,$4,$6,mknothing(),startlineno,mkno_pragma()); }
- | datakey context DARROW simple EQUAL constrs DERIVING dtyclses
- { $$ = mktbind($2,$4,$6,mkjust($8),startlineno,mkno_pragma()); }
+datad : datakey simple EQUAL constrs deriving
+ { $$ = mktbind(Lnil,$2,$4,$5,startlineno); }
+ | datakey context DARROW simple EQUAL constrs deriving
+ { $$ = mktbind($2,$4,$6,$7,startlineno); }
+ ;
+
+newtd : newtypekey simple EQUAL constr1 deriving
+ { $$ = mkntbind(Lnil,$2,$4,$5,startlineno); }
+ | newtypekey context DARROW simple EQUAL constr1 deriving
+ { $$ = mkntbind($2,$4,$6,$7,startlineno); }
;
-newtd : newtypekey simple EQUAL constr1
- { $$ = mkntbind(Lnil,$2,$4,mknothing(),startlineno,mkno_pragma()); }
- | newtypekey simple EQUAL constr1 DERIVING dtyclses
- { $$ = mkntbind(Lnil,$2,$4,mkjust($6),startlineno,mkno_pragma()); }
- | newtypekey context DARROW simple EQUAL constr1
- { $$ = mkntbind($2,$4,$6,mknothing(),startlineno,mkno_pragma()); }
- | newtypekey context DARROW simple EQUAL constr1 DERIVING dtyclses
- { $$ = mkntbind($2,$4,$6,mkjust($8),startlineno,mkno_pragma()); }
+deriving: /* empty */ { $$ = mknothing(); }
+ | DERIVING dtyclses { $$ = mkjust($2); }
;
-classd : classkey context DARROW class cbody { $$ = mkcbind($2,$4,$5,startlineno,mkno_pragma()); }
- | classkey class cbody { $$ = mkcbind(Lnil,$2,$3,startlineno,mkno_pragma()); }
+classd : classkey context DARROW class cbody
+ { $$ = mkcbind($2,$4,$5,startlineno); }
+ | classkey class cbody
+ { $$ = mkcbind(Lnil,$2,$3,startlineno); }
;
cbody : /* empty */ { $$ = mknullbind(); }
;
instd : instkey context DARROW gtycon restrict_inst rinst
- { $$ = mkibind(1/*source*/,the_module_name,$2,$4,$5,$6,startlineno,mkno_pragma()); }
+ { $$ = mkibind($2,$4,$5,$6,startlineno); }
| instkey gtycon general_inst rinst
- { $$ = mkibind(1/*source*/,the_module_name,Lnil,$2,$3,$4,startlineno,mkno_pragma()); }
+ { $$ = mkibind(Lnil,$2,$3,$4,startlineno); }
;
-rinst : /* empty */ { $$ = mknullbind(); }
- | WHERE ocurly instdefs ccurly { $$ = $3; }
- | WHERE vocurly instdefs vccurly { $$ = $3; }
+rinst : /* empty */ { $$ = mknullbind(); }
+ | WHERE ocurly instdefs ccurly { $$ = $3; }
+ | WHERE vocurly instdefs vccurly { $$ = $3; }
;
restrict_inst : gtycon { $$ = mktname($1); }
| defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); }
;
-decls : decl
- | decls SEMI decl
+decls : decl
+ | decls SEMI decl
{
if(SAMEFN)
{
}
;
-
/*
Note: if there is an iclasop_pragma here, then we must be
doing a class-op in an interface -- unless the user is up
to real mischief (ugly, but likely to work).
*/
-decl : qvarsk DCOLON ctype iclasop_pragma
- { $$ = mksbind($1,$3,startlineno,$4);
+decl : qvarsk DCOLON ctype
+ { $$ = mksbind($1,$3,startlineno);
PREVPATT = NULL; FN = NULL; SAMEFN = 0;
}
+
/* User-specified pragmas come in as "signatures"...
They are similar in that they can appear anywhere in the module,
and have to be "joined up" with their related entity.
/* 1 S/R conflict at RARROW -> shift */
type : btype { $$ = $1; }
| btype RARROW type { $$ = mktfun($1,$3); }
-
- | FORALL core_tv_templates DARROW type { $$ = mkuniforall($2, $4); }
;
/* btype is split so we can parse gtyconapp without S/R conflicts */
| OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); }
| OBRACK type CBRACK { $$ = mktllist($2); }
| OPAREN type CPAREN { $$ = $2; }
-
- | OCURLY OCURLY gtycon type CCURLY CCURLY { $$ = mkunidict($3, $4); }
- | TYVAR_TEMPLATE_ID { $$ = mkunityvartemplate($1); }
- ;
+ ;
gtycon : qtycon
| OPAREN RARROW CPAREN { $$ = creategid(-2); }
precedence parsing to work.
*/
/* 9 S/R conflicts on qop -> shift */
-oexp : oexp qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); precparse($$); }
+oexp : oexp qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
| dexp
;
This comes here because of the funny precedence rules concerning
prefix minus.
*/
-dexp : MINUS kexp { $$ = mknegate($2,NULL,NULL); }
+dexp : MINUS kexp { $$ = mknegate($2); }
| kexp
;
expLno : oexpLno DCOLON ctype { $$ = mkrestr($1,$3); }
| oexpLno
;
-oexpLno : oexpLno qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); precparse($$); }
+oexpLno : oexpLno qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
| dexpLno
;
-dexpLno : MINUS kexp { $$ = mknegate($2,NULL,NULL); }
+dexpLno : MINUS kexp { $$ = mknegate($2); }
| kexpLno
;
expL : oexpL DCOLON ctype { $$ = mkrestr($1,$3); }
| oexpL
;
-oexpL : oexpL qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); precparse($$); }
+oexpL : oexpL qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
| kexpL
;
aexp : qvar { $$ = mkident($1); }
| gcon { $$ = mkident($1); }
| lit_constant { $$ = mklit($1); }
- | OPAREN exp CPAREN { $$ = mkpar($2); } /* mkpar: stop infix parsing at ()'s */
+ | OPAREN exp CPAREN { $$ = mkpar($2); } /* mkpar: stop infix parsing at ()'s */
| qcon OCURLY CCURLY { $$ = mkrecord($1,Lnil); }
- | qcon OCURLY rbinds CCURLY { $$ = mkrecord($1,$3); } /* 1 S/R conflict on OCURLY -> shift */
+ | qcon OCURLY rbinds CCURLY { $$ = mkrecord($1,$3); } /* 1 S/R conflict on OCURLY -> shift */
| OBRACK list_exps CBRACK { $$ = mkllist($2); }
| OPAREN exp COMMA texps CPAREN { if (ttree($4) == tuple)
$$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4)));
| exp COMMA texps
{ if (ttree($3) == tuple)
$$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3)));
+ else if (ttree($3) == par)
+ $$ = mktuple(ldub($1, gpare((struct Spar *) $3)));
else
- $$ = mktuple(ldub($1, $3));
+ hsperror("hsparser:texps: panic");
}
/* right recursion? WDP */
;
*/
opatk : dpatk
- | opatk qop opat %prec MINUS
- {
- $$ = mkinfixap($2,$1,$3);
-
- if (isconstr(qid_to_string($2)))
- precparse($$);
- else
- {
- checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */
- checkprec($3,$2,TRUE); /* then check the right pattern */
- }
- }
+ | opatk qop opat %prec MINUS { $$ = mkinfixap($2,$1,$3); }
;
opat : dpat
- | opat qop opat %prec MINUS
- {
- $$ = mkinfixap($2,$1,$3);
-
- if(isconstr(qid_to_string($2)))
- precparse($$);
- else
- {
- checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */
- checkprec($3,$2,TRUE); /* then check the right pattern */
- }
- }
+ | opat qop opat %prec MINUS { $$ = mkinfixap($2,$1,$3); }
;
/*
*/
-dpat : MINUS fpat { $$ = mknegate($2,NULL,NULL); }
+dpat : MINUS fpat { $$ = mknegate($2); }
| fpat
;
| aapat
;
-dpatk : minuskey fpat { $$ = mknegate($2,NULL,NULL); }
+dpatk : minuskey fpat { $$ = mknegate($2); }
| fpatk
;
/* right recursion? (WDP) */
;
-pat : pat qconop bpat { $$ = mkinfixap($2,$1,$3); precparse($$); }
+pat : pat qconop bpat { $$ = mkinfixap($2,$1,$3); }
| bpat
;
| INTPRIM { $$ = mkintprim($1); }
| FLOATPRIM { $$ = mkfloatprim($1); }
| DOUBLEPRIM { $$ = mkdoubleprim($1); }
- | CLITLIT /* yurble yurble */ { $$ = mkclitlit($1, ""); }
- | CLITLIT KIND_PRAGMA CONID { $$ = mkclitlit($1, $3); }
- | NOREP_INTEGER INTEGER { $$ = mknorepi($2); }
- | NOREP_RATIONAL INTEGER INTEGER { $$ = mknorepr($2, $3); }
- | NOREP_STRING STRING { $$ = mknoreps($2); }
+ | CLITLIT /* yurble yurble */ { $$ = mkclitlit($1); }
;
rpats : rpat { $$ = lsing($1); }
| AS { $$ = install_literal("as"); }
| HIDING { $$ = install_literal("hiding"); }
| QUALIFIED { $$ = install_literal("qualified"); }
- | INTERFACE { $$ = install_literal("interface"); }
;
/* DARROW BANG are valid varsyms */
| CONID
;
-tyvar : varid { $$ = mknamedtvar($1); }
+tyvar : varid { $$ = mknamedtvar(mknoqual($1)); }
;
tycon : CONID
;
* *
**********************************************************************/
+void
+checkinpat()
+{
+ if(!inpat)
+ hsperror("pattern syntax used in expression");
+}
+
+
/* The parser calls "hsperror" when it sees a
`report this and die' error. It sets the stage
and calls "yyerror".
#include "either.h"
#include "ttype.h"
#include "constr.h"
-#include "coresyn.h"
-#include "hpragma.h"
#include "binding.h"
#include "entidt.h"
#include "tree.h"
charprim : < gcharprim : hstring; >;
string : < gstring : hstring; >;
stringprim : < gstringprim : hstring; >;
- clitlit : < gclitlit : stringId;
- gclitlit_kind : stringId; >;
- norepi : < gnorepi : stringId; >;
- norepr : < gnorepr_n : stringId;
- gnorepr_d : stringId; >;
- noreps : < gnoreps : hstring; >;
+ clitlit : < gclitlit : stringId; >;
end;
BOOLEAN samefn[MAX_CONTEXTS] = { FALSE };
tree prevpatt[MAX_CONTEXTS] = { NULL };
-BOOLEAN inpat = FALSE;
-
static BOOLEAN checkorder2 PROTO((binding, BOOLEAN));
static BOOLEAN checksig PROTO((BOOLEAN, binding));
}
-void
-checkinpat()
-{
- if(!inpat)
- hsperror("pattern syntax used in expression");
-}
-
/* ------------------------------------------------------------------------
*/
case ident:
return(TRUE);
- /* This change might break ap infixop below. BEWARE.
- return (isconstr(qid_to_string(gident(e))));
- */
case ap:
{
fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind));
}
-/*
-
- Precedence Parser for Haskell. By default operators are left-associative,
- so it is only necessary to rearrange the parse tree where the new operator
- has a greater precedence than the existing one, or where two operators have
- the same precedence and are both right-associative. Error conditions are
- handled.
-
- Note: Prefix negation has the same precedence as infix minus.
- The algorithm must thus take account of explicit negates.
-*/
-
-void
-precparse(tree t)
-{
- if(ttree(t) == infixap)
- {
- tree left = ginfarg1(t);
-
- if(ttree(left) == negate)
- {
- struct infix *ttabpos = infixlookup(ginffun(t));
- struct infix *ntabpos = infixlookup(mknoqual(install_literal("-")));
-
- if(pprecedence(ntabpos) < pprecedence(ttabpos))
- {
- /* (-x)*y ==> -(x*y) */
- qid lop = ginffun(t);
- tree arg1 = gnexp(left);
- tree arg2 = ginfarg2(t);
-
- t->tag = negate;
- gnexp(t) = left;
- gnxxx1(t) = NULL;
- gnxxx2(t) = NULL;
-
- left->tag = infixap;
- ginffun(left) = lop;
- ginfarg1(left) = arg1;
- ginfarg2(left) = arg2;
-
- precparse(left);
- }
- }
-
- else if(ttree(left) == infixap)
- {
- struct infix *ttabpos = infixlookup(ginffun(t));
- struct infix *lefttabpos = infixlookup(ginffun(left));
-
- if(pprecedence(lefttabpos) < pprecedence(ttabpos))
- rearrangeprec(left,t);
-
- else if(pprecedence(lefttabpos) == pprecedence(ttabpos))
- {
- if(pfixity(lefttabpos) == INFIXR && pfixity(ttabpos) == INFIXR)
- rearrangeprec(left,t);
-
- else if(pfixity(lefttabpos) == INFIXL && pfixity(ttabpos) == INFIXL)
- /* SKIP */;
-
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"Cannot mix %s and %s in the same infix expression",
- qid_to_string(ginffun(left)), qid_to_string(ginffun(t)));
- hsperror(errbuf);
- }
- }
- }
- }
-}
-
-
-/*
- Rearrange a tree to effectively insert an operator in the correct place.
-
- x+y*z ==parsed== (x+y)*z ==> x+(y*z)
-
- The recursive call to precparse ensures this filters down as necessary.
-*/
-
-static void
-rearrangeprec(tree left, tree t)
-{
- qid top = ginffun(left);
- qid lop = ginffun(t);
- tree arg1 = ginfarg1(left);
- tree arg2 = ginfarg2(left);
- tree arg3 = ginfarg2(t);
-
- ginffun(t) = top;
- ginfarg1(t) = arg1;
- ginfarg2(t) = left;
-
- ginffun(left) = lop;
- ginfarg1(left) = arg2;
- ginfarg2(left) = arg3;
-
- precparse(left);
-}
pbinding
createpat(guards,where)
return(mkpgrhs(PREVPATT,guards,where,func,endlineno));
}
+
char *
ineg(i)
char *i;
return(p);
}
-#if 0
-/* UNUSED: at the moment */
-void
-checkmodname(import,interface)
- id import, interface;
-{
- if(strcmp(import,interface) != 0)
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"interface name (%s) does not agree with import name (%s)",interface,import);
- hsperror(errbuf);
- }
-}
-#endif /* 0 */
-
/*
Check the ordering of declarations in a cbody.
All signatures must appear before any declarations.
return(checksig(sigs,decls));
}
-
static BOOLEAN
checksig(sig,decl)
BOOLEAN sig;
/*
- Check the precedence of a pattern or expression to ensure that
- sections and function definitions have the correct parse.
-*/
-
-void
-checkprec(exp,qfn,right)
- tree exp;
- qid qfn;
- BOOLEAN right;
-{
- if(ttree(exp) == infixap)
- {
- struct infix *ftabpos = infixlookup(qfn);
- struct infix *etabpos = infixlookup(ginffun(exp));
-
- if (pprecedence(etabpos) > pprecedence(ftabpos) ||
- (pprecedence(etabpos) == pprecedence(ftabpos) &&
- ((pfixity(etabpos) == INFIXR && pfixity(ftabpos) == INFIXR && right) ||
- ((pfixity(etabpos) == INFIXL && pfixity(ftabpos) == INFIXL && !right)))))
- /* SKIP */;
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"Cannot mix %s and %s on a LHS or in a section",
- qid_to_string(qfn), qid_to_string(ginffun(exp)));
- hsperror(errbuf);
- }
- }
-}
-
-
-/*
Checks there are no bangs in a tycon application.
*/
hsperror("panic: splittyconap: bad tycon application (no tycon)");
}
}
+
+
+#if 0
+
+Precedence Parsing Is Now Done In The Compiler !!!
+
+/*
+
+ Precedence Parser for Haskell. By default operators are left-associative,
+ so it is only necessary to rearrange the parse tree where the new operator
+ has a greater precedence than the existing one, or where two operators have
+ the same precedence and are both right-associative. Error conditions are
+ handled.
+
+ Note: Prefix negation has the same precedence as infix minus.
+ The algorithm must thus take account of explicit negates.
+*/
+
+void
+precparse(tree t)
+{
+ if(ttree(t) == infixap)
+ {
+ tree left = ginfarg1(t);
+
+ if(ttree(left) == negate)
+ {
+ struct infix *ttabpos = infixlookup(ginffun(t));
+ struct infix *ntabpos = infixlookup(mknoqual(install_literal("-")));
+
+ if(pprecedence(ntabpos) < pprecedence(ttabpos))
+ {
+ /* (-x)*y ==> -(x*y) */
+ qid lop = ginffun(t);
+ tree arg1 = gnexp(left);
+ tree arg2 = ginfarg2(t);
+
+ t->tag = negate;
+ gnexp(t) = left;
+ gnxxx1(t) = NULL;
+ gnxxx2(t) = NULL;
+
+ left->tag = infixap;
+ ginffun(left) = lop;
+ ginfarg1(left) = arg1;
+ ginfarg2(left) = arg2;
+
+ precparse(left);
+ }
+ }
+
+ else if(ttree(left) == infixap)
+ {
+ struct infix *ttabpos = infixlookup(ginffun(t));
+ struct infix *lefttabpos = infixlookup(ginffun(left));
+
+ if(pprecedence(lefttabpos) < pprecedence(ttabpos))
+ rearrangeprec(left,t);
+
+ else if(pprecedence(lefttabpos) == pprecedence(ttabpos))
+ {
+ if(pfixity(lefttabpos) == INFIXR && pfixity(ttabpos) == INFIXR)
+ rearrangeprec(left,t);
+
+ else if(pfixity(lefttabpos) == INFIXL && pfixity(ttabpos) == INFIXL)
+ /* SKIP */;
+
+ else
+ {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf,"Cannot mix %s and %s in the same infix expression",
+ qid_to_string(ginffun(left)), qid_to_string(ginffun(t)));
+ hsperror(errbuf);
+ }
+ }
+ }
+ }
+}
+
+
+/*
+ Rearrange a tree to effectively insert an operator in the correct place.
+
+ x+y*z ==parsed== (x+y)*z ==> x+(y*z)
+
+ The recursive call to precparse ensures this filters down as necessary.
+*/
+
+static void
+rearrangeprec(tree left, tree t)
+{
+ qid top = ginffun(left);
+ qid lop = ginffun(t);
+ tree arg1 = ginfarg1(left);
+ tree arg2 = ginfarg2(left);
+ tree arg3 = ginfarg2(t);
+
+ ginffun(t) = top;
+ ginfarg1(t) = arg1;
+ ginfarg2(t) = left;
+
+ ginffun(left) = lop;
+ ginfarg1(left) = arg2;
+ ginfarg2(left) = arg3;
+
+ precparse(left);
+}
+
+
+/*
+ Check the precedence of a pattern or expression to ensure that
+ sections and function definitions have the correct parse.
+*/
+
+void
+checkprec(exp,qfn,right)
+ tree exp;
+ qid qfn;
+ BOOLEAN right;
+{
+ if(ttree(exp) == infixap)
+ {
+ struct infix *ftabpos = infixlookup(qfn);
+ struct infix *etabpos = infixlookup(ginffun(exp));
+
+ if (pprecedence(etabpos) > pprecedence(ftabpos) ||
+ (pprecedence(etabpos) == pprecedence(ftabpos) &&
+ ((pfixity(etabpos) == INFIXR && pfixity(ftabpos) == INFIXR && right) ||
+ ((pfixity(etabpos) == INFIXL && pfixity(ftabpos) == INFIXL && !right)))))
+ /* SKIP */;
+ else
+ {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf,"Cannot mix %s and %s on a LHS or in a section",
+ qid_to_string(qfn), qid_to_string(ginffun(exp)));
+ hsperror(errbuf);
+ }
+ }
+}
+
+#endif /* 0 */
+
ghexplist : maybe; /* Maybe [entity] */
ghfixes : list; /* [fixop] */
ghmodlist : binding;
+ ghversion : long;
ghmodline : long; >;
- fixop : < gfixop : unkId;
+ fixop : < gfixop : qid;
gfixinfx : long;
- gfixprec : long; >;
+ gfixprec : long; >;
ident : < gident : qid; >;
lit : < glit : literal; >;
infixap : < ginffun : qid;
ginfarg1 : tree;
ginfarg2 : tree; >;
- negate : < gnexp : tree;
- gnxxx1 : VOID_STAR;
- gnxxx2 : VOID_STAR; >;
- /*
- infixap and negate have the same size
- so they can be rearranged in precparse
- */
+ negate : < gnexp : tree; >;
lambda : < glampats : list;
glamexpr : tree;
%}}
type ttype;
tname : < gtypeid : qid; >;
- namedtvar : < gnamedtvar : unkId; /* ToDo: rm unkIds entirely??? */ >;
+ namedtvar : < gnamedtvar : qid; >;
tllist : < gtlist : ttype; >;
ttuple : < gttuple : list; >;
tfun : < gtin : ttype;
tbang : < gtbang : ttype; >;
context : < gtcontextl : list;
gtcontextt : ttype; >;
-
- unidict : < gunidict_clas : qid;
- gunidict_ty : ttype; >;
- unityvartemplate: <gunityvartemplate : unkId; >;
- uniforall : < guniforall_tv : list;
- guniforall_ty : ttype; >;
end;
void extendfn PROTO((binding, binding));
void checkorder PROTO((binding));
-void precparse PROTO((tree));
-void checkprec PROTO((tree, qid, BOOLEAN));
void checkdostmts PROTO((list));
void checknobangs PROTO((ttype));
void splittyconapp PROTO((ttype, qid *, list *));
+/*
+void precparse PROTO((tree));
+void checkprec PROTO((tree, qid, BOOLEAN));
+*/
+
BOOLEAN isconstr PROTO((char *));
void setstartlineno PROTO((void));
void find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *));
pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
gLASGOW_ST, gLASGOW_MISC,
- -- lookup functions for built-in names, for the renamer:
- builtinNameInfo,
+ -- finite maps for built-in things (for the renamer and typechecker):
+ builtinNameInfo, BuiltinNames(..),
+ BuiltinKeys(..), BuiltinIdInfos(..),
-- *odd* values that need to be reached out and grabbed:
eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
import TysWiredIn
-- others:
-import CmdLineOpts
-import FiniteMap
-import Id ( mkTupleCon, GenId{-instances-} )
-import Name ( Name(..) )
-import NameTypes ( mkPreludeCoreName, FullName, ShortName )
-import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon{-instances-} )
+import CmdLineOpts ( opt_HideBuiltinNames,
+ opt_HideMostBuiltinNames,
+ opt_ForConcurrent
+ )
+import FiniteMap ( FiniteMap, emptyFM, listToFM )
+import Id ( mkTupleCon, GenId, Id(..) )
+import Maybes ( catMaybes )
+import Name ( mkBuiltinName )
+import Outputable ( getOrigName )
+import RnHsSyn ( RnName(..) )
+import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon )
import Type
+import UniqFM ( UniqFM, emptyUFM, listToUFM )
import Unique -- *Key stuff
import Util ( nOfThem, panic )
\end{code}
@Classes@, the other to look up values.
\begin{code}
-builtinNameInfo :: (FAST_STRING -> Maybe Name, -- name lookup fn for values
- FAST_STRING -> Maybe Name) -- name lookup fn for tycons/classes
+builtinNameInfo :: ( BuiltinNames, BuiltinKeys, BuiltinIdInfos )
+
+type BuiltinNames = FiniteMap FAST_STRING RnName -- WiredIn Ids/TyCons
+type BuiltinKeys = FiniteMap FAST_STRING Unique -- Names with known uniques
+type BuiltinIdInfos = UniqFM IdInfo -- Info for known unique Ids
builtinNameInfo
- = (init_val_lookup_fn, init_tc_lookup_fn)
+ = if opt_HideBuiltinNames then
+ (
+ emptyFM,
+ emptyFM,
+ emptyUFM
+ )
+ else if opt_HideMostBuiltinNames then
+ (
+ listToFM min_assoc_wired,
+ emptyFM,
+ emptyUFM
+ )
+ else
+ (
+ listToFM assoc_wired,
+ listToFM assoc_keys,
+ listToUFM assoc_id_infos
+ )
+
where
- --
- -- values (including data constructors)
- --
- init_val_lookup_fn
- = if opt_HideBuiltinNames then
- (\ x -> Nothing)
- else if opt_HideMostBuiltinNames then
- lookupFM (listToFM (concat min_val_assoc_lists))
- else
- lookupFM (listToFM (concat val_assoc_lists))
-
- min_val_assoc_lists -- min needed when compiling bits of Prelude
- = [
- concat (map pcDataConNameInfo g_con_tycons),
- concat (map pcDataConNameInfo min_nonprim_tycon_list),
- totally_wired_in_Ids,
- unboxed_ops
+ min_assoc_wired -- min needed when compiling bits of Prelude
+ = concat
+ [
+ -- tycons
+ map pcTyConWiredInInfo prim_tycons,
+ map pcTyConWiredInInfo g_tycons,
+ map pcTyConWiredInInfo min_nonprim_tycon_list,
+
+ -- data constrs
+ concat (map pcDataConWiredInInfo g_con_tycons),
+ concat (map pcDataConWiredInInfo min_nonprim_tycon_list),
+
+ -- values
+ map pcIdWiredInInfo wired_in_ids,
+ primop_ids
]
- val_assoc_lists
- = [
- concat (map pcDataConNameInfo g_con_tycons),
- concat (map pcDataConNameInfo data_tycons),
- totally_wired_in_Ids,
- unboxed_ops,
- special_class_ops,
- if opt_ForConcurrent then parallel_vals else []
+ assoc_wired
+ = concat
+ [
+ -- tycons
+ map pcTyConWiredInInfo prim_tycons,
+ map pcTyConWiredInInfo g_tycons,
+ map pcTyConWiredInInfo data_tycons,
+ map pcTyConWiredInInfo synonym_tycons,
+
+ -- data consts
+ concat (map pcDataConWiredInInfo g_con_tycons),
+ concat (map pcDataConWiredInInfo data_tycons),
+
+ -- values
+ map pcIdWiredInInfo wired_in_ids,
+ map pcIdWiredInInfo parallel_ids,
+ primop_ids
]
- --
- -- type constructors and classes
- --
- init_tc_lookup_fn
- = if opt_HideBuiltinNames then
- (\ x -> Nothing)
- else if opt_HideMostBuiltinNames then
- lookupFM (listToFM (concat min_tc_assoc_lists))
- else
- lookupFM (listToFM (concat tc_assoc_lists))
-
- min_tc_assoc_lists -- again, pretty ad-hoc
- = [
- map pcTyConNameInfo prim_tycons,
- map pcTyConNameInfo g_tycons,
- map pcTyConNameInfo min_nonprim_tycon_list
+ assoc_keys
+ = concat
+ [
+ id_keys,
+ tysyn_keys,
+ class_keys,
+ class_op_keys
]
- tc_assoc_lists
- = [
- map pcTyConNameInfo prim_tycons,
- map pcTyConNameInfo g_tycons,
- map pcTyConNameInfo data_tycons,
- map pcTyConNameInfo synonym_tycons,
- std_tycon_list,
- std_class_list
- ]
+ id_keys = map id_key id_keys_infos
+ id_key (str, uniq, info) = (str, uniq)
+
+ assoc_id_infos = catMaybes (map assoc_info id_keys_infos)
+ assoc_info (str, uniq, Just info) = Just (uniq, info)
+ assoc_info (str, uniq, Nothing) = Nothing
+\end{code}
+
- -- We let a lot of "non-standard" values be visible, so that we
- -- can make sense of them in interface pragmas. It's cool, though
- -- they all have "non-standard" names, so they won't get past
- -- the parser in user code.
+We let a lot of "non-standard" values be visible, so that we can make
+sense of them in interface pragmas. It's cool, though they all have
+"non-standard" names, so they won't get past the parser in user code.
+The WiredIn TyCons and DataCons ...
+\begin{code}
prim_tycons
= [addrPrimTyCon,
ratioTyCon,
liftTyCon,
return2GMPsTyCon, -- ADR asked for these last two (WDP 94/11)
- returnIntAndGMPTyCon ]
+ returnIntAndGMPTyCon
+ ]
+
data_tycons
- = [addrTyCon,
+ = [
+ addrTyCon,
boolTyCon,
--- byteArrayTyCon,
charTyCon,
orderingTyCon,
doubleTyCon,
integerTyCon,
liftTyCon,
mallocPtrTyCon,
--- mutableArrayTyCon,
--- mutableByteArrayTyCon,
ratioTyCon,
return2GMPsTyCon,
returnIntAndGMPTyCon,
]
synonym_tycons
- = [primIoTyCon,
+ = [
+ primIoTyCon,
rationalTyCon,
stTyCon,
- stringTyCon]
-
-
-totally_wired_in_Ids
- = [(SLIT("error"), WiredInVal eRROR_ID),
- (SLIT("patError#"), WiredInVal pAT_ERROR_ID), -- occurs in i/faces
- (SLIT("parError#"), WiredInVal pAR_ERROR_ID), -- ditto
- (SLIT("_trace"), WiredInVal tRACE_ID),
-
- -- now the foldr/build Ids, which need to be built in
- -- because they have magic unfoldings
- (SLIT("_build"), WiredInVal buildId),
- (SLIT("_augment"), WiredInVal augmentId),
- (SLIT("foldl"), WiredInVal foldlId),
- (SLIT("foldr"), WiredInVal foldrId),
- (SLIT("unpackAppendPS#"), WiredInVal unpackCStringAppendId),
- (SLIT("unpackFoldrPS#"), WiredInVal unpackCStringFoldrId),
-
- (SLIT("_runST"), WiredInVal runSTId),
- (SLIT("_seq_"), WiredInVal seqId), -- yes, used in sequential-land, too
- -- WDP 95/11
- (SLIT("realWorld#"), WiredInVal realWorldPrimId)
+ stringTyCon
+ ]
+
+pcTyConWiredInInfo :: TyCon -> (FAST_STRING, RnName)
+pcTyConWiredInInfo tc = (snd (getOrigName tc), WiredInTyCon tc)
+
+pcDataConWiredInInfo :: TyCon -> [(FAST_STRING, RnName)]
+pcDataConWiredInInfo tycon
+ = [ (snd (getOrigName con), WiredInId con) | con <- tyConDataCons tycon ]
+\end{code}
+
+The WiredIn Ids ...
+ToDo: Some of these should be moved to id_keys_infos!
+\begin{code}
+wired_in_ids
+ = [eRROR_ID,
+ pAT_ERROR_ID, -- occurs in i/faces
+ pAR_ERROR_ID, -- ditto
+ tRACE_ID,
+
+ runSTId,
+ seqId,
+ realWorldPrimId,
+
+ -- foldr/build Ids have magic unfoldings
+ buildId,
+ augmentId,
+ foldlId,
+ foldrId,
+ unpackCStringAppendId,
+ unpackCStringFoldrId
]
-parallel_vals
- =[(SLIT("_par_"), WiredInVal parId),
- (SLIT("_fork_"), WiredInVal forkId)
+parallel_ids
+ = if not opt_ForConcurrent then
+ []
+ else
+ [parId,
+ forkId
#ifdef GRAN
- ,
- (SLIT("_parLocal_"), WiredInVal parLocalId),
- (SLIT("_parGlobal_"), WiredInVal parGlobalId)
- -- Add later:
- -- (SLIT("_parAt_"), WiredInVal parAtId)
- -- (SLIT("_parAtForNow_"), WiredInVal parAtForNowId)
- -- (SLIT("_copyable_"), WiredInVal copyableId)
- -- (SLIT("_noFollow_"), WiredInVal noFollowId)
+ ,parLocalId
+ ,parGlobalId
+ -- Add later:
+ -- ,parAtId
+ -- ,parAtForNowId
+ -- ,copyableId
+ -- ,noFollowId
#endif {-GRAN-}
- ]
-
-special_class_ops
- = let
- swizzle_over (str, key)
- = (str, ClassOpName key bottom1 str bottom2)
-
- bottom1 = panic "PrelInfo.special_class_ops:class"
- bottom2 = panic "PrelInfo.special_class_ops:tag"
- in
- map swizzle_over
- [ (SLIT("fromInt"), fromIntClassOpKey),
- (SLIT("fromInteger"), fromIntegerClassOpKey),
- (SLIT("fromRational"), fromRationalClassOpKey),
- (SLIT("enumFrom"), enumFromClassOpKey),
- (SLIT("enumFromThen"), enumFromThenClassOpKey),
- (SLIT("enumFromTo"), enumFromToClassOpKey),
- (SLIT("enumFromThenTo"),enumFromThenToClassOpKey),
- (SLIT("=="), eqClassOpKey),
- (SLIT(">="), geClassOpKey),
- (SLIT("-"), negateClassOpKey)
- ]
-
-unboxed_ops
- = map primOpNameInfo allThePrimOps
- -- plus some of the same ones but w/ different names ...
- ++ map fn funny_name_primops
+ ]
+
+pcIdWiredInInfo :: Id -> (FAST_STRING, RnName)
+pcIdWiredInInfo id = (snd (getOrigName id), WiredInId id)
+\end{code}
+
+WiredIn primitive numeric operations ...
+\begin{code}
+primop_ids
+ = map primOpNameInfo allThePrimOps ++ map fn funny_name_primops
where
fn (op,s) = case (primOpNameInfo op) of (_,n) -> (s,n)
funny_name_primops
- = [(IntAddOp, SLIT("+#")),
+ = [
+ (IntAddOp, SLIT("+#")),
(IntSubOp, SLIT("-#")),
(IntMulOp, SLIT("*#")),
(IntGtOp, SLIT(">#")),
(DoubleEqOp, SLIT("==##")),
(DoubleNeOp, SLIT("/=##")),
(DoubleLtOp, SLIT("<##")),
- (DoubleLeOp, SLIT("<=##"))]
-
-
-std_tycon_list
- = let
- swizzle_over (mod, nm, key, arity, is_data)
- = let
- fname = mkPreludeCoreName mod nm
- in
- (nm, TyConName key fname arity is_data (panic "std_tycon_list:data_cons"))
- in
- map swizzle_over
- [(SLIT("PreludeMonadicIO"), SLIT("IO"), iOTyConKey, 1, False)
- ]
-
-std_class_list
- = let
- swizzle_over (str, key)
- = (str, ClassName key (mkPreludeCoreName pRELUDE_CORE str) (panic "std_class_list:ops"))
- in
- map swizzle_over
- [(SLIT("Eq"), eqClassKey),
- (SLIT("Ord"), ordClassKey),
- (SLIT("Num"), numClassKey),
- (SLIT("Real"), realClassKey),
- (SLIT("Integral"), integralClassKey),
- (SLIT("Fractional"), fractionalClassKey),
- (SLIT("Floating"), floatingClassKey),
- (SLIT("RealFrac"), realFracClassKey),
- (SLIT("RealFloat"), realFloatClassKey),
- (SLIT("Ix"), ixClassKey),
- (SLIT("Enum"), enumClassKey),
- (SLIT("Show"), showClassKey),
- (SLIT("Read"), readClassKey),
- (SLIT("Monad"), monadClassKey),
- (SLIT("MonadZero"), monadZeroClassKey),
- (SLIT("Binary"), binaryClassKey),
- (SLIT("_CCallable"), cCallableClassKey),
- (SLIT("_CReturnable"), cReturnableClassKey)
- ]
-
+ (DoubleLeOp, SLIT("<=##"))
+ ]
\end{code}
-Make table entries for various things:
+
+Ids, Synonyms, Classes and ClassOps with builtin keys.
+For the Ids we may also have some builtin IdInfo.
\begin{code}
-pcTyConNameInfo :: TyCon -> (FAST_STRING, Name)
-pcTyConNameInfo tc = (getOccurrenceName tc, WiredInTyCon tc)
+id_keys_infos :: [(FAST_STRING, Unique, Maybe IdInfo)]
+id_keys_infos
+ = [
+ ]
+
+tysyn_keys
+ = [
+ (SLIT("IO"), iOTyConKey) -- SLIT("PreludeMonadicIO")
+ ]
+
+class_keys
+ = [
+ (SLIT("Eq"), eqClassKey),
+ (SLIT("Ord"), ordClassKey),
+ (SLIT("Num"), numClassKey),
+ (SLIT("Real"), realClassKey),
+ (SLIT("Integral"), integralClassKey),
+ (SLIT("Fractional"), fractionalClassKey),
+ (SLIT("Floating"), floatingClassKey),
+ (SLIT("RealFrac"), realFracClassKey),
+ (SLIT("RealFloat"), realFloatClassKey),
+ (SLIT("Ix"), ixClassKey),
+ (SLIT("Enum"), enumClassKey),
+ (SLIT("Show"), showClassKey),
+ (SLIT("Read"), readClassKey),
+ (SLIT("Monad"), monadClassKey),
+ (SLIT("MonadZero"), monadZeroClassKey),
+ (SLIT("Binary"), binaryClassKey),
+ (SLIT("_CCallable"), cCallableClassKey),
+ (SLIT("_CReturnable"), cReturnableClassKey)
+ ]
-pcDataConNameInfo :: TyCon -> [(FAST_STRING, Name)]
-pcDataConNameInfo tycon
- = -- slurp out its data constructors...
- [ (getOccurrenceName con, WiredInVal con) | con <- tyConDataCons tycon ]
+class_op_keys
+ = [
+ (SLIT("fromInt"), fromIntClassOpKey),
+ (SLIT("fromInteger"), fromIntegerClassOpKey),
+ (SLIT("fromRational"), fromRationalClassOpKey),
+ (SLIT("enumFrom"), enumFromClassOpKey),
+ (SLIT("enumFromThen"), enumFromThenClassOpKey),
+ (SLIT("enumFromTo"), enumFromToClassOpKey),
+ (SLIT("enumFromThenTo"), enumFromThenToClassOpKey),
+ (SLIT("=="), eqClassOpKey),
+ (SLIT(">="), geClassOpKey)
+ ]
\end{code}
import Class ( GenClass )
import CoreUnfold ( mkMagicUnfolding, UnfoldingDetails )
import IdUtils ( primOpNameInfo )
-import Name ( Name )
-import NameTypes ( mkPreludeCoreName, FullName )
+import Name ( Name, mkBuiltinName )
import PrimOp ( PrimOp )
+import RnHsSyn ( RnName )
import Type ( mkSigmaTy, mkFunTys, GenType )
import TyVar ( GenTyVar )
import Unique ( Unique )
import Usage ( GenUsage )
mkMagicUnfolding :: Unique -> UnfoldingDetails
-mkPreludeCoreName :: _PackedString -> _PackedString -> FullName
+mkBuiltinName :: Unique -> _PackedString -> _PackedString -> Name
mkSigmaTy :: [a] -> [(GenClass (GenTyVar (GenUsage Unique)) Unique, GenType a b)] -> GenType a b -> GenType a b
mkFunTys :: [GenType a b] -> GenType a b -> GenType a b
-primOpNameInfo :: PrimOp -> (_PackedString, Name)
+primOpNameInfo :: PrimOp -> (_PackedString, RnName)
\end{code}
pRELUDE_LIST, pRELUDE_TEXT,
pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
gLASGOW_ST, gLASGOW_MISC,
- pRELUDE_FB
+ pRELUDE_FB, fromPrelude
) where
CHK_Ubiq() -- debugging consistency check
pRELUDE_PS = SLIT("PreludePS")
pRELUDE_RATIO = SLIT("PreludeRatio")
pRELUDE_TEXT = SLIT("PreludeText")
+
+fromPrelude :: FAST_STRING -> Bool
+fromPrelude s = (_SUBSTR_ s 0 6 == SLIT("Prelude"))
\end{code}
-- others:
import CoreSyn -- quite a bit
---import CoreUnfold ( UnfoldingGuidance(..), mkMagicUnfolding )
import IdInfo -- quite a bit
import Literal ( mkMachInt )
---import NameTypes ( mkPreludeCoreName )
import PrimOp ( PrimOp(..) )
import SpecEnv ( SpecEnv(..), nullSpecEnv )
---import Type ( mkSigmaTy, mkFunTys, GenType(..) )
import TyVar ( alphaTyVar, betaTyVar )
import Unique -- lots of *Keys
import Util ( panic )
pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
pcMiscPrelId key mod name ty info
- = mkPreludeId key (mkPreludeCoreName mod name) ty info
+ = mkPreludeId (mkBuiltinName key mod name) ty info
\end{code}
%************************************************************************
import CStrings ( identToC )
import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
import HeapOffs ( addOff, intOff, totHdrSize )
-import NameTypes ( mkPreludeCoreName, FullName, ShortName )
import PprStyle ( codeStyle )
import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} )
import Pretty
import Ubiq
import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind )
-import NameTypes ( mkPreludeCoreName, FullName )
+import Name ( mkBuiltinName )
import PrelMods ( pRELUDE_BUILTIN )
import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn
import TyCon ( mkPrimTyCon, mkDataTyCon, NewOrData(..) )
\begin{code}
-- only used herein
-pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> ([PrimRep] -> PrimRep) -> TyCon
-pcPrimTyCon key name arity{-UNUSED-} kind_fn{-UNUSED-}
- = mkPrimTyCon key full_name mkUnboxedTypeKind
+pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING
+ -> Int -> ([PrimRep] -> PrimRep) -> TyCon
+pcPrimTyCon key str arity{-UNUSED-} kind_fn{-UNUSED-}
+ = mkPrimTyCon name mkUnboxedTypeKind
where
- full_name = mkPreludeCoreName pRELUDE_BUILTIN name
+ name = mkBuiltinName key pRELUDE_BUILTIN str
charPrimTy = applyTyCon charPrimTyCon []
\begin{code}
realWorldTy = applyTyCon realWorldTyCon []
realWorldTyCon
- = mkDataTyCon realWorldTyConKey mkBoxedTypeKind full_name
+ = mkDataTyCon name mkBoxedTypeKind
[{-no tyvars-}]
[{-no context-}]
[{-no data cons!-}] -- we tell you *nothing* about this guy
[{-no derivings-}]
DataType
where
- full_name = mkPreludeCoreName pRELUDE_BUILTIN SLIT("_RealWorld")
+ name = mkBuiltinName realWorldTyConKey pRELUDE_BUILTIN SLIT("_RealWorld")
realWorldStatePrimTy = mkStatePrimTy realWorldTy
\end{code}
-- others:
import SpecEnv ( SpecEnv(..) )
-import NameTypes ( mkPreludeCoreName, mkShortName )
import Kind ( mkBoxedTypeKind, mkArrowKind )
+import Name ( mkBuiltinName )
import SrcLoc ( mkBuiltinSrcLoc )
import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
NewOrData(..), TyCon
pc_gen_specs = error "TysWiredIn:pc_gen_specs "
mkSpecInfo = error "TysWiredIn:SpecInfo"
-pcDataTyCon :: Unique{-TyConKey-} -> FAST_STRING -> FAST_STRING -> [TyVar] -> [Id] -> TyCon
-pcDataTyCon key mod name tyvars cons
- = mkDataTyCon key tycon_kind full_name tyvars
- [{-no context-}] cons [{-no derivings-}]
+pcDataTyCon :: Unique{-TyConKey-} -> Module -> FAST_STRING
+ -> [TyVar] -> [Id] -> TyCon
+pcDataTyCon key mod str tyvars cons
+ = mkDataTyCon (mkBuiltinName key mod str) tycon_kind
+ tyvars [{-no context-}] cons [{-no derivings-}]
DataType
where
- full_name = mkPreludeCoreName mod name
tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind tyvars
-pcDataCon :: Unique{-DataConKey-} -> FAST_STRING -> FAST_STRING -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
-pcDataCon key mod name tyvars context arg_tys tycon specenv
- = mkDataCon key (mkPreludeCoreName mod name)
+pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING
+ -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
+pcDataCon key mod str tyvars context arg_tys tycon specenv
+ = mkDataCon (mkBuiltinName key mod str)
[ NotMarkedStrict | a <- arg_tys ]
+ [ {- no labelled fields -} ]
tyvars context arg_tys tycon
-- specenv
stTyCon
= mkSynTyCon
- stTyConKey
- (mkPreludeCoreName gLASGOW_ST SLIT("_ST"))
+ (mkBuiltinName stTyConKey gLASGOW_ST SLIT("_ST"))
(panic "TysWiredIn.stTyCon:Kind")
- 2
- [alphaTyVar, betaTyVar]
+ 2 [alphaTyVar, betaTyVar]
(mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy]))
\end{code}
primIoTyCon
= mkSynTyCon
- primIoTyConKey
- (mkPreludeCoreName pRELUDE_PRIMIO SLIT("PrimIO"))
+ (mkBuiltinName primIoTyConKey pRELUDE_PRIMIO SLIT("PrimIO"))
(panic "TysWiredIn.primIoTyCon:Kind")
- 1
- [alphaTyVar]
- (mkStateTransformerTy realWorldTy alphaTy)
+ 1 [alphaTyVar] (mkStateTransformerTy realWorldTy alphaTy)
\end{code}
%************************************************************************
rationalTyCon
= mkSynTyCon
- rationalTyConKey
- (mkPreludeCoreName pRELUDE_RATIO SLIT("Rational"))
+ (mkBuiltinName rationalTyConKey pRELUDE_RATIO SLIT("Rational"))
mkBoxedTypeKind
- 0 -- arity
- [] -- tyvars
- rationalTy -- == mkRatioTy integerTy
+ 0 [] rationalTy -- == mkRatioTy integerTy
\end{code}
%************************************************************************
stringTyCon
= mkSynTyCon
- stringTyConKey
- (mkPreludeCoreName pRELUDE_CORE SLIT("String"))
+ (mkBuiltinName stringTyConKey pRELUDE_CORE SLIT("String"))
mkBoxedTypeKind
- 0
- [] -- type variables
- stringTy
+ 0 [] stringTy
\end{code}
import Id ( externallyVisibleId, GenId, Id(..) )
import CStrings ( identToC, stringToC )
import Maybes ( Maybe(..) )
+import Name ( showRdr, RdrName )
import Outputable
import Pretty ( ppShow, prettyToUn )
import PprStyle ( PprStyle(..) )
do_id :: Id -> String
do_id id
= if print_as_string
- then _UNPK_ (getOccurrenceName id) -- don't want module in the name
- else showId sty id -- we really do
+ then showRdr sty (getOccName id) -- use occ name
+ else showId sty id -- we really do
do_calved IsCafCC = "/CAF"
do_calved _ = ""
RdrBinding(..),
RdrId(..),
RdrMatch(..),
- RdrTySigPragmas(..),
SigConverter(..),
SrcFile(..),
SrcFun(..),
readInteger
) where
-import Ubiq{-uitous-}
+import Ubiq
import HsSyn
import RdrHsSyn
import Util ( panic )
-type RdrId = ProtoName
+type RdrId = RdrName
type SrcLine = Int
type SrcFile = FAST_STRING
-type SrcFun = ProtoName
+type SrcFun = RdrName
\end{code}
\begin{code}
= RdrNullBind
| RdrAndBindings RdrBinding RdrBinding
- | RdrTyDecl ProtoNameTyDecl
+ | RdrTyDecl RdrNameTyDecl
| RdrFunctionBinding SrcLine [RdrMatch]
| RdrPatternBinding SrcLine [RdrMatch]
- | RdrClassDecl ProtoNameClassDecl
- | RdrInstDecl ProtoNameInstDecl
- | RdrDefaultDecl ProtoNameDefaultDecl
- | RdrIfaceImportDecl (IfaceImportDecl ProtoName)
- | RdrIfaceFixities [ProtoNameFixityDecl]
+ | RdrClassDecl RdrNameClassDecl
+ | RdrInstDecl RdrNameInstDecl
+ | RdrDefaultDecl RdrNameDefaultDecl
-- signatures are mysterious; we can't
-- tell if its a Sig or a ClassOpSig,
-- so we just save the pieces:
- | RdrTySig [ProtoName] -- vars getting sigs
- ProtoNamePolyType -- the type
- RdrTySigPragmas -- val/class-op pragmas
+ | RdrTySig [RdrName] -- vars getting sigs
+ RdrNamePolyType -- the type
SrcLoc
-- user pragmas come in in a Sig-ish way/form...
- | RdrSpecValSig [ProtoNameSig]
- | RdrInlineValSig ProtoNameSig
- | RdrDeforestSig ProtoNameSig
- | RdrMagicUnfoldingSig ProtoNameSig
- | RdrSpecInstSig ProtoNameSpecInstSig
- | RdrSpecDataSig ProtoNameSpecDataSig
-
-data RdrTySigPragmas
- = RdrNoPragma
- | RdrGenPragmas ProtoNameGenPragmas
- | RdrClassOpPragmas ProtoNameClassOpPragmas
-
-type SigConverter = RdrBinding {- a RdrTySig... -} -> [ProtoNameSig]
+ | RdrSpecValSig [RdrNameSig]
+ | RdrInlineValSig RdrNameSig
+ | RdrDeforestSig RdrNameSig
+ | RdrMagicUnfoldingSig RdrNameSig
+ | RdrSpecInstSig RdrNameSpecInstSig
+ | RdrSpecDataSig RdrNameSpecDataSig
+
+type SigConverter = RdrBinding {- a Sig -} -> [RdrNameSig]
\end{code}
\begin{code}
data RdrMatch
= RdrMatch_NoGuard
SrcLine SrcFun
- ProtoNamePat
- ProtoNameHsExpr
+ RdrNamePat
+ RdrNameHsExpr
RdrBinding
| RdrMatch_Guards
SrcLine SrcFun
- ProtoNamePat
- [(ProtoNameHsExpr, ProtoNameHsExpr)]
+ RdrNamePat
+ [(RdrNameHsExpr, RdrNameHsExpr)]
-- (guard, expr)
RdrBinding
\end{code}
#include "HsVersions.h"
module PrefixToHs (
- cvBinds,
+ cvValSig,
cvClassOpSig,
cvInstDeclSig,
+ cvBinds,
cvMatches,
cvMonoBinds,
cvSepdBinds,
- cvValSig,
- sepDeclsForInterface,
sepDeclsForTopBinds,
sepDeclsIntoSigsAndBinds
) where
import RdrHsSyn
import HsPragmas ( noGenPragmas, noClassOpPragmas )
-import ProtoName ( ProtoName(..) )
import SrcLoc ( mkSrcLoc2 )
import Util ( panic, assertPanic )
\end{code}
\begin{code}
cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
-cvValSig (RdrTySig vars poly_ty pragmas src_loc)
- = [ Sig v poly_ty (cvt_pragmas pragmas) src_loc | v <- vars ]
- where
- cvt_pragmas RdrNoPragma = noGenPragmas
- cvt_pragmas (RdrGenPragmas ps) = ps
+cvValSig (RdrTySig vars poly_ty src_loc)
+ = [ Sig v poly_ty noGenPragmas src_loc | v <- vars ]
-cvClassOpSig (RdrTySig vars poly_ty pragmas src_loc)
- = [ ClassOpSig v poly_ty (cvt_pragmas pragmas) src_loc | v <- vars ]
- where
- cvt_pragmas RdrNoPragma = noClassOpPragmas
- cvt_pragmas (RdrClassOpPragmas ps) = ps
+cvClassOpSig (RdrTySig vars poly_ty src_loc)
+ = [ ClassOpSig v poly_ty noClassOpPragmas src_loc | v <- vars ]
cvInstDeclSig (RdrSpecValSig sigs) = sigs
cvInstDeclSig (RdrInlineValSig sig) = [ sig ]
analyser.
\begin{code}
-cvBinds :: SrcFile -> SigConverter -> RdrBinding -> ProtoNameHsBinds
+cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds
cvBinds sf sig_cvtr raw_binding
= cvSepdBinds sf sig_cvtr (sepDeclsForBinds raw_binding)
-cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> ProtoNameHsBinds
+cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> RdrNameHsBinds
cvSepdBinds sf sig_cvtr bindings
= case (mkMonoBindsAndSigs sf sig_cvtr bindings) of { (mbs, sigs) ->
if (null sigs)
else BindWith (RecBind mbs) sigs
}
-cvMonoBinds :: SrcFile -> [RdrBinding] -> ProtoNameMonoBinds
+cvMonoBinds :: SrcFile -> [RdrBinding] -> RdrNameMonoBinds
cvMonoBinds sf bindings
= case (mkMonoBindsAndSigs sf bottom bindings) of { (mbs,sigs) ->
if (null sigs)
mkMonoBindsAndSigs :: SrcFile
-> SigConverter
-> [RdrBinding]
- -> (ProtoNameMonoBinds, [ProtoNameSig])
+ -> (RdrNameMonoBinds, [RdrNameSig])
mkMonoBindsAndSigs sf sig_cvtr fbs
= foldl mangle_bind (EmptyMonoBinds, []) fbs
-- function. Otherwise there is only one pattern, which is paired
-- with a guarded right hand side.
- mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _ _)
+ mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _)
= (b_acc, s_acc ++ sig_cvtr sig)
mangle_bind (b_acc, s_acc) (RdrSpecValSig sig) = (b_acc, sig ++ s_acc)
\end{code}
\begin{code}
-cvPatMonoBind :: SrcFile -> RdrMatch -> (ProtoNamePat, [ProtoNameGRHS], ProtoNameHsBinds)
+cvPatMonoBind :: SrcFile -> RdrMatch -> (RdrNamePat, [RdrNameGRHS], RdrNameHsBinds)
cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding)
= (pat, [OtherwiseGRHS expr (mkSrcLoc2 sf srcline)], cvBinds sf cvValSig binding)
cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding)
= (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding)
-cvFunMonoBind :: SrcFile -> [RdrMatch] -> (ProtoName {-VarName-}, [ProtoNameMatch])
+cvFunMonoBind :: SrcFile -> [RdrMatch] -> (RdrName {-VarName-}, [RdrNameMatch])
cvFunMonoBind sf matches
= (srcfun {- cheating ... -}, cvMatches sf False matches)
RdrMatch_NoGuard _ sfun _ _ _ -> sfun
RdrMatch_Guards _ sfun _ _ _ -> sfun
-cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [ProtoNameMatch]
-cvMatch :: SrcFile -> Bool -> RdrMatch -> ProtoNameMatch
+cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [RdrNameMatch]
+cvMatch :: SrcFile -> Bool -> RdrMatch -> RdrNameMatch
cvMatches sf is_case matches = map (cvMatch sf is_case) matches
doctor_pat (ConOpPatIn p1 op p2) = ConPatIn op [p1, p2]
doctor_pat other_pat = other_pat
-cvGRHS :: SrcFile -> SrcLine -> (ProtoNameHsExpr, ProtoNameHsExpr) -> ProtoNameGRHS
+cvGRHS :: SrcFile -> SrcLine -> (RdrNameHsExpr, RdrNameHsExpr) -> RdrNameGRHS
cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl)
\end{code}
binds RdrFunctionBinding RdrPatternBinding RdrTySig
RdrSpecValSig RdrInlineValSig RdrDeforestSig
RdrMagicUnfoldingSig
-iimps RdrIfaceImportDecl (interfaces only)
\end{display}
This function isn't called directly; some other function calls it,
\begin{code}
sepDecls (RdrTyDecl a)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (a:tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs)
+ tys tysigs classes insts instsigs defaults binds
+ = (a:tys,tysigs,classes,insts,instsigs,defaults,binds)
sepDecls a@(RdrFunctionBinding _ _)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
+ tys tysigs classes insts instsigs defaults binds
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
sepDecls a@(RdrPatternBinding _ _)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
+ tys tysigs classes insts instsigs defaults binds
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-- RdrAndBindings catered for below...
sepDecls (RdrClassDecl a)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,a:classes,insts,instsigs,defaults,binds,iimps,ifixs)
+ tys tysigs classes insts instsigs defaults binds
+ = (tys,tysigs,a:classes,insts,instsigs,defaults,binds)
sepDecls (RdrInstDecl a)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,classes,a:insts,instsigs,defaults,binds,iimps,ifixs)
+ tys tysigs classes insts instsigs defaults binds
+ = (tys,tysigs,classes,a:insts,instsigs,defaults,binds)
sepDecls (RdrDefaultDecl a)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,classes,insts,instsigs,a:defaults,binds,iimps,ifixs)
-
-sepDecls a@(RdrTySig _ _ _ _)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
+ tys tysigs classes insts instsigs defaults binds
+ = (tys,tysigs,classes,insts,instsigs,a:defaults,binds)
-sepDecls (RdrIfaceImportDecl a)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,classes,insts,instsigs,defaults,binds,a:iimps,ifixs)
-
-sepDecls (RdrIfaceFixities a)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,a++ifixs)
+sepDecls a@(RdrTySig _ _ _)
+ tys tysigs classes insts instsigs defaults binds
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
sepDecls a@(RdrSpecValSig _)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
+ tys tysigs classes insts instsigs defaults binds
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
sepDecls a@(RdrInlineValSig _)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
+ tys tysigs classes insts instsigs defaults binds
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
sepDecls a@(RdrDeforestSig _)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
+ tys tysigs classes insts instsigs defaults binds
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
sepDecls a@(RdrMagicUnfoldingSig _)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds,iimps,ifixs)
+ tys tysigs classes insts instsigs defaults binds
+ = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
sepDecls (RdrSpecInstSig a)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,classes,insts,a:instsigs,defaults,binds,iimps,ifixs)
+ tys tysigs classes insts instsigs defaults binds
+ = (tys,tysigs,classes,insts,a:instsigs,defaults,binds)
sepDecls (RdrSpecDataSig a)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,a:tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs)
+ tys tysigs classes insts instsigs defaults binds
+ = (tys,a:tysigs,classes,insts,instsigs,defaults,binds)
sepDecls RdrNullBind
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs)
+ tys tysigs classes insts instsigs defaults binds
+ = (tys,tysigs,classes,insts,instsigs,defaults,binds)
sepDecls (RdrAndBindings bs1 bs2)
- tys tysigs classes insts instsigs defaults binds iimps ifixs
- = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds iimps ifixs) of {
- (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) ->
- sepDecls bs1 tys tysigs classes insts instsigs defaults binds iimps ifixs
+ tys tysigs classes insts instsigs defaults binds
+ = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds) of {
+ (tys,tysigs,classes,insts,instsigs,defaults,binds) ->
+ sepDecls bs1 tys tysigs classes insts instsigs defaults binds
}
\end{code}
\begin{code}
sepDeclsForTopBinds binding
- = case (sepDecls binding [] [] [] [] [] [] [] [] [])
- of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) ->
- ASSERT ((null iimps)
- && (null ifixs))
- (tys,tysigs,classes,insts,instsigs,defaults,binds)
- }
+ = sepDecls binding [] [] [] [] [] [] []
sepDeclsForBinds binding
- = case (sepDecls binding [] [] [] [] [] [] [] [] [])
- of { (tys,tysigs,classes,insts,instsigs,defaults,binds,iimps,ifixs) ->
+ = case (sepDecls binding [] [] [] [] [] [] [])
+ of { (tys,tysigs,classes,insts,instsigs,defaults,binds) ->
ASSERT ((null tys)
&& (null tysigs)
&& (null classes)
&& (null insts)
&& (null instsigs)
- && (null defaults)
- && (null iimps)
- && (null ifixs))
+ && (null defaults))
binds
}
foldr sep_stuff ([],[]) sigs_and_binds
}
where
- sep_stuff s@(RdrTySig _ _ _ _) (sigs,defs) = (s:sigs,defs)
+ sep_stuff s@(RdrTySig _ _ _) (sigs,defs) = (s:sigs,defs)
sep_stuff s@(RdrSpecValSig _) (sigs,defs) = (s:sigs,defs)
sep_stuff s@(RdrInlineValSig _) (sigs,defs) = (s:sigs,defs)
sep_stuff s@(RdrDeforestSig _) (sigs,defs) = (s:sigs,defs)
sep_stuff d@(RdrPatternBinding _ _) (sigs,defs) = (sigs,d:defs)
-sepDeclsForInterface binding
- = case (sepDecls binding [] [] [] [] [] [] [] [] [])
- of { (tys,tysigs,classes,insts,instsigs,defaults,sigs,iimps,ifixs) ->
- ASSERT ((null defaults)
- && (null tysigs)
- && (null instsigs))
- ASSERT (not (not_all_sigs sigs))
- (tys,classes,insts,sigs,iimps,ifixs)
- }
- where
- not_all_sigs sigs = not (all is_a_sig sigs)
-
- is_a_sig (RdrTySig _ _ _ _) = True
- is_a_sig anything_else = False
\end{code}
%
\section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}
-(Well, really, for specialisations involving @ProtoName@s, even if
+(Well, really, for specialisations involving @RdrName@s, even if
they are used somewhat later on in the compiler...)
\begin{code}
#include "HsVersions.h"
module RdrHsSyn (
- cmpInstanceTypes,
- eqMonoType,
- getMentionedVars,
- getNonPrelOuterTyCon,
- ExportListInfo(..),
- getImportees,
- getExportees,
- getRawImportees,
- getRawExportees,
+ RdrNameArithSeqInfo(..),
+ RdrNameBind(..),
+ RdrNameClassDecl(..),
+ RdrNameClassOpSig(..),
+ RdrNameConDecl(..),
+ RdrNameContext(..),
+ RdrNameSpecDataSig(..),
+ RdrNameDefaultDecl(..),
+ RdrNameFixityDecl(..),
+ RdrNameGRHS(..),
+ RdrNameGRHSsAndBinds(..),
+ RdrNameHsBinds(..),
+ RdrNameHsExpr(..),
+ RdrNameHsModule(..),
+ RdrNameIE(..),
+ RdrNameImportDecl(..),
+ RdrNameInstDecl(..),
+ RdrNameMatch(..),
+ RdrNameMonoBinds(..),
+ RdrNameMonoType(..),
+ RdrNamePat(..),
+ RdrNamePolyType(..),
+ RdrNameQual(..),
+ RdrNameSig(..),
+ RdrNameSpecInstSig(..),
+ RdrNameStmt(..),
+ RdrNameTyDecl(..),
+
+ RdrNameClassOpPragmas(..),
+ RdrNameClassPragmas(..),
+ RdrNameDataPragmas(..),
+ RdrNameGenPragmas(..),
+ RdrNameInstancePragmas(..),
+ RdrNameCoreExpr(..),
- ProtoNameArithSeqInfo(..),
- ProtoNameBind(..),
- ProtoNameClassDecl(..),
- ProtoNameClassOpPragmas(..),
- ProtoNameClassOpSig(..),
- ProtoNameClassPragmas(..),
- ProtoNameConDecl(..),
- ProtoNameContext(..),
- ProtoNameCoreExpr(..),
- ProtoNameDataPragmas(..),
- ProtoNameSpecDataSig(..),
- ProtoNameDefaultDecl(..),
- ProtoNameFixityDecl(..),
- ProtoNameGRHS(..),
- ProtoNameGRHSsAndBinds(..),
- ProtoNameGenPragmas(..),
- ProtoNameHsBinds(..),
- ProtoNameHsExpr(..),
- ProtoNameHsModule(..),
- ProtoNameIE(..),
- ProtoNameImportedInterface(..),
- ProtoNameInstDecl(..),
- ProtoNameInstancePragmas(..),
- ProtoNameInterface(..),
- ProtoNameMatch(..),
- ProtoNameMonoBinds(..),
- ProtoNameMonoType(..),
- ProtoNamePat(..),
- ProtoNamePolyType(..),
- ProtoNameQual(..),
- ProtoNameSig(..),
- ProtoNameSpecInstSig(..),
- ProtoNameStmt(..),
- ProtoNameTyDecl(..),
- ProtoNameUnfoldingCoreExpr(..)
+ getRawImportees,
+ getRawExportees
) where
-import Ubiq{-uitous-}
+import Ubiq
-import Bag ( emptyBag, snocBag, unionBags, listToBag, Bag )
-import FiniteMap ( mkSet, listToFM, emptySet, emptyFM, FiniteSet(..), FiniteMap )
import HsSyn
import Outputable ( ExportFlag(..) )
-import ProtoName ( cmpProtoName, ProtoName(..) )
-import Util ( panic{-ToDo:rm eventually-} )
-\end{code}
-
-\begin{code}
-type ProtoNameArithSeqInfo = ArithSeqInfo Fake Fake ProtoName ProtoNamePat
-type ProtoNameBind = Bind Fake Fake ProtoName ProtoNamePat
-type ProtoNameClassDecl = ClassDecl Fake Fake ProtoName ProtoNamePat
-type ProtoNameClassOpPragmas = ClassOpPragmas ProtoName
-type ProtoNameClassOpSig = Sig ProtoName
-type ProtoNameClassPragmas = ClassPragmas ProtoName
-type ProtoNameConDecl = ConDecl ProtoName
-type ProtoNameContext = Context ProtoName
-type ProtoNameCoreExpr = UnfoldingCoreExpr ProtoName
-type ProtoNameDataPragmas = DataPragmas ProtoName
-type ProtoNameSpecDataSig = SpecDataSig ProtoName
-type ProtoNameDefaultDecl = DefaultDecl ProtoName
-type ProtoNameFixityDecl = FixityDecl ProtoName
-type ProtoNameGRHS = GRHS Fake Fake ProtoName ProtoNamePat
-type ProtoNameGRHSsAndBinds = GRHSsAndBinds Fake Fake ProtoName ProtoNamePat
-type ProtoNameGenPragmas = GenPragmas ProtoName
-type ProtoNameHsBinds = HsBinds Fake Fake ProtoName ProtoNamePat
-type ProtoNameHsExpr = HsExpr Fake Fake ProtoName ProtoNamePat
-type ProtoNameHsModule = HsModule Fake Fake ProtoName ProtoNamePat
-type ProtoNameIE = IE ProtoName
-type ProtoNameImportedInterface = ImportedInterface Fake Fake ProtoName ProtoNamePat
-type ProtoNameInstDecl = InstDecl Fake Fake ProtoName ProtoNamePat
-type ProtoNameInstancePragmas = InstancePragmas ProtoName
-type ProtoNameInterface = Interface Fake Fake ProtoName ProtoNamePat
-type ProtoNameMatch = Match Fake Fake ProtoName ProtoNamePat
-type ProtoNameMonoBinds = MonoBinds Fake Fake ProtoName ProtoNamePat
-type ProtoNameMonoType = MonoType ProtoName
-type ProtoNamePat = InPat ProtoName
-type ProtoNamePolyType = PolyType ProtoName
-type ProtoNameQual = Qual Fake Fake ProtoName ProtoNamePat
-type ProtoNameSig = Sig ProtoName
-type ProtoNameSpecInstSig = SpecInstSig ProtoName
-type ProtoNameStmt = Stmt Fake Fake ProtoName ProtoNamePat
-type ProtoNameTyDecl = TyDecl ProtoName
-type ProtoNameUnfoldingCoreExpr = UnfoldingCoreExpr ProtoName
-\end{code}
-
-\begin{code}
-eqMonoType :: ProtoNameMonoType -> ProtoNameMonoType -> Bool
-
-eqMonoType a b = case (cmpMonoType cmpProtoName a b) of { EQ_ -> True; _ -> False }
-\end{code}
-
-
-@cmpInstanceTypes@ compares two @PolyType@s which are being used as
-``instance types.'' This is used when comparing as-yet-unrenamed
-instance decls to eliminate duplicates. We allow things (e.g.,
-overlapping instances) which standard Haskell doesn't, so we must
-cater for that. Generally speaking, the instance-type
-``shape''-checker in @tcInstDecl@ will catch any mischief later on.
-
-All we do is call @cmpMonoType@, passing it a tyvar-comparing function
-that always claims that tyvars are ``equal;'' the result is that we
-end up comparing the non-tyvar-ish structure of the two types.
-
-\begin{code}
-cmpInstanceTypes :: ProtoNamePolyType -> ProtoNamePolyType -> TAG_
-
-cmpInstanceTypes (HsPreForAllTy _ ty1) (HsPreForAllTy _ ty2)
- = cmpMonoType funny_cmp ty1 ty2 -- Hey! ignore those contexts!
- where
- funny_cmp :: ProtoName -> ProtoName -> TAG_
-
- {- The only case we are really trying to catch
- is when both types are tyvars: which are both
- "Unk"s and names that start w/ a lower-case letter! (Whew.)
- -}
- funny_cmp (Unk u1) (Unk u2)
- | isLower s1 && isLower s2 = EQ_
- where
- s1 = _HEAD_ u1
- s2 = _HEAD_ u2
-
- funny_cmp x y = cmpProtoName x y -- otherwise completely normal
\end{code}
-@getNonPrelOuterTyCon@ is a yukky function required when deciding
-whether to import an instance decl. If the class name or type
-constructor are ``wanted'' then we should import it, otherwise not.
-But the built-in core constructors for lists, tuples and arrows are
-never ``wanted'' in this sense. @getNonPrelOuterTyCon@ catches just a
-user-defined tycon and returns it.
-
\begin{code}
-getNonPrelOuterTyCon :: ProtoNameMonoType -> Maybe ProtoName
-
-getNonPrelOuterTyCon (MonoTyApp con _) = Just con
-getNonPrelOuterTyCon _ = Nothing
+type RdrNameArithSeqInfo = ArithSeqInfo Fake Fake RdrName RdrNamePat
+type RdrNameBind = Bind Fake Fake RdrName RdrNamePat
+type RdrNameClassDecl = ClassDecl Fake Fake RdrName RdrNamePat
+type RdrNameClassOpSig = Sig RdrName
+type RdrNameConDecl = ConDecl RdrName
+type RdrNameContext = Context RdrName
+type RdrNameSpecDataSig = SpecDataSig RdrName
+type RdrNameDefaultDecl = DefaultDecl RdrName
+type RdrNameFixityDecl = FixityDecl RdrName
+type RdrNameGRHS = GRHS Fake Fake RdrName RdrNamePat
+type RdrNameGRHSsAndBinds = GRHSsAndBinds Fake Fake RdrName RdrNamePat
+type RdrNameHsBinds = HsBinds Fake Fake RdrName RdrNamePat
+type RdrNameHsExpr = HsExpr Fake Fake RdrName RdrNamePat
+type RdrNameHsModule = HsModule Fake Fake RdrName RdrNamePat
+type RdrNameIE = IE RdrName
+type RdrNameImportDecl = ImportDecl RdrName
+type RdrNameInstDecl = InstDecl Fake Fake RdrName RdrNamePat
+type RdrNameMatch = Match Fake Fake RdrName RdrNamePat
+type RdrNameMonoBinds = MonoBinds Fake Fake RdrName RdrNamePat
+type RdrNameMonoType = MonoType RdrName
+type RdrNamePat = InPat RdrName
+type RdrNamePolyType = PolyType RdrName
+type RdrNameQual = Qual Fake Fake RdrName RdrNamePat
+type RdrNameSig = Sig RdrName
+type RdrNameSpecInstSig = SpecInstSig RdrName
+type RdrNameStmt = Stmt Fake Fake RdrName RdrNamePat
+type RdrNameTyDecl = TyDecl RdrName
+
+type RdrNameClassOpPragmas = ClassOpPragmas RdrName
+type RdrNameClassPragmas = ClassPragmas RdrName
+type RdrNameDataPragmas = DataPragmas RdrName
+type RdrNameGenPragmas = GenPragmas RdrName
+type RdrNameInstancePragmas = InstancePragmas RdrName
+type RdrNameCoreExpr = UnfoldingCoreExpr RdrName
\end{code}
%************************************************************************
%* *
%************************************************************************
-We want to know what names are exported (the first list of the result)
-and what modules are exported (the second list of the result).
\begin{code}
-type ExportListInfo
- = Maybe -- Nothing => no export list
- ( FiniteMap FAST_STRING ExportFlag,
- -- Assoc list of im/exported things &
- -- their "export" flags (im/exported
- -- abstractly, concretely, etc.)
- -- Hmm... slight misnomer there (WDP 95/02)
- FiniteSet FAST_STRING )
- -- List of modules to be exported
- -- entirely; NB: *not* everything with
- -- original names in these modules;
- -- but: everything that these modules'
- -- interfaces told us about.
- -- Note: This latter component can
- -- only arise on export lists.
-
-getImportees :: [ProtoNameIE] -> FiniteSet FAST_STRING
-getExportees :: Maybe [ProtoNameIE] -> ExportListInfo
-
-getRawImportees :: [ProtoNameIE] -> [FAST_STRING]
-getRawExportees :: Maybe [ProtoNameIE] -> ([(ProtoName, ExportFlag)], [FAST_STRING])
- -- "Raw" gives the raw lists of things; we need this for
- -- checking for duplicates.
-
-getImportees [] = emptySet
-getImportees imps = mkSet (getRawImportees imps)
-
-getExportees Nothing = Nothing
-getExportees exps
- = case (getRawExportees exps) of { (pairs, mods) ->
- Just (panic "RdrHsSyn.getExportees" {-listToFM pairs-}, mkSet mods) }
+getRawImportees :: [RdrNameIE] -> [RdrName]
+getRawExportees :: Maybe [RdrNameIE] -> ([(RdrName, ExportFlag)], [Module])
getRawImportees imps
= foldr do_imp [] imps
where
- do_imp (IEVar (Unk n)) acc = n:acc
- do_imp (IEThingAbs (Unk n)) acc = n:acc
- do_imp (IEThingAll (Unk n)) acc = n:acc
+ do_imp (IEVar n) acc = n:acc
+ do_imp (IEThingAbs n) acc = n:acc
+ do_imp (IEThingWith n _) acc = n:acc
+ do_imp (IEThingAll n) acc = n:acc
getRawExportees Nothing = ([], [])
getRawExportees (Just exps)
do_exp (IEVar n) (prs, mods) = ((n, ExportAll):prs, mods)
do_exp (IEThingAbs n) (prs, mods) = ((n, ExportAbs):prs, mods)
do_exp (IEThingAll n) (prs, mods) = ((n, ExportAll):prs, mods)
+ do_exp (IEThingWith n _) (prs, mods) = ((n, ExportAll):prs, mods)
do_exp (IEModuleContents n) (prs, mods) = (prs, n : mods)
\end{code}
-
-%************************************************************************
-%* *
-\subsection{Collect mentioned variables}
-%* *
-%************************************************************************
-
-This is just a {\em hack} whichs collects, from a module body, all the
-variables that are ``mentioned,'' either as top-level binders or as
-free variables. We can then use this list when walking over
-interfaces, using it to avoid imported variables that are patently of
-no interest.
-
-We have to be careful to look out for \tr{M..} constructs in the
-export list; if so, the game is up (and we must so report).
-
-\begin{code}
-type NameMapper a = FAST_STRING -> Maybe a
- -- For our purposes here, we don't care *what*
- -- they are mapped to; only if the names are
- -- in the mapper
-
-getMentionedVars :: NameMapper any -- a prelude-name lookup function, so
- -- we can avoid recording prelude things
- -- as "mentioned"
- -> Maybe [IE ProtoName]{-exports-} -- All the bits of the module body to
- -> [ProtoNameFixityDecl]-- look in for "mentioned" vars.
- -> [ProtoNameClassDecl]
- -> [ProtoNameInstDecl]
- -> ProtoNameHsBinds
-
- -> (Bool, -- True <=> M.. construct in exports
- Bag FAST_STRING) -- list of vars "mentioned" in the module body
-
-getMentionedVars val_nf exports fixes class_decls inst_decls binds
- = panic "getMentionedVars (RdrHsSyn)"
-{- TO THE END
- = case (mention_IE exports) of { (module_dotdot_seen, export_mentioned) ->
- (module_dotdot_seen,
- initMentioned val_nf export_mentioned (
--- mapMent fixity fixes `thenMent_` -- see note below.
- mapMent classDecl class_decls `thenMent_`
- mapMent instDecl inst_decls `thenMent_`
- bindsDecls True{-top-level-} binds )
- )}
-\end{code}
-ToDo: if we ever do something proper with fixity declarations,
-we will need to create a @fixities@ function and make it do something.
-
-Here's relevant bit of monad fluff: hides carrying around
-the NameMapper function (down only) and passing along an
-accumulator:
-\begin{code}
-type MentionM nm a = NameMapper nm -> Bag FAST_STRING -> Bag FAST_STRING
-
-initMentioned :: NameMapper nm -> Bag FAST_STRING -> MentionM nm a -> Bag FAST_STRING
-thenMent_ :: MentionM nm a -> MentionM nm b -> MentionM nm b
-returnNothing :: MentionM nm a
-mapMent :: (a -> MentionM nm b) -> [a] -> MentionM nm b
-mentionedName :: FAST_STRING -> MentionM nm a
-mentionedNames :: [FAST_STRING] -> MentionM nm a
-lookupAndAdd :: ProtoName -> MentionM nm a
-
-initMentioned val_nf acc action = action val_nf acc
-
-returnNothing val_nf acc = acc
-
-thenMent_ act1 act2 val_nf acc
- = act2 val_nf (act1 val_nf acc)
-
-mapMent f [] = returnNothing
-mapMent f (x:xs)
- = f x `thenMent_`
- mapMent f xs
-
-mentionedName name val_nf acc
- = acc `snocBag` name
-
-mentionedNames names val_nf acc
- = acc `unionBags` listToBag names
-
-lookupAndAdd (Unk str) val_nf acc
- | _LENGTH_ str >= 3 -- simply don't bother w/ very short names...
- = case (val_nf str) of
- Nothing -> acc `snocBag` str
- Just _ -> acc
-
-lookupAndAdd _ _ acc = acc -- carry on with what we had
-\end{code}
-
-\begin{code}
-mention_IE :: [IE ProtoName] -> (Bool, Bag FAST_STRING)
-
-mention_IE exps
- = foldr men (False, emptyBag) exps
- where
- men (IEVar str) (dotdot_seen, so_far) = (dotdot_seen, so_far `snocBag` str)
- men (IEModuleContents _) (_, so_far) = (True, so_far)
- men other_ie acc = acc
-\end{code}
-
-\begin{code}
-classDecl (ClassDecl _ _ _ _ binds _ _) = monoBinds True{-toplev-} binds
-instDecl (InstDecl _ _ binds _ _ _ _ _) = monoBinds True{-toplev-} binds
-\end{code}
-
-\begin{code}
-bindsDecls toplev EmptyBinds = returnNothing
-bindsDecls toplev (ThenBinds a b)= bindsDecls toplev a `thenMent_` bindsDecls toplev b
-bindsDecls toplev (SingleBind a) = bindDecls toplev a
-bindsDecls toplev (BindWith a _) = bindDecls toplev a
-
-bindDecls toplev EmptyBind = returnNothing
-bindDecls toplev (NonRecBind a) = monoBinds toplev a
-bindDecls toplev (RecBind a) = monoBinds toplev a
-
-monoBinds toplev EmptyMonoBinds = returnNothing
-monoBinds toplev (AndMonoBinds a b) = monoBinds toplev a `thenMent_` monoBinds toplev b
-monoBinds toplev (PatMonoBind p gb _)
- = (if toplev
- then mentionedNames (map stringify (collectPatBinders p))
- else returnNothing) `thenMent_`
- grhssAndBinds gb
-
-monoBinds toplev (FunMonoBind v ms _)
- = (if toplev
- then mentionedName (stringify v)
- else returnNothing) `thenMent_`
- mapMent match ms
-
-stringify :: ProtoName -> FAST_STRING
-stringify (Unk s) = s
-\end{code}
-
-\begin{code}
-match (PatMatch _ m) = match m
-match (GRHSMatch gb) = grhssAndBinds gb
-
-grhssAndBinds (GRHSsAndBindsIn gs bs)
- = mapMent grhs gs `thenMent_` bindsDecls False bs
-
-grhs (OtherwiseGRHS e _) = expr e
-grhs (GRHS g e _) = expr g `thenMent_` expr e
-\end{code}
-
-\begin{code}
-expr (HsVar v) = lookupAndAdd v
-
-expr (HsLit _) = returnNothing
-expr (HsLam m) = match m
-expr (HsApp a b) = expr a `thenMent_` expr b
-expr (OpApp a b c) = expr a `thenMent_` expr b `thenMent_` expr c
-expr (SectionL a b) = expr a `thenMent_` expr b
-expr (SectionR a b) = expr a `thenMent_` expr b
-expr (CCall _ es _ _ _) = mapMent expr es
-expr (HsSCC _ e) = expr e
-expr (HsCase e ms _)= expr e `thenMent_` mapMent match ms
-expr (HsLet b e) = expr e `thenMent_` bindsDecls False{-not toplev-} b
-expr (HsDo bs _) = panic "mentioned_whatnot:RdrHsSyn:HsDo"
-expr (ListComp e q) = expr e `thenMent_` mapMent qual q
-expr (ExplicitList es) = mapMent expr es
-expr (ExplicitTuple es) = mapMent expr es
-expr (RecordCon con rbinds) = panic "mentioned:RdrHsSyn:RecordCon"
-expr (RecordUpd aexp rbinds) = panic "mentioned:RdrHsSyn:RecordUpd"
-expr (ExprWithTySig e _) = expr e
-expr (HsIf b t e _) = expr b `thenMent_` expr t `thenMent_` expr e
-expr (ArithSeqIn s) = arithSeq s
-
-arithSeq (From a) = expr a
-arithSeq (FromThen a b) = expr a `thenMent_` expr b
-arithSeq (FromTo a b) = expr a `thenMent_` expr b
-arithSeq (FromThenTo a b c) = expr a `thenMent_` expr b `thenMent_` expr c
-
-qual (GeneratorQual _ e) = expr e
-qual (FilterQual e) = expr e
-qual (LetQual bs) = bindsDecls False{-not toplev-} bs
--}
-\end{code}
+++ /dev/null
-This module breaks the loops among the reader modules
-ReadPragmas and ReadPrefix.
-
-\begin{code}
-interface RdrLoop where
-
-import PreludeStdIO ( Maybe )
-
-import U_list ( U_list )
-import U_maybe ( U_maybe )
-import U_ttype ( U_ttype )
-import UgenUtil ( UgnM(..), ParseTree(..) )
-import ReadPrefix ( rdConDecl, rdMonoType, wlkList, wlkMaybe, wlkMonoType )
-import RdrHsSyn ( ProtoNameMonoType(..), ProtoNameConDecl(..) )
-
-data U_list
-data U_ttype
-
-rdConDecl :: ParseTree -> UgnM ProtoNameConDecl
-rdMonoType :: ParseTree -> UgnM ProtoNameMonoType
-wlkList :: (_Addr -> UgnM a) -> U_list -> UgnM [a]
-wlkMaybe :: (_Addr -> UgnM a) -> U_maybe -> UgnM (Maybe a)
-wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType
-\end{code}
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
-%
-\section{Read pragmatic interface info, including Core}
-
-\begin{code}
-#include "HsVersions.h"
-
-module ReadPragmas (
- ProtoUfBinder(..),
-
- wlkClassPragma,
- wlkDataPragma,
- wlkInstPragma,
- wlkTySigPragmas
- ) where
-
-import Ubiq{-uitous-}
-
-import RdrLoop -- break dependency loop
-
-import UgenAll -- all Yacc parser gumpff...
-import PrefixSyn -- and various syntaxen.
-import HsSyn
-import RdrHsSyn
-import HsPragmas -- NB: we are concerned with grimy
-import HsCore -- *Pragmas and *Core stuff here
-
--- others:
-import CoreUnfold ( UnfoldingGuidance(..) )
-import Id ( mkTupleCon )
-import IdInfo
-import IdUtils ( primOpNameInfo )
-import Literal ( mkMachInt, Literal(..) )
-import Name ( Name(..) )
-import PrelInfo ( nilDataCon )
-import PrimOp ( PrimOp(..), allThePrimOps )
-import PrimRep ( guessPrimRep ) -- really, VERY horrible...
-import ProtoName ( ProtoName(..) )
-import Util ( assertPanic, panic )
-\end{code}
-
-Only used here:
-\begin{code}
-readUnfoldingPrimOp :: FAST_STRING -> PrimOp
-
-readUnfoldingPrimOp
- = let
- -- "reverse" lookup table
- tbl = map (\ o -> let { (str,_) = primOpNameInfo o } in (str, o)) allThePrimOps
- in
- \ str -> case [ op | (s, op) <- tbl, s == str ] of
- (op:_) -> op
-#ifdef DEBUG
- [] -> panic "readUnfoldingPrimOp" -- ++ _UNPK_ str ++"::"++show (map fst tbl))
-#endif
-\end{code}
-
-\begin{code}
-wlkDataPragma :: U_hpragma -> UgnM ProtoNameDataPragmas
-
-wlkDataPragma pragma
- = case pragma of
- U_no_pragma -> returnUgn (DataPragmas [] [])
- U_idata_pragma cs ss ->
- wlkList rdConDecl cs `thenUgn` \ cons ->
- wlkList rd_spec ss `thenUgn` \ specs ->
- returnUgn (DataPragmas cons specs)
- where
- rd_spec pt
- = rdU_hpragma pt `thenUgn` \ stuff ->
- case stuff of { U_idata_pragma_4s ss ->
-
- wlkList rdMonoTypeMaybe ss `thenUgn` \ specs ->
- returnUgn specs }
-\end{code}
-
-\begin{code}
-wlkClassPragma :: U_hpragma -> UgnM ProtoNameClassPragmas
-
-wlkClassPragma pragma
- = case pragma of
- U_no_pragma -> returnUgn NoClassPragmas
- U_iclas_pragma gens ->
- wlkList rdGenPragma gens `thenUgn` \ gen_pragmas ->
- ASSERT(not (null gen_pragmas))
- returnUgn (SuperDictPragmas gen_pragmas)
-\end{code}
-
-\begin{code}
-wlkInstPragma :: U_hpragma -> UgnM ProtoNameInstancePragmas
-
-wlkInstPragma pragma
- = case pragma of
- U_no_pragma ->
- returnUgn NoInstancePragmas
-
- U_iinst_simpl_pragma dfun_gen ->
- wlkGenPragma dfun_gen `thenUgn` \ gen_pragmas ->
- returnUgn (SimpleInstancePragma gen_pragmas)
-
- U_iinst_const_pragma dfun_gen constm_stuff ->
- wlkGenPragma dfun_gen `thenUgn` \ gen_pragma ->
- wlkList rd_constm constm_stuff `thenUgn` \ constm_pragmas ->
- returnUgn (ConstantInstancePragma gen_pragma constm_pragmas)
-
-rd_constm pt
- = rdU_hpragma pt `thenUgn` \ stuff ->
- case stuff of { U_iname_pragma_pr name gen ->
-
- wlkGenPragma gen `thenUgn` \ prag ->
- returnUgn (name, prag) }
-\end{code}
-
-\begin{code}
-rdGenPragma :: ParseTree -> UgnM ProtoNameGenPragmas
-
-rdGenPragma pt = rdU_hpragma pt `thenUgn` \ prag -> wlkGenPragma prag
-
-wlkGenPragma :: U_hpragma -> UgnM ProtoNameGenPragmas
-
-wlkGenPragma pragma
- = case pragma of
- U_no_pragma -> returnUgn noGenPragmas
-
- U_igen_pragma aritee update deforest strct uf speccs ->
- wlk_arity aritee `thenUgn` \ arity ->
- wlk_update update `thenUgn` \ upd ->
- wlk_deforest deforest `thenUgn` \ def ->
- wlk_strict strct `thenUgn` \ strict ->
- wlk_unfold uf `thenUgn` \ unfold ->
- wlkList rd_spec speccs `thenUgn` \ specs ->
- returnUgn (GenPragmas arity upd def strict unfold specs)
- where
- wlk_arity stuff
- = case stuff of
- U_no_pragma -> returnUgn Nothing
- U_iarity_pragma arity ->
- returnUgn (Just arity)
-
- ------------
- wlk_update stuff
- = case stuff of
- U_no_pragma -> returnUgn Nothing
- U_iupdate_pragma upd_spec ->
- returnUgn (Just ((read (_UNPK_ upd_spec))::UpdateInfo))
-
- ------------
- wlk_deforest stuff
- = case stuff of
- U_no_pragma -> returnUgn Don'tDeforest
- U_ideforest_pragma -> returnUgn DoDeforest
-
- ------------
- wlk_unfold stuff
- = case stuff of
- U_no_pragma -> returnUgn NoImpUnfolding
-
- U_imagic_unfolding_pragma magic ->
- returnUgn (ImpMagicUnfolding magic)
-
- U_iunfolding_pragma guide core ->
- wlkGuidance guide `thenUgn` \ guidance ->
- wlkCoreExpr core `thenUgn` \ coresyn ->
- returnUgn (ImpUnfolding guidance coresyn)
-
- ------------
- wlk_strict stuff
- = case stuff of
- U_no_pragma -> returnUgn NoImpStrictness
-
- U_istrictness_pragma strict_spec wrkr_stuff ->
- wlkGenPragma wrkr_stuff `thenUgn` \ wrkr_pragma ->
- let
- strict_spec_str = _UNPK_ strict_spec
- (is_bot, ww_strict_info)
- = if (strict_spec_str == "B")
- then (True, [])
- else (False, (read strict_spec_str)::[Demand])
- in
- returnUgn (ImpStrictness is_bot ww_strict_info wrkr_pragma)
-
- ------------
- rd_spec pt
- = rdU_hpragma pt `thenUgn` \ stuff ->
- case stuff of { U_itype_pragma_pr maybe_tys num_dicts prag ->
-
- wlkList rdMonoTypeMaybe maybe_tys `thenUgn` \ mono_tys_maybe ->
- wlkGenPragma prag `thenUgn` \ gen_prag ->
- returnUgn (mono_tys_maybe, num_dicts, gen_prag) }
-\end{code}
-
-The only tricky case is pragmas on signatures; we have no way of
-knowing whether it is a @GenPragma@ or a @ClassOp@ pragma. So we read
-whatever comes, store it in a @RdrTySigPragmas@ structure, and someone
-will sort it out later.
-\begin{code}
-wlkTySigPragmas :: U_hpragma -> UgnM RdrTySigPragmas
-
-wlkTySigPragmas pragma
- = case pragma of
- U_no_pragma -> returnUgn RdrNoPragma
-
- U_iclasop_pragma dsel defm ->
- wlkGenPragma dsel `thenUgn` \ dsel_pragma ->
- wlkGenPragma defm `thenUgn` \ defm_pragma ->
- returnUgn (RdrClassOpPragmas (ClassOpPragmas dsel_pragma defm_pragma))
-
- other ->
- wlkGenPragma other `thenUgn` \ gen_pragmas ->
- returnUgn (RdrGenPragmas gen_pragmas)
-\end{code}
-
-\begin{code}
-wlkGuidance guide
- = case guide of
- U_iunfold_always -> returnUgn UnfoldAlways
-
- U_iunfold_if_args num_ty_args num_val_args con_arg_spec size ->
- let
- con_arg_info = take num_val_args (map cvt (_UNPK_ con_arg_spec))
- -- if there were 0 args, we want to throw away
- -- any dummy con_arg_spec stuff...
- in
- returnUgn (UnfoldIfGoodArgs num_ty_args num_val_args
- con_arg_info size)
- where
- cvt 'C' = True -- want a constructor in this arg position
- cvt _ = False
-\end{code}
-
-\begin{code}
-wlkCoreExpr :: U_coresyn -> UgnM ProtoNameUnfoldingCoreExpr
-
-wlkCoreExpr core_expr
- = case core_expr of
- U_covar v ->
- wlkCoreId v `thenUgn` \ var ->
- returnUgn (UfVar var)
-
- U_coliteral l ->
- wlkBasicLit l `thenUgn` \ lit ->
- returnUgn (UfLit lit)
-
- U_cocon c ts as ->
- wlkCoreId c `thenUgn` \ (BoringUfId con) ->
- wlkList rdCoreType ts `thenUgn` \ tys ->
- wlkList rdCoreAtom as `thenUgn` \ vs ->
- returnUgn (UfCon con tys vs)
-
- U_coprim o ts as ->
- wlk_primop o `thenUgn` \ op ->
- wlkList rdCoreType ts `thenUgn` \ tys ->
- wlkList rdCoreAtom as `thenUgn` \ vs ->
- let
- fixed_vs = case op of { UfOtherOp pop -> fixup pop vs ; _ -> vs }
- in
- returnUgn (UfPrim op tys fixed_vs)
- where
-
- -- Question: why did ccall once panic if you looked at the
- -- maygc flag? Was this just laziness or is it not needed?
- -- In that case, modify the stuff that writes them to pragmas
- -- so that it never adds the _GC_ tag. ADR
-
- wlk_primop op
- = case op of
- U_co_primop op_str ->
- returnUgn (UfOtherOp (readUnfoldingPrimOp op_str))
-
- U_co_ccall fun_str may_gc a_tys r_ty ->
- wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
- wlkCoreType r_ty `thenUgn` \ res_ty ->
- returnUgn (UfCCallOp fun_str False (is_T_or_F may_gc) arg_tys res_ty)
-
- U_co_casm litlit may_gc a_tys r_ty ->
- wlkBasicLit litlit `thenUgn` \ (MachLitLit casm_str _) ->
- wlkList rdCoreType a_tys `thenUgn` \ arg_tys ->
- wlkCoreType r_ty `thenUgn` \ res_ty ->
- returnUgn (UfCCallOp casm_str True (is_T_or_F may_gc) arg_tys res_ty)
- where
- is_T_or_F 0 = False
- is_T_or_F _ = True
-
- -- Now *this* is a hack: we can't distinguish Int# literals
- -- from Word# literals as they come in; this is only likely
- -- to bite on the args of certain PrimOps (shifts, etc); so
- -- we look for those and fix things up!!! (WDP 95/05)
-
- fixup AndOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup OrOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup NotOp [a1] = [fixarg a1]
- fixup SllOp [a1, a2] = [fixarg a1, a2]
- fixup SraOp [a1, a2] = [fixarg a1, a2]
- fixup SrlOp [a1, a2] = [fixarg a1, a2]
- fixup WordGtOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup WordGeOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup WordLtOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup WordLeOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup WordEqOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup WordNeOp [a1, a2] = [fixarg a1, fixarg a2]
- fixup _ as = as
-
- fixarg (UfCoLitAtom (MachInt i _)) = UfCoLitAtom (MachInt i False{-unsigned-})
- fixarg arg = arg
-
- U_colam vars expr ->
- wlkList rdCoreBinder vars `thenUgn` \ bs ->
- wlkCoreExpr expr `thenUgn` \ body ->
- returnUgn (foldr UfLam body bs)
-
- U_coapp f as ->
- wlkCoreExpr f `thenUgn` \ fun ->
- wlkList rdCoreAtom as `thenUgn` \ args ->
- returnUgn (foldl UfApp fun args)
-
- U_cocase s as ->
- wlkCoreExpr s `thenUgn` \ scrut ->
- wlk_alts as `thenUgn` \ alts ->
- returnUgn (UfCase scrut alts)
- where
- wlk_alts (U_coalg_alts as d)
- = wlkList rd_alg_alt as `thenUgn` \ alts ->
- wlk_deflt d `thenUgn` \ deflt ->
- returnUgn (UfCoAlgAlts alts deflt)
- where
- rd_alg_alt pt
- = rdU_coresyn pt `thenUgn` \ (U_coalg_alt c bs exp) ->
-
- wlkCoreId c `thenUgn` \ (BoringUfId con) ->
- wlkList rdCoreBinder bs `thenUgn` \ params ->
- wlkCoreExpr exp `thenUgn` \ rhs ->
- returnUgn (con, params, rhs)
-
- wlk_alts (U_coprim_alts as d)
- = wlkList rd_prim_alt as `thenUgn` \ alts ->
- wlk_deflt d `thenUgn` \ deflt ->
- returnUgn (UfCoPrimAlts alts deflt)
- where
- rd_prim_alt pt
- = rdU_coresyn pt `thenUgn` \ (U_coprim_alt l exp) ->
-
- wlkBasicLit l `thenUgn` \ lit ->
- wlkCoreExpr exp `thenUgn` \ rhs ->
- returnUgn (lit, rhs)
-
- wlk_deflt U_conodeflt = returnUgn UfCoNoDefault
- wlk_deflt (U_cobinddeflt v exp)
- = wlkCoreBinder v `thenUgn` \ b ->
- wlkCoreExpr exp `thenUgn` \ rhs ->
- returnUgn (UfCoBindDefault b rhs)
-
- U_colet b expr ->
- wlk_bind b `thenUgn` \ bind ->
- wlkCoreExpr expr `thenUgn` \ body ->
- returnUgn (UfLet bind body)
- where
- wlk_bind (U_cononrec v expr)
- = wlkCoreBinder v `thenUgn` \ b ->
- wlkCoreExpr expr `thenUgn` \ rhs ->
- returnUgn (UfCoNonRec b rhs)
-
- wlk_bind (U_corec prs)
- = wlkList rd_pair prs `thenUgn` \ pairs ->
- returnUgn (UfCoRec pairs)
- where
- rd_pair pt
- = rdU_coresyn pt `thenUgn` \ (U_corec_pair v expr) ->
-
- wlkCoreBinder v `thenUgn` \ b ->
- wlkCoreExpr expr `thenUgn` \ rhs ->
- returnUgn (b, rhs)
-
- U_coscc c expr ->
- wlk_cc c `thenUgn` \ cc ->
- wlkCoreExpr expr `thenUgn` \ body ->
- returnUgn (UfSCC cc body)
- where
- wlk_cc (U_co_preludedictscc dupd)
- = wlk_dupd dupd `thenUgn` \ is_dupd ->
- returnUgn (UfPreludeDictsCC is_dupd)
-
- wlk_cc (U_co_alldictscc m g dupd)
- = wlk_dupd dupd `thenUgn` \ is_dupd ->
- returnUgn (UfAllDictsCC m g is_dupd)
-
- wlk_cc (U_co_usercc n m g dupd cafd)
- = wlk_dupd dupd `thenUgn` \ is_dupd ->
- wlk_cafd cafd `thenUgn` \ is_cafd ->
- returnUgn (UfUserCC n m g is_dupd is_cafd)
-
- wlk_cc (U_co_autocc id m g dupd cafd)
- = wlkCoreId id `thenUgn` \ i ->
- wlk_dupd dupd `thenUgn` \ is_dupd ->
- wlk_cafd cafd `thenUgn` \ is_cafd ->
- returnUgn (UfAutoCC i m g is_dupd is_cafd)
-
- wlk_cc (U_co_dictcc id m g dupd cafd)
- = wlkCoreId id `thenUgn` \ i ->
- wlk_dupd dupd `thenUgn` \ is_dupd ->
- wlk_cafd cafd `thenUgn` \ is_cafd ->
- returnUgn (UfDictCC i m g is_dupd is_cafd)
-
- ------
- wlk_cafd U_co_scc_noncaf = returnUgn False
- wlk_cafd U_co_scc_caf = returnUgn True
-
- wlk_dupd U_co_scc_nondupd = returnUgn False
- wlk_dupd U_co_scc_dupd = returnUgn True
-\end{code}
-
-\begin{code}
-type ProtoUfBinder = (ProtoName, PolyType ProtoName)
-
-rdCoreBinder :: ParseTree -> UgnM ProtoUfBinder
-
-rdCoreBinder pt = rdU_coresyn pt `thenUgn` \ x -> wlkCoreBinder x
-
-wlkCoreBinder :: U_coresyn -> UgnM ProtoUfBinder
-
-wlkCoreBinder (U_cobinder b t)
- = wlkCoreType t `thenUgn` \ ty ->
- returnUgn (b, ty)
-
-rdCoreAtom pt
- = rdU_coresyn pt `thenUgn` \ atom ->
- case atom of
- U_colit l ->
- wlkBasicLit l `thenUgn` \ lit ->
- returnUgn (UfCoLitAtom lit)
-
- U_colocal var ->
- wlkCoreId var `thenUgn` \ v ->
- returnUgn (UfCoVarAtom v)
-\end{code}
-
-\begin{code}
-rdCoreType :: ParseTree -> UgnM ProtoNamePolyType
-
-rdCoreType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkCoreType ttype
-
-wlkCoreType :: U_ttype -> UgnM ProtoNamePolyType
-
-wlkCoreType other
- = panic "ReadPragmas:wlkCoreType:ToDo"
-{- LATER:
-wlkCoreType (U_uniforall ts t)
- = wlkList rdU_???unkId ts `thenUgn` \ tvs ->
- wlkMonoType t `thenUgn` \ ty ->
- returnUgn (HsForAllTy tvs ty)
-
-wlkCoreType other
- = wlkMonoType other `thenUgn` \ ty ->
- returnUgn (UnoverloadedTy ty)
--}
-\end{code}
-
-\begin{code}
-rdMonoTypeMaybe pt
- = rdU_maybe pt `thenUgn` \ ty_maybe ->
- wlkMaybe rdMonoType ty_maybe
-\end{code}
-
-\begin{code}
-wlkCoreId :: U_coresyn -> UgnM (UfId ProtoName)
-
-wlkCoreId (U_co_id v)
- = returnUgn (BoringUfId (cvt_IdString v))
-
-wlkCoreId (U_co_orig_id mod nm)
- = returnUgn (BoringUfId (Imp mod nm [mod]{-dubious, but doesn't matter-} nm))
-
-wlkCoreId (U_co_sdselid clas super_clas)
- = returnUgn (SuperDictSelUfId clas super_clas)
-
-wlkCoreId (U_co_classopid clas method)
- = returnUgn (ClassOpUfId clas method)
-
-wlkCoreId (U_co_defmid clas method)
- = returnUgn (DefaultMethodUfId clas method)
-
-wlkCoreId (U_co_dfunid clas t)
- = wlkCoreType t `thenUgn` \ ty ->
- returnUgn (DictFunUfId clas ty)
-
-wlkCoreId (U_co_constmid clas op t)
- = wlkCoreType t `thenUgn` \ ty ->
- returnUgn (ConstMethodUfId clas op ty)
-
-wlkCoreId (U_co_specid id tys)
- = wlkCoreId id `thenUgn` \ unspec ->
- wlkList rdMonoTypeMaybe tys `thenUgn` \ ty_maybes ->
- returnUgn (SpecUfId unspec ty_maybes)
-
-wlkCoreId (U_co_wrkrid un)
- = wlkCoreId un `thenUgn` \ unwrkr ->
- returnUgn (WorkerUfId unwrkr)
-
-------------
-cvt_IdString :: FAST_STRING -> ProtoName
-
-cvt_IdString s
- = if (_HEAD_ s /= '_') then
- boring
- else if (sub_s == SLIT("NIL_")) then
- Prel (WiredInVal nilDataCon)
- else if (sub_s == SLIT("TUP_")) then
- Prel (WiredInVal (mkTupleCon arity))
- else
- boring
- where
- boring = Unk s
- sub_s = _SUBSTR_ s 1 4 -- chars 1--4 (0-origin)
- arity = read (_UNPK_ (_SUBSTR_ s 5 999999))
- -- chars 5 onwards give the arity
-\end{code}
-
-\begin{code}
-wlkBasicLit :: U_literal -> UgnM Literal
-
-wlkBasicLit (U_norepr n d)
- = let
- num = ((read (_UNPK_ n)) :: Integer)
- den = ((read (_UNPK_ d)) :: Integer)
- in
- returnUgn (NoRepRational (num % den))
-
-wlkBasicLit other
- = returnUgn (
- case other of
- U_intprim s -> mkMachInt (as_integer s)
- U_doubleprim s -> MachDouble (as_rational s)
- U_floatprim s -> MachFloat (as_rational s)
- U_charprim s -> MachChar (as_char s)
- U_stringprim s -> MachStr (as_string s)
-
- U_clitlit s k -> MachLitLit (as_string s) (guessPrimRep (_UNPK_ k))
-
- U_norepi s -> NoRepInteger (as_integer s)
- U_noreps s -> NoRepStr (as_string s)
- )
- where
- as_char s = _HEAD_ s
- as_integer s = readInteger (_UNPK_ s)
- as_rational s = _readRational (_UNPK_ s) -- non-std
- as_string s = s
-\end{code}
#include "HsVersions.h"
module ReadPrefix (
- rdModule,
-
- -- used over in ReadPragmas...
- wlkList, wlkMaybe, rdConDecl, wlkMonoType, rdMonoType
+ rdModule
) where
-import Ubiq{-uitous-}
-import RdrLoop -- for paranoia checking
+import Ubiq
import UgenAll -- all Yacc parser gumpff...
import PrefixSyn -- and various syntaxen.
import HsSyn
+import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas )
import RdrHsSyn
+import PrefixToHs
--- friends:
-import ReadPragmas
-import PrefixToHs -- reader utilities
-
--- others:
+import CmdLineOpts ( opt_CompilingPrelude )
+import ErrUtils ( addErrLoc )
import FiniteMap ( elemFM, FiniteMap )
-import MainMonad ( thenMn, MainIO(..) )
+import MainMonad ( writeMn, exitMn, MainIO(..) )
+import Name ( RdrName(..), isConopRdr )
import PprStyle ( PprStyle(..) )
import Pretty
-import ProtoName ( isConopPN, ProtoName(..) )
+import SrcLoc ( SrcLoc )
import Util ( nOfThem, pprError, panic )
\end{code}
\end{code}
\begin{code}
-rdQid :: ParseTree -> UgnM ProtoName
+rdQid :: ParseTree -> UgnM RdrName
rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid
-wlkQid :: U_qid -> UgnM ProtoName
+wlkQid :: U_qid -> UgnM RdrName
wlkQid (U_noqual name)
- = returnUgn (Unk name)
+ = returnUgn (Unqual name)
wlkQid (U_aqual mod name)
- = returnUgn (Qunk mod name)
+ = returnUgn (Qual mod name)
wlkQid (U_gid n name)
- = returnUgn (Unk name)
+ = returnUgn (Unqual name)
+
+cvFlag :: U_long -> Bool
+cvFlag 0 = False
+cvFlag 1 = True
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-rdModule :: MainIO
- (FAST_STRING, -- this module's name
- (FAST_STRING -> Bool, -- a function to chk if <x> is in the export list
- FAST_STRING -> Bool), -- a function to chk if <M> is among the M..
- -- ("dotdot") modules in the export list.
- ProtoNameHsModule) -- the main goods
+rdModule :: MainIO (Module, -- this module's name
+ RdrNameHsModule) -- the main goods
rdModule
= _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser!
let
srcfile = _packCString ``input_filename'' -- What A Great Hack! (TM)
in
- initUgn srcfile (
+ initUgn $
+ rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
+ hmodlist srciface_version srcline) ->
- rdU_tree pt `thenUgn` \ (U_hmodule name himplist hexplist hfixlist hmodlist srcline) ->
+ setSrcFileUgn srcfile $
+ setSrcModUgn modname $
+ mkSrcLocUgn srcline $ \ src_loc ->
+
+ wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
+ wlkList rdImport himplist `thenUgn` \ imports ->
wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
wlkBinding hmodlist `thenUgn` \ binding ->
- wlkList rdImportedInterface himplist `thenUgn` \ imports ->
- wlkMaybe rdEntities hexplist `thenUgn` \ exp_list ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
-
- case sepDeclsForTopBinds binding of {
- (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
- returnUgn (
- name,
- mk_export_list_chker exp_list,
- HsModule name
- exp_list
- imports
- fixities
- tydecls
- tysigs
- classdecls
- instdecls
- instsigs
- defaultdecls
- (cvSepdBinds srcfile cvValSig binds)
- [{-no sigs-}]
- src_loc
- ) } )
- where
- mk_export_list_chker = panic "ReadPrefix:mk_export_list_chker"
-{- LATER:
- mk_export_list_chker exp_list
- = case (getExportees exp_list) of
- Nothing -> ( \ n -> False, \ n -> False ) -- all suspicious
- Just (entity_info, dotdot_modules) ->
- ( \ n -> n `elemFM` entity_info,
- \ n -> n `elemFM` dotdot_modules )
--}
+ case sepDeclsForTopBinds binding of
+ (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
+
+ returnUgn (modname,
+ HsModule modname
+ (case srciface_version of { 0 -> Nothing; n -> Just n })
+ exports
+ imports
+ fixities
+ tydecls
+ tysigs
+ classdecls
+ instdecls
+ instsigs
+ defaultdecls
+ (cvSepdBinds srcfile cvValSig binds)
+ [{-no interface sigs yet-}]
+ src_loc
+ )
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-rdExpr :: ParseTree -> UgnM ProtoNameHsExpr
-rdPat :: ParseTree -> UgnM ProtoNamePat
+rdExpr :: ParseTree -> UgnM RdrNameHsExpr
+rdPat :: ParseTree -> UgnM RdrNamePat
rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree
-wlkExpr :: U_tree -> UgnM ProtoNameHsExpr
-wlkPat :: U_tree -> UgnM ProtoNamePat
+wlkExpr :: U_tree -> UgnM RdrNameHsExpr
+wlkPat :: U_tree -> UgnM RdrNamePat
wlkExpr expr
= case expr of
- U_par expr -> -- parenthesised expr
- wlkExpr expr
+ U_par pexpr -> -- parenthesised expr
+ wlkExpr pexpr `thenUgn` \ expr ->
+ returnUgn (HsPar expr)
U_lsection lsexp lop -> -- left section
wlkExpr lsexp `thenUgn` \ expr ->
returnUgn (HsSCC label expr)
U_lambda lampats lamexpr srcline -> -- lambda expression
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkList rdPat lampats `thenUgn` \ pats ->
wlkExpr lamexpr `thenUgn` \ body ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
returnUgn (
HsLam (foldr PatMatch
(GRHSMatch (GRHSsAndBindsIn
)
U_casee caseexpr casebody srcline -> -- case expression
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkExpr caseexpr `thenUgn` \ expr ->
wlkList rdMatch casebody `thenUgn` \ mats ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
getSrcFileUgn `thenUgn` \ sf ->
let
matches = cvMatches sf True mats
returnUgn (HsCase expr matches src_loc)
U_ife ifpred ifthen ifelse srcline -> -- if expression
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkExpr ifpred `thenUgn` \ e1 ->
wlkExpr ifthen `thenUgn` \ e2 ->
wlkExpr ifelse `thenUgn` \ e3 ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
returnUgn (HsIf e1 e2 e3 src_loc)
U_let letvdefs letvexpr -> -- let expression
in
returnUgn (HsLet binds expr)
- U_doe gdo srcline -> -- do expression
+ U_doe gdo srcline -> -- do expression
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkList rd_stmt gdo `thenUgn` \ stmts ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
returnUgn (HsDo stmts src_loc)
where
rd_stmt pt
= rdU_tree pt `thenUgn` \ bind ->
case bind of
U_doexp exp srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkExpr exp `thenUgn` \ expr ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
returnUgn (ExprStmt expr src_loc)
U_dobind pat exp srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkPat pat `thenUgn` \ patt ->
wlkExpr exp `thenUgn` \ expr ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
returnUgn (BindStmt patt expr src_loc)
U_seqlet seqlet ->
wlkExpr arg2 `thenUgn` \ expr2 ->
returnUgn (OpApp expr1 (HsVar op) expr2)
- U_negate nexp _ _ -> -- prefix negation
+ U_negate nexp -> -- prefix negation
wlkExpr nexp `thenUgn` \ expr ->
- returnUgn (HsApp (HsVar (Unk SLIT("negate"))) expr)
+ returnUgn (NegApp expr)
U_llist llist -> -- explicit list
wlkList rdExpr llist `thenUgn` \ exprs ->
returnUgn (RecordUpd aexp recbinds)
#ifdef DEBUG
- U_hmodule _ _ _ _ _ _ -> error "U_hmodule"
- U_as _ _ -> error "U_as"
- U_lazyp _ -> error "U_lazyp"
- U_wildp -> error "U_wildp"
- U_qual _ _ -> error "U_qual"
- U_guard _ -> error "U_guard"
- U_seqlet _ -> error "U_seqlet"
- U_dobind _ _ _ -> error "U_dobind"
- U_doexp _ _ -> error "U_doexp"
- U_rbind _ _ -> error "U_rbind"
- U_fixop _ _ _ -> error "U_fixop"
+ U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
+ U_as _ _ -> error "U_as"
+ U_lazyp _ -> error "U_lazyp"
+ U_wildp -> error "U_wildp"
+ U_qual _ _ -> error "U_qual"
+ U_guard _ -> error "U_guard"
+ U_seqlet _ -> error "U_seqlet"
+ U_dobind _ _ _ -> error "U_dobind"
+ U_doexp _ _ -> error "U_doexp"
+ U_rbind _ _ -> error "U_rbind"
+ U_fixop _ _ _ -> error "U_fixop"
#endif
rdRbind pt
\begin{code}
wlkPat pat
= case pat of
- U_par pat -> -- parenthesised pattern
- wlkPat pat
+ U_par ppat -> -- parenthesised pattern
+ wlkPat ppat `thenUgn` \ pat ->
+ returnUgn (ParPatIn pat)
U_as avar as_pat -> -- "as" pattern
wlkQid avar `thenUgn` \ var ->
U_wildp -> returnUgn WildPatIn -- wildcard pattern
- --------------------------------------------------------------
- -- now the prefix items that can either be an expression or
- -- pattern, except we know they are *patterns* here.
- --------------------------------------------------------------
- U_negate nexp _ _ -> -- negated pattern: must be a literal
- wlkPat nexp `thenUgn` \ lit_pat ->
- case lit_pat of
- LitPatIn lit -> returnUgn (LitPatIn (negLiteral lit))
- _ -> panic "wlkPat: bad negated pattern!"
-
U_lit lit -> -- literal pattern
wlkLiteral lit `thenUgn` \ lit ->
returnUgn (LitPatIn lit)
U_ident nn -> -- simple identifier
wlkQid nn `thenUgn` \ n ->
returnUgn (
- if isConopPN n
+ if isConopRdr n
then ConPatIn n []
else VarPatIn n
)
U_ap l r -> -- "application": there's a list of patterns lurking here!
wlkPat r `thenUgn` \ rpat ->
collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
- let
- (n, arg_pats)
- = case lpat of
- VarPatIn x -> (x, lpats)
- ConPatIn x [] -> (x, lpats)
- ConOpPatIn x op y -> (op, x:y:lpats)
- _ -> -- sorry about the weedy msg; the parser missed this one
- pprError "ERROR: an illegal `application' of a pattern to another one:"
- (ppInterleave ppSP (map (ppr PprForUser) (lpat:lpats)))
- in
+ (case lpat of
+ VarPatIn x -> returnUgn (x, lpats)
+ ConPatIn x [] -> returnUgn (x, lpats)
+ ConOpPatIn x op y -> returnUgn (op, x:y:lpats)
+ _ -> getSrcLocUgn `thenUgn` \ loc ->
+ let
+ err = addErrLoc loc "Illegal pattern `application'"
+ (\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats)))
+ msg = ppShow 100 (err PprForUser)
+ in
+ ioToUgnM (writeMn stderr msg) `thenUgn` \ _ ->
+ ioToUgnM (exitMn 1) `thenUgn` \ _ ->
+ returnUgn (error "ReadPrefix")
+
+ ) `thenUgn` \ (n, arg_pats) ->
returnUgn (ConPatIn n arg_pats)
where
collect_pats pat acc
wlkPat other `thenUgn` \ pat ->
returnUgn (pat,acc)
- U_infixap fun arg1 arg2 ->
+ U_infixap fun arg1 arg2 -> -- infix pattern
wlkQid fun `thenUgn` \ op ->
wlkPat arg1 `thenUgn` \ pat1 ->
wlkPat arg2 `thenUgn` \ pat2 ->
returnUgn (ConOpPatIn pat1 op pat2)
+ U_negate npat -> -- negated pattern
+ wlkPat npat `thenUgn` \ pat ->
+ returnUgn (NegPatIn pat)
+
U_llist llist -> -- explicit list
wlkList rdPat llist `thenUgn` \ pats ->
returnUgn (ListPatIn pats)
wlkLiteral ulit
= returnUgn (
case ulit of
- U_integer s -> HsInt (as_integer s)
- U_floatr s -> HsFrac (as_rational s)
- U_intprim s -> HsIntPrim (as_integer s)
- U_doubleprim s -> HsDoublePrim (as_rational s)
- U_floatprim s -> HsFloatPrim (as_rational s)
- U_charr s -> HsChar (as_char s)
- U_charprim s -> HsCharPrim (as_char s)
- U_string s -> HsString (as_string s)
- U_stringprim s -> HsStringPrim (as_string s)
- U_clitlit s _ -> HsLitLit (as_string s)
+ U_integer s -> HsInt (as_integer s)
+ U_floatr s -> HsFrac (as_rational s)
+ U_intprim s -> HsIntPrim (as_integer s)
+ U_doubleprim s -> HsDoublePrim (as_rational s)
+ U_floatprim s -> HsFloatPrim (as_rational s)
+ U_charr s -> HsChar (as_char s)
+ U_charprim s -> HsCharPrim (as_char s)
+ U_string s -> HsString (as_string s)
+ U_stringprim s -> HsStringPrim (as_string s)
+ U_clitlit s -> HsLitLit (as_string s)
)
where
as_char s = _HEAD_ s
wlkBinding binding
= case binding of
- U_nullbind -> -- null binding
+ -- null binding
+ U_nullbind ->
returnUgn RdrNullBind
- U_abind a b -> -- "and" binding (just glue, really)
+ -- "and" binding (just glue, really)
+ U_abind a b ->
wlkBinding a `thenUgn` \ binding1 ->
wlkBinding b `thenUgn` \ binding2 ->
returnUgn (RdrAndBindings binding1 binding2)
- U_tbind tctxt ttype tcons tderivs srcline tpragma -> -- "data" declaration
+ -- "data" declaration
+ U_tbind tctxt ttype tcons tderivs srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkContext tctxt `thenUgn` \ ctxt ->
wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
wlkList rdConDecl tcons `thenUgn` \ cons ->
wlkDerivings tderivs `thenUgn` \ derivings ->
- wlkDataPragma tpragma `thenUgn` \ pragmas ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings pragmas src_loc))
+ returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings noDataPragmas src_loc))
- U_ntbind ntctxt nttype ntcon ntderivs srcline ntpragma -> -- "newtype" declaration
+ -- "newtype" declaration
+ U_ntbind ntctxt nttype ntcon ntderivs srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkContext ntctxt `thenUgn` \ ctxt ->
wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
wlkList rdConDecl ntcon `thenUgn` \ con ->
wlkDerivings ntderivs `thenUgn` \ derivings ->
- wlkDataPragma ntpragma `thenUgn` \ pragma ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings pragma src_loc))
+ returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings noDataPragmas src_loc))
- U_nbind nbindid nbindas srcline -> -- "type" declaration
+ -- "type" declaration
+ U_nbind nbindid nbindas srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
wlkMonoType nbindas `thenUgn` \ expansion ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
- U_fbind fbindl srcline -> -- function binding
+ -- function binding
+ U_fbind fbindl srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkList rdMatch fbindl `thenUgn` \ matches ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
returnUgn (RdrFunctionBinding srcline matches)
- U_pbind pbindl srcline -> -- pattern binding
+ -- pattern binding
+ U_pbind pbindl srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkList rdMatch pbindl `thenUgn` \ matches ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
returnUgn (RdrPatternBinding srcline matches)
- U_cbind cbindc cbindid cbindw srcline cpragma -> -- "class" declaration
+ -- "class" declaration
+ U_cbind cbindc cbindid cbindw srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkContext cbindc `thenUgn` \ ctxt ->
wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
wlkBinding cbindw `thenUgn` \ binding ->
- wlkClassPragma cpragma `thenUgn` \ pragma ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
getSrcFileUgn `thenUgn` \ sf ->
let
(class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
final_methods = cvMonoBinds sf class_methods
in
returnUgn (RdrClassDecl
- (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc))
+ (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
- U_ibind from_source orig_mod -- "instance" declaration
- ibindc iclas ibindi ibindw srcline ipragma ->
+ -- "instance" declaration
+ U_ibind ibindc iclas ibindi ibindw srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkContext ibindc `thenUgn` \ ctxt ->
wlkQid iclas `thenUgn` \ clas ->
wlkMonoType ibindi `thenUgn` \ inst_ty ->
wlkBinding ibindw `thenUgn` \ binding ->
- wlkInstPragma ipragma `thenUgn` \ pragma ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ getSrcModUgn `thenUgn` \ modname ->
getSrcFileUgn `thenUgn` \ sf ->
let
- from_here = case from_source of { 0 -> False; 1 -> True }
(ss, bs) = sepDeclsIntoSigsAndBinds binding
binds = cvMonoBinds sf bs
uprags = concat (map cvInstDeclSig ss)
ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
+ maybe_mod = if opt_CompilingPrelude
+ then Nothing
+ else Just modname
in
returnUgn (RdrInstDecl
- (InstDecl clas ctxt_inst_ty binds from_here orig_mod uprags pragma src_loc))
+ (InstDecl clas ctxt_inst_ty binds True maybe_mod uprags noInstancePragmas src_loc))
- U_dbind dbindts srcline -> -- "default" declaration
+ -- "default" declaration
+ U_dbind dbindts srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkList rdMonoType dbindts `thenUgn` \ tys ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
- U_mbind mod mbindimp srcline ->
- -- "import" declaration in an interface
- wlkList rdEntity mbindimp `thenUgn` \ entities ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrIfaceImportDecl (IfaceImportDecl mod entities src_loc))
-
- U_mfbind fixes ->
- -- "infix" declarations in an interface
- wlkList rdFixOp fixes `thenUgn` \ fixities ->
- returnUgn (RdrIfaceFixities fixities)
-
a_sig_we_hope ->
-- signature(-like) things, including user pragmas
wlk_sig_thing a_sig_we_hope
\end{code}
\begin{code}
-wlkDerivings :: U_maybe -> UgnM (Maybe [ProtoName])
+wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
wlkDerivings (U_nothing) = returnUgn Nothing
wlkDerivings (U_just pt)
\end{code}
\begin{code}
-wlk_sig_thing (U_sbind sbindids sbindid srcline spragma) -- type signature
- = wlkList rdQid sbindids `thenUgn` \ vars ->
+ -- type signature
+wlk_sig_thing (U_sbind sbindids sbindid srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rdQid sbindids `thenUgn` \ vars ->
wlkPolyType sbindid `thenUgn` \ poly_ty ->
- wlkTySigPragmas spragma `thenUgn` \ pragma ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- returnUgn (RdrTySig vars poly_ty pragma src_loc)
+ returnUgn (RdrTySig vars poly_ty src_loc)
-wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline) -- value specialisation user-pragma
- = wlkQid uvar `thenUgn` \ var ->
+ -- value specialisation user-pragma
+wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid uvar `thenUgn` \ var ->
wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
| (ty, using_id) <- tys_and_ids ])
where
- rd_ty_and_id :: ParseTree -> UgnM (ProtoNamePolyType, Maybe ProtoName)
+ rd_ty_and_id :: ParseTree -> UgnM (RdrNamePolyType, Maybe RdrName)
rd_ty_and_id pt
= rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
wlkPolyType vspec_ty `thenUgn` \ ty ->
wlkMaybe rdQid vspec_id `thenUgn` \ id_maybe ->
returnUgn(ty, id_maybe)
-wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)-- instance specialisation user-pragma
- = wlkQid iclas `thenUgn` \ clas ->
+ -- instance specialisation user-pragma
+wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid iclas `thenUgn` \ clas ->
wlkMonoType ispec_ty `thenUgn` \ ty ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
-wlk_sig_thing (U_inline_uprag ivar srcline) -- value inlining user-pragma
- = wlkQid ivar `thenUgn` \ var ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ -- data specialisation user-pragma
+wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid itycon `thenUgn` \ tycon ->
+ wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
+ returnUgn (RdrSpecDataSig (SpecDataSig tycon (MonoTyApp tycon tys) src_loc))
+
+ -- value inlining user-pragma
+wlk_sig_thing (U_inline_uprag ivar srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid ivar `thenUgn` \ var ->
returnUgn (RdrInlineValSig (InlineSig var src_loc))
-wlk_sig_thing (U_deforest_uprag ivar srcline) -- "deforest me" user-pragma
- = wlkQid ivar `thenUgn` \ var ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ -- "deforest me" user-pragma
+wlk_sig_thing (U_deforest_uprag ivar srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid ivar `thenUgn` \ var ->
returnUgn (RdrDeforestSig (DeforestSig var src_loc))
-wlk_sig_thing (U_magicuf_uprag ivar str srcline) -- "magic" unfolding user-pragma
- = wlkQid ivar `thenUgn` \ var ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ -- "magic" unfolding user-pragma
+wlk_sig_thing (U_magicuf_uprag ivar str srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid ivar `thenUgn` \ var ->
returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
-
-wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
- = wlkQid itycon `thenUgn` \ tycon ->
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
- wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
- let
- spec_ty = MonoTyApp tycon tys
- in
- returnUgn (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc))
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-rdPolyType :: ParseTree -> UgnM ProtoNamePolyType
-rdMonoType :: ParseTree -> UgnM ProtoNameMonoType
+rdPolyType :: ParseTree -> UgnM RdrNamePolyType
+rdMonoType :: ParseTree -> UgnM RdrNameMonoType
rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
-wlkPolyType :: U_ttype -> UgnM ProtoNamePolyType
-wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType
+wlkPolyType :: U_ttype -> UgnM RdrNamePolyType
+wlkMonoType :: U_ttype -> UgnM RdrNameMonoType
wlkPolyType ttype
= case ttype of
-{-LATER:
- U_uniforall utvs uty -> -- forall type (pragmas)
- wlkList rdU_unkId utvs `thenUgn` \ tvs ->
- wlkMonoType uty `thenUgn` \ ty ->
- returnUgn (HsForAllTy tvs ty)
--}
-
U_context tcontextl tcontextt -> -- context
wlkContext tcontextl `thenUgn` \ ctxt ->
wlkMonoType tcontextt `thenUgn` \ ty ->
wlkMonoType ttype
= case ttype of
- U_namedtvar tyvar -> -- type variable
+ U_namedtvar tv -> -- type variable
+ wlkQid tv `thenUgn` \ tyvar ->
returnUgn (MonoTyVar tyvar)
U_tname tcon -> -- type constructor
where
collect t acc
= case t of
- U_tapp t1 t2 -> wlkMonoType t2 `thenUgn` \ ty2 ->
- collect t1 (ty2:acc)
- U_tname tcon -> wlkQid tcon `thenUgn` \ tycon ->
- returnUgn (tycon, acc)
- U_namedtvar tv -> returnUgn (tv, acc)
+ U_tapp t1 t2 -> wlkMonoType t2 `thenUgn` \ ty2 ->
+ collect t1 (ty2:acc)
+ U_tname tcon -> wlkQid tcon `thenUgn` \ tycon ->
+ returnUgn (tycon, acc)
+ U_namedtvar tv -> wlkQid tv `thenUgn` \ tyvar ->
+ returnUgn (tyvar, acc)
U_tllist _ -> panic "tlist"
U_ttuple _ -> panic "ttuple"
U_tfun _ _ -> panic "tfun"
- U_tbang _ -> panic "tbang"
+ U_tbang _ -> panic "tbang"
U_context _ _ -> panic "context"
_ -> panic "something else"
wlkMonoType targ `thenUgn` \ ty2 ->
returnUgn (MonoFunTy ty1 ty2)
- U_unidict uclas t -> -- DictTy (pragmas)
- wlkQid uclas `thenUgn` \ clas ->
- wlkMonoType t `thenUgn` \ ty ->
- returnUgn (MonoDictTy clas ty)
\end{code}
\begin{code}
-wlkTyConAndTyVars :: U_ttype -> UgnM (ProtoName, [ProtoName])
-wlkContext :: U_list -> UgnM ProtoNameContext
-wlkClassAssertTy :: U_ttype -> UgnM (ProtoName, ProtoName)
+wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [RdrName])
+wlkContext :: U_list -> UgnM RdrNameContext
+wlkClassAssertTy :: U_ttype -> UgnM (RdrName, RdrName)
wlkTyConAndTyVars ttype
= wlkMonoType ttype `thenUgn` \ (MonoTyApp tycon ty_args) ->
= wlkMonoType xs `thenUgn` \ mono_ty ->
returnUgn (mk_class_assertion mono_ty)
-mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
+mk_class_assertion :: RdrNameMonoType -> (RdrName, RdrName)
mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
mk_class_assertion other
\end{code}
\begin{code}
-rdConDecl :: ParseTree -> UgnM ProtoNameConDecl
+rdConDecl :: ParseTree -> UgnM RdrNameConDecl
rdConDecl pt
= rdU_constr pt `thenUgn` \ blah ->
wlkConDecl blah
-wlkConDecl :: U_constr -> UgnM ProtoNameConDecl
+wlkConDecl :: U_constr -> UgnM RdrNameConDecl
wlkConDecl (U_constrpre ccon ctys srcline)
- = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ = mkSrcLocUgn srcline $ \ src_loc ->
wlkQid ccon `thenUgn` \ con ->
wlkList rdBangType ctys `thenUgn` \ tys ->
returnUgn (ConDecl con tys src_loc)
wlkConDecl (U_constrinf cty1 cop cty2 srcline)
- = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ = mkSrcLocUgn srcline $ \ src_loc ->
wlkBangType cty1 `thenUgn` \ ty1 ->
wlkQid cop `thenUgn` \ op ->
wlkBangType cty2 `thenUgn` \ ty2 ->
returnUgn (ConOpDecl ty1 op ty2 src_loc)
wlkConDecl (U_constrnew ccon cty srcline)
- = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ = mkSrcLocUgn srcline $ \ src_loc ->
wlkQid ccon `thenUgn` \ con ->
wlkMonoType cty `thenUgn` \ ty ->
returnUgn (NewConDecl con ty src_loc)
wlkConDecl (U_constrrec ccon cfields srcline)
- = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+ = mkSrcLocUgn srcline $ \ src_loc ->
wlkQid ccon `thenUgn` \ con ->
wlkList rd_field cfields `thenUgn` \ fields_lists ->
returnUgn (RecConDecl con fields_lists src_loc)
where
- rd_field :: ParseTree -> UgnM ([ProtoName], BangType ProtoName)
+ rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
rd_field pt
= rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
wlkList rdQid fvars `thenUgn` \ vars ->
-----------------
rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
-wlkBangType :: U_ttype -> UgnM (BangType ProtoName)
+wlkBangType :: U_ttype -> UgnM (BangType RdrName)
wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> returnUgn (Banged ty)
wlkBangType uty = wlkMonoType uty `thenUgn` \ ty -> returnUgn (Unbanged ty)
rdMatch pt
= rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
-
- wlkPat gpat `thenUgn` \ pat ->
- wlkBinding gbind `thenUgn` \ binding ->
- wlkQid gsrcfun `thenUgn` \ srcfun ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkPat gpat `thenUgn` \ pat ->
+ wlkBinding gbind `thenUgn` \ binding ->
+ wlkQid gsrcfun `thenUgn` \ srcfun ->
let
wlk_guards (U_pnoguards exp)
= wlkExpr exp `thenUgn` \ expr ->
%************************************************************************
\begin{code}
-rdFixOp :: ParseTree -> UgnM ProtoNameFixityDecl
+rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
rdFixOp pt
= rdU_tree pt `thenUgn` \ fix ->
case fix of
- U_fixop op (-1) prec -> returnUgn (InfixL op prec)
- U_fixop op 0 prec -> returnUgn (InfixN op prec)
- U_fixop op 1 prec -> returnUgn (InfixR op prec)
+ U_fixop op (-1) prec -> wlkQid op `thenUgn` \ op ->
+ returnUgn (InfixL op prec)
+ U_fixop op 0 prec -> wlkQid op `thenUgn` \ op ->
+ returnUgn (InfixN op prec)
+ U_fixop op 1 prec -> wlkQid op `thenUgn` \ op ->
+ returnUgn (InfixR op prec)
_ -> error "ReadPrefix:rdFixOp"
\end{code}
%************************************************************************
%* *
-\subsection[rdImportedInterface]{Read an imported interface}
+\subsection[rdImport]{Read an import decl}
%* *
%************************************************************************
\begin{code}
-rdImportedInterface :: ParseTree
- -> UgnM ProtoNameImportedInterface
-
-rdImportedInterface pt
- = rdU_binding pt
- `thenUgn` \ (U_import ifname iffile binddef imod iqual ias ispec srcline) ->
+rdImport :: ParseTree
+ -> UgnM RdrNameImportDecl
- mkSrcLocUgn srcline `thenUgn` \ src_loc ->
+rdImport pt
+ = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec srcline) ->
+ mkSrcLocUgn srcline $ \ src_loc ->
wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
-
- setSrcFileUgn iffile ( -- looking inside the .hi file...
- wlkBinding binddef
- ) `thenUgn` \ iface_bs ->
-
- case (sepDeclsForInterface iface_bs) of {
- (tydecls,classdecls,instdecls,sigs,iimpdecls,ifixities) ->
- let
- cv_sigs = concat (map cvValSig sigs)
-
- cv_iface = Interface ifname iimpdecls ifixities
- tydecls classdecls instdecls cv_sigs
- src_loc
-
- cv_qual = case iqual of {0 -> False; 1 -> True}
- in
- returnUgn (ImportMod cv_iface cv_qual maybe_as maybe_spec)
- }
+ returnUgn (ImportDecl imod (cvFlag iqual) maybe_as maybe_spec src_loc)
where
rd_spec pt = rdU_either pt `thenUgn` \ spec ->
case spec of
= rdU_list pt `thenUgn` \ list ->
wlkList rdEntity list
-rdEntity :: ParseTree -> UgnM (IE ProtoName)
+rdEntity :: ParseTree -> UgnM (IE RdrName)
rdEntity pt
= rdU_entidt pt `thenUgn` \ entity ->
module Rename ( renameModule ) where
-import Ubiq{-uitous-}
+import PreludeGlaST ( thenPrimIO, returnPrimIO, fixPrimIO, newVar, MutableVar(..) )
+
+import Ubiq
import HsSyn
-import RdrHsSyn ( ProtoNameHsModule(..) )
-import RnHsSyn ( RenamedHsModule(..) )
-
-import Bag ( isEmptyBag, unionBags )
-import CmdLineOpts ( opt_UseGetMentionedVars )
-import ErrUtils ( Error(..) )
-import Pretty ( Pretty(..){-ToDo:rm?-} )
-import RnMonad12 ( initRn12 )
-import RnMonad4 ( initRn4 )
-import RnPass1
-import RnPass2
-import RnPass3
-import RnPass4
-import RnUtils ( PreludeNameMappers(..), GlobalNameMappers(..) )
+import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) )
+import RnHsSyn ( RnName, RenamedHsModule(..), isRnTyCon, isRnClass )
+
+import RnMonad
+import RnNames ( getGlobalNames, GlobalNameInfo(..) )
+import RnSource ( rnSource )
+import RnIfaces ( rnInterfaces, finalIfaceInfo, VersionInfo(..), ParsedIface )
+import RnUtils ( extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
+import MainMonad
+
+import Bag ( isEmptyBag, unionBags, bagToList, listToBag )
+import ErrUtils ( Error(..), Warning(..) )
+import FiniteMap ( emptyFM, eltsFM )
+import Name ( Name, RdrName(..) )
+import Outputable ( getOrigNameRdr, isLocallyDefined )
+import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
+import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
import UniqSupply ( splitUniqSupply )
-import Util ( panic )
-\end{code}
+import Util ( panic, assertPanic )
-Here's what the renamer does, basically:
-\begin{description}
-\item[@RnPass1@:]
-Flattens out the declarations from the interfaces which this module
-imports. The result is a new module with no imports, but with more
-declarations. (Obviously, the imported declarations have ``funny
-names'' [@ProtoNames@] to indicate their origin.) Handles selective
-import, renaming, \& such.
-
-%--------------------------------------------------------------------
-\item[@RnPass2@:]
-Removes duplicate declarations. Duplicates can arise when two
-imported interface have a signature (or whatever) for the same
-thing. We check that the two are consistent and then drop one.
-Considerable huff and puff to pick the one with the ``better''
-pragmatic information.
-
-%--------------------------------------------------------------------
-\item[@RnPass3@:]
-Find all the top-level-ish (i.e., global) entities, assign them
-@Uniques@, and make a \tr{ProtoName -> Name} mapping for them,
-in preparation for...
-
-%--------------------------------------------------------------------
-\item[@RnPass4@:]
-Actually prepare the ``renamed'' module. In sticking @Names@ on
-everything, it will catch out-of-scope errors (and a couple of similar
-type-variable-use errors). We also our initial dependency analysis of
-the program (required before typechecking).
-\end{description}
+findHiFiles :: PrimIO (FiniteMap Module FAST_STRING)
+findHiFiles = returnPrimIO emptyFM
+\end{code}
\begin{code}
-renameModule :: PreludeNameMappers -- lookup funs for deeply wired-in names
- -> ProtoNameHsModule -- input
+renameModule :: BuiltinNames
+ -> BuiltinKeys
-> UniqSupply
- -> (RenamedHsModule, -- output, after renaming
- Bag FAST_STRING, -- Names of the imported modules
- -- (profiling needs to know this)
- GlobalNameMappers, -- final name funs; used later
- -- to rename generated `deriving'
- -- bindings.
- Bag Error -- Errors, from passes 1-4
+ -> RdrNameHsModule
+
+ -> MainIO
+ (
+ RenamedHsModule, -- output, after renaming
+ [Module], -- imported modules; for profiling
+
+ VersionInfo, -- version info; for usage
+ [Module], -- instance modules; for iface
+
+ Bag Error,
+ Bag Warning
)
+\end{code}
--- Very space-leak sensitive
+ToDo: May want to arrange to return old interface for this module!
+ToDo: Return OrigName RnEnv to rename derivings etc with.
+ToDo: Builtin names which must be read.
+ToDo: Deal with instances (instance version, this module on instance list ???)
-renameModule gnfs@(val_pnf, tc_pnf)
- input@(HsModule mod_name _ _ _ _ _ _ _ _ _ _ _ _)
- uniqs
- = let
- use_mentioned_vars = opt_UseGetMentionedVars
- in
- case (initRn12 mod_name (rnModule1 gnfs use_mentioned_vars input))
- of { ((mod1, imported_module_names), errs1) ->
+\begin{code}
+renameModule b_names b_keys us
+ input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
+ = findHiFiles `thenPrimIO` \ hi_files ->
+ newVar (emptyFM, hi_files) `thenPrimIO` \ iface_var ->
- case (initRn12 mod_name (rnModule2 mod1)) of { (mod2, errs2) ->
+ fixPrimIO ( \ (_, _, _, _, rec_occ_fm, rec_export_fn) ->
+ let
+ rec_occ_fn :: Name -> [RdrName]
+ rec_occ_fn n = case lookupUFM rec_occ_fm n of
+ Nothing -> []
+ Just (rn,occs) -> occs
- case (splitUniqSupply uniqs) of { (us1, us2) ->
+ global_name_info = (b_names, b_keys, rec_export_fn, rec_occ_fn)
+ in
+ getGlobalNames iface_var global_name_info us1 input
+ `thenPrimIO` \ (occ_env, imp_mods, imp_fixes, top_errs, top_warns) ->
- case (initRn3 (rnModule3 gnfs imported_module_names mod2) us1)
- of { (val_space, tc_space, v_gnf, tc_gnf, errs3) ->
+ if not (isEmptyBag top_errs) then
+ returnPrimIO (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic)
+ else
+
+ -- No top-level name errors so rename source ...
+ case initRn True mod occ_env us2
+ (rnSource imp_mods imp_fixes input) of {
+ ((rn_module, export_fn, src_occs), src_errs, src_warns) ->
let
- final_name_funs = (v_gnf, tc_gnf)
+ occ_fm :: UniqFM (RnName, [RdrName])
+
+ occ_list = [ (rn,(rn,[occ])) | (rn,occ) <- bagToList src_occs]
+ occ_fm = addListToUFM_C insert_occ emptyUFM occ_list
- errs_so_far = errs1 `unionBags` errs2 `unionBags` errs3
- -- see note below about why we consult errs at this pt
+ insert_occ (rn,olds) (rn',[new]) = (rn, insert new olds)
+
+ insert new [] = [new]
+ insert new xxs@(x:xs) = case cmp new x of LT_ -> new : xxs
+ EQ_ -> xxs
+ GT__ -> x : insert new xs
+
+ occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm))
+ multiple_occs (rn, (o1:o2:_)) = True
+ multiple_occs _ = False
in
- if not (isEmptyBag errs_so_far) then -- give up now
- ( panic "rename", imported_module_names, final_name_funs, errs_so_far )
+ returnPrimIO (rn_module, imp_mods,
+ top_errs `unionBags` src_errs,
+ top_warns `unionBags` src_warns `unionBags` listToBag occ_warns,
+ occ_fm, export_fn)
+
+ }) `thenPrimIO` \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) ->
+
+ if not (isEmptyBag errs_so_far) then
+ returnMn (rn_panic, rn_panic, rn_panic, rn_panic,
+ errs_so_far, warns_so_far)
else
- case (initRn4 final_name_funs (rnModule mod2) us2)
- of { (mod4, errs4) ->
- ( mod4, imported_module_names, final_name_funs, errs4 ) }
- }}}}
-\end{code}
+ -- No errors renaming source so rename the interfaces ...
+ let
+ imports_used = [ rn | (rn,_) <- eltsUFM occ_fm, not (isLocallyDefined rn) ]
+ (import_tcs, import_vals) = partition (\ rn -> isRnTyCon rn || isRnClass rn) imports_used
+
+ (orig_env, orig_dups) = extendGlobalRnEnv emptyRnEnv (map pair_orig import_vals)
+ (map pair_orig import_tcs)
+ pair_orig rn = (getOrigNameRdr rn, rn)
-Why stop if errors in the first three passes: Suppose you're compiling
-a module with a top-level definition named \tr{scaleFloat}. Sadly,
-this is also a Prelude class-method name. \tr{rnModule3} will have
-detected this error, but: it will also have picked (arbitrarily) one
-of the two definitions for its final ``value'' name-function. If, by
-chance, it should have picked the class-method... when it comes to pin
-a Unique on the top-level (bogus) \tr{scaleFloat}, it will ask for the
-class-method's Unique (!); it doesn't have one, and you will get a
-panic.
-
-Another way to handle this would be for the duplicate detector to
-clobber duplicates with some ``safe'' value. Then things would be
-fine in \tr{rnModule}. Maybe some other time...
+ -- ToDo: Do we need top-level names from this module in orig_env ???
+ in
+ ASSERT (isEmptyBag orig_dups)
+ rnInterfaces iface_var orig_env us3 rn_module imports_used
+ `thenPrimIO` \ (rn_module_with_imports,
+ (implicit_val_fm, implicit_tc_fm),
+ iface_errs, iface_warns) ->
+ let
+ all_imports_used = imports_used ++ eltsFM implicit_tc_fm ++ eltsFM implicit_val_fm
+ in
+ finalIfaceInfo iface_var all_imports_used imp_mods
+ `thenPrimIO` \ (version_info, instance_mods) ->
+
+ returnMn (rn_module_with_imports, imp_mods,
+ version_info, instance_mods,
+ errs_so_far `unionBags` iface_errs,
+ warns_so_far `unionBags` iface_warns)
+
+ where
+ rn_panic = panic "renameModule: aborted with errors"
+
+ (us1, us') = splitUniqSupply us
+ (us2, us3) = splitUniqSupply us'
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnBinds]{Renaming and dependency analysis of bindings}
+
+This module does renaming and dependency analysis on value bindings in
+the abstract syntax. It does {\em not} do cycle-checks on class or
+type-synonym declarations; those cannot be done at this stage because
+they may be affected by renaming (which isn't fully worked out yet).
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnBinds (
+ rnTopBinds,
+ rnMethodBinds,
+ rnBinds,
+ FreeVars(..),
+ DefinedVars(..)
+ ) where
+
+import Ubiq
+import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops
+
+import HsSyn
+import HsPragmas ( isNoGenPragmas, noGenPragmas )
+import RdrHsSyn
+import RnHsSyn
+import RnMonad
+import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat )
+
+import CmdLineOpts ( opt_SigsRequired )
+import Digraph ( stronglyConnComp )
+import ErrUtils ( addErrLoc, addShortErrLocLine )
+import Name ( RdrName )
+import Maybes ( catMaybes )
+import Pretty
+import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
+ unionUniqSets, unionManyUniqSets,
+ elementOfUniqSet, uniqSetToList, UniqSet(..) )
+import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic )
+\end{code}
+
+-- ToDo: Put the annotations into the monad, so that they arrive in the proper
+-- place and can be used when complaining.
+
+The code tree received by the function @rnBinds@ contains definitions
+in where-clauses which are all apparently mutually recursive, but which may
+not really depend upon each other. For example, in the top level program
+\begin{verbatim}
+f x = y where a = x
+ y = x
+\end{verbatim}
+the definitions of @a@ and @y@ do not depend on each other at all.
+Unfortunately, the typechecker cannot always check such definitions.
+\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
+definitions. In Proceedings of the International Symposium on Programming,
+Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
+However, the typechecker usually can check definitions in which only the
+strongly connected components have been collected into recursive bindings.
+This is precisely what the function @rnBinds@ does.
+
+ToDo: deal with case where a single monobinds binds the same variable
+twice.
+
+Sets of variable names are represented as sets explicitly, rather than lists.
+
+\begin{code}
+type DefinedVars = UniqSet RnName
+type FreeVars = UniqSet RnName
+\end{code}
+
+i.e., binders.
+
+The vertag tag is a unique @Int@; the tags only need to be unique
+within one @MonoBinds@, so that unique-Int plumbing is done explicitly
+(heavy monad machinery not needed).
+
+\begin{code}
+type VertexTag = Int
+type Cycle = [VertexTag]
+type Edge = (VertexTag, VertexTag)
+\end{code}
+
+%************************************************************************
+%* *
+%* naming conventions *
+%* *
+%************************************************************************
+\subsection[name-conventions]{Name conventions}
+
+The basic algorithm involves walking over the tree and returning a tuple
+containing the new tree plus its free variables. Some functions, such
+as those walking polymorphic bindings (HsBinds) and qualifier lists in
+list comprehensions (@Quals@), return the variables bound in local
+environments. These are then used to calculate the free variables of the
+expression evaluated in these environments.
+
+Conventions for variable names are as follows:
+\begin{itemize}
+\item
+new code is given a prime to distinguish it from the old.
+
+\item
+a set of variables defined in @Exp@ is written @dvExp@
+
+\item
+a set of variables free in @Exp@ is written @fvExp@
+\end{itemize}
+
+%************************************************************************
+%* *
+%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *
+%* *
+%************************************************************************
+\subsubsection[dep-HsBinds]{Polymorphic bindings}
+
+Non-recursive expressions are reconstructed without any changes at top
+level, although their component expressions may have to be altered.
+However, non-recursive expressions are currently not expected as
+\Haskell{} programs, and this code should not be executed.
+
+Monomorphic bindings contain information that is returned in a tuple
+(a @FlatMonoBindsInfo@) containing:
+
+\begin{enumerate}
+\item
+a unique @Int@ that serves as the ``vertex tag'' for this binding.
+
+\item
+the name of a function or the names in a pattern. These are a set
+referred to as @dvLhs@, the defined variables of the left hand side.
+
+\item
+the free variables of the body. These are referred to as @fvBody@.
+
+\item
+the definition's actual code. This is referred to as just @code@.
+\end{enumerate}
+
+The function @nonRecDvFv@ returns two sets of variables. The first is
+the set of variables defined in the set of monomorphic bindings, while the
+second is the set of free variables in those bindings.
+
+The set of variables defined in a non-recursive binding is just the
+union of all of them, as @union@ removes duplicates. However, the
+free variables in each successive set of cumulative bindings is the
+union of those in the previous set plus those of the newest binding after
+the defined variables of the previous set have been removed.
+
+@rnMethodBinds@ deals only with the declarations in class and
+instance declarations. It expects only to see @FunMonoBind@s, and
+it expects the global environment to contain bindings for the binders
+(which are all class operations).
+
+\begin{code}
+rnTopBinds :: RdrNameHsBinds -> RnM_Fixes s RenamedHsBinds
+rnMethodBinds :: RnName{-class-} -> RdrNameMonoBinds -> RnM_Fixes s RenamedMonoBinds
+rnBinds :: RdrNameHsBinds -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName])
+
+rnTopBinds EmptyBinds = returnRn EmptyBinds
+rnTopBinds (SingleBind (RecBind bind)) = rnTopMonoBinds bind []
+rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs
+ -- the parser doesn't produce other forms
+
+-- ********************************************************************
+
+rnMethodBinds class_name EmptyMonoBinds = returnRn EmptyMonoBinds
+
+rnMethodBinds class_name (AndMonoBinds mb1 mb2)
+ = andRn AndMonoBinds (rnMethodBinds class_name mb1)
+ (rnMethodBinds class_name mb2)
+
+rnMethodBinds class_name (FunMonoBind occname matches locn)
+ = pushSrcLocRn locn $
+ lookupClassOp class_name occname `thenRn` \ op_name ->
+ mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
+ returnRn (FunMonoBind op_name new_matches locn)
+
+rnMethodBinds class_name (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
+ = pushSrcLocRn locn $
+ lookupClassOp class_name occname `thenRn` \ op_name ->
+ rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
+ returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
+
+-- Can't handle method pattern-bindings which bind multiple methods.
+rnMethodBinds _ mbind@(PatMonoBind other_pat _ locn)
+ = failButContinueRn EmptyMonoBinds (methodBindErr mbind locn)
+
+-- ********************************************************************
+
+rnBinds EmptyBinds = returnRn (EmptyBinds,emptyUniqSet,[])
+rnBinds (SingleBind (RecBind bind)) = rnNestedMonoBinds bind []
+rnBinds (BindWith (RecBind bind) sigs) = rnNestedMonoBinds bind sigs
+ -- the parser doesn't produce other forms
+\end{code}
+
+@rnNestedMonoBinds@
+ - collects up the binders for this declaration group,
+ - checkes that they form a set
+ - extends the environment to bind them to new local names
+ - calls @rnMonoBinds@ to do the real work
+
+In contrast, @rnTopMonoBinds@ doesn't extend the environment, because that's
+already done in pass3. All it does is call @rnMonoBinds@ and discards
+the free var info.
+
+\begin{code}
+rnTopMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] -> RnM_Fixes s RenamedHsBinds
+
+rnTopMonoBinds EmptyMonoBinds sigs = returnRn EmptyBinds
+
+rnTopMonoBinds mbs sigs
+ = rnBindSigs True{-top-level-} (collectMonoBinders mbs) sigs `thenRn` \ siglist ->
+ rnMonoBinds mbs siglist `thenRn` \ (new_binds, fv_set) ->
+ returnRn new_binds
+
+
+rnNestedMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
+ -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName])
+
+rnNestedMonoBinds EmptyMonoBinds sigs
+ = returnRn (EmptyBinds, emptyUniqSet, [])
+
+rnNestedMonoBinds mbinds sigs -- Non-empty monobinds
+ =
+ -- Extract all the binders in this group,
+ -- and extend current scope, inventing new names for the new binders
+ -- This also checks that the names form a set
+ let
+ mbinders_w_srclocs = collectMonoBindersAndLocs mbinds
+ mbinders = map fst mbinders_w_srclocs
+ in
+ newLocalNames "variable"
+ mbinders_w_srclocs `thenRn` \ new_mbinders ->
+
+ extendSS2 new_mbinders (
+ rnBindSigs False{-not top- level-} mbinders sigs `thenRn` \ siglist ->
+ rnMonoBinds mbinds siglist
+ ) `thenRn` \ (new_binds, fv_set) ->
+ returnRn (new_binds, fv_set, new_mbinders)
+\end{code}
+
+@rnMonoBinds@ is used by *both* top-level and nested bindings. It
+assumes that all variables bound in this group are already in scope.
+This is done *either* by pass 3 (for the top-level bindings),
+*or* by @rnNestedMonoBinds@ (for the nested ones).
+
+\begin{code}
+rnMonoBinds :: RdrNameMonoBinds
+ -> [RenamedSig] -- Signatures attached to this group
+ -> RnM_Fixes s (RenamedHsBinds, FreeVars)
+
+rnMonoBinds mbinds siglist
+ =
+ -- Rename the bindings, returning a MonoBindsInfo
+ -- which is a list of indivisible vertices so far as
+ -- the strongly-connected-components (SCC) analysis is concerned
+ flattenMonoBinds 0 siglist mbinds `thenRn` \ (_, mbinds_info) ->
+
+ -- Do the SCC analysis
+ let vertices = mkVertices mbinds_info
+ edges = mkEdges vertices mbinds_info
+
+ scc_result = stronglyConnComp (==) edges vertices
+
+ -- Deal with bound and free-var calculation
+ rhs_free_vars = foldr f emptyUniqSet mbinds_info
+
+ final_binds = reconstructRec scc_result edges mbinds_info
+
+ happy_answer = returnRn (final_binds, rhs_free_vars)
+ in
+ case (inline_sigs_in_recursive_binds final_binds) of
+ Nothing -> happy_answer
+ Just names_n_locns ->
+-- SLPJ: sometimes want recursive INLINE for worker wrapper style stuff
+-- addErrRn (inlineInRecursiveBindsErr names_n_locns) `thenRn_`
+ {-not so-}happy_answer
+ where
+ f :: (a,b, FreeVars, c,d) -> FreeVars -> FreeVars
+
+ f (_, _, fvs_body, _, _) fvs_sofar = fvs_sofar `unionUniqSets` fvs_body
+
+ inline_sigs_in_recursive_binds (BindWith (RecBind _) sigs)
+ = case [(n, locn) | (InlineSig n locn) <- sigs ] of
+ [] -> Nothing
+ sigh ->
+#if OMIT_DEFORESTER
+ Just sigh
+#else
+ -- Allow INLINEd recursive functions if they are
+ -- designated DEFORESTable too.
+ case [(n, locn) | (DeforestSig n locn) <- sigs ] of
+ [] -> Just sigh
+ sigh -> Nothing
+#endif
+
+ inline_sigs_in_recursive_binds (ThenBinds b1 b2)
+ = case (inline_sigs_in_recursive_binds b1) of
+ Nothing -> inline_sigs_in_recursive_binds b2
+ Just x -> Just x -- NB: won't report error(s) in b2
+
+ inline_sigs_in_recursive_binds anything_else = Nothing
+\end{code}
+
+@flattenMonoBinds@ is ever-so-slightly magical in that it sticks
+unique ``vertex tags'' on its output; minor plumbing required.
+
+\begin{code}
+flattenMonoBinds :: Int -- Next free vertex tag
+ -> [RenamedSig] -- Signatures
+ -> RdrNameMonoBinds
+ -> RnM_Fixes s (Int, FlatMonoBindsInfo)
+
+flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, [])
+
+flattenMonoBinds uniq sigs (AndMonoBinds mB1 mB2)
+ = flattenMonoBinds uniq sigs mB1 `thenRn` \ (uniq1, flat1) ->
+ flattenMonoBinds uniq1 sigs mB2 `thenRn` \ (uniq2, flat2) ->
+ returnRn (uniq2, flat1 ++ flat2)
+
+flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
+ = pushSrcLocRn locn $
+ rnPat pat `thenRn` \ pat' ->
+ rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
+
+ -- Find which things are bound in this group
+ let
+ names_bound_here = collectPatBinders pat'
+
+ sigs_etc_for_here = foldl (sig_for_here (\ n -> n `is_elem` names_bound_here))
+ [] sigs
+
+ sigs_fvs = foldr sig_fv emptyUniqSet sigs_etc_for_here
+
+ is_elem = isIn "flattenMonoBinds"
+ in
+ returnRn (
+ uniq + 1,
+ [(uniq,
+ mkUniqSet names_bound_here,
+ fvs `unionUniqSets` sigs_fvs,
+ PatMonoBind pat' grhss_and_binds' locn,
+ sigs_etc_for_here
+ )]
+ )
+
+flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
+ = pushSrcLocRn locn $
+ lookupValue name `thenRn` \ name' ->
+ mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
+ let
+ fvs = unionManyUniqSets fv_lists
+
+ sigs_for_me = foldl (sig_for_here (\ n -> n == name')) [] sigs
+
+ sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me
+ in
+ returnRn (
+ uniq + 1,
+ [(uniq,
+ unitUniqSet name',
+ fvs `unionUniqSets` sigs_fvs,
+ FunMonoBind name' new_matches locn,
+ sigs_for_me
+ )]
+ )
+\end{code}
+
+Grab type-signatures/user-pragmas of interest:
+\begin{code}
+sig_for_here want_me acc s@(Sig n _ _ _) | want_me n = s:acc
+sig_for_here want_me acc s@(InlineSig n _) | want_me n = s:acc
+sig_for_here want_me acc s@(DeforestSig n _) | want_me n = s:acc
+sig_for_here want_me acc s@(SpecSig n _ _ _) | want_me n = s:acc
+sig_for_here want_me acc s@(MagicUnfoldingSig n _ _)
+ | want_me n = s:acc
+sig_for_here want_me acc other_wise = acc
+
+-- 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
+
+sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionUniqSets` unitUniqSet blah
+sig_fv _ acc = acc
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[reconstruct-deps]{Reconstructing dependencies}
+%* *
+%************************************************************************
+
+This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
+as the two cases are similar.
+
+\begin{code}
+reconstructRec :: [Cycle] -- Result of SCC analysis; at least one
+ -> [Edge] -- Original edges
+ -> FlatMonoBindsInfo
+ -> RenamedHsBinds
+
+reconstructRec cycles edges mbi
+ = foldr1 ThenBinds (map (reconstructCycle mbi) cycles)
+ where
+ reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds
+
+ reconstructCycle mbi2 cycle
+ = BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
+ _TO_ relevant_binds_and_sigs ->
+
+ BIND (unzip relevant_binds_and_sigs) _TO_ (binds, sig_lists) ->
+
+ BIND (foldr AndMonoBinds EmptyMonoBinds binds) _TO_ this_gp_binds ->
+ let
+ this_gp_sigs = foldr1 (++) sig_lists
+ have_sigs = not (null sig_lists)
+ -- ToDo: this might not be the right
+ -- thing to call this predicate;
+ -- e.g. "have_sigs [[], [], []]" ???????????
+ in
+ mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) have_sigs
+ BEND BEND BEND
+ where
+ is_elem = isIn "reconstructRec"
+
+ mk_binds :: RenamedMonoBinds -> [RenamedSig]
+ -> Bool -> Bool -> RenamedHsBinds
+
+ mk_binds bs ss True False = SingleBind (RecBind bs)
+ mk_binds bs ss True True{-have sigs-} = BindWith (RecBind bs) ss
+ mk_binds bs ss False False = SingleBind (NonRecBind bs)
+ mk_binds bs ss False True{-have sigs-} = BindWith (NonRecBind bs) ss
+
+ -- moved from Digraph, as this is the only use here
+ -- (avoid overloading cost). We have to use elem
+ -- (not FiniteMaps or whatever), because there may be
+ -- many edges out of one vertex. We give it its own
+ -- "elem" just for speed.
+
+ isCyclic es [] = panic "isCyclic: empty component"
+ isCyclic es [v] = (v,v) `elem` es
+ isCyclic es vs = True
+
+ elem _ [] = False
+ elem x (y:ys) = x==y || elem x ys
+\end{code}
+
+%************************************************************************
+%* *
+%* Manipulating FlatMonoBindInfo *
+%* *
+%************************************************************************
+
+During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
+The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
+a function binding, and has itself been dependency-analysed and
+renamed.
+
+\begin{code}
+type FlatMonoBindsInfo
+ = [(VertexTag, -- Identifies the vertex
+ UniqSet RnName, -- Set of names defined in this vertex
+ UniqSet RnName, -- Set of names used in this vertex
+ RenamedMonoBinds, -- Binding for this vertex (always just one binding, either fun or pat)
+ [RenamedSig]) -- Signatures, if any, for this vertex
+ ]
+
+mkVertices :: FlatMonoBindsInfo -> [VertexTag]
+mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
+
+mkEdges :: [VertexTag] -> FlatMonoBindsInfo -> [Edge]
+
+mkEdges vertices flat_info
+ -- An edge (v,v') indicates that v depends on v'
+ = [ (source_vertex, target_vertex)
+ | (source_vertex, _, used_names, _, _) <- flat_info,
+ target_name <- uniqSetToList used_names,
+ target_vertex <- vertices_defining target_name flat_info
+ ]
+ where
+ -- If each name only has one binding in this group, then
+ -- vertices_defining will always return the empty list, or a
+ -- singleton. The case when there is more than one binding (an
+ -- error) needs more thought.
+
+ vertices_defining name flat_info2
+ = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2,
+ name `elementOfUniqSet` names_defined
+ ]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
+%* *
+%************************************************************************
+
+@rnBindSigs@ checks for: (a)~more than one sig for one thing;
+(b)~signatures given for things not bound here; (c)~with suitably
+flaggery, that all top-level things have type signatures.
+
+\begin{code}
+rnBindSigs :: Bool -- True <=> top-level binders
+ -> [RdrName] -- Binders for this decl group
+ -> [RdrNameSig]
+ -> RnM_Fixes s [RenamedSig] -- List of Sig constructors
+
+rnBindSigs is_toplev binder_occnames sigs
+ =
+ -- Rename the signatures
+ -- Will complain about sigs for variables not in this group
+ mapRn rename_sig sigs `thenRn` \ sigs_maybe ->
+ let
+ sigs' = catMaybes sigs_maybe
+
+ -- Discard unbound ones we've already complained about, so we
+ -- complain about duplicate ones.
+
+ (goodies, dups) = removeDups compare (filter not_unbound sigs')
+ in
+ mapRn (addErrRn . dupSigDeclErr) dups `thenRn_`
+
+ getSrcLocRn `thenRn` \ locn ->
+
+ (if (is_toplev && opt_SigsRequired) then
+ let
+ sig_frees = catMaybes (map (sig_free sigs) binder_occnames)
+ in
+ mapRn (addErrRn . missingSigErr locn) sig_frees
+ else
+ returnRn []
+ ) `thenRn_`
+
+ returnRn sigs' -- bad ones and all:
+ -- we need bindings of *some* sort for every name
+ where
+ rename_sig (Sig v ty pragmas src_loc)
+ = pushSrcLocRn src_loc $
+ if not (v `elem` binder_occnames) then
+ addErrRn (unknownSigDeclErr "type signature" v src_loc) `thenRn_`
+ returnRn Nothing
+ else
+ lookupValue v `thenRn` \ new_v ->
+ rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
+
+ ASSERT(isNoGenPragmas pragmas)
+ returnRn (Just (Sig new_v new_ty noGenPragmas src_loc))
+
+ -- and now, the various flavours of value-modifying user-pragmas:
+
+ rename_sig (SpecSig v ty using src_loc)
+ = pushSrcLocRn src_loc $
+ if not (v `elem` binder_occnames) then
+ addErrRn (unknownSigDeclErr "SPECIALIZE pragma" v src_loc) `thenRn_`
+ returnRn Nothing
+ else
+ lookupValue v `thenRn` \ new_v ->
+ rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
+ rn_using using `thenRn` \ new_using ->
+ returnRn (Just (SpecSig new_v new_ty new_using src_loc))
+ where
+ rn_using Nothing = returnRn Nothing
+ rn_using (Just x) = lookupValue x `thenRn` \ new_x ->
+ returnRn (Just new_x)
+
+ rename_sig (InlineSig v src_loc)
+ = pushSrcLocRn src_loc $
+ if not (v `elem` binder_occnames) then
+ addErrRn (unknownSigDeclErr "INLINE pragma" v src_loc) `thenRn_`
+ returnRn Nothing
+ else
+ lookupValue v `thenRn` \ new_v ->
+ returnRn (Just (InlineSig new_v src_loc))
+
+ rename_sig (DeforestSig v src_loc)
+ = pushSrcLocRn src_loc $
+ if not (v `elem` binder_occnames) then
+ addErrRn (unknownSigDeclErr "DEFOREST pragma" v src_loc) `thenRn_`
+ returnRn Nothing
+ else
+ lookupValue v `thenRn` \ new_v ->
+ returnRn (Just (DeforestSig new_v src_loc))
+
+ rename_sig (MagicUnfoldingSig v str src_loc)
+ = pushSrcLocRn src_loc $
+ if not (v `elem` binder_occnames) then
+ addErrRn (unknownSigDeclErr "MAGIC_UNFOLDING pragma" v src_loc) `thenRn_`
+ returnRn Nothing
+ else
+ lookupValue v `thenRn` \ new_v ->
+ returnRn (Just (MagicUnfoldingSig new_v str src_loc))
+
+ not_unbound :: RenamedSig -> Bool
+
+ not_unbound (Sig n _ _ _) = not (isRnUnbound n)
+ not_unbound (SpecSig n _ _ _) = not (isRnUnbound n)
+ not_unbound (InlineSig n _) = not (isRnUnbound n)
+ not_unbound (DeforestSig n _) = not (isRnUnbound n)
+ not_unbound (MagicUnfoldingSig n _ _) = not (isRnUnbound n)
+
+ -------------------------------------
+ sig_free :: [RdrNameSig] -> RdrName -> Maybe RdrName
+ -- Return "Just x" if "x" has no type signature in
+ -- sigs. Nothing, otherwise.
+
+ sig_free [] ny = Just ny
+ sig_free (Sig nx _ _ _ : rest) ny
+ = if (nx == ny) then Nothing else sig_free rest ny
+ sig_free (_ : rest) ny = sig_free rest ny
+
+ -------------------------------------
+ compare :: RenamedSig -> RenamedSig -> TAG_
+ compare (Sig n1 _ _ _) (Sig n2 _ _ _) = n1 `cmp` n2
+ compare (InlineSig n1 _) (InlineSig n2 _) = n1 `cmp` n2
+ compare (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
+ compare (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
+ = -- may have many specialisations for one value;
+ -- but not ones that are exactly the same...
+ thenCmp (n1 `cmp` n2) (cmpPolyType cmp ty1 ty2)
+
+ compare other_1 other_2 -- tags *must* be different
+ = let tag1 = tag other_1
+ tag2 = tag other_2
+ in
+ if tag1 _LT_ tag2 then LT_ else GT_
+
+ tag (Sig n1 _ _ _) = (ILIT(1) :: FAST_INT)
+ tag (SpecSig n1 _ _ _) = ILIT(2)
+ tag (InlineSig n1 _) = ILIT(3)
+ tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
+ tag (DeforestSig n1 _) = ILIT(5)
+ tag _ = panic# "tag(RnBinds)"
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Error messages}
+%* *
+%************************************************************************
+
+\begin{code}
+dupSigDeclErr sigs
+ = let
+ undup_sigs = fst (removeDups cmp_sig sigs)
+ in
+ addErrLoc locn1
+ ("more than one "++what_it_is++"\n\thas been given for these variables") ( \ sty ->
+ ppAboves (map (ppr sty) undup_sigs) )
+ where
+ (what_it_is, locn1)
+ = case (head sigs) of
+ Sig _ _ _ loc -> ("type signature",loc)
+ ClassOpSig _ _ _ loc -> ("class-method type signature", loc)
+ SpecSig _ _ _ loc -> ("SPECIALIZE pragma",loc)
+ InlineSig _ loc -> ("INLINE pragma",loc)
+ MagicUnfoldingSig _ _ loc -> ("MAGIC_UNFOLDING pragma",loc)
+
+ cmp_sig a b = get_name a `cmp` get_name b
+
+ get_name (Sig n _ _ _) = n
+ get_name (ClassOpSig n _ _ _) = n
+ get_name (SpecSig n _ _ _) = n
+ get_name (InlineSig n _) = n
+ get_name (MagicUnfoldingSig n _ _) = n
+
+------------------------
+methodBindErr mbind locn
+ = addErrLoc locn "Can't handle multiple methods defined by one pattern binding"
+ (\ sty -> ppr sty mbind)
+
+--------------------------
+missingSigErr locn var
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr "a definition but no type signature for `",
+ ppr sty var,
+ ppStr "'."])
+
+--------------------------------
+unknownSigDeclErr flavor var locn
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr flavor, ppStr " but no definition for `",
+ ppr sty var,
+ ppStr "'."])
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnExpr]{Renaming of expressions}
+
+Basically dependency analysis.
+
+Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qual@ datatypes. In
+general, all of these functions return a renamed thing, and a set of
+free variables.
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnExpr (
+ rnMatch, rnGRHSsAndBinds, rnPat
+ ) where
+
+import Ubiq
+import RnLoop -- break the RnPass4/RnExpr4/RnBinds4 loops
+
+import HsSyn
+import RdrHsSyn
+import RnHsSyn
+import RnMonad
+
+import ErrUtils ( addErrLoc )
+import Name ( isLocallyDefinedName, Name, RdrName )
+import Outputable ( pprOp )
+import Pretty
+import UniqFM ( lookupUFM )
+import UniqSet ( emptyUniqSet, unitUniqSet,
+ unionUniqSets, unionManyUniqSets,
+ UniqSet(..) )
+import Util ( Ord3(..), panic )
+\end{code}
+
+
+*********************************************************
+* *
+\subsection{Patterns}
+* *
+*********************************************************
+
+\begin{code}
+rnPat :: RdrNamePat -> RnM_Fixes s RenamedPat
+
+rnPat WildPatIn = returnRn WildPatIn
+
+rnPat (VarPatIn name)
+ = lookupValue name `thenRn` \ vname ->
+ returnRn (VarPatIn vname)
+
+rnPat (LitPatIn n) = returnRn (LitPatIn n)
+
+rnPat (LazyPatIn pat)
+ = rnPat pat `thenRn` \ pat' ->
+ returnRn (LazyPatIn pat')
+
+rnPat (AsPatIn name pat)
+ = rnPat pat `thenRn` \ pat' ->
+ lookupValue name `thenRn` \ vname ->
+ returnRn (AsPatIn vname pat')
+
+rnPat (ConPatIn name pats)
+ = lookupValue name `thenRn` \ name' ->
+ mapRn rnPat pats `thenRn` \ patslist ->
+ returnRn (ConPatIn name' patslist)
+
+rnPat (ConOpPatIn pat1 name pat2)
+ = lookupValue name `thenRn` \ name' ->
+ rnPat pat1 `thenRn` \ pat1' ->
+ rnPat pat2 `thenRn` \ pat2' ->
+ precParsePat (ConOpPatIn pat1' name' pat2')
+
+rnPat neg@(NegPatIn pat)
+ = getSrcLocRn `thenRn` \ src_loc ->
+ addErrIfRn (not (is_lit pat)) (negPatErr neg src_loc)
+ `thenRn_`
+ rnPat pat `thenRn` \ pat' ->
+ returnRn (NegPatIn pat')
+ where
+ is_lit (LitPatIn _) = True
+ is_lit _ = False
+
+rnPat (ParPatIn pat)
+ = rnPat pat `thenRn` \ pat' ->
+ returnRn (ParPatIn pat')
+
+rnPat (ListPatIn pats)
+ = mapRn rnPat pats `thenRn` \ patslist ->
+ returnRn (ListPatIn patslist)
+
+rnPat (TuplePatIn pats)
+ = mapRn rnPat pats `thenRn` \ patslist ->
+ returnRn (TuplePatIn patslist)
+
+rnPat (RecPatIn con rpats)
+ = panic "rnPat:RecPatIn"
+
+\end{code}
+
+************************************************************************
+* *
+\subsection{Match}
+* *
+************************************************************************
+
+\begin{code}
+rnMatch :: RdrNameMatch -> RnM_Fixes s (RenamedMatch, FreeVars)
+
+rnMatch match
+ = getSrcLocRn `thenRn` \ src_loc ->
+ newLocalNames "variable in pattern"
+ (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
+ extendSS2 new_binders (rnMatch_aux match)
+ where
+ binders = collect_binders match
+
+ collect_binders :: RdrNameMatch -> [RdrName]
+
+ collect_binders (GRHSMatch _) = []
+ collect_binders (PatMatch pat match)
+ = collectPatBinders pat ++ collect_binders match
+
+rnMatch_aux (PatMatch pat match)
+ = rnPat pat `thenRn` \ pat' ->
+ rnMatch_aux match `thenRn` \ (match', fvMatch) ->
+ returnRn (PatMatch pat' match', fvMatch)
+
+rnMatch_aux (GRHSMatch grhss_and_binds)
+ = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
+ returnRn (GRHSMatch grhss_and_binds', fvs)
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
+%* *
+%************************************************************************
+
+\begin{code}
+rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnM_Fixes s (RenamedGRHSsAndBinds, FreeVars)
+
+rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
+ = rnBinds binds `thenRn` \ (binds', fvBinds, scope) ->
+ extendSS2 scope (rnGRHSs grhss) `thenRn` \ (grhss', fvGRHS) ->
+ returnRn (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS)
+ where
+ rnGRHSs [] = returnRn ([], emptyUniqSet)
+
+ rnGRHSs (grhs:grhss)
+ = rnGRHS grhs `thenRn` \ (grhs', fvs) ->
+ rnGRHSs grhss `thenRn` \ (grhss', fvss) ->
+ returnRn (grhs' : grhss', fvs `unionUniqSets` fvss)
+
+ rnGRHS (GRHS guard expr locn)
+ = pushSrcLocRn locn $
+ rnExpr guard `thenRn` \ (guard', fvsg) ->
+ rnExpr expr `thenRn` \ (expr', fvse) ->
+ returnRn (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse)
+
+ rnGRHS (OtherwiseGRHS expr locn)
+ = pushSrcLocRn locn $
+ rnExpr expr `thenRn` \ (expr', fvs) ->
+ returnRn (OtherwiseGRHS expr' locn, fvs)
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Expressions}
+%* *
+%************************************************************************
+
+\begin{code}
+rnExprs :: [RdrNameHsExpr] -> RnM_Fixes s ([RenamedHsExpr], FreeVars)
+
+rnExprs [] = returnRn ([], emptyUniqSet)
+
+rnExprs (expr:exprs)
+ = rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ rnExprs exprs `thenRn` \ (exprs', fvExprs) ->
+ returnRn (expr':exprs', fvExpr `unionUniqSets` fvExprs)
+\end{code}
+
+Variables. We look up the variable and return the resulting name. The
+interesting question is what the free-variable set should be. We
+don't want to return imported or prelude things as free vars. So we
+look at the RnName returned from the lookup, and make it part of the
+free-var set iff if it's a LocallyDefined RnName.
+
+ToDo: what about RnClassOps ???
+\end{itemize}
+
+\begin{code}
+rnExpr :: RdrNameHsExpr -> RnM_Fixes s (RenamedHsExpr, FreeVars)
+
+rnExpr (HsVar v)
+ = lookupValue v `thenRn` \ vname ->
+ returnRn (HsVar vname, fv_set vname)
+ where
+ fv_set vname@(RnName n)
+ | isLocallyDefinedName n = unitUniqSet vname
+ | otherwise = emptyUniqSet
+
+rnExpr (HsLit lit)
+ = returnRn (HsLit lit, emptyUniqSet)
+
+rnExpr (HsLam match)
+ = rnMatch match `thenRn` \ (match', fvMatch) ->
+ returnRn (HsLam match', fvMatch)
+
+rnExpr (HsApp fun arg)
+ = rnExpr fun `thenRn` \ (fun',fvFun) ->
+ rnExpr arg `thenRn` \ (arg',fvArg) ->
+ returnRn (HsApp fun' arg', fvFun `unionUniqSets` fvArg)
+
+rnExpr (OpApp e1 op e2)
+ = rnExpr e1 `thenRn` \ (e1', fvs_e1) ->
+ rnExpr op `thenRn` \ (op', fvs_op) ->
+ rnExpr e2 `thenRn` \ (e2', fvs_e2) ->
+ precParseExpr (OpApp e1' op' e2') `thenRn` \ exp ->
+ returnRn (exp, (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
+
+rnExpr (NegApp e)
+ = rnExpr e `thenRn` \ (e', fvs_e) ->
+ returnRn (NegApp e', fvs_e)
+
+rnExpr (HsPar e)
+ = rnExpr e `thenRn` \ (e', fvs_e) ->
+ returnRn (HsPar e', fvs_e)
+
+rnExpr (SectionL expr op)
+ = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
+ rnExpr op `thenRn` \ (op', fvs_op) ->
+ returnRn (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr)
+
+rnExpr (SectionR op expr)
+ = rnExpr op `thenRn` \ (op', fvs_op) ->
+ rnExpr expr `thenRn` \ (expr', fvs_expr) ->
+ returnRn (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr)
+
+rnExpr (CCall fun args may_gc is_casm fake_result_ty)
+ = rnExprs args `thenRn` \ (args', fvs_args) ->
+ returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
+
+rnExpr (HsSCC label expr)
+ = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
+ returnRn (HsSCC label expr', fvs_expr)
+
+rnExpr (HsCase expr ms src_loc)
+ = pushSrcLocRn src_loc $
+ rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
+ mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
+ returnRn (HsCase new_expr new_ms src_loc, unionManyUniqSets (e_fvs : ms_fvs))
+
+rnExpr (HsLet binds expr)
+ = rnBinds binds `thenRn` \ (binds', fvBinds, new_binders) ->
+ extendSS2 new_binders (rnExpr expr) `thenRn` \ (expr',fvExpr) ->
+ returnRn (HsLet binds' expr', fvBinds `unionUniqSets` fvExpr)
+
+rnExpr (HsDo stmts src_loc)
+ = pushSrcLocRn src_loc $
+ rnStmts stmts `thenRn` \ (stmts', fvStmts) ->
+ returnRn (HsDo stmts' src_loc, fvStmts)
+
+rnExpr (ListComp expr quals)
+ = rnQuals quals `thenRn` \ ((quals', qual_binders), fvQuals) ->
+ extendSS2 qual_binders (rnExpr expr) `thenRn` \ (expr', fvExpr) ->
+ returnRn (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals)
+
+rnExpr (ExplicitList exps)
+ = rnExprs exps `thenRn` \ (exps', fvs) ->
+ returnRn (ExplicitList exps', fvs)
+
+rnExpr (ExplicitTuple exps)
+ = rnExprs exps `thenRn` \ (exps', fvExps) ->
+ returnRn (ExplicitTuple exps', fvExps)
+
+rnExpr (RecordCon con rbinds)
+ = panic "rnExpr:RecordCon"
+rnExpr (RecordUpd exp rbinds)
+ = panic "rnExpr:RecordUpd"
+
+rnExpr (ExprWithTySig expr pty)
+ = rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ rnPolyType nullTyVarNamesEnv pty `thenRn` \ pty' ->
+ returnRn (ExprWithTySig expr' pty', fvExpr)
+
+rnExpr (HsIf p b1 b2 src_loc)
+ = pushSrcLocRn src_loc $
+ rnExpr p `thenRn` \ (p', fvP) ->
+ rnExpr b1 `thenRn` \ (b1', fvB1) ->
+ rnExpr b2 `thenRn` \ (b2', fvB2) ->
+ returnRn (HsIf p' b1' b2' src_loc, unionManyUniqSets [fvP, fvB1, fvB2])
+
+rnExpr (ArithSeqIn seq)
+ = rn_seq seq `thenRn` \ (new_seq, fvs) ->
+ returnRn (ArithSeqIn new_seq, fvs)
+ where
+ rn_seq (From expr)
+ = rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ returnRn (From expr', fvExpr)
+
+ rn_seq (FromThen expr1 expr2)
+ = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
+ returnRn (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
+
+ rn_seq (FromTo expr1 expr2)
+ = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
+ returnRn (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
+
+ rn_seq (FromThenTo expr1 expr2 expr3)
+ = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
+ rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
+ rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
+ returnRn (FromThenTo expr1' expr2' expr3',
+ unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{@Qual@s: in list comprehensions}
+%* *
+%************************************************************************
+
+Note that although some bound vars may appear in the free var set for
+the first qual, these will eventually be removed by the caller. For
+example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
+@[q <- r, p <- q]@, the free var set for @q <- r@ will
+be @{r}@, and the free var set for the entire Quals will be @{r}@. This
+@r@ will be removed only when we finally return from examining all the
+Quals.
+
+\begin{code}
+rnQuals :: [RdrNameQual]
+ -> RnM_Fixes s (([RenamedQual], -- renamed qualifiers
+ [RnName]), -- qualifiers' binders
+ FreeVars) -- free variables
+
+rnQuals [qual] -- must be at least one qual
+ = rnQual qual `thenRn` \ ((new_qual, bs), fvs) ->
+ returnRn (([new_qual], bs), fvs)
+
+rnQuals (qual: quals)
+ = rnQual qual `thenRn` \ ((qual', bs1), fvQuals1) ->
+ extendSS2 bs1 (rnQuals quals) `thenRn` \ ((quals', bs2), fvQuals2) ->
+ returnRn
+ ((qual' : quals', bs2 ++ bs1), -- The ones on the right (bs2) shadow the
+ -- ones on the left (bs1)
+ fvQuals1 `unionUniqSets` fvQuals2)
+
+rnQual (GeneratorQual pat expr)
+ = rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ let
+ binders = collectPatBinders pat
+ in
+ getSrcLocRn `thenRn` \ src_loc ->
+ newLocalNames "variable in list-comprehension-generator pattern"
+ (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
+ extendSS new_binders (rnPat pat) `thenRn` \ pat' ->
+
+ returnRn ((GeneratorQual pat' expr', new_binders), fvExpr)
+
+rnQual (FilterQual expr)
+ = rnExpr expr `thenRn` \ (expr', fvs) ->
+ returnRn ((FilterQual expr', []), fvs)
+
+rnQual (LetQual binds)
+ = rnBinds binds `thenRn` \ (binds', binds_fvs, new_binders) ->
+ returnRn ((LetQual binds', new_binders), binds_fvs)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{@Stmt@s: in @do@ expressions}
+%* *
+%************************************************************************
+
+\begin{code}
+rnStmts :: [RdrNameStmt] -> RnM_Fixes s ([RenamedStmt], FreeVars)
+
+rnStmts [stmt@(ExprStmt _ _)] -- last stmt must be ExprStmt
+ = rnStmt stmt `thenRn` \ ((stmt',[]), fvStmt) ->
+ returnRn ([stmt'], fvStmt)
+
+rnStmts (stmt:stmts)
+ = rnStmt stmt `thenRn` \ ((stmt',bs), fvStmt) ->
+ extendSS2 bs (rnStmts stmts) `thenRn` \ (stmts', fvStmts) ->
+ returnRn (stmt':stmts', fvStmt `unionUniqSets` fvStmts)
+
+
+rnStmt (BindStmt pat expr src_loc)
+ = pushSrcLocRn src_loc $
+ rnExpr expr `thenRn` \ (expr', fvExpr) ->
+ let
+ binders = collectPatBinders pat
+ in
+ newLocalNames "variable in do binding"
+ (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
+ extendSS new_binders (rnPat pat) `thenRn` \ pat' ->
+
+ returnRn ((BindStmt pat' expr' src_loc, new_binders), fvExpr)
+
+rnStmt (ExprStmt expr src_loc)
+ =
+ rnExpr expr `thenRn` \ (expr', fvs) ->
+ returnRn ((ExprStmt expr' src_loc, []), fvs)
+
+rnStmt (LetStmt binds)
+ = rnBinds binds `thenRn` \ (binds', binds_fvs, new_binders) ->
+ returnRn ((LetStmt binds', new_binders), binds_fvs)
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsubsection{Precedence Parsing}
+%* *
+%************************************************************************
+
+\begin{code}
+precParseExpr :: RenamedHsExpr -> RnM_Fixes s RenamedHsExpr
+precParsePat :: RenamedPat -> RnM_Fixes s RenamedPat
+
+precParseExpr exp@(OpApp (NegApp e1) (HsVar op) e2)
+ = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
+ if 6 < op_prec then
+ -- negate precedence 6 wired in
+ -- (-x)*y ==> -(x*y)
+ precParseExpr (OpApp e1 (HsVar op) e2) `thenRn` \ op_app ->
+ returnRn (NegApp op_app)
+ else
+ returnRn exp
+
+precParseExpr exp@(OpApp (OpApp e11 (HsVar op1) e12) (HsVar op) e2)
+ = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
+ lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
+ case cmp op1_prec op_prec of
+ LT_ -> rearrange
+ EQ_ -> case (op1_fix, op_fix) of
+ (INFIXR, INFIXR) -> rearrange
+ (INFIXL, INFIXL) -> returnRn exp
+ _ -> getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn exp
+ (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc)
+ GT__ -> returnRn exp
+ where
+ rearrange = precParseExpr (OpApp e12 (HsVar op) e2) `thenRn` \ e2' ->
+ returnRn (OpApp e11 (HsVar op1) e2')
+
+precParseExpr exp = returnRn exp
+
+
+precParsePat pat@(ConOpPatIn (NegPatIn e1) op e2)
+ = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
+ if 6 < op_prec then
+ -- negate precedence 6 wired in
+ getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn pat (precParseNegPatErr (op,op_fix,op_prec) src_loc)
+ else
+ returnRn pat
+
+precParsePat pat@(ConOpPatIn (ConOpPatIn p11 op1 p12) op p2)
+ = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
+ lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
+ case cmp op1_prec op_prec of
+ LT_ -> rearrange
+ EQ_ -> case (op1_fix, op_fix) of
+ (INFIXR, INFIXR) -> rearrange
+ (INFIXL, INFIXL) -> returnRn pat
+ _ -> getSrcLocRn `thenRn` \ src_loc ->
+ failButContinueRn pat
+ (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc)
+ GT__ -> returnRn pat
+ where
+ rearrange = precParsePat (ConOpPatIn p12 op p2) `thenRn` \ p2' ->
+ returnRn (ConOpPatIn p11 op1 p2')
+
+precParsePat pat = returnRn pat
+
+
+data INFIX = INFIXL | INFIXR | INFIXN
+
+lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int)
+lookupFixity op
+ = getExtraRn `thenRn` \ fixity_fm ->
+ case lookupUFM fixity_fm op of
+ Nothing -> returnRn (INFIXL, 9)
+ Just (InfixL _ n) -> returnRn (INFIXL, n)
+ Just (InfixR _ n) -> returnRn (INFIXR, n)
+ Just (InfixN _ n) -> returnRn (INFIXN, n)
+\end{code}
+
+\begin{code}
+negPatErr pat src_loc
+ = addErrLoc src_loc "prefix `-' not applied to literal in pattern" ( \sty ->
+ ppr sty pat)
+
+precParseNegPatErr op src_loc
+ = addErrLoc src_loc "precedence parsing error" (\ sty ->
+ ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"])
+
+precParseErr op1 op2 src_loc
+ = addErrLoc src_loc "precedence parsing error" (\ sty ->
+ ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2,
+ ppStr " in the same infix expression"])
+
+pp_op sty (op, fix, prec) = ppBesides [pprOp sty op, ppLparen, pp_fix fix, ppSP, ppInt prec, ppRparen]
+pp_fix INFIXL = ppStr "infixl"
+pp_fix INFIXR = ppStr "infixr"
+pp_fix INFIXN = ppStr "infix"
+\end{code}
module RnHsSyn where
-import Ubiq{-uitous-}
+import Ubiq
import HsSyn
+
+import Name ( isLocalName, nameUnique, Name, RdrName )
+import Id ( GenId, Id(..) )
+import Outputable ( Outputable(..) )
+import PprType ( GenType, GenTyVar, TyCon )
+import PprStyle ( PprStyle(..) )
+import Pretty
+import TyCon ( TyCon )
+import TyVar ( GenTyVar )
+import Unique ( Unique )
+import Util ( panic, pprPanic )
+\end{code}
+
+\begin{code}
+data RnName
+ = WiredInId Id
+ | WiredInTyCon TyCon
+ | RnName Name -- funtions/binders/tyvars
+ | RnSyn Name -- type synonym
+ | RnData Name [Name] -- data type (with constrs)
+ | RnConstr Name Name -- constructor (with data type)
+ | RnClass Name [Name] -- class (with class ops)
+ | RnClassOp Name Name -- class op (with class)
+ | RnImplicit Name -- implicitly imported
+ | RnImplicitTyCon Name -- implicitly imported
+ | RnImplicitClass Name -- implicitly imported
+ | RnUnbound RdrName -- place holder
+
+mkRnName = RnName
+mkRnImplicit = RnImplicit
+mkRnImplicitTyCon = RnImplicitTyCon
+mkRnImplicitClass = RnImplicitClass
+mkRnUnbound = RnUnbound
+
+isRnWired (WiredInId _) = True
+isRnWired (WiredInTyCon _) = True
+isRnWired _ = False
+
+isRnLocal (RnName n) = isLocalName n
+isRnLocal _ = False
+
+
+isRnTyCon (WiredInTyCon _) = True
+isRnTyCon (RnSyn _) = True
+isRnTyCon (RnData _ _) = True
+isRnTyCon (RnImplicitTyCon _) = True
+isRnTyCon _ = False
+
+isRnClass (RnClass _ _) = True
+isRnClass (RnImplicitClass _) = True
+isRnClass _ = False
+
+isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls
+isRnClassOp cls (RnImplicit _) = True -- ho hummm ...
+isRnClassOp cls _ = False
+
+isRnImplicit (RnImplicit _) = True
+isRnImplicit (RnImplicitTyCon _) = True
+isRnImplicit (RnImplicitClass _) = True
+isRnImplicit _ = False
+
+isRnUnbound (RnUnbound _) = True
+isRnUnbound _ = False
+
+-- Very general NamedThing comparison, used when comparing
+-- Uniquable things with different types
+
+eqUniqsNamed n1 n2 = uniqueOf n1 == uniqueOf n2
+cmpUniqsNamed n1 n2 = uniqueOf n1 `cmp` uniqueOf n2
+
+instance Eq RnName where
+ a == b = eqUniqsNamed a b
+
+instance Ord3 RnName where
+ a `cmp` b = cmpUniqsNamed a b
+
+instance Uniquable RnName where
+ uniqueOf = nameUnique . getName
+
+instance NamedThing RnName where
+ getName (WiredInId id) = getName id
+ getName (WiredInTyCon tc) = getName tc
+ getName (RnName n) = n
+ getName (RnSyn n) = n
+ getName (RnData n _) = n
+ getName (RnConstr n _) = n
+ getName (RnClass n _) = n
+ getName (RnClassOp n _) = n
+ getName (RnImplicit n) = n
+ getName (RnUnbound occ) = pprPanic "getRnName:RnUnbound" (ppr PprDebug occ)
+
+instance Outputable RnName where
+#ifdef DEBUG
+ ppr sty@PprShowAll (RnData n cs) = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppStr "-}"]
+ ppr sty@PprShowAll (RnConstr n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
+ ppr sty@PprShowAll (RnClass n ops) = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"]
+ ppr sty@PprShowAll (RnClassOp n c) = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"]
+#endif
+ ppr sty (WiredInId id) = ppr sty id
+ ppr sty (WiredInTyCon tycon)= ppr sty tycon
+ ppr sty (RnUnbound occ) = ppBeside (ppr sty occ) (ppPStr SLIT("{-UNBOUND-}"))
+ ppr sty rn_name = ppr sty (getName rn_name)
\end{code}
\begin{code}
-type RenamedArithSeqInfo = ArithSeqInfo Fake Fake Name RenamedPat
-type RenamedBind = Bind Fake Fake Name RenamedPat
-type RenamedClassDecl = ClassDecl Fake Fake Name RenamedPat
-type RenamedClassOpPragmas = ClassOpPragmas Name
-type RenamedClassOpSig = Sig Name
-type RenamedClassPragmas = ClassPragmas Name
-type RenamedConDecl = ConDecl Name
-type RenamedContext = Context Name
-type RenamedDataPragmas = DataPragmas Name
-type RenamedSpecDataSig = SpecDataSig Name
-type RenamedDefaultDecl = DefaultDecl Name
-type RenamedFixityDecl = FixityDecl Name
-type RenamedGRHS = GRHS Fake Fake Name RenamedPat
-type RenamedGRHSsAndBinds = GRHSsAndBinds Fake Fake Name RenamedPat
-type RenamedGenPragmas = GenPragmas Name
-type RenamedHsBinds = HsBinds Fake Fake Name RenamedPat
-type RenamedHsExpr = HsExpr Fake Fake Name RenamedPat
-type RenamedHsModule = HsModule Fake Fake Name RenamedPat
-type RenamedRecordBinds = HsRecordBinds Fake Fake Name RenamedPat
-type RenamedImportedInterface = ImportedInterface Fake Fake Name RenamedPat
-type RenamedInstDecl = InstDecl Fake Fake Name RenamedPat
-type RenamedInstancePragmas = InstancePragmas Name
-type RenamedInterface = Interface Fake Fake Name RenamedPat
-type RenamedMatch = Match Fake Fake Name RenamedPat
-type RenamedMonoBinds = MonoBinds Fake Fake Name RenamedPat
-type RenamedMonoType = MonoType Name
-type RenamedPat = InPat Name
-type RenamedPolyType = PolyType Name
-type RenamedQual = Qual Fake Fake Name RenamedPat
-type RenamedSig = Sig Name
-type RenamedSpecInstSig = SpecInstSig Name
-type RenamedStmt = Stmt Fake Fake Name RenamedPat
-type RenamedTyDecl = TyDecl Name
+type RenamedArithSeqInfo = ArithSeqInfo Fake Fake RnName RenamedPat
+type RenamedBind = Bind Fake Fake RnName RenamedPat
+type RenamedClassDecl = ClassDecl Fake Fake RnName RenamedPat
+type RenamedClassOpSig = Sig RnName
+type RenamedConDecl = ConDecl RnName
+type RenamedContext = Context RnName
+type RenamedSpecDataSig = SpecDataSig RnName
+type RenamedDefaultDecl = DefaultDecl RnName
+type RenamedFixityDecl = FixityDecl RnName
+type RenamedGRHS = GRHS Fake Fake RnName RenamedPat
+type RenamedGRHSsAndBinds = GRHSsAndBinds Fake Fake RnName RenamedPat
+type RenamedHsBinds = HsBinds Fake Fake RnName RenamedPat
+type RenamedHsExpr = HsExpr Fake Fake RnName RenamedPat
+type RenamedHsModule = HsModule Fake Fake RnName RenamedPat
+type RenamedInstDecl = InstDecl Fake Fake RnName RenamedPat
+type RenamedMatch = Match Fake Fake RnName RenamedPat
+type RenamedMonoBinds = MonoBinds Fake Fake RnName RenamedPat
+type RenamedMonoType = MonoType RnName
+type RenamedPat = InPat RnName
+type RenamedPolyType = PolyType RnName
+type RenamedRecordBinds = HsRecordBinds Fake Fake RnName RenamedPat
+type RenamedQual = Qual Fake Fake RnName RenamedPat
+type RenamedSig = Sig RnName
+type RenamedSpecInstSig = SpecInstSig RnName
+type RenamedStmt = Stmt Fake Fake RnName RenamedPat
+type RenamedTyDecl = TyDecl RnName
+
+type RenamedClassOpPragmas = ClassOpPragmas RnName
+type RenamedClassPragmas = ClassPragmas RnName
+type RenamedDataPragmas = DataPragmas RnName
+type RenamedGenPragmas = GenPragmas RnName
+type RenamedInstancePragmas = InstancePragmas RnName
\end{code}
\begin{code}
-collectQualBinders :: [RenamedQual] -> [Name]
+collectQualBinders :: [RenamedQual] -> [RnName]
collectQualBinders quals
= concat (map collect quals)
collect (FilterQual expr) = []
collect (LetQual binds) = collectTopLevelBinders binds
\end{code}
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnIfaces]{Cacheing and Renaming of Interfaces}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnIfaces (
+ cacheInterface,
+ readInterface,
+ rnInterfaces,
+ finalIfaceInfo,
+ IfaceCache(..),
+ VersionInfo(..),
+ ParsedIface(..)
+ ) where
+
+import PreludeGlaST ( returnPrimIO, thenPrimIO,
+ readVar, writeVar, MutableVar(..) )
+
+import Ubiq
+
+import HsSyn
+import RdrHsSyn
+import RnHsSyn
+
+import RnMonad
+import RnUtils ( RnEnv(..) )
+
+import Bag ( emptyBag )
+import ErrUtils ( Error(..), Warning(..) )
+import FiniteMap ( emptyFM, lookupFM, addToFM )
+import Pretty
+import Maybes ( MaybeErr(..) )
+import Util ( panic )
+
+\end{code}
+
+
+\begin{code}
+type IfaceCache = MutableVar _RealWorld (FiniteMap Module ParsedIface,
+ FiniteMap Module FAST_STRING)
+
+data ParsedIface = ParsedIface
+
+
+cacheInterface :: IfaceCache -> Module
+ -> PrimIO (MaybeErr ParsedIface Error)
+
+cacheInterface iface_var mod
+ = readVar iface_var `thenPrimIO` \ (iface_fm, file_fm) ->
+ case lookupFM iface_fm mod of
+ Just iface -> returnPrimIO (Succeeded iface)
+ Nothing ->
+ case lookupFM file_fm mod of
+ Nothing -> returnPrimIO (Failed (noIfaceErr mod))
+ Just file ->
+ readInterface file mod `thenPrimIO` \ read_iface ->
+ case read_iface of
+ Failed err -> returnPrimIO (Failed err)
+ Succeeded iface ->
+ let
+ iface_fm' = addToFM iface_fm mod iface
+ in
+ writeVar iface_var (iface_fm', file_fm) `thenPrimIO` \ _ ->
+ returnPrimIO (Succeeded iface)
+
+
+readInterface :: FAST_STRING -> Module
+ -> PrimIO (MaybeErr ParsedIface Error)
+
+readInterface file mod = panic "readInterface"
+\end{code}
+
+
+\begin{code}
+rnInterfaces ::
+ IfaceCache -- iface cache
+ -> RnEnv -- original name env
+ -> UniqSupply
+ -> RenamedHsModule -- module to extend with iface decls
+ -> [RnName] -- imported names required
+ -> PrimIO (RenamedHsModule, -- extended module
+ ImplicitEnv, -- implicit names required
+ Bag Error,
+ Bag Warning)
+
+rnInterfaces iface_var occ_env us rn_module todo
+ = returnPrimIO (rn_module, (emptyFM, emptyFM), emptyBag, emptyBag)
+\end{code}
+
+
+\begin{code}
+finalIfaceInfo ::
+ IfaceCache -- iface cache
+ -> [RnName] -- all imported names required
+ -> [Module] -- directly imported modules
+ -> PrimIO (VersionInfo, -- info about version numbers
+ [Module]) -- special instance modules
+
+type VersionInfo = [(Module, Version, [(FAST_STRING, Version)])]
+
+finalIfaceInfo iface_var imps_reqd imp_mods
+ = returnPrimIO ([], [])
+\end{code}
+
+
+\begin{code}
+noIfaceErr mod sty
+ = ppCat [ppStr "Could not find interface for", ppPStr mod]
+\end{code}
-Breaks the RnPass4/RnExpr4/RnBind4 loops.
+Breaks the RnSource/RnExpr/RnBinds loops.
\begin{code}
interface RnLoop where
-import Name ( Name )
-import RdrHsSyn ( ProtoNameHsBinds(..), ProtoNamePolyType(..), ProtoNameGenPragmas(..) )
-import RnHsSyn ( RenamedHsBinds(..), RenamedPolyType(..), RenamedGenPragmas(..) )
-import RnBinds4 ( rnBinds, FreeVars(..) )
-import RnMonad4 ( TyVarNamesEnv(..), Rn4M(..) )
-import RnPass4 ( rnPolyType, rnGenPragmas )
+import RdrHsSyn ( RdrNameHsBinds(..), RdrNamePolyType(..) )
+import RnHsSyn ( RnName, RenamedHsBinds(..), RenamedPolyType(..) )
+import RnBinds ( rnBinds, FreeVars(..) )
+import RnMonad ( TyVarNamesEnv(..), RnM_Fixes(..) )
+import RnSource ( rnPolyType )
import UniqSet ( UniqSet(..) )
-rnBinds :: ProtoNameHsBinds -> Rn4M (RenamedHsBinds, FreeVars, [Name])
-rnGenPragmas :: ProtoNameGenPragmas -> Rn4M RenamedGenPragmas
-rnPolyType :: Bool
- -> TyVarNamesEnv
- -> ProtoNamePolyType
- -> Rn4M RenamedPolyType
-
-type FreeVars = UniqSet Name
+rnBinds :: RdrNameHsBinds -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName])
+rnPolyType :: TyVarNamesEnv
+ -> RdrNamePolyType
+ -> RnM_Fixes s RenamedPolyType
+type FreeVars = UniqSet RnName
\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnMonad]{The monad used by the renamer}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnMonad (
+ RnMonad(..), RnM(..), RnM_Fixes(..), RnDown, SST_R,
+ initRn, thenRn, thenRn_, andRn, returnRn,
+ mapRn, mapAndUnzipRn,
+
+ addErrRn, addErrIfRn, addWarnRn, addWarnIfRn,
+ failButContinueRn, warnAndContinueRn,
+ setExtraRn, getExtraRn,
+ getModuleRn, pushSrcLocRn, getSrcLocRn,
+ getSourceRn, getOccurrenceUpRn,
+ getImplicitUpRn, ImplicitEnv(..),
+ rnGetUnique, rnGetUniques,
+
+ newLocalNames,
+ lookupValue, lookupValueMaybe,
+ lookupTyCon, lookupClass, lookupClassOp,
+ extendSS2, extendSS,
+
+ TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
+ lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs
+ ) where
+
+import Ubiq{-uitous-}
+
+import SST
+
+import HsSyn ( FixityDecl )
+import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit,
+ mkRnImplicitTyCon, mkRnImplicitClass,
+ isRnLocal, isRnWired, isRnTyCon, isRnClass, isRnClassOp,
+ RenamedFixityDecl(..) )
+import RnUtils ( RnEnv(..), extendLocalRnEnv,
+ lookupRnEnv, lookupTcRnEnv,
+ unknownNameErr, badClassOpErr, qualNameErr,
+ dupNamesErr, shadowedNameWarn )
+
+import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
+import CmdLineOpts ( opt_WarnNameShadowing )
+import ErrUtils ( Error(..), Warning(..) )
+import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM )
+import Maybes ( assocMaybe )
+import Name ( Module(..), RdrName(..), isQual,
+ Name, mkLocalName, mkImplicitName
+ )
+import Outputable ( getOccName )
+import PprStyle ( PprStyle )
+import Pretty ( Pretty(..), PrettyRep )
+import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
+import UniqFM ( UniqFM, emptyUFM )
+import UniqSet ( UniqSet(..), mkUniqSet, minusUniqSet )
+import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
+import Unique ( Unique )
+import Util
+
+infixr 9 `thenRn`, `thenRn_`
+\end{code}
+
+\begin{code}
+type RnM s r = RnMonad () s r
+type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r
+
+type RnMonad x s r = RnDown x s -> SST s r
+
+data RnDown x s
+ = RnDown
+ x
+ Module -- Module name
+ SrcLoc -- Source location
+ (RnMode s) -- Source or Iface
+ RnEnv -- Renaming environment
+ (MutableVar s UniqSupply) -- Unique supply
+ (MutableVar s (Bag Warning, -- Warnings and Errors
+ Bag Error))
+
+data RnMode s
+ = RnSource (MutableVar s (Bag (RnName, RdrName)))
+ -- Renaming source; returning occurences
+
+ | RnIface (MutableVar s ImplicitEnv)
+ -- Renaming interface; creating and returning implicit names
+ -- One map for Values and one for TyCons/Classes.
+
+type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
+
+
+-- With a builtin polymorphic type for _runSST the type for
+-- initTc should use RnM s r instead of RnM _RealWorld r
+
+initRn :: Bool -- True => Source; False => Iface
+ -> Module
+ -> RnEnv
+ -> UniqSupply
+ -> RnM _RealWorld r
+ -> (r, Bag Error, Bag Warning)
+
+initRn source mod env us do_rn
+ = _runSST (
+ newMutVarSST emptyBag `thenSST` \ occ_var ->
+ newMutVarSST (emptyFM,emptyFM) `thenSST` \ imp_var ->
+ newMutVarSST us `thenSST` \ us_var ->
+ newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
+ let
+ mode = if source then
+ RnSource occ_var
+ else
+ RnIface imp_var
+
+ rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
+ in
+ -- do the buisness
+ do_rn rn_down `thenSST` \ res ->
+
+ -- grab errors and return
+ readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ returnSST (res, errs, warns)
+ )
+
+{-# INLINE thenRn #-}
+{-# INLINE thenRn_ #-}
+{-# INLINE returnRn #-}
+{-# INLINE andRn #-}
+
+returnRn :: a -> RnMonad x s a
+thenRn :: RnMonad x s a -> (a -> RnMonad x s b) -> RnMonad x s b
+thenRn_ :: RnMonad x s a -> RnMonad x s b -> RnMonad x s b
+andRn :: (a -> a -> a) -> RnMonad x s a -> RnMonad x s a -> RnMonad x s a
+mapRn :: (a -> RnMonad x s b) -> [a] -> RnMonad x s [b]
+mapAndUnzipRn :: (a -> RnMonad x s (b,c)) -> [a] -> RnMonad x s ([b],[c])
+
+returnRn v down = returnSST v
+thenRn m k down = m down `thenSST` \ r -> k r down
+thenRn_ m k down = m down `thenSST_` k down
+
+andRn combiner m1 m2 down
+ = m1 down `thenSST` \ res1 ->
+ m2 down `thenSST` \ res2 ->
+ returnSST (combiner res1 res2)
+
+mapRn f [] = returnRn []
+mapRn f (x:xs)
+ = f x `thenRn` \ r ->
+ mapRn f xs `thenRn` \ rs ->
+ returnRn (r:rs)
+
+mapAndUnzipRn f [] = returnRn ([],[])
+mapAndUnzipRn f (x:xs)
+ = f x `thenRn` \ (r1, r2) ->
+ mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
+ returnRn (r1:rs1, r2:rs2)
+\end{code}
+
+For errors and warnings ...
+\begin{code}
+failButContinueRn :: a -> Error -> RnMonad x s a
+failButContinueRn res err (RnDown _ _ _ _ _ _ errs_var)
+ = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
+ returnSST res
+
+warnAndContinueRn :: a -> Warning -> RnMonad x s a
+warnAndContinueRn res warn (RnDown _ _ _ _ _ _ errs_var)
+ = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
+ returnSST res
+
+addErrRn :: Error -> RnMonad x s ()
+addErrRn err = failButContinueRn () err
+
+addErrIfRn :: Bool -> Error -> RnMonad x s ()
+addErrIfRn True err = addErrRn err
+addErrIfRn False err = returnRn ()
+
+addWarnRn :: Warning -> RnMonad x s ()
+addWarnRn warn = warnAndContinueRn () warn
+
+addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
+addWarnIfRn True warn = addWarnRn warn
+addWarnIfRn False warn = returnRn ()
+\end{code}
+
+
+\begin{code}
+setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
+setExtraRn x m (RnDown _ mod locn mode env us errs)
+ = m (RnDown x mod locn mode env us errs)
+
+getExtraRn :: RnMonad x s x
+getExtraRn (RnDown x _ _ _ _ _ _)
+ = returnSST x
+
+getModuleRn :: RnMonad x s Module
+getModuleRn (RnDown _ mod _ _ _ _ _)
+ = returnSST mod
+
+pushSrcLocRn :: SrcLoc -> RnMonad x s a -> RnMonad x s a
+pushSrcLocRn locn m (RnDown x mod _ mode env us errs)
+ = m (RnDown x mod locn mode env us errs)
+
+getSrcLocRn :: RnMonad x s SrcLoc
+getSrcLocRn (RnDown _ _ locn _ _ _ _)
+ = returnSST locn
+
+getSourceRn :: RnMonad x s Bool
+getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True
+getSourceRn (RnDown _ _ _ (RnIface _) _ _ _) = returnSST False
+
+getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
+getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
+ = readMutVarSST occ_var
+getOccurrenceUpRn (RnDown _ _ _ (RnIface _) _ _ _)
+ = panic "getOccurrenceUpRn:RnIface"
+
+getImplicitUpRn :: RnMonad x s (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
+getImplicitUpRn (RnDown _ _ _ (RnIface imp_var) _ _ _)
+ = readMutVarSST imp_var
+getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
+ = panic "getImplicitUpRn:RnIface"
+\end{code}
+
+\begin{code}
+rnGetUnique :: RnMonad x s Unique
+rnGetUnique (RnDown _ _ _ _ _ us_var _)
+ = get_unique us_var
+
+rnGetUniques :: Int -> RnMonad x s [Unique]
+rnGetUniques n (RnDown _ _ _ _ _ us_var _)
+ = get_uniques n us_var
+
+
+get_unique us_var
+ = readMutVarSST us_var `thenSST` \ uniq_supply ->
+ let
+ (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ uniq = getUnique uniq_s
+ in
+ writeMutVarSST us_var new_uniq_supply `thenSST_`
+ returnSST uniq
+
+get_uniques n us_var
+ = readMutVarSST us_var `thenSST` \ uniq_supply ->
+ let
+ (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ uniqs = getUniques n uniq_s
+ in
+ writeMutVarSST us_var new_uniq_supply `thenSST_`
+ returnSST uniqs
+
+snoc_bag_var add bag_var
+ = readMutVarSST bag_var `thenSST` \ bag ->
+ writeMutVarSST bag_var (bag `snocBag` add)
+
+\end{code}
+
+*********************************************************
+* *
+\subsection{Making new names}
+* *
+*********************************************************
+
+@newLocalNames@ takes a bunch of RdrNames, which are defined together
+in a group (eg a pattern or set of bindings), checks they are
+unqualified and distinct, and creates new Names for them.
+
+\begin{code}
+newLocalNames :: String -- Documentation string
+ -> [(RdrName, SrcLoc)]
+ -> RnMonad x s [RnName]
+
+newLocalNames str names_w_loc
+ = mapRn (addErrRn . qualNameErr str) quals `thenRn_`
+ mapRn (addErrRn . dupNamesErr str) dups `thenRn_`
+ mkLocalNames these
+ where
+ quals = filter (isQual.fst) names_w_loc
+ (these, dups) = removeDups cmp_fst names_w_loc
+ cmp_fst (a,_) (b,_) = cmp a b
+\end{code}
+
+\begin{code}
+mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName]
+mkLocalNames names_w_locs
+ = rnGetUniques (length names_w_locs) `thenRn` \ uniqs ->
+ returnRn (zipWithEqual new_local uniqs names_w_locs)
+ where
+ new_local uniq (Unqual str, srcloc)
+ = mkRnName (mkLocalName uniq str srcloc)
+\end{code}
+
+
+*********************************************************
+* *
+\subsection{Looking up values}
+* *
+*********************************************************
+
+Action to look up a value depends on the RnMode.
+\begin{description}
+\item[RnSource:]
+Lookup value in RnEnv, recording occurrence for non-local values found.
+If not found report error and return Unbound name.
+\item[RnIface:]
+Lookup value in RnEnv. If not found lookup in implicit name env.
+If not found create new implicit name, adding it to the implicit env.
+\end{description}
+
+\begin{code}
+lookupValue :: RdrName -> RnMonad x s RnName
+lookupClassOp :: RnName -> RdrName -> RnMonad x s RnName
+
+lookupValue rdr
+ = lookup_val rdr (\ rn -> True) (unknownNameErr "value")
+
+lookupClassOp cls rdr
+ = lookup_val rdr (isRnClassOp cls) (badClassOpErr cls)
+
+
+lookup_val rdr check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
+ = case lookupRnEnv env rdr of
+ Just name | check name -> succ name
+ | otherwise -> fail
+ Nothing -> fail
+
+ where
+ succ name = if isRnLocal name || isRnWired name then
+ returnSST name
+ else
+ snoc_bag_var (name,rdr) occ_var `thenSST_`
+ returnSST name
+ fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
+
+lookup_val rdr check do_err down@(RnDown _ _ locn (RnIface imp_var) env us_var _)
+ = case lookupRnEnv env rdr of
+ Just name | check name -> returnSST name
+ | otherwise -> failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
+ Nothing -> lookup_or_create_implicit_val imp_var us_var rdr
+
+lookup_or_create_implicit_val imp_var us_var rdr
+ = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm)->
+ case lookupFM implicit_val_fm rdr of
+ Just implicit -> returnSST implicit
+ Nothing ->
+ get_unique us_var `thenSST` \ uniq ->
+ let
+ implicit = mkRnImplicit (mkImplicitName uniq rdr)
+ new_val_fm = addToFM implicit_val_fm rdr implicit
+ in
+ writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
+ returnSST implicit
+
+
+lookupValueMaybe :: RdrName -> RnMonad x s (Maybe RnName)
+lookupValueMaybe rdr down@(RnDown _ _ _ (RnSource _) env _ _)
+ = returnSST (lookupRnEnv env rdr)
+\end{code}
+
+
+\begin{code}
+lookupTyCon :: RdrName -> RnMonad x s RnName
+lookupClass :: RdrName -> RnMonad x s RnName
+
+lookupTyCon rdr
+ = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor"
+
+lookupClass rdr
+ = lookup_tc rdr isRnClass mkRnImplicitClass "class"
+
+
+lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
+ = case lookupTcRnEnv env rdr of
+ Just name | check name -> succ name
+ | otherwise -> fail
+ Nothing -> fail
+ where
+ succ name = snoc_bag_var (name,rdr) occ_var `thenSST_`
+ returnSST name
+ fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
+
+lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface imp_var) env us_var _)
+ = case lookupTcRnEnv env rdr of
+ Just name | check name -> returnSST name
+ | otherwise -> fail
+ Nothing -> lookup_or_create_implicit_tc check mk_implicit fail imp_var us_var rdr
+ where
+ fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
+
+lookup_or_create_implicit_tc check mk_implicit fail imp_var us_var rdr
+ = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm)->
+ case lookupFM implicit_tc_fm rdr of
+ Just implicit | check implicit -> returnSST implicit
+ | otherwise -> fail
+ Nothing ->
+ get_unique us_var `thenSST` \ uniq ->
+ let
+ implicit = mk_implicit (mkImplicitName uniq rdr)
+ new_tc_fm = addToFM implicit_tc_fm rdr implicit
+ in
+ writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_`
+ returnSST implicit
+\end{code}
+
+
+@extendSS@ extends the scope; @extendSS2@ also removes the newly bound
+free vars from the result.
+
+\begin{code}
+extendSS :: [RnName] -- Newly bound names
+ -> RnMonad x s a
+ -> RnMonad x s a
+
+extendSS binders m down@(RnDown x mod locn mode env us errs)
+ = (mapRn (addErrRn . shadowedNameWarn locn) dups `thenRn_`
+ m) (RnDown x mod locn mode new_env us errs)
+ where
+ (new_env,dups) = extendLocalRnEnv opt_WarnNameShadowing env binders
+
+extendSS2 :: [RnName] -- Newly bound names
+ -> RnMonad x s (a, UniqSet RnName)
+ -> RnMonad x s (a, UniqSet RnName)
+
+extendSS2 binders m
+ = extendSS binders m `thenRn` \ (r, fvs) ->
+ returnRn (r, fvs `minusUniqSet` (mkUniqSet binders))
+\end{code}
+
+The free var set returned by @(extendSS binders m)@ is that returned
+by @m@, {\em minus} binders.
+
+
+*********************************************************
+* *
+\subsection{TyVarNamesEnv}
+* *
+*********************************************************
+
+\begin{code}
+type TyVarNamesEnv = [(RdrName, RnName)]
+
+nullTyVarNamesEnv :: TyVarNamesEnv
+nullTyVarNamesEnv = []
+
+catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
+catTyVarNamesEnvs e1 e2 = e1 ++ e2
+
+domTyVarNamesEnv :: TyVarNamesEnv -> [RdrName]
+domTyVarNamesEnv env = map fst env
+\end{code}
+
+@mkTyVarNamesEnv@ checks for duplicates, and complains if so.
+
+\begin{code}
+mkTyVarNamesEnv
+ :: SrcLoc
+ -> [RdrName] -- The type variables
+ -> RnMonad x s (TyVarNamesEnv,[RnName]) -- Environment and renamed tyvars
+
+mkTyVarNamesEnv src_loc tyvars
+ = newLocalNames "type variable"
+ (tyvars `zip` repeat src_loc) `thenRn` \ rn_tyvars ->
+
+ -- rn_tyvars may not be in the same order as tyvars, so we need some
+ -- jiggery pokery to build the right tyvar env, and return the
+ -- renamed tyvars in the original order.
+ let tv_occ_name_pairs = map tv_occ_name_pair rn_tyvars
+ tv_env = map (lookup_occ_name tv_occ_name_pairs) tyvars
+ rn_tyvars_in_orig_order = map snd tv_env
+ in
+ returnRn (tv_env, rn_tyvars_in_orig_order)
+ where
+ tv_occ_name_pair :: RnName -> (RdrName, RnName)
+ tv_occ_name_pair rn_name = (getOccName rn_name, rn_name)
+
+ lookup_occ_name :: [(RdrName, RnName)] -> RdrName -> (RdrName, RnName)
+ lookup_occ_name pairs tyvar_occ
+ = (tyvar_occ, assoc "mkTyVarNamesEnv" pairs tyvar_occ)
+\end{code}
+
+\begin{code}
+lookupTyVarName :: TyVarNamesEnv -> RdrName -> RnMonad x s RnName
+lookupTyVarName env occ
+ = case (assocMaybe env occ) of
+ Just name -> returnRn name
+ Nothing -> getSrcLocRn `thenRn` \ loc ->
+ failButContinueRn (mkRnUnbound occ)
+ (unknownNameErr "type variable" occ loc)
+\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[RnMonad12]{The monad used by the renamer passes 1 and 2}
-
-\begin{code}
-#include "HsVersions.h"
-
-module RnMonad12 (
- Rn12M(..),
- initRn12, thenRn12, returnRn12,
- mapRn12, zipWithRn12, foldrRn12,
- addErrRn12, getModuleNameRn12, recoverQuietlyRn12
-
- -- and to make the interface self-sufficient...
- ) where
-
-import Ubiq{-uitous-}
-
-import Bag ( emptyBag, isEmptyBag, snocBag, Bag )
-import ErrUtils ( Error(..) )
-import Pretty ( Pretty(..) )
-
-infixr 9 `thenRn12`
-\end{code}
-
-In this monad, we pass down the name of the module we are working on,
-and we thread the collected errors.
-
-\begin{code}
-type Rn12M result
- = FAST_STRING{-module name-}
- -> Bag Error
- -> (result, Bag Error)
-
-{-# INLINE thenRn12 #-}
-{-# INLINE returnRn12 #-}
-
-initRn12 :: FAST_STRING{-module name-} -> Rn12M a -> (a, Bag Error)
-initRn12 mod action = action mod emptyBag
-
-thenRn12 :: Rn12M a -> (a -> Rn12M b) -> Rn12M b
-thenRn12 expr continuation mod errs_so_far
- = case (expr mod errs_so_far) of
- (res1, errs1) -> continuation res1 mod errs1
-
-returnRn12 :: a -> Rn12M a
-returnRn12 x mod errs_so_far = (x, errs_so_far)
-
-mapRn12 :: (a -> Rn12M b) -> [a] -> Rn12M [b]
-
-mapRn12 f [] = returnRn12 []
-mapRn12 f (x:xs)
- = f x `thenRn12` \ r ->
- mapRn12 f xs `thenRn12` \ rs ->
- returnRn12 (r:rs)
-
-zipWithRn12 :: (a -> b -> Rn12M c) -> [a] -> [b] -> Rn12M [c]
-
-zipWithRn12 f [] [] = returnRn12 []
-zipWithRn12 f (x:xs) (y:ys)
- = f x y `thenRn12` \ r ->
- zipWithRn12 f xs ys `thenRn12` \ rs ->
- returnRn12 (r:rs)
--- NB: zipWithRn12 behaves like zipWithEqual
--- (requires equal-length lists)
-
-foldrRn12 :: (a -> b -> Rn12M b) -> b -> [a] -> Rn12M b
-
-foldrRn12 f z [] = returnRn12 z
-foldrRn12 f z (x:xs)
- = foldrRn12 f z xs `thenRn12` \ rest ->
- f x rest
-
-addErrRn12 :: Error -> Rn12M ()
-addErrRn12 err mod errs_so_far
- = ( (), errs_so_far `snocBag` err )
-
-getModuleNameRn12 :: Rn12M FAST_STRING
-getModuleNameRn12 mod errs_so_far = (mod, errs_so_far)
-\end{code}
-
-\begin{code}
-recoverQuietlyRn12 :: a -> Rn12M a -> Rn12M a
-
-recoverQuietlyRn12 use_this_if_err action mod errs_so_far
- = let
- (result, errs_out)
- = case (action mod emptyBag{-no errors-}) of { (res, errs) ->
- if isEmptyBag errs then
- (res, errs_so_far) -- retain incoming errs
- else
- (use_this_if_err, errs_so_far)
- }
- in
- (result, errs_out)
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[RnMonad3]{The monad used by the third renamer pass}
-
-\begin{code}
-#include "HsVersions.h"
-
-module RnMonad3 (
- Rn3M(..),
- initRn3, thenRn3, andRn3, returnRn3, mapRn3, fixRn3,
-
- putInfoDownM3,
-
- newFullNameM3, newInvisibleNameM3
-
- -- for completeness
- ) where
-
-import Ubiq{-uitous-}
-
-import FiniteMap ( emptyFM, isEmptyFM, lookupFM,
- emptySet, isEmptySet, elementOf
- )
-import HsSyn ( IE )
-import NameTypes -- lots of stuff
-import Outputable ( ExportFlag(..) )
-import ProtoName ( ProtoName(..) )
-import RdrHsSyn ( getExportees, ExportListInfo(..), ProtoNameIE(..) )
-import UniqSupply ( getUnique, splitUniqSupply )
-import Util ( panic )
-
-infixr 9 `thenRn3`
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Plain @RnPass3@ monadery}
-%* *
-%************************************************************************
-
-\begin{code}
-type Rn3M result
- = ExportListInfo -> FAST_STRING{-ModuleName-} -> UniqSupply
- -> result
-
-{-# INLINE andRn3 #-}
-{-# INLINE thenRn3 #-}
-{-# INLINE returnRn3 #-}
-
-initRn3 :: Rn3M a -> UniqSupply -> a
-
-initRn3 m us = m Nothing{-no export list-} (panic "initRn3: uninitialised module name") us
-
-thenRn3 :: Rn3M a -> (a -> Rn3M b) -> Rn3M b
-andRn3 :: (a -> a -> a) -> Rn3M a -> Rn3M a -> Rn3M a
-
-thenRn3 expr continuation exps mod_name uniqs
- = case splitUniqSupply uniqs of { (s1, s2) ->
- case (expr exps mod_name s1) of { res1 ->
- continuation res1 exps mod_name s2 }}
-
-andRn3 combiner m1 m2 exps mod_name uniqs
- = case splitUniqSupply uniqs of { (s1, s2) ->
- case (m1 exps mod_name s1) of { res1 ->
- case (m2 exps mod_name s2) of { res2 ->
- combiner res1 res2 }}}
-
-returnRn3 :: a -> Rn3M a
-returnRn3 result exps mod_name uniqs = result
-
-mapRn3 :: (a -> Rn3M b) -> [a] -> Rn3M [b]
-
-mapRn3 f [] = returnRn3 []
-mapRn3 f (x:xs)
- = f x `thenRn3` \ r ->
- mapRn3 f xs `thenRn3` \ rs ->
- returnRn3 (r:rs)
-
-fixRn3 :: (a -> Rn3M a) -> Rn3M a
-
-fixRn3 m exps mod_name us
- = result
- where
- result = m result exps mod_name us
-
-putInfoDownM3 :: FAST_STRING{-ModuleName-} -> Maybe [ProtoNameIE] -> Rn3M a -> Rn3M a
-
-putInfoDownM3 mod_name exports cont _ _ uniqs
- = cont (getExportees exports) mod_name uniqs
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[RnMonad3-new-names]{Making new names}
-%* *
-%************************************************************************
-
-@newFullNameM3@ makes a new user-visible FullName (the usual);
-@newInvisibleNameM3@ is the odd case. @new_name@ does all the work.
-
-\begin{code}
-newFullNameM3, newInvisibleNameM3
- :: ProtoName -- input
- -> SrcLoc -- where it started life
- -> Bool -- if it is "TyCon"ish (rather than "val"ish)
- -> Maybe ExportFlag -- Just flag => force the use of that exportness
- -> Rn3M (Unique, FullName)
-
-newFullNameM3 pn src_loc is_tycon_ish frcd_exp exps mod_name uniqs
- = new_name pn src_loc is_tycon_ish frcd_exp False{-visible-} exps mod_name uniqs
-
-newInvisibleNameM3 pn src_loc is_tycon_ish frcd_exp exps mod_name uniqs
- = new_name pn src_loc is_tycon_ish frcd_exp True{-invisible-} exps mod_name uniqs
-\end{code}
-
-\begin{code}
-new_name pn src_loc is_tycon_ish frcd_export_flag want_invisible exps mod_name uniqs
- = (uniq, name)
- where
- uniq = getUnique uniqs
-
- mk_name = if want_invisible then mkPrivateFullName else mkFullName
-
- name = case pn of
-
- Unk s -> mk_name mod_name s
- (if fromPrelude mod_name
- && is_tycon_ish then -- & tycon/clas/datacon => Core
- HereInPreludeCore
- else
- ThisModule
- )
- (case frcd_export_flag of
- Just fl -> fl
- Nothing -> mk_export_flag True [mod_name] s exps)
- src_loc
-
- Qunk m s -> mk_name mod_name s
- (if fromPrelude mod_name
- && is_tycon_ish then -- & tycon/clas/datacon => Core
- HereInPreludeCore
- else
- ThisModule
- )
- (case frcd_export_flag of
- Just fl -> fl
- Nothing -> mk_export_flag (_trace "mk_export_flag?" True) [m] s exps)
- src_loc
-
- -- note: the assigning of prelude-ness is most dubious (ToDo)
-
- Imp m d informant_mods l
- -> mk_name m d
- (if fromPrelude m then -- as above
- if is_tycon_ish then
- ExportedByPreludeCore
- else
- OtherPrelude l
- else if m == mod_name then -- pretty dang weird... (ToDo: anything?)
- ThisModule
- else
- OtherModule l informant_mods -- for Other*, we save its occurrence name
- )
- (case frcd_export_flag of
- Just fl -> fl
- Nothing -> mk_export_flag (m==mod_name) informant_mods l exps)
- src_loc
-
- Prel n -> panic "RnMonad3.new_name: prelude name"
-\end{code}
-
-In deciding the ``exportness'' of something, there are these cases to
-consider:
-\begin{description}
-\item[No explicit export list:]
-Everything defined in this module goes out.
-
-\item[Matches a non-\tr{M..} item in the export list:]
-Then it's exported as its @name_pr@ item suggests.
-
-\item[Matches a \tr{M..} item in the export list:]
-
-(Note: the module \tr{M} may be {\em this} module!) It's exported if
-we got it from \tr{M}'s interface; {\em most emphatically not} the
-same thing as ``it originally came from \tr{M}''.
-
-\item[Otherwise:]
-It isn't exported.
-\end{description}
-
-\begin{code}
-mk_export_flag :: Bool -- True <=> originally from the module we're compiling
- -> [FAST_STRING]-- modules that told us about this thing
- -> FAST_STRING -- name of the thing we're looking at
- -> ExportListInfo
- -> ExportFlag -- result
-
-mk_export_flag this_module informant_mods thing Nothing{-no export list-}
- = if this_module then ExportAll else NotExported
-
-mk_export_flag this_module informant_mods thing (Just (exports_alist, dotdot_modules))
- | otherwise
- = case (lookupFM exports_alist thing) of
- Just how_to_export -> how_to_export
- Nothing -> if (or [ im `elementOf` dotdot_modules | im <- informant_mods ])
- then ExportAll
- else NotExported
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[RnMonad4]{The monad used by the fourth renamer pass}
-
-\begin{code}
-#include "HsVersions.h"
-
-module RnMonad4 (
- Rn4M(..),
- initRn4, thenRn4, thenRn4_, andRn4, returnRn4, mapRn4, mapAndUnzipRn4,
- addErrRn4, failButContinueRn4, recoverQuietlyRn4,
- pushSrcLocRn4,
- getSrcLocRn4,
- lookupValue, lookupValueEvenIfInvisible,
- lookupClassOp, lookupFixityOp,
- lookupTyCon, lookupTyConEvenIfInvisible,
- lookupClass,
- extendSS2, extendSS,
- namesFromProtoNames,
-
- TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
- lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs
-
- -- for completeness
- ) where
-
-import Ubiq{-uitous-}
-
-import Bag ( emptyBag, isEmptyBag, unionBags, snocBag, Bag )
-import CmdLineOpts ( opt_ShowPragmaNameErrs, opt_NameShadowingNotOK )
-import ErrUtils
-import FiniteMap ( emptyFM, addListToFM, addToFM, lookupFM )
-import Name ( invisibleName, isTyConName, isClassName,
- isClassOpName, isUnboundName, Name(..)
- )
-import NameTypes ( mkShortName, ShortName{-instances-} )
-import Outputable ( pprNonOp )
-import Pretty
-import ProtoName ( eqProtoName, cmpByLocalName, ProtoName(..) )
-import RnUtils ( dupNamesErr, GlobalNameMappers(..) )
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc{-instance-} )
-import UniqSet ( mkUniqSet, minusUniqSet, UniqSet(..) )
-import UniqSupply ( getUniques, splitUniqSupply )
-import Util ( assoc, removeDups, zipWithEqual, panic )
-
-infixr 9 `thenRn4`, `thenRn4_`
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[RnMonad4]{Plain @Rename@ monadery for pass~4}
-%* *
-%************************************************************************
-
-\begin{code}
-type ScopeStack = FiniteMap FAST_STRING Name
-
-type Rn4M result
- = GlobalNameMappers
- -> ScopeStack
- -> Bag Error
- -> UniqSupply
- -> SrcLoc
- -> (result, Bag Error)
-
-{-# INLINE andRn4 #-}
-{-# INLINE thenRn4 #-}
-{-# INLINE thenLazilyRn4 #-}
-{-# INLINE thenRn4_ #-}
-{-# INLINE returnRn4 #-}
-
-initRn4 :: GlobalNameMappers
- -> Rn4M result
- -> UniqSupply
- -> (result, Bag Error)
-
-initRn4 gnfs renamer init_us
- = renamer gnfs emptyFM emptyBag init_us mkUnknownSrcLoc
-
-thenRn4, thenLazilyRn4
- :: Rn4M a -> (a -> Rn4M b) -> Rn4M b
-thenRn4_ :: Rn4M a -> Rn4M b -> Rn4M b
-andRn4 :: (a -> a -> a) -> Rn4M a -> Rn4M a -> Rn4M a
-
-thenRn4 expr cont gnfs ss errs uniqs locn
- = case (splitUniqSupply uniqs) of { (s1, s2) ->
- case (expr gnfs ss errs s1 locn) of { (res1, errs1) ->
- case (cont res1 gnfs ss errs1 s2 locn) of { (res2, errs2) ->
- (res2, errs2) }}}
-
-thenLazilyRn4 expr cont gnfs ss errs uniqs locn
- = let
- (s1, s2) = splitUniqSupply uniqs
- (res1, errs1) = expr gnfs ss errs s1 locn
- (res2, errs2) = cont res1 gnfs ss errs1 s2 locn
- in
- (res2, errs2)
-
-thenRn4_ expr cont gnfs ss errs uniqs locn
- = case (splitUniqSupply uniqs) of { (s1, s2) ->
- case (expr gnfs ss errs s1 locn) of { (_, errs1) ->
- case (cont gnfs ss errs1 s2 locn) of { (res2, errs2) ->
- (res2, errs2) }}}
-
-andRn4 combiner m1 m2 gnfs ss errs us locn
- = case (splitUniqSupply us) of { (s1, s2) ->
- case (m1 gnfs ss errs s1 locn) of { (res1, errs1) ->
- case (m2 gnfs ss errs1 s2 locn) of { (res2, errs2) ->
- (combiner res1 res2, errs2) }}}
-
-returnRn4 :: a -> Rn4M a
-returnRn4 result gnfs ss errs_so_far uniqs locn
- = (result, errs_so_far)
-
-failButContinueRn4 :: a -> Error -> Rn4M a
-failButContinueRn4 res err gnfs ss errs_so_far uniqs locn
- = (res, errs_so_far `snocBag` err)
-
-addErrRn4 :: Error -> Rn4M ()
-addErrRn4 err gnfs ss errs_so_far uniqs locn
- = ((), errs_so_far `snocBag` err)
-\end{code}
-
-When we're looking at interface pragmas, we want to be able to recover
-back to a ``I don't know anything pragmatic'' state if we encounter
-some problem. @recoverQuietlyRn4@ is given a ``use-this-instead'' value,
-as well as the action to perform. This code is intentionally very lazy,
-returning a triple immediately, no matter what.
-\begin{code}
-recoverQuietlyRn4 :: a -> Rn4M a -> Rn4M a
-
-recoverQuietlyRn4 use_this_if_err action gnfs ss errs_so_far uniqs locn
- = let
- (result, errs_out)
- = case (action gnfs ss emptyBag{-leav out errs-} uniqs locn) of
- (result1, errs1) ->
- if isEmptyBag errs1 then -- all's well! (but retain incoming errs)
- (result1, errs_so_far)
- else -- give up; return *incoming* UniqueSupply...
- (use_this_if_err,
- if opt_ShowPragmaNameErrs
- then errs_so_far `unionBags` errs1
- else errs_so_far) -- toss errs, otherwise
- in
- (result, errs_out)
-\end{code}
-
-\begin{code}
-mapRn4 :: (a -> Rn4M b) -> [a] -> Rn4M [b]
-
-mapRn4 f [] = returnRn4 []
-mapRn4 f (x:xs)
- = f x `thenRn4` \ r ->
- mapRn4 f xs `thenRn4` \ rs ->
- returnRn4 (r:rs)
-
-mapAndUnzipRn4 :: (a -> Rn4M (b,c)) -> [a] -> Rn4M ([b],[c])
-
-mapAndUnzipRn4 f [] = returnRn4 ([],[])
-mapAndUnzipRn4 f (x:xs)
- = f x `thenRn4` \ (r1, r2) ->
- mapAndUnzipRn4 f xs `thenRn4` \ (rs1, rs2) ->
- returnRn4 (r1:rs1, r2:rs2)
-\end{code}
-
-\begin{code}
-pushSrcLocRn4 :: SrcLoc -> Rn4M a -> Rn4M a
-pushSrcLocRn4 locn exp gnfs ss errs_so_far uniq_supply old_locn
- = exp gnfs ss errs_so_far uniq_supply locn
-
-getSrcLocRn4 :: Rn4M SrcLoc
-
-getSrcLocRn4 gnfs ss errs_so_far uniq_supply locn
- = returnRn4 locn gnfs ss errs_so_far uniq_supply locn
-\end{code}
-
-\begin{code}
-getNextUniquesFromRn4 :: Int -> Rn4M [Unique]
-getNextUniquesFromRn4 n gnfs ss errs_so_far us locn
- = case (getUniques n us) of { next_uniques ->
- (next_uniques, errs_so_far) }
-\end{code}
-
-*********************************************************
-* *
-\subsection{Making new names}
-* *
-*********************************************************
-
-@namesFromProtoNames@ takes a bunch of protonames, which are defined
-together in a group (eg a pattern or set of bindings), checks they
-are distinct, and creates new full names for them.
-
-\begin{code}
-namesFromProtoNames :: String -- Documentation string
- -> [(ProtoName, SrcLoc)]
- -> Rn4M [Name]
-
-namesFromProtoNames kind pnames_w_src_loc gnfs ss errs_so_far us locn
- = (mapRn4 (addErrRn4 . dupNamesErr kind) dups `thenRn4_`
- mkNewNames goodies
- ) {-Rn4-} gnfs ss errs_so_far us locn
- where
- (goodies, dups) = removeDups cmp pnames_w_src_loc
- -- We want to compare their local names rather than their
- -- full protonames. It probably doesn't matter here, but it
- -- does in RnPass3.lhs!
- cmp (a, _) (b, _) = cmpByLocalName a b
-\end{code}
-
-@mkNewNames@ assumes the names are unique.
-
-\begin{code}
-mkNewNames :: [(ProtoName, SrcLoc)] -> Rn4M [Name]
-mkNewNames pnames_w_locs
- = getNextUniquesFromRn4 (length pnames_w_locs) `thenRn4` \ uniqs ->
- returnRn4 (zipWithEqual new_short_name uniqs pnames_w_locs)
- where
- new_short_name uniq (Unk str, srcloc) -- gotta be an Unk...
- = Short uniq (mkShortName str srcloc)
-\end{code}
-
-
-*********************************************************
-* *
-\subsection{Local scope extension and lookup}
-* *
-*********************************************************
-
-If the input name is an @Imp@, @lookupValue@ looks it up in the GNF.
-If it is an @Unk@, it looks it up first in the local environment
-(scope stack), and if it isn't found there, then in the value GNF. If
-it isn't found at all, @lookupValue@ adds an error message, and
-returns an @Unbound@ name.
-
-\begin{code}
-unboundName :: ProtoName -> Name
-unboundName pn
- = Unbound (grab_string pn)
- where
- grab_string (Unk s) = s
- grab_string (Qunk _ s) = s
- grab_string (Imp _ _ _ s) = s
-\end{code}
-
-@lookupValue@ looks up a non-invisible value;
-@lookupValueEvenIfInvisible@ gives a successful lookup even if the
-value is not visible to the user (e.g., came out of a pragma).
-@lookup_val@ is the help function to do the work.
-
-\begin{code}
-lookupValue v {-Rn4-} gnfs ss errs_so_far us locn
- = (lookup_val v `thenLazilyRn4` \ name ->
- if invisibleName name
- then failButContinueRn4 (unboundName v) (unknownNameErr "value" v mkUnknownSrcLoc)
- else returnRn4 name
- ) {-Rn4-} gnfs ss errs_so_far us locn
-
-lookupValueEvenIfInvisible v = lookup_val v
-
-lookup_val :: ProtoName -> Rn4M Name
-
-lookup_val pname@(Unk v) gnfs@(v_gnf, tc_gnf) ss a b locn
- = case (lookupFM ss v) of
- Just name -> returnRn4 name gnfs ss a b locn
- Nothing -> case (v_gnf pname) of
- Just name -> returnRn4 name gnfs ss a b locn
- Nothing -> failButContinueRn4 (unboundName pname)
- (unknownNameErr "value" pname locn)
- gnfs ss a b locn
-
-lookup_val (Qunk _ _) _ _ _ _ _ = panic "RnMonad4:lookup_val:Qunk"
-
--- If it ain't an Unk it must be in the global name fun; that includes
--- prelude things.
-lookup_val pname gnfs@(v_gnf, tc_gnf) ss a b locn
- = case (v_gnf pname) of
- Just name -> returnRn4 name gnfs ss a b locn
- Nothing -> failButContinueRn4 (unboundName pname)
- (unknownNameErr "value" pname locn)
- gnfs ss a b locn
-\end{code}
-
-Looking up the operators in a fixity decl is done differently. We
-want to simply drop any fixity decls which refer to operators which
-aren't in scope. Unfortunately, such fixity decls {\em will} appear
-because the parser collects *all* the fixity decls from {\em all} the
-imported interfaces (regardless of selective import), and dumps them
-together as the module fixity decls. This is really a bug. In
-particular:
-\begin{itemize}
-\item
-We won't complain about fixity decls for operators which aren't
-declared.
-\item
-We won't attach the right fixity to something which has been renamed.
-\end{itemize}
-
-We're not going to export Prelude-related fixities (ToDo: correctly),
-so we nuke those, too.
-
-\begin{code}
-lookupFixityOp (Prel _) gnfs@(v_gnf, tc_gnf) = returnRn4 Nothing gnfs
-lookupFixityOp pname gnfs@(v_gnf, tc_gnf) = returnRn4 (v_gnf pname) gnfs
-\end{code}
-
-\begin{code}
-lookupTyCon, lookupTyConEvenIfInvisible :: ProtoName -> Rn4M Name
--- The global name funs handle Prel things
-
-lookupTyCon tc {-Rn4-} gnfs ss errs_so_far us locn
- = (lookup_tycon tc `thenLazilyRn4` \ name ->
- if invisibleName name
- then failButContinueRn4 (unboundName tc) (unknownNameErr "type constructor" tc mkUnknownSrcLoc)
- else returnRn4 name
- ) {-Rn4-} gnfs ss errs_so_far us locn
-
-lookupTyConEvenIfInvisible tc = lookup_tycon tc
-
-lookup_tycon (Prel name) gnfs ss a b locn = returnRn4 name gnfs ss a b locn
-
-lookup_tycon pname gnfs@(v_gnf, tc_gnf) ss a b locn
- = case (tc_gnf pname) of
- Just name | isTyConName name -> returnRn4 name gnfs ss a b locn
- _ -> failButContinueRn4 (unboundName pname)
- (unknownNameErr "type constructor" pname locn)
- gnfs ss a b locn
-\end{code}
-
-\begin{code}
-lookupClass :: ProtoName -> Rn4M Name
-
-lookupClass pname gnfs@(v_gnf, tc_gnf) ss a b locn
- = case (tc_gnf pname) of
- Just name | isClassName name -> returnRn4 name gnfs ss a b locn
- _ -> failButContinueRn4 (unboundName pname)
- (unknownNameErr "class" pname locn)
- gnfs ss a b locn
-\end{code}
-
-@lookupClassOp@ is used when looking up the lhs identifiers in a class
-or instance decl. It checks that the name it finds really is a class
-op, and that its class matches that of the class or instance decl
-being looked at.
-
-\begin{code}
-lookupClassOp :: Name -> ProtoName -> Rn4M Name
-
-lookupClassOp class_name pname gnfs@(v_gnf, tc_gnf) ss a b locn
- = case v_gnf pname of
- Just op_name | isClassOpName class_name op_name
- || isUnboundName class_name -- avoid spurious errors
- -> returnRn4 op_name gnfs ss a b locn
-
- other -> failButContinueRn4 (unboundName pname)
- (badClassOpErr class_name pname locn)
- gnfs ss a b locn
-\end{code}
-
-@extendSS@ extends the scope; @extendSS2@ also removes the newly bound
-free vars from the result.
-
-\begin{code}
-extendSS :: [Name] -- Newly bound names
- -> Rn4M a
- -> Rn4M a
-
-extendSS binders expr gnfs ss errs us locn
- = case (extend binders ss gnfs ss errs us locn) of { (new_ss, new_errs) ->
- expr gnfs new_ss new_errs us locn }
- where
- extend :: [Name] -> ScopeStack -> Rn4M ScopeStack
-
- extend names ss
- = if opt_NameShadowingNotOK then
- hard_way names ss
- else -- ignore shadowing; blast 'em in
- returnRn4 (
- addListToFM ss [ (getOccurrenceName x, n) | n@(Short _ x) <- names]
- )
-
- hard_way [] ss = returnRn4 ss
- hard_way (name@(Short _ sname):names) ss
- = let
- str = getOccurrenceName sname
- in
- (case (lookupFM ss str) of
- Nothing -> returnRn4 (addToFM ss str name)
- Just _ -> failButContinueRn4 ss (shadowedNameErr name locn)
-
- ) `thenRn4` \ new_ss ->
- hard_way names new_ss
-
-extendSS2 :: [Name] -- Newly bound names
- -> Rn4M (a, UniqSet Name)
- -> Rn4M (a, UniqSet Name)
-
-extendSS2 binders expr gnfs ss errs_so_far us locn
- = case (extendSS binders expr gnfs ss errs_so_far us locn) of
- ((e2, freevars), errs)
- -> ((e2, freevars `minusUniqSet` (mkUniqSet binders)),
- errs)
-\end{code}
-
-The free var set returned by @(extendSS binders m)@ is that returned
-by @m@, {\em minus} binders.
-
-*********************************************************
-* *
-\subsection{mkTyVarNamesEnv}
-* *
-*********************************************************
-
-\begin{code}
-type TyVarNamesEnv = [(ProtoName, Name)]
-
-nullTyVarNamesEnv :: TyVarNamesEnv
-nullTyVarNamesEnv = []
-
-catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
-catTyVarNamesEnvs e1 e2 = e1 ++ e2
-
-domTyVarNamesEnv :: TyVarNamesEnv -> [ProtoName]
-domTyVarNamesEnv env = map fst env
-\end{code}
-
-@mkTyVarNamesEnv@ checks for duplicates, and complains if so.
-
-\begin{code}
-mkTyVarNamesEnv
- :: SrcLoc
- -> [ProtoName] -- The type variables
- -> Rn4M (TyVarNamesEnv,[Name]) -- Environment and renamed tyvars
-
-mkTyVarNamesEnv src_loc tyvars {-Rn4-} gnfs ss errs_so_far us locn
- = (namesFromProtoNames "type variable"
- (tyvars `zip` repeat src_loc) `thenRn4` \ tyvars2 ->
-
- -- tyvars2 may not be in the same order as tyvars, so we need some
- -- jiggery pokery to build the right tyvar env, and return the
- -- renamed tyvars in the original order.
- let tv_string_name_pairs = extend tyvars2 []
- tv_env = map (lookup tv_string_name_pairs) tyvars
- tyvars2_in_orig_order = map snd tv_env
- in
- returnRn4 (tv_env, tyvars2_in_orig_order)
- ) {-Rn4-} gnfs ss errs_so_far us locn
- where
- extend :: [Name] -> [(FAST_STRING, Name)] -> [(FAST_STRING, Name)]
- extend [] ss = ss
- extend (name@(Short _ sname):names) ss
- = (getOccurrenceName sname, name) : extend names ss
-
- lookup :: [(FAST_STRING, Name)] -> ProtoName -> (ProtoName, Name)
- lookup pairs tyvar_pn
- = (tyvar_pn, assoc "mkTyVarNamesEnv" pairs (getOccurrenceName tyvar_pn))
-\end{code}
-
-\begin{code}
-lookupTyVarName :: TyVarNamesEnv -> ProtoName -> Rn4M Name
-lookupTyVarName env pname {-Rn4-} gnfs ss errs_so_far us locn
- = (case (assoc_maybe env pname) of
- Just name -> returnRn4 name
- Nothing -> getSrcLocRn4 `thenRn4` \ loc ->
- failButContinueRn4 (unboundName pname)
- (unknownNameErr "type variable" pname loc)
- ) {-Rn4-} gnfs ss errs_so_far us locn
- where
- assoc_maybe [] _ = Nothing
- assoc_maybe ((tv,xxx) : tvs) key
- = if tv `eqProtoName` key then Just xxx else assoc_maybe tvs key
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Error messages}
-%* *
-%************************************************************************
-
-\begin{code}
-badClassOpErr clas op locn
- = addErrLoc locn "" ( \ sty ->
- ppBesides [ppChar '`', pprNonOp sty op, ppStr "' is not an operation of class `",
- ppr sty clas, ppStr "'."] )
-
-----------------------------
--- dupNamesErr: from RnUtils
-
----------------------------
-shadowedNameErr shadow locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "more than one value with the same name (shadowing): ",
- ppr sty shadow] )
-
-------------------------------------------
-unknownNameErr descriptor undef_thing locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ",
- pprNonOp sty undef_thing] )
-\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnNames]{Extracting imported and top-level names in scope}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnNames (
+ getGlobalNames,
+ GlobalNameInfo(..)
+ ) where
+
+import PreludeGlaST ( returnPrimIO, thenPrimIO, MutableVar(..) )
+
+import Ubiq
+
+import HsSyn
+import RdrHsSyn
+import RnHsSyn
+
+import RnMonad
+import RnIfaces ( IfaceCache(..), cacheInterface, ParsedIface )
+import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, qualNameErr, dupNamesErr )
+
+import Bag ( emptyBag, unitBag, unionBags, unionManyBags, mapBag, listToBag, bagToList )
+import ErrUtils ( Error(..), Warning(..), addShortErrLocLine )
+import FiniteMap ( fmToList )
+import Name ( RdrName(..), isQual, mkTopLevName, mkImportedName, nameExportFlag, Name )
+import Outputable ( getLocalName, getSrcLoc, pprNonOp )
+import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
+import PrelMods ( fromPrelude )
+import Pretty
+import SrcLoc ( SrcLoc )
+import UniqSupply ( splitUniqSupply )
+import Util ( equivClasses, panic )
+\end{code}
+
+
+\begin{code}
+type GlobalNameInfo = (BuiltinNames,
+ BuiltinKeys,
+ Name -> ExportFlag,
+ Name -> [RdrName])
+
+type RnM_Info s r = RnMonad GlobalNameInfo s r
+
+getGlobalNames ::
+ IfaceCache
+ -> GlobalNameInfo
+ -> UniqSupply
+ -> RdrNameHsModule
+ -> PrimIO (RnEnv,
+ [Module],
+ Bag RenamedFixityDecl,
+ Bag Error,
+ Bag Warning)
+
+getGlobalNames iface_var info us
+ (HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _)
+ = case initRn True mod emptyRnEnv us1
+ (setExtraRn info $
+ getSourceNames ty_decls cls_decls binds)
+ of { ((src_vals, src_tcs), src_errs, src_warns) ->
+
+ getImportedNames iface_var info us2 imports `thenPrimIO`
+ \ (imp_vals, imp_tcs, imp_mods, imp_fixes, imp_errs, imp_warns) ->
+
+ let
+ unqual_vals = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_vals
+ unqual_tcs = mapBag (\rn -> (Unqual (getLocalName rn), rn)) src_tcs
+
+ all_vals = bagToList (unqual_vals `unionBags` imp_vals)
+ all_tcs = bagToList (unqual_tcs `unionBags` imp_tcs)
+
+ (all_env, dups) = extendGlobalRnEnv emptyRnEnv all_vals all_tcs
+
+ dup_errs = map dup_err (equivClasses cmp_rdr (bagToList dups))
+ cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2
+ dup_err ((rdr,rn,rn'):rest) = globalDupNamesErr rdr (rn:rn': [rn|(_,_,rn)<-rest])
+
+ all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
+ all_warns = src_warns `unionBags` imp_warns
+ in
+ returnPrimIO (all_env, bagToList imp_mods, imp_fixes, all_errs, all_warns)
+ }
+ where
+ (us1, us2) = splitUniqSupply us
+\end{code}
+
+*********************************************************
+* *
+\subsection{Top-level source names}
+* *
+*********************************************************
+
+\begin{code}
+getSourceNames ::
+ [RdrNameTyDecl]
+ -> [RdrNameClassDecl]
+ -> RdrNameHsBinds
+ -> RnM_Info s (Bag RnName, -- values
+ Bag RnName) -- tycons/classes
+
+getSourceNames ty_decls cls_decls binds
+ = mapAndUnzipRn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s) ->
+ mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) ->
+ getTopBindsNames binds `thenRn` \ bind_names ->
+ returnRn (unionManyBags constrs_s `unionBags`
+ unionManyBags cls_ops_s `unionBags` bind_names,
+ listToBag tycon_s `unionBags` listToBag cls_s)
+
+
+getTyDeclNames :: RdrNameTyDecl
+ -> RnM_Info s (RnName, Bag RnName) -- tycon and constrs
+
+getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
+ = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
+ mapRn (getConDeclName (Just (nameExportFlag tycon_name)))
+ condecls `thenRn` \ con_names ->
+ returnRn (RnData tycon_name con_names,
+ listToBag (map (\ n -> RnConstr n tycon_name) con_names))
+
+getTyDeclNames (TyNew _ tycon _ condecls _ _ src_loc)
+ = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
+ mapRn (getConDeclName (Just (nameExportFlag tycon_name)))
+ condecls `thenRn` \ con_names ->
+ returnRn (RnData tycon_name con_names,
+ listToBag (map (\ n -> RnConstr n tycon_name) con_names))
+
+getTyDeclNames (TySynonym tycon _ _ src_loc)
+ = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name ->
+ returnRn (RnSyn tycon_name, emptyBag)
+
+getConDeclName exp (ConDecl con _ src_loc)
+ = newGlobalName src_loc exp con
+getConDeclName exp (ConOpDecl _ op _ src_loc)
+ = newGlobalName src_loc exp op
+getConDeclName exp (NewConDecl con _ src_loc)
+ = newGlobalName src_loc exp con
+getConDeclName exp (RecConDecl con fields src_loc)
+ = panic "getConDeclName:RecConDecl"
+ newGlobalName src_loc exp con
+
+
+getClassNames :: RdrNameClassDecl
+ -> RnM_Info s (RnName, Bag RnName) -- class and class ops
+
+getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
+ = newGlobalName src_loc Nothing cname `thenRn` \ class_name ->
+ getClassOpNames (Just (nameExportFlag class_name))
+ sigs `thenRn` \ op_names ->
+ returnRn (RnClass class_name op_names,
+ listToBag (map (\ n -> RnClassOp n class_name) op_names))
+
+getClassOpNames exp []
+ = returnRn []
+getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
+ = newGlobalName src_loc exp op `thenRn` \ op_name ->
+ getClassOpNames exp sigs `thenRn` \ op_names ->
+ returnRn (op_name : op_names)
+getClassOpNames exp (_ : sigs)
+ = getClassOpNames exp sigs
+\end{code}
+
+*********************************************************
+* *
+\subsection{Bindings}
+* *
+*********************************************************
+
+\begin{code}
+getTopBindsNames :: RdrNameHsBinds
+ -> RnM_Info s (Bag RnName)
+
+getTopBindsNames binds = doBinds binds
+
+doBinds EmptyBinds = returnRn emptyBag
+doBinds (SingleBind bind) = doBind bind
+doBinds (BindWith bind sigs) = doBind bind
+doBinds (ThenBinds binds1 binds2)
+ = andRn unionBags (doBinds binds1) (doBinds binds2)
+
+doBind EmptyBind = returnRn emptyBag
+doBind (NonRecBind mbind) = doMBinds mbind
+doBind (RecBind mbind) = doMBinds mbind
+
+doMBinds EmptyMonoBinds = returnRn emptyBag
+doMBinds (PatMonoBind pat grhss_and_binds locn) = doPat locn pat
+doMBinds (FunMonoBind p_name _ locn) = doName locn p_name
+doMBinds (AndMonoBinds mbinds1 mbinds2)
+ = andRn unionBags (doMBinds mbinds1) (doMBinds mbinds2)
+
+doPats locn pats
+ = mapRn (doPat locn) pats `thenRn` \ pats_s ->
+ returnRn (unionManyBags pats_s)
+
+doPat locn WildPatIn = returnRn emptyBag
+doPat locn (LitPatIn _) = returnRn emptyBag
+doPat locn (LazyPatIn pat) = doPat locn pat
+doPat locn (VarPatIn var) = doName locn var
+doPat locn (NegPatIn pat) = doPat locn pat
+doPat locn (ParPatIn pat) = doPat locn pat
+doPat locn (ListPatIn pats) = doPats locn pats
+doPat locn (TuplePatIn pats) = doPats locn pats
+doPat locn (ConPatIn name pats) = doPats locn pats
+doPat locn (ConOpPatIn p1 op p2)
+ = andRn unionBags (doPat locn p1) (doPat locn p2)
+doPat locn (AsPatIn as_name pat)
+ = andRn unionBags (doName locn as_name) (doPat locn pat)
+doPat locn (RecPatIn name fields)
+ = mapRn (doField locn) fields `thenRn` \ fields_s ->
+ returnRn (unionManyBags fields_s)
+
+doField locn (field, _, True{-pun-}) = doName locn field
+doField locn (field, pat, _) = doPat locn pat
+
+doName locn rdr
+ = newGlobalName locn Nothing rdr `thenRn` \ name ->
+ returnRn (unitBag (RnName name))
+\end{code}
+
+*********************************************************
+* *
+\subsection{Creating a new global name}
+* *
+*********************************************************
+
+\begin{code}
+newGlobalName :: SrcLoc -> Maybe ExportFlag
+ -> RdrName -> RnM_Info s Name
+
+newGlobalName locn maybe_exp rdr
+ = getExtraRn `thenRn` \ (_,_,exp_fn,occ_fn) ->
+ getModuleRn `thenRn` \ mod ->
+ getSourceRn `thenRn` \ source ->
+ rnGetUnique `thenRn` \ u ->
+ let
+ src_unqual = getLocalName rdr
+
+ src_orig = if fromPrelude mod
+ then (Unqual src_unqual)
+ else (Qual mod src_unqual)
+
+ exp = case maybe_exp of
+ Just exp -> exp
+ Nothing -> exp_fn n
+
+ n = if source then
+ mkTopLevName u src_orig locn exp (occ_fn n)
+ else
+ mkImportedName u rdr locn exp (occ_fn n)
+ in
+ addErrIfRn (source && isQual rdr)
+ (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
+ returnRn n
+\end{code}
+
+*********************************************************
+* *
+\subsection{Imported names}
+* *
+*********************************************************
+
+\begin{code}
+getImportedNames ::
+ IfaceCache
+ -> GlobalNameInfo -- builtin and knot name info
+ -> UniqSupply
+ -> [RdrNameImportDecl] -- import declarations
+ -> PrimIO (Bag (RdrName,RnName), -- imported values in scope
+ Bag (RdrName,RnName), -- imported tycons/classes in scope
+ Bag Module, -- directly imported modules
+ Bag RenamedFixityDecl, -- fixity info for imported names
+ Bag Error,
+ Bag Warning)
+
+getImportedNames iface_var info us imports
+ = returnPrimIO (builtin_vals, builtin_tcs, emptyBag, emptyBag, emptyBag, emptyBag)
+ where
+ -- For now jsut add the builtin names ...
+ (b_names,_,_,_) = info
+ builtin_vals = listToBag [(Unqual s, rn) | (s,rn) <- fmToList b_names, not (isRnTyCon rn)]
+ builtin_tcs = listToBag [(Unqual s, rn) | (s,rn) <- fmToList b_names, isRnTyCon rn]
+\end{code}
+
+
+\begin{code}
+globalDupNamesErr rdr rns sty
+ = ppHang (ppBesides [pprNonOp sty rdr, ppStr " multiply defined:"])
+ 4 (ppAboves (map pp_def rns))
+ where
+ pp_def rn = addShortErrLocLine (getSrcLoc rn) (\ sty -> ppr sty rn) sty
+
+ -- ToDo: print import src locs for imported names
+\end{code}
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1992-1996
-%
-\section[RnPass2]{Second renaming pass: boil down to non-duplicated info}
-
-\begin{code}
-#include "HsVersions.h"
-
-module RnPass2 (
- rnModule2
-
- -- for completeness
- ) where
-
-import Ubiq{-uitous-}
-
-import HsSyn
-import HsCore
-import HsPragmas
-import RdrHsSyn
-import RnMonad12
-
-import Bag ( Bag )
-import IdInfo ( DeforestInfo(..), Demand{-instances-}, UpdateInfo{-instance-} )
-import Outputable ( Outputable(..){-instances-} )
-import PprStyle ( PprStyle(..) )
-import Pretty -- quite a bit of it
-import ProtoName ( cmpProtoName, eqProtoName, eqByLocalName,
- elemProtoNames, elemByLocalNames,
- ProtoName(..)
- )
-import RnUtils ( dupNamesErr )
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc{-instances-} )
-import Util ( isIn, equivClasses,
- panic, panic#, pprTrace, assertPanic
- )
-\end{code}
-
-This pass removes duplicate declarations. Duplicates can arise when
-two imported interface have a signature (or whatever) for the same
-thing. We check that the two are consistent and then drop one.
-
-For preference, if one is declared in this module and the other is
-imported, we keep the former; in the case of an instance decl or type
-decl, the local version has a lot more information which we must not
-lose!
-
-Similarly, if one has interesting pragmas and one has not, we keep the
-former.
-
-The notion of ``duplicate'' includes an imported signature and a
-binding in this module. In this case, the signature is discarded.
-See note below about how this should be improved.
-
-ToDo: There are still known cases in which we blithely consider two
-declarations to be ``duplicates'' and we then select one of them, {\em
-without} actually checking that they contain the same information!
-[WDP 93/8/16] [Improved, at least WDP 93/08/26]
-
-\begin{code}
-rnModule2 :: ProtoNameHsModule -> Rn12M ProtoNameHsModule
-
-rnModule2 (HsModule mod_name exports imports fixes
- ty_decls absty_sigs class_decls inst_decls specinst_sigs
- defaults binds int_sigs src_loc)
-
- = uniquefy mod_name cmpFix selFix fixes
- `thenRn12` \ fixes ->
-
- uniquefy mod_name cmpTys selTys ty_decls
- `thenRn12` \ ty_decls ->
-
- uniquefy mod_name cmpTySigs selTySigs absty_sigs
- `thenRn12` \ absty_sigs ->
-
- uniquefy mod_name cmpClassDecl selClass class_decls
- `thenRn12` \ class_decls ->
-
- uniquefy mod_name cmpInst selInst inst_decls
- `thenRn12` \ inst_decls ->
-
- uniquefy mod_name cmpSpecInstSigs selSpecInstSigs specinst_sigs
- `thenRn12` \ specinst_sigs ->
-
- -- From the imported signatures discard any which are for
- -- variables bound in this module.
- -- But, be wary of those that *clash* with those for this
- -- module...
- -- Note that we want to do this properly later (ToDo) because imported
- -- signatures may differ from those declared in the module itself.
-
- rm_sigs_for_here mod_name int_sigs
- `thenRn12` \ non_here_int_sigs ->
-
- uniquefy mod_name cmpSig selSig non_here_int_sigs
- `thenRn12` \ int_sigs ->
- returnRn12
- (HsModule mod_name
- exports -- export and import lists are passed along
- imports -- for checking in RnPass3; no other reason
- fixes
- ty_decls
- absty_sigs
- class_decls
- inst_decls
- specinst_sigs
- defaults
- binds
- int_sigs
- src_loc)
- where
- top_level_binders = collectTopLevelBinders binds
-
- rm_sigs_for_here :: FAST_STRING -> [ProtoNameSig] -> Rn12M [ProtoNameSig]
- -- NB: operates only on interface signatures, so don't
- -- need to worry about user-pragmas, etc.
-
- rm_sigs_for_here mod_name [] = returnRn12 []
-
- rm_sigs_for_here mod_name (sig@(Sig name _ _ src_loc) : more_sigs)
- = rm_sigs_for_here mod_name more_sigs `thenRn12` \ rest_sigs ->
-
- if not (name `elemByLocalNames` top_level_binders) then -- no name clash...
- returnRn12 (sig : rest_sigs)
-
- else -- name clash...
- if name `elemProtoNames` top_level_binders
- && name_for_this_module name then
- -- the very same thing; just drop it
- returnRn12 rest_sigs
- else
- -- a different thing with the same name (due to renaming?)
- -- ToDo: locations need improving
- report_dup "(renamed?) variable"
- name src_loc name mkUnknownSrcLoc
- rest_sigs
- where
- name_for_this_module (Imp m _ _ _) = m == mod_name
- name_for_this_module other = True
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[FixityDecls-RnPass2]{Functions for @FixityDecls@}
-%* *
-%************************************************************************
-
-\begin{code}
-cmpFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> TAG_
-
-cmpFix (InfixL n1 i1) (InfixL n2 i2) = n1 `cmpProtoName` n2
-cmpFix (InfixL n1 i1) other = LT_
-cmpFix (InfixR n1 i1) (InfixR n2 i2) = n1 `cmpProtoName` n2
-cmpFix (InfixR n1 i1) (InfixN n2 i2) = LT_
-cmpFix (InfixN n1 i1) (InfixN n2 i2) = n1 `cmpProtoName` n2
-cmpFix a b = GT_
-\end{code}
-
-We are pretty un-fussy about which FixityDecl we keep.
-
-\begin{code}
-selFix :: ProtoNameFixityDecl -> ProtoNameFixityDecl -> Rn12M ProtoNameFixityDecl
-selFix f1 f2 = returnRn12 f1
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TyDecls-RnPass2]{Functions for @TyDecls@}
-%* *
-%************************************************************************
-
-\begin{code}
-cmpTys :: ProtoNameTyDecl -> ProtoNameTyDecl -> TAG_
-
-cmpTys (TyData _ n1 _ _ _ _ _) (TyData _ n2 _ _ _ _ _) = cmpProtoName n1 n2
-cmpTys (TyNew _ n1 _ _ _ _ _) (TyNew _ n2 _ _ _ _ _) = cmpProtoName n1 n2
-cmpTys (TySynonym n1 _ _ _) (TySynonym n2 _ _ _) = cmpProtoName n1 n2
-cmpTys a b
- = let tag1 = tag a
- tag2 = tag b
- in
- if tag1 _LT_ tag2 then LT_ else GT_
- where
- tag (TyData _ _ _ _ _ _ _) = (ILIT(1) :: FAST_INT)
- tag (TyNew _ _ _ _ _ _ _) = ILIT(2)
- tag (TySynonym _ _ _ _) = ILIT(3)
-\end{code}
-
-\begin{code}
-selTys :: ProtoNameTyDecl -> ProtoNameTyDecl
- -> Rn12M ProtoNameTyDecl
-
--- Note: we could check these more closely.
--- NB: It would be a mistake to cross-check derivings,
--- because we don't preserve those in interfaces.
-
-selTys td1@(TyData c name1 tvs cons1 ds pragmas1 locn1)
- td2@(TyData _ name2 _ cons2 _ pragmas2 locn2)
- = selByBetterName "algebraic datatype"
- name1 pragmas1 locn1 td1
- name2 pragmas2 locn2 td2
- (\ p -> TyData c name1 tvs cons1 ds p locn1)
- chooser_TyData
-
-selTys td1@(TyNew c name1 tvs con1 ds pragmas1 locn1)
- td2@(TyNew _ name2 _ con2 _ pragmas2 locn2)
- = selByBetterName "algebraic newtype"
- name1 pragmas1 locn1 td1
- name2 pragmas2 locn2 td2
- (\ p -> TyNew c name1 tvs con1 ds p locn1)
- chooser_TyNew
-
-selTys ts1@(TySynonym name1 tvs expand1 locn1)
- ts2@(TySynonym name2 _ expand2 locn2)
- = selByBetterName "type synonym"
- name1 bottom locn1 ts1
- name2 bottom locn2 ts2
- (\ p -> TySynonym name1 tvs expand1 locn1)
- chooser_TySynonym
- where
- bottom = panic "RnPass2:selTys:TySynonym"
-\end{code}
-
-If only one is ``abstract'' (no condecls), we take the other.
-
-Next, we check that they don't have differing lists of data
-constructors (what a disaster if those get through...); then we do a
-similar thing using pragmatic info.
-
-\begin{code}
-chooser_TyNew wout pragmas1 locn1 td1@(TyNew _ name1 _ con1 _ _ _)
- pragmas2 locn2 td2@(TyNew _ name2 _ con2 _ _ _)
- = panic "RnPass2:chooser_TyNew"
-
-
-chooser_TyData wout pragmas1 locn1 td1@(TyData _ name1 _ cons1 _ _ _)
- pragmas2 locn2 td2@(TyData _ name2 _ cons2 _ _ _)
- = let
- td1_abstract = null cons1
- td2_abstract = null cons2
-
- choose_by_pragmas = sub_chooser pragmas1 pragmas2
- in
- if td1_abstract && td2_abstract then
- choose_by_pragmas
-
- else if td1_abstract then
- returnRn12 td2
-
- else if td2_abstract then
- returnRn12 td1
-
- else if not (eqConDecls cons1 cons2) then
- report_dup "algebraic datatype (mismatched data constuctors)"
- name1 locn1 name2 locn2 td1
- else
- sub_chooser pragmas1 pragmas2
- where
- sub_chooser (DataPragmas [] []) b = returnRn12 (wout b)
- sub_chooser a (DataPragmas [] []) = returnRn12 (wout a)
- sub_chooser a@(DataPragmas cons1 specs1) (DataPragmas cons2 specs2)
- = if not (eqConDecls cons1 cons2) then
- pprTrace "Mismatched info in DATA pragmas:\n"
- (ppAbove (ppr PprDebug cons1) (ppr PprDebug cons2)) (
- returnRn12 (wout (DataPragmas [] []))
- )
- else if not (eq_data_specs specs1 specs2) then
- pprTrace "Mismatched specialisation info in DATA pragmas:\n"
- (ppAbove (ppr_data_specs specs1) (ppr_data_specs specs2)) (
- returnRn12 (wout (DataPragmas [] []))
- )
- else
- returnRn12 (wout a) -- same, pick one
-
- -- ToDo: Should we use selByBetterName ???
- -- ToDo: Report errors properly and recover quietly ???
-
- -- ToDo: Should we merge specialisations ???
-
- eq_data_specs [] [] = True
- eq_data_specs (spec1:specs1) (spec2:specs2)
- = eq_spec spec1 spec2 && eq_data_specs specs1 specs2
- eq_data_specs _ _ = False
-
- eq_spec spec1 spec2 = case cmp_spec spec1 spec2 of { EQ_ -> True; _ -> False}
-
- ppr_data_specs specs
- = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [
- ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
- | ty_maybes <- specs ]]
-
- pp_the_list [p] = p
- pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
-
- pp_maybe Nothing = pp_NONE
- pp_maybe (Just ty) = pprParendMonoType PprDebug ty
-
- pp_NONE = ppStr "_N_"
-\end{code}
-
-Sort of similar deal on synonyms: this is the time to check that the
-expansions are really the same; otherwise, we use the pragmas.
-
-\begin{code}
-chooser_TySynonym wout _ locn1 ts1@(TySynonym name1 _ expand1 _)
- _ locn2 ts2@(TySynonym name2 _ expand2 _)
- = if not (eqMonoType expand1 expand2) then
- report_dup "type synonym" name1 locn1 name2 locn2 ts1
- else
- returnRn12 ts1 -- same, just pick one
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[SpecDataSigs-RnPass2]{Functions for @SpecDataSigs@}
-%* *
-%************************************************************************
-
-\begin{code}
-cmpTySigs :: ProtoNameSpecDataSig -> ProtoNameSpecDataSig -> TAG_
-
-cmpTySigs (SpecDataSig n1 ty1 _) (SpecDataSig n2 ty2 _)
- = case cmpProtoName n1 n2 of
- EQ_ -> LT_ -- multiple SPECIALIZE data pragmas allowed
- other -> other
-
-selTySigs :: ProtoNameSpecDataSig
- -> ProtoNameSpecDataSig
- -> Rn12M ProtoNameSpecDataSig
-
-selTySigs s1@(SpecDataSig n1 ty1 locn1) s2@(SpecDataSig n2 ty2 locn2)
- = selByBetterName "SPECIALIZE data user-pragma"
- n1 bottom locn1 s1
- n2 bottom locn2 s2
- bottom bottom
- where
- bottom = panic "RnPass2:selTySigs:SpecDataSig"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ClassDecl-RnPass2]{Functions for @ClassDecls@}
-%* *
-%************************************************************************
-
-\begin{code}
-cmpClassDecl :: ProtoNameClassDecl -> ProtoNameClassDecl -> TAG_
-
-cmpClassDecl (ClassDecl _ n1 _ _ _ _ _) (ClassDecl _ n2 _ _ _ _ _)
- = cmpProtoName n1 n2
-
-selClass :: ProtoNameClassDecl -> ProtoNameClassDecl
- -> Rn12M ProtoNameClassDecl
-
-selClass cd1@(ClassDecl ctxt n1 tv sigs bs pragmas1 locn1)
- cd2@(ClassDecl _ n2 _ _ _ pragmas2 locn2)
- = selByBetterName "class"
- n1 pragmas1 locn1 cd1
- n2 pragmas2 locn2 cd2
- (\ p -> ClassDecl ctxt n1 tv sigs bs p locn1)
- chooser_Class
-\end{code}
-
-\begin{code}
-chooser_Class wout NoClassPragmas _ _ b _ _ = returnRn12 (wout b)
-chooser_Class wout a _ _ NoClassPragmas _ _ = returnRn12 (wout a)
-
-chooser_Class wout sd1@(SuperDictPragmas gs1) l1 _ sd2@(SuperDictPragmas gs2) l2 _
- = if length gs1 /= length gs2 then -- urgh
- returnRn12 (wout NoClassPragmas)
- else
- recoverQuietlyRn12 [{-no gen prags-}] (
- zipWithRn12 choose_prag gs1 gs2
- ) `thenRn12` \ new_gprags ->
- returnRn12 (wout (
- if null new_gprags then
- pprTrace "tossed all SuperDictPragmas (rename2):"
- (ppAbove (ppr PprDebug sd1) (ppr PprDebug sd2))
- NoClassPragmas
- else
- SuperDictPragmas new_gprags
- ))
- where
- choose_prag g1 g2 = selGenPragmas g1 l1 g2 l2
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[InstDecls-RnPass2]{Functions for @InstDecls@}
-%* *
-%************************************************************************
-
-\begin{code}
-cmpInst :: ProtoNameInstDecl -> ProtoNameInstDecl -> TAG_
-
-cmpInst (InstDecl c1 ty1 _ _ _ _ _ _) (InstDecl c2 ty2 _ _ _ _ _ _)
- = case cmpProtoName c1 c2 of
- EQ_ -> cmpInstanceTypes ty1 ty2
- other -> other
-\end{code}
-
-Select the instance declaration from the module (rather than an
-interface), if it exists.
-
-\begin{code}
-selInst :: ProtoNameInstDecl -> ProtoNameInstDecl
- -> Rn12M ProtoNameInstDecl
-
-selInst i1@(InstDecl c ty bs from_here1 orig_mod1 uprags pragmas1 locn1)
- i2@(InstDecl _ _ _ from_here2 orig_mod2 _ pragmas2 locn2)
- = let
- have_orig_mod1 = not (_NULL_ orig_mod1)
- have_orig_mod2 = not (_NULL_ orig_mod2)
-
- choose_no1 = returnRn12 i1
- choose_no2 = returnRn12 i2
- in
- -- generally: try to keep the locally-defined instance decl
-
- if from_here1 && from_here2 then
- -- If they are both from this module, don't throw either away,
- -- otherwise we silently discard erroneous duplicates
- trace ("selInst: duplicate instance in this module (ToDo: msg!)")
- choose_no1
-
- else if from_here1 then
- if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
- trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)")
- choose_no1
- else
- choose_no1
-
- else if from_here2 then
- if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
- trace ("selInst: instance in this module also defined somewhere else! (ToDo: msg!)")
- choose_no2
- else
- choose_no2
-
- else -- it's definitely an imported instance;
- -- first, a quick sanity check...
- if ( have_orig_mod1 && have_orig_mod2 && orig_mod1 /= orig_mod2 ) then
- trace ("selInst: `same' instances coming in from two modules! (ToDo: msg!)")
- choose_no2 -- arbitrary
- else
- panic "RnPass2: need original modules for imported instances"
-
-{- LATER ???
- -- now we *cheat*: so we can use the "informing module" stuff
- -- in "selByBetterName", we *make up* some ProtoNames for
- -- these instance decls
- let
- ii = SLIT("!*INSTANCE*!")
- n1 = Imp orig_mod1 ii [infor_mod1] ii
- n2 = Imp orig_mod2 ii [infor_mod2] ii
- in
- selByBetterName "instance"
- n1 pragmas1 locn1 i1
- n2 pragmas2 locn2 i2
- (\ p -> InstDecl c ty bs from_here1 orig_mod1 infor_mod1
- [{-none-}] p locn1)
- chooser_Inst
--}
-\end{code}
-
-\begin{code}
-chooser_Inst wout iprags1 loc1 i1 iprags2 loc2 i2
- = chk_pragmas iprags1 iprags2
- where
- -- easy cases:
- chk_pragmas NoInstancePragmas b = returnRn12 (wout b)
- chk_pragmas a NoInstancePragmas = returnRn12 (wout a)
-
- -- SimpleInstance pragmas meet: choose by GenPragmas
- chk_pragmas (SimpleInstancePragma gprags1) (SimpleInstancePragma gprags2)
- = recoverQuietlyRn12 NoGenPragmas (
- selGenPragmas gprags1 loc1 gprags2 loc2
- ) `thenRn12` \ new_prags ->
- returnRn12 (wout (
- case new_prags of
- NoGenPragmas -> NoInstancePragmas -- bottled out
- _ -> SimpleInstancePragma new_prags
- ))
-
- -- SimpleInstance pragma meets anything else... take the "else"
- chk_pragmas (SimpleInstancePragma _) b = returnRn12 (wout b)
- chk_pragmas a (SimpleInstancePragma _) = returnRn12 (wout a)
-
- chk_pragmas (ConstantInstancePragma gp1 prs1) (ConstantInstancePragma gp2 prs2)
- = recoverQuietlyRn12 NoGenPragmas (
- selGenPragmas gp1 loc1 gp2 loc2
- ) `thenRn12` \ dfun_prags ->
-
- recoverQuietlyRn12 [] (
- selNamePragmaPairs prs1 loc1 prs2 loc2
- ) `thenRn12` \ new_pairs ->
-
- returnRn12 (wout (
- if null new_pairs then -- bottled out
- case dfun_prags of
- NoGenPragmas -> NoInstancePragmas -- doubly bottled out
- _ -> SimpleInstancePragma dfun_prags
- else
- ConstantInstancePragma dfun_prags new_pairs
- ))
-
- -- SpecialisedInstancePragmas: choose by gens, then specialisations
- chk_pragmas a@(SpecialisedInstancePragma _ _) (SpecialisedInstancePragma _ _)
- = trace "not checking two SpecialisedInstancePragma pragmas!" (returnRn12 (wout a))
-
- chk_pragmas other1 other2 -- oops, bad mismatch
- = pRAGMA_ERROR "instance pragmas" (wout other1) -- ToDo: msg
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[SpecInstSigs-RnPass2]{Functions for @AbstractTypeSigs@}
-%* *
-%************************************************************************
-
-We don't make any effort to look for duplicate ``SPECIALIZE instance''
-pragmas. (Later??)
-
-We do this by make \tr{cmp*} always return \tr{LT_}---then there's
-nothing for \tr{sel*} to do!
-
-\begin{code}
-cmpSpecInstSigs
- :: ProtoNameSpecInstSig -> ProtoNameSpecInstSig -> TAG_
-
-selSpecInstSigs :: ProtoNameSpecInstSig
- -> ProtoNameSpecInstSig
- -> Rn12M ProtoNameSpecInstSig
-
-cmpSpecInstSigs a b = LT_
-selSpecInstSigs a b = panic "RnPass2:selSpecInstSigs"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Functions for SigDecls}
-%* *
-%************************************************************************
-
-These \tr{*Sig} functions only operate on things from interfaces, so
-we don't have to worry about user-pragmas and other such junk.
-
-\begin{code}
-cmpSig :: ProtoNameSig -> ProtoNameSig -> TAG_
-
-cmpSig (Sig n1 _ _ _) (Sig n2 _ _ _) = cmpProtoName n1 n2
-
-cmpSig _ _ = panic# "cmpSig (rename2)"
-
-selSig :: ProtoNameSig -> ProtoNameSig -> Rn12M ProtoNameSig
-
-selSig s1@(Sig n1 ty pragmas1 locn1) s2@(Sig n2 _ pragmas2 locn2)
- = selByBetterName "type signature"
- n1 pragmas1 locn1 s1
- n2 pragmas2 locn2 s2
- (\ p -> Sig n1 ty p locn1) -- w/out its pragmas
- chooser_Sig
-\end{code}
-
-\begin{code}
-chooser_Sig wout_prags g1 l1 s1@(Sig n1 ty1 _ _) g2 l2 s2@(Sig n2 ty2 _ _)
- = case (cmpPolyType cmpProtoName ty1 ty2) of
- EQ_ ->
- recoverQuietlyRn12 NoGenPragmas (
- selGenPragmas g1 l1 g2 l2
- ) `thenRn12` \ new_prags ->
- returnRn12 (wout_prags new_prags)
- _ -> report_dup "signature" n1 l1 n2 l2 s1
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Help functions: selecting based on pragmas}
-%* *
-%************************************************************************
-
-\begin{code}
-selGenPragmas
- :: ProtoNameGenPragmas -> SrcLoc
- -> ProtoNameGenPragmas -> SrcLoc
- -> Rn12M ProtoNameGenPragmas
-
-selGenPragmas NoGenPragmas _ b _ = returnRn12 b
-selGenPragmas a _ NoGenPragmas _ = returnRn12 a
-
-selGenPragmas g1@(GenPragmas arity1 upd1 def1 strict1 unfold1 specs1) locn1
- g2@(GenPragmas arity2 upd2 def2 strict2 unfold2 specs2) locn2
-
- = sel_arity arity1 arity2 `thenRn12` \ arity ->
- sel_upd upd1 upd2 `thenRn12` \ upd ->
- sel_def def1 def2 `thenRn12` \ def ->
- sel_strict strict1 strict2 `thenRn12` \ strict ->
- sel_unfold unfold1 unfold2 `thenRn12` \ unfold ->
- sel_specs specs1 specs2 `thenRn12` \ specs ->
- returnRn12 (GenPragmas arity upd def strict unfold specs)
- where
- sel_arity Nothing Nothing = returnRn12 Nothing
- sel_arity a@(Just a1) (Just a2) = if a1 == a2
- then returnRn12 a
- else pRAGMA_ERROR "arity pragmas" a
- sel_arity a _ = pRAGMA_ERROR "arity pragmas" a
-
- -------
- sel_upd Nothing Nothing = returnRn12 Nothing
- sel_upd a@(Just u1) (Just u2) = if u1 == u2
- then returnRn12 a
- else pRAGMA_ERROR "update pragmas" a
- sel_upd a _ = pRAGMA_ERROR "update pragmas" a
-
- -------
- sel_def Don'tDeforest Don'tDeforest = returnRn12 Don'tDeforest
- sel_def DoDeforest DoDeforest = returnRn12 DoDeforest
- sel_def a _ = pRAGMA_ERROR "deforest pragmas" a
-
- ----------
- sel_unfold NoImpUnfolding b = returnRn12 b
- sel_unfold a NoImpUnfolding = returnRn12 a
-
- sel_unfold a@(ImpUnfolding _ c1) (ImpUnfolding _ c2)
- = if c1 `eqUfExpr` c2 -- very paranoid (and rightly so)
- then returnRn12 a
- else pprTrace "mismatched unfoldings:\n" (ppAbove (ppr PprDebug c1) (ppr PprDebug c2)) (
- returnRn12 NoImpUnfolding
- )
-
- sel_unfold a@(ImpMagicUnfolding b) (ImpMagicUnfolding c)
- = if b == c then returnRn12 a else pRAGMA_ERROR "magic unfolding" a
-
- sel_unfold a _ = pRAGMA_ERROR "unfolding pragmas" a
-
- ----------
- sel_strict NoImpStrictness NoImpStrictness = returnRn12 NoImpStrictness
-
- sel_strict a@(ImpStrictness b1 i1 g1) (ImpStrictness b2 i2 g2)
- = if b1 /= b2 || i1 /= i2
- then pRAGMA_ERROR "strictness pragmas" a
- else recoverQuietlyRn12 NoGenPragmas (
- selGenPragmas g1 locn1 g2 locn2
- ) `thenRn12` \ wrkr_prags ->
- returnRn12 (ImpStrictness b1 i1 wrkr_prags)
-
- sel_strict a _ = pRAGMA_ERROR "strictness pragmas" a
-
- ---------
- sel_specs specs1 specs2
- = selSpecialisations specs1 locn1 specs2 locn2
-\end{code}
-
-\begin{code}
-selNamePragmaPairs
- :: [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
- -> [(ProtoName, ProtoNameGenPragmas)] -> SrcLoc
- -> Rn12M [(ProtoName, ProtoNameGenPragmas)]
-
-selNamePragmaPairs [] _ [] _ = returnRn12 []
-selNamePragmaPairs [] _ bs _ = returnRn12 bs
-selNamePragmaPairs as _ [] _ = returnRn12 as
-
-selNamePragmaPairs ((name1, prags1) : pairs1) loc1
- ((name2, prags2) : pairs2) loc2
-
- = if not (name1 `eqProtoName` name2) then
- -- msg of any kind??? ToDo
- pRAGMA_ERROR "named pragmas" pairs1
- else
- selGenPragmas prags1 loc1 prags2 loc2 `thenRn12` \ new_prags ->
- selNamePragmaPairs pairs1 loc1 pairs2 loc2 `thenRn12` \ rest ->
- returnRn12 ( (name1, new_prags) : rest )
-\end{code}
-
-For specialisations we merge the lists from each Sig. This allows the user to
-declare specialised prelude functions in their own PreludeSpec module.
-
-\begin{code}
-selSpecialisations
- :: [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
- -> [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)] -> SrcLoc
- -> Rn12M [([Maybe ProtoNameMonoType], Int, ProtoNameGenPragmas)]
-
-selSpecialisations [] _ [] _ = returnRn12 []
-selSpecialisations [] _ bs _ = returnRn12 bs -- arguable ... ToDo?
-selSpecialisations as _ [] _ = returnRn12 as -- ditto
-
-selSpecialisations all_specs1@((spec1, dicts1, prags1) : rest_specs1) loc1
- all_specs2@((spec2, dicts2, prags2) : rest_specs2) loc2
-
- = case (cmp_spec spec1 spec2) of
- LT_ -> selSpecialisations rest_specs1 loc1 all_specs2 loc2
- `thenRn12` \ rest ->
- returnRn12 ( (spec1, dicts1, prags1) : rest )
-
- EQ_ -> ASSERT(dicts1 == dicts2)
- recoverQuietlyRn12 NoGenPragmas (
- selGenPragmas prags1 loc1 prags2 loc2
- ) `thenRn12` \ new_prags ->
- selSpecialisations rest_specs1 loc1 rest_specs2 loc2
- `thenRn12` \ rest ->
- returnRn12 ( (spec1, dicts1, new_prags) : rest )
-
- GT_ -> selSpecialisations all_specs1 loc1 rest_specs2 loc2
- `thenRn12` \ rest ->
- returnRn12 ( (spec2, dicts2, prags2) : rest )
-
-cmp_spec [] [] = EQ_
-cmp_spec (Nothing:xs) (Nothing:ys) = cmp_spec xs ys
-cmp_spec (Just t1:xs) (Just t2:ys) = case cmpMonoType cmpProtoName t1 t2 of
- EQ_ -> cmp_spec xs ys
- xxx -> xxx
-cmp_spec (Nothing:xs) (Just t2:ys) = LT_
-cmp_spec (Just t1:xs) (Nothing:ys) = GT_
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Help functions: @uniquefy@ and @selByBetterName@}
-%* *
-%************************************************************************
-
-\begin{code}
-uniquefy :: FAST_STRING -- Module name
- -> (a -> a -> TAG_) -- Comparison function
- -> (a -> a -> Rn12M a) -- Selection function
- -> [a] -- Things to be processed
- -> Rn12M [a] -- Processed things
-
-uniquefy mod cmp sel things
- = mapRn12 (check_group_consistency sel) grouped_things
- where
- grouped_things = equivClasses cmp things
-
- check_group_consistency :: (a -> a -> Rn12M a) -- Selection function
- -> [a] -- things to be compared
- -> Rn12M a
-
- check_group_consistency sel [] = panic "RnPass2: runs produced an empty list"
- check_group_consistency sel (thing:things) = foldrRn12 sel thing things
-\end{code}
-
-@selByBetterName@: There are two ways one thing can have a ``better
-name'' than another.
-
-First: Something with an @Unk@ name is declared in this module, so we
-keep that, rather than something from an interface (with an @Imp@
-name, probably).
-
-Second: If we have two non-@Unk@ names, but one ``informant module''
-is also the {\em original} module for the entity, then we choose that
-one. I.e., if one interface says, ``I am the module that created this
-thing'' then we believe it and take that one.
-
-If we can't figure out which one to choose by the names, we use the
-info provided to select based on the pragmas.
-
-LATER: but surely we have to worry about different-by-original-name
-things which are same-by-local-name things---these should be reported
-as errors.
-
-\begin{code}
-selByBetterName :: String -- class/datatype/synonym (for error msg)
-
- -- 1st/2nd comparee name/pragmas + their things
- -> ProtoName -> pragmas -> SrcLoc -> thing
- -> ProtoName -> pragmas -> SrcLoc -> thing
-
- -- a thing without its pragmas
- -> (pragmas -> thing)
-
- -- choose-by-pragma function
- -> ((pragmas -> thing) -- thing minus its pragmas
- -> pragmas -> SrcLoc -> thing -- comparee 1
- -> pragmas -> SrcLoc -> thing -- comparee 2
- -> Rn12M thing ) -- thing w/ its new pragmas
-
- -> Rn12M thing -- selected thing
-
-selByBetterName dup_msg
- pn1 pragmas1 locn1 thing1
- pn2 pragmas2 locn2 thing2
- thing_wout_pragmas
- chooser
- = getModuleNameRn12 `thenRn12` \ mod_name ->
- let
- choose_thing1 = chk_eq (returnRn12 thing1)
- choose_thing2 = chk_eq (returnRn12 thing2)
- check_n_choose = chk_eq (chooser thing_wout_pragmas
- pragmas1 locn1 thing1
- pragmas2 locn2 thing2)
-
- dup_error = report_dup dup_msg pn1 locn1 pn2 locn2 thing1
- in
- case pn1 of
- Unk _ -> case pn2 of
- Unk _ -> dup_error
- _ -> if orig_modules_clash mod_name pn2
- then dup_error
- else choose_thing1
-
- Prel _ -> case pn2 of
- Unk _ -> if orig_modules_clash mod_name pn1
- then dup_error
- else choose_thing2
- _ -> check_n_choose
-
- Imp om1 _ im1 _ -> -- we're gonna check `informant module' info...
- case pn2 of
- Unk _ -> if orig_modules_clash mod_name pn1
- then dup_error
- else choose_thing2
- Prel _ -> check_n_choose
- Imp om2 _ im2 _
- -> let
- is_elem = isIn "selByBetterName"
-
- name1_claims_orig = om1 `is_elem` im1 && not (_NULL_ om1)
- name2_claims_orig = om2 `is_elem` im2 && not (_NULL_ om2)
- in
- if name1_claims_orig
- then if name2_claims_orig then check_n_choose else choose_thing1
- else if name2_claims_orig then choose_thing2 else check_n_choose
- where
- chk_eq if_OK
- = if not (eqProtoName pn1 pn2) && eqByLocalName pn1 pn2
- then report_dup dup_msg pn1 locn1 pn2 locn2 thing1
- else if_OK
-
- orig_modules_clash this_module pn
- = case (getOrigName pn) of { (that_module, _) ->
- not (this_module == that_module) }
-
-report_dup dup_msg pn1 locn1 pn2 locn2 thing
- = addErrRn12 err_msg `thenRn12` \ _ ->
- returnRn12 thing
- where
- err_msg = dupNamesErr dup_msg [(pn1,locn1), (pn2,locn2)]
-
-pRAGMA_ERROR :: String -> a -> Rn12M a
-pRAGMA_ERROR msg x
- = addErrRn12 (\ sty -> ppStr ("PRAGMA ERROR:"++msg)) `thenRn12` \ _ ->
- returnRn12 x
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[RnPass3]{Third of the renaming passes}
-
-The business of this pass is to:
-\begin{itemize}
-\item find all the things declared at top level,
-\item assign uniques to them
-\item return an association list mapping their @ProtoName@s to
- freshly-minted @Names@ for them.
-\end{itemize}
-
-No attempt is made to discover whether the same thing is declared
-twice: that is up to the caller to sort out.
-
-\begin{code}
-#include "HsVersions.h"
-
-module RnPass3 (
- rnModule3,
- initRn3, Rn3M(..) -- re-exported from monad
-
- -- for completeness
- ) where
-
-import Ubiq{-uitous-}
-
-import RnMonad3
-import HsSyn
-import RdrHsSyn
-
-import Bag ( emptyBag, listToBag, unionBags, unionManyBags,
- unitBag, snocBag, elemBag, bagToList, Bag
- )
-import ErrUtils
-import HsPragmas ( DataPragmas(..) )
-import Name ( Name(..) )
-import NameTypes ( fromPrelude, FullName{-instances-} )
-import Pretty
-import ProtoName ( cmpByLocalName, ProtoName(..) )
-import RnUtils ( mkGlobalNameFun,
- GlobalNameMappers(..), GlobalNameMapper(..),
- PreludeNameMappers(..), PreludeNameMapper(..),
- dupNamesErr
- )
-import SrcLoc ( SrcLoc{-instance-} )
-import Util ( isIn, removeDups, cmpPString, panic )
-\end{code}
-
-*********************************************************
-* *
-\subsection{Type declarations}
-* *
-*********************************************************
-
-\begin{code}
-type BagAssoc = Bag (ProtoName, Name) -- Bag version
-type NameSpaceAssoc = [(ProtoName, Name)] -- List version
-\end{code}
-
-
-*********************************************************
-* *
-\subsection{Main function: @rnModule3@}
-* *
-*********************************************************
-
-\begin{code}
-rnModule3 :: PreludeNameMappers
- -> Bag FAST_STRING -- list of imported module names
- -> ProtoNameHsModule
- -> Rn3M ( NameSpaceAssoc, NameSpaceAssoc,
- GlobalNameMapper, GlobalNameMapper,
- Bag Error )
-
-rnModule3 pnfs@(val_pnf, tc_pnf) imported_mod_names
- (HsModule mod_name exports imports _ ty_decls _ class_decls
- inst_decls _ _ binds sigs _)
-
- = putInfoDownM3 {- ???pnfs -} mod_name exports (
-
- doTyDecls3 ty_decls `thenRn3` \ (constrs, tycons) ->
- doClassDecls3 class_decls `thenRn3` \ (ops, classes) ->
- doBinds3 binds `thenRn3` \ val_binds ->
- doIntSigs3 sigs `thenRn3` \ val_sigs ->
-
- let val_namespace = constrs `unionBags` ops `unionBags` val_binds
- `unionBags` val_sigs
- tc_namespace = tycons `unionBags` classes
-
- (var_alist, var_dup_errs) = deal_with_dups "variable" val_pnf (bagToList val_namespace)
- (tc_alist, tc_dup_errs) = deal_with_dups "type or class" tc_pnf (bagToList tc_namespace)
- v_gnf = mkGlobalNameFun mod_name val_pnf var_alist
- tc_gnf = mkGlobalNameFun mod_name tc_pnf tc_alist
- in
-
- verifyExports v_gnf tc_gnf (imported_mod_names `snocBag` mod_name) exports
- `thenRn3` \ export_errs ->
- verifyImports v_gnf tc_gnf imports `thenRn3` \ import_errs ->
-
- returnRn3 ( var_alist, tc_alist,
- v_gnf, tc_gnf,
- var_dup_errs `unionBags` tc_dup_errs `unionBags`
- export_errs `unionBags` import_errs
- ))
- where
- deal_with_dups :: String -> PreludeNameMapper -> NameSpaceAssoc
- -> (NameSpaceAssoc, Bag Error)
-
- deal_with_dups kind_str pnf alist
- = (goodies,
- listToBag (map mk_dup_err dup_lists) `unionBags`
- listToBag (map mk_prel_dup_err prel_dups)
- )
- where
- goodies :: [(ProtoName,Name)] --NameSpaceAssoc
- dup_lists :: [[(ProtoName, Name)]]
-
- -- Find all the names which are defined twice.
- -- By "name" here, we mean "string"; that is, we are looking
- -- for places where two strings are bound to different Names
- -- in the top-level scope of this module.
-
- (singles, dup_lists) = removeDups cmp alist
- -- We want to compare their *local* names; the removeDups thing
- -- is checking for whether two objects have the same local name.
- cmp (a, _) (b, _) = cmpByLocalName a b
-
- -- Anything in alist with a Unk name is defined right here in
- -- this module; hence, it should not be a prelude name. We
- -- need to check this separately, because the prelude is
- -- imported only implicitly, via the PrelNameFuns argument
-
- (goodies, prel_dups) = if fromPrelude mod_name then
- (singles, []) -- Compiling the prelude, so ignore this check
- else
- partition local_def_of_prelude_thing singles
-
- local_def_of_prelude_thing (Unk s, _)
- = case pnf s of
- Just _ -> False -- Eek! It's a prelude name
- Nothing -> True -- It isn't; all is ok
- local_def_of_prelude_thing other = True
-
- mk_dup_err :: [(ProtoName, Name)] -> Error
- mk_dup_err dups_of_name
- = let
- dup_pnames_w_src_loc = [ (pn, getSrcLoc name) | (pn,name) <- dups_of_name ]
- in
- dupNamesErr kind_str dup_pnames_w_src_loc
-
- -- This module defines a prelude thing
- mk_prel_dup_err :: (ProtoName, Name) -> Error
- mk_prel_dup_err (pn, name)
- = dupPreludeNameErr kind_str (pn, getSrcLoc name)
-\end{code}
-
-*********************************************************
-* *
-\subsection{Type and class declarations}
-* *
-*********************************************************
-
-\begin{code}
-doTyDecls3 :: [ProtoNameTyDecl] -> Rn3M (BagAssoc, BagAssoc)
-
-doTyDecls3 [] = returnRn3 (emptyBag, emptyBag)
-
-doTyDecls3 (tyd:tyds)
- = andRn3 combiner (do_decl tyd) (doTyDecls3 tyds)
- where
- combiner (cons1, tycons1) (cons2, tycons2)
- = (cons1 `unionBags` cons2, tycons1 `unionBags` tycons2)
-
- do_decl (TyData context tycon tyvars condecls _ pragmas src_loc)
- = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
- `thenRn3` \ (uniq, tycon_name) ->
- let
- exp_flag = getExportFlag tycon_name
- -- we want to force all data cons to have the very
- -- same export flag as their type constructor
- in
- doConDecls3 False{-not invisibles-} exp_flag condecls `thenRn3` \ data_cons ->
- do_data_pragmas exp_flag pragmas `thenRn3` \ pragma_data_cons ->
- returnRn3 (data_cons `unionBags` pragma_data_cons,
- unitBag (tycon, TyConName uniq tycon_name (length tyvars)
- True -- indicates data/newtype tycon
- [ c | (_,c) <- bagToList data_cons ]))
-
- do_decl (TyNew context tycon tyvars condecl _ pragmas src_loc)
- = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
- `thenRn3` \ (uniq, tycon_name) ->
- let
- exp_flag = getExportFlag tycon_name
- -- we want to force all data cons to have the very
- -- same export flag as their type constructor
- in
- doConDecls3 False{-not invisibles-} exp_flag condecl `thenRn3` \ data_con ->
- do_data_pragmas exp_flag pragmas `thenRn3` \ pragma_data_con ->
- returnRn3 (data_con `unionBags` pragma_data_con,
- unitBag (tycon, TyConName uniq tycon_name (length tyvars)
- True -- indicates data/newtype tycon
- [ c | (_,c) <- bagToList data_con ]))
-
- do_decl (TySynonym tycon tyvars monoty src_loc)
- = newFullNameM3 tycon src_loc True{-tycon-ish-} Nothing
- `thenRn3` \ (uniq, tycon_name) ->
- returnRn3 (emptyBag,
- unitBag (tycon, TyConName uniq tycon_name (length tyvars) False bottom))
- -- Flase indicates type tycon
- where
- bottom = panic "do_decl: data cons on synonym?"
-
- do_data_pragmas exp_flag (DataPragmas con_decls specs)
- = doConDecls3 True{-invisibles-} exp_flag con_decls
-\end{code}
-
-\begin{code}
-doConDecls3 :: Bool -- True <=> mk invisible FullNames
- -> ExportFlag -- Export flag of the TyCon; we want
- -- to force its use.
- -> [ProtoNameConDecl]
- -> Rn3M BagAssoc
-
-doConDecls3 _ _ [] = returnRn3 emptyBag
-
-doConDecls3 want_invisibles exp_flag (cd:cds)
- = andRn3 unionBags (do_decl cd) (doConDecls3 want_invisibles exp_flag cds)
- where
- mk_name = if want_invisibles then newInvisibleNameM3 else newFullNameM3
-
- do_decl (ConDecl con tys src_loc)
- = mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
- returnRn3 (unitBag (con, ValName uniq con_name))
- do_decl (ConOpDecl ty1 op ty2 src_loc)
- = mk_name op src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
- returnRn3 (unitBag (op, ValName uniq con_name))
- do_decl (NewConDecl con ty src_loc)
- = mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
- returnRn3 (unitBag (con, ValName uniq con_name))
- do_decl (RecConDecl con fields src_loc)
- = _trace "doConDecls3:RecConDecl:nothing for fields\n" $
- mk_name con src_loc True{-tycon-ish-} (Just exp_flag) `thenRn3` \ (uniq, con_name) ->
- returnRn3 (unitBag (con, ValName uniq con_name))
-\end{code}
-
-
-@doClassDecls3@ uses the `name function' to map local class names into
-original names, calling @doClassOps3@ to do the same for the
-class operations. @doClassDecls3@ is used to process module
-class declarations.
-
-\begin{code}
-doClassDecls3 :: [ProtoNameClassDecl] -> Rn3M (BagAssoc, BagAssoc)
-
-doClassDecls3 [] = returnRn3 (emptyBag, emptyBag)
-
-doClassDecls3 (cd:cds)
- = andRn3 combiner (do_decl cd) (doClassDecls3 cds)
- where
- combiner (ops1, classes1) (ops2, classes2)
- = (ops1 `unionBags` ops2, classes1 `unionBags` classes2)
-
- do_decl (ClassDecl context cname@(Prel c) tyvar sigs defaults pragmas src_loc)
- = doClassOps3 c 1 sigs `thenRn3` \ (_, ops) ->
- returnRn3 (ops, unitBag (cname, c))
-
- do_decl (ClassDecl context cname tyvar sigs defaults pragmas src_loc)
- = newFullNameM3 cname src_loc True{-tycon-ish-} Nothing
- `thenRn3` \ (uniq, class_name) ->
- fixRn3 ( \ ~(clas_ops,_) ->
- let
- class_Name = ClassName uniq class_name
- [ o | (_,o) <- bagToList clas_ops ]
- in
- doClassOps3 class_Name 1 sigs `thenRn3` \ (_, ops) ->
- returnRn3 (ops, class_Name)
- ) `thenRn3` \ (ops, class_Name) ->
-
- returnRn3 (ops, unitBag (cname, class_Name))
-\end{code}
-
-We stitch on a class-op tag to each class operation. They are guaranteed
-to be done in left-to-right order.
-
-\begin{code}
-doClassOps3 :: Name{-class-} -> Int -> [ProtoNameSig] -> Rn3M (Int, BagAssoc)
-
-doClassOps3 clas tag [] = returnRn3 (tag, emptyBag)
-
-doClassOps3 clas tag (sig:rest)
- = do_op sig `thenRn3` \ (tag1, bag1) ->
- doClassOps3 clas tag1 rest `thenRn3` \ (tagr, bagr) ->
- returnRn3 (tagr, bag1 `unionBags` bagr)
- where
-{- LATER: NB: OtherVal is a Name, not a ProtoName
- do_op (ClassOpSig op@(OtherVal uniq name) ty pragma src_loc)
- = -- A classop whose unique is pre-ordained, so the type checker
- -- can look it up easily
- let
- op_name = ClassOpName uniq clas (snd (getOrigName name)) tag
- in
- returnRn3 (tag+1, unitBag (op, op_name))
--}
-
- do_op (ClassOpSig op ty pragma src_loc)
- = newFullNameM3 op src_loc False{-not tyconish-} Nothing `thenRn3` \ (uniq, _) ->
- let
- op_name = ClassOpName uniq clas (get_str op) tag
- in
- returnRn3 (tag+1, unitBag (op, op_name))
- where
- -- A rather yukky function to get the original name out of a
- -- class operation. The "snd (getOrigName ...)" in the other
- -- ClassOpSig case does the corresponding yukky thing.
- get_str :: ProtoName -> FAST_STRING
- get_str (Unk s) = s
- get_str (Qunk _ s) = s
- get_str (Imp _ d _ _) = d
-\end{code}
-
-Remember, interface signatures don't have user-pragmas, etc., in them.
-\begin{code}
-doIntSigs3 :: [ProtoNameSig] -> Rn3M BagAssoc
-
-doIntSigs3 [] = returnRn3 emptyBag
-
-doIntSigs3 (s:ss)
- = andRn3 unionBags (do_sig s) (doIntSigs3 ss)
- where
- do_sig (Sig v ty pragma src_loc)
- = newFullNameM3 v src_loc False{-distinctly untycon-ish-} Nothing
- `thenRn3` \ (uniq, v_fname) ->
- returnRn3 (unitBag (v, ValName uniq v_fname))
-\end{code}
-
-*********************************************************
-* *
-\subsection{Bindings}
-* *
-*********************************************************
-
-\begin{code}
-doBinds3 :: ProtoNameHsBinds -> Rn3M BagAssoc
-
-doBinds3 EmptyBinds = returnRn3 emptyBag
-
-doBinds3 (ThenBinds binds1 binds2)
- = andRn3 unionBags (doBinds3 binds1) (doBinds3 binds2)
-
-doBinds3 (SingleBind bind) = doBind3 bind
-
-doBinds3 (BindWith bind sigs) = doBind3 bind
-\end{code}
-
-\begin{code}
-doBind3 :: ProtoNameBind -> Rn3M BagAssoc
-doBind3 EmptyBind = returnRn3 emptyBag
-doBind3 (NonRecBind mbind) = doMBinds3 mbind
-doBind3 (RecBind mbind) = doMBinds3 mbind
-
-doMBinds3 :: ProtoNameMonoBinds -> Rn3M BagAssoc
-
-doMBinds3 EmptyMonoBinds = returnRn3 emptyBag
-doMBinds3 (PatMonoBind pat grhss_and_binds locn) = doPat3 locn pat
-doMBinds3 (FunMonoBind p_name _ locn) = doTopLevName locn p_name
-
-doMBinds3 (AndMonoBinds mbinds1 mbinds2)
- = andRn3 unionBags (doMBinds3 mbinds1) (doMBinds3 mbinds2)
-\end{code}
-
-Fold over a list of patterns:
-\begin{code}
-doPats3 locn [] = returnRn3 emptyBag
-doPats3 locn (pat:pats)
- = andRn3 unionBags (doPat3 locn pat) (doPats3 locn pats)
-\end{code}
-
-\begin{code}
-doPat3 :: SrcLoc -> ProtoNamePat -> Rn3M BagAssoc
-
-doPat3 locn WildPatIn = returnRn3 emptyBag
-doPat3 locn (LitPatIn _) = returnRn3 emptyBag
-doPat3 locn (LazyPatIn pat) = doPat3 locn pat
-doPat3 locn (VarPatIn n) = doTopLevName locn n
-doPat3 locn (ListPatIn pats) = doPats3 locn pats
-doPat3 locn (TuplePatIn pats) = doPats3 locn pats
-
-doPat3 locn (AsPatIn p_name pat)
- = andRn3 unionBags (doTopLevName locn p_name) (doPat3 locn pat)
-
-doPat3 locn (ConPatIn name pats) = doPats3 locn pats
-
-doPat3 locn (ConOpPatIn pat1 name pat2)
- = andRn3 unionBags (doPat3 locn pat1) (doPat3 locn pat2)
-\end{code}
-
-\begin{code}
-doTopLevName :: SrcLoc -> ProtoName -> Rn3M BagAssoc
-
-doTopLevName locn pn
- = newFullNameM3 pn locn False{-un-tycon-ish-} Nothing `thenRn3` \ (uniq, name) ->
- returnRn3 (unitBag (pn, ValName uniq name))
-\end{code}
-
-Have to check that export/imports lists aren't too drug-crazed.
-
-\begin{code}
-verifyExports :: GlobalNameMapper -> GlobalNameMapper
- -> Bag FAST_STRING -- module names that might appear
- -- in an export list; includes the
- -- name of this module
- -> Maybe [IE ProtoName] -- export list
- -> Rn3M (Bag Error)
-
-verifyExports _ _ _ Nothing{-no export list-} = returnRn3 emptyBag
-
-verifyExports v_gnf tc_gnf imported_mod_names export_list@(Just exports)
- = mapRn3 verify exports `thenRn3` \ errs ->
- chk_exp_dups export_list `thenRn3` \ dup_errs ->
- returnRn3 (unionManyBags (errs ++ dup_errs))
- where
- ok = returnRn3 emptyBag
- naughty nm msg = returnRn3 (unitBag (badExportNameErr (_UNPK_ nm) msg))
- undef_name nm = naughty nm "is not defined."
- dup_name (nm:_)= naughty nm "occurs more than once."
-
- undef_name :: FAST_STRING -> Rn3M (Bag Error)
- dup_name :: [FAST_STRING] -> Rn3M (Bag Error)
-
- ----------------
- chk_exp_dups :: Maybe [IE ProtoName] -> Rn3M [Bag Error]
-
- chk_exp_dups exports
- = let
- export_strs = [ nm | (nm, _) <- fst (getRawExportees exports) ]
- (_, dup_lists) = removeDups cmpByLocalName{-????-} export_strs
- in
- mapRn3 dup_name [map getOccurrenceName dl | dl <- dup_lists]
-
- ---------------- the more serious checking
- verify :: IE ProtoName -> Rn3M (Bag Error)
-
- verify (IEVar v)
- = case (v_gnf v) of { Nothing -> undef_name (getOccurrenceName v); _ -> ok }
-
- verify (IEModuleContents mod)
- = if not (mod `elemBag` imported_mod_names) then undef_name mod else ok
-
- verify (IEThingAbs tc)
- = case (tc_gnf tc) of
- Nothing -> undef_name (getOccurrenceName tc)
- Just nm -> let
- naughty_tc = naughty (getOccurrenceName tc)
- in
- case nm of
- TyConName _ _ _ False{-syn-} _
- -> naughty_tc "must be exported with a `(..)' -- it's a synonym."
-
- ClassName _ _ _
- -> naughty_tc "cannot be exported \"abstractly\" (it's a class)."
- _ -> ok
-
- verify (IEThingAll tc)
- = case (tc_gnf tc) of
- Nothing -> undef_name (getOccurrenceName tc)
- Just nm -> let
- naughty_tc = naughty (getOccurrenceName tc)
- in
- case nm of
- TyConName _ _ _ True{-data or newtype-} [{-no cons-}]
- -> naughty_tc "can't be exported with a `(..)' -- it was imported abstractly."
- _ -> ok
-
-{- OLD:
- verify (IEConWithCons tc cs)
- = case (tc_gnf tc) of
- Nothing -> undef_name tc
- Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs ->
- returnRn3 (unionManyBags errs)
- -- ToDo: turgid checking which we don't care about (WDP 94/10)
-
- verify (IEClsWithOps c ms)
- = case (tc_gnf c) of
- Nothing -> undef_name c
- Just _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs ->
- returnRn3 (unionManyBags errs)
- -- ToDo: turgid checking which we don't care about (WDP 94/10)
--}
-\end{code}
-
-Note: we're not too particular about whether something mentioned in an
-import list is in {\em that} interface... (ToDo? Probably not.)
-
-\begin{code}
-verifyImports :: GlobalNameMapper -> GlobalNameMapper
- -> [ProtoNameImportedInterface]
- -> Rn3M (Bag Error)
-
-verifyImports v_gnf tc_gnf imports
- = mapRn3 chk_one (map collect imports) `thenRn3` \ errs ->
- returnRn3 (unionManyBags errs)
- where
- -- collect: name/locn, import list
-
- collect (ImportMod iff qual asmod details)
- = (iface iff, imp_list, hide_list)
- where
- (imp_list, hide_list)
- = case details of
- Nothing -> ([], [])
- Just (True{-hidden-}, ies) -> ([], ies)
- Just (_ {-unhidden-}, ies) -> (ies, [])
-
- ------------
- iface (Interface name _ _ _ _ _ _ locn) = (name, locn)
-
- ------------
- chk_one :: ((FAST_STRING, SrcLoc), [IE ProtoName], [IE ProtoName])
- -> Rn3M (Bag Error)
-
- chk_one ((mod_name, locn), import_list, hide_list)
- = mapRn3 verify import_list `thenRn3` \ errs1 ->
- chk_imp_dups import_list `thenRn3` \ dup_errs ->
- -- ToDo: we could check the hiding list more carefully
- chk_imp_dups hide_list `thenRn3` \ dup_errs2 ->
- returnRn3 (unionManyBags (errs1 ++ dup_errs ++ dup_errs2))
- where
- ok = returnRn3 emptyBag
- naughty nm msg = returnRn3 (unitBag (badImportNameErr (_UNPK_ mod_name) (_UNPK_ nm) msg locn))
- undef_name nm = naughty nm "is not defined."
- dup_name (nm:_) = naughty nm "occurs more than once."
-
- undef_name :: FAST_STRING -> Rn3M (Bag Error)
- dup_name :: [FAST_STRING] -> Rn3M (Bag Error)
-
- ----------------
- chk_imp_dups imports
- = let
- import_strs = getRawImportees imports
- (_, dup_lists) = removeDups _CMP_STRING_ import_strs
- in
- mapRn3 dup_name dup_lists
-
- ----------------
- verify :: IE ProtoName -> Rn3M (Bag Error)
-
- verify (IEVar v)
- = case (v_gnf v) of { Nothing -> undef_name (getOccurrenceName v); _ -> ok }
-
- verify (IEThingAbs tc)
- = case (tc_gnf tc) of
- Nothing -> undef_name (getOccurrenceName tc)
- Just nm -> let
- naughty_tc = naughty (getOccurrenceName tc)
- in
- case nm of
- TyConName _ _ _ False{-syn-} _
- -> naughty_tc "must be imported with a `(..)' -- it's a synonym."
- ClassName _ _ _
- -> naughty_tc "cannot be imported \"abstractly\" (it's a class)."
- _ -> ok
-
- verify (IEThingAll tc)
- = case (tc_gnf tc) of
- Nothing -> undef_name (getOccurrenceName tc)
- Just nm -> let
- naughty_tc = naughty (getOccurrenceName tc)
- in
- case nm of
- TyConName _ _ _ True{-data or newtype-} [{-no cons-}]
- -> naughty_tc "can't be imported with a `(..)' -- the interface says it's abstract."
- _ -> ok
-
-{- OLD:
- verify (IEConWithCons tc cs)
- = case (tc_gnf tc) of
- Nothing -> undef_name (getOccurrenceName tc)
- Just nm -> mapRn3 verify (map IEVar cs) `thenRn3` \ errs ->
- returnRn3 (unionManyBags errs)
- -- One could add a great wad of tedious checking
- -- here, but I am too lazy to do so. WDP 94/10
-
- verify (IEClsWithOps c ms)
- = case (tc_gnf c) of
- Nothing -> undef_name (getOccurrenceName c)
- Just _ -> mapRn3 verify (map IEVar ms) `thenRn3` \ errs ->
- returnRn3 (unionManyBags errs)
- -- Ditto about tedious checking. WDP 94/10
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Error messages}
-%* *
-%************************************************************************
-
-\begin{code}
-badExportNameErr name whats_wrong
- = dontAddErrLoc
- "Error in the export list" ( \ sty ->
- ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
-
-------------------------------------------
-badImportNameErr mod name whats_wrong locn
- = addErrLoc locn
- ("Error in an import list for the module `"++mod++"'") ( \ sty ->
- ppBesides [ppChar '`', ppStr name, ppStr "' ", ppStr whats_wrong] )
-
-----------------------------
--- dupNamesErr: from RnUtils
-
---------------------------------------
-dupPreludeNameErr descriptor (nm, locn)
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ ppStr "A conflict with a Prelude ", ppStr descriptor,
- ppStr ": ", ppr sty nm ])
-\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnSource]{Main pass of renamer}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnSource ( rnSource, rnPolyType ) where
+
+import Ubiq
+import RnLoop -- *check* the RnPass4/RnExpr4/RnBinds4 loop-breaking
+
+import HsSyn
+import HsPragmas
+import RdrHsSyn
+import RnHsSyn
+import RnMonad
+import RnBinds ( rnTopBinds, rnMethodBinds )
+
+import Bag ( bagToList )
+import Class ( derivableClassKeys )
+import ListSetOps ( unionLists, minusList )
+import Name ( RdrName )
+import Maybes ( maybeToBool, catMaybes )
+import Outputable ( isLocallyDefined, isAvarid, getLocalName, ExportFlag(..) )
+import Pretty
+import SrcLoc ( SrcLoc )
+import Unique ( Unique )
+import UniqFM ( addListToUFM, listToUFM )
+import UniqSet ( UniqSet(..) )
+import Util ( isn'tIn, panic, assertPanic )
+
+rnExports mods Nothing = returnRn (\n -> ExportAll)
+rnExports mods (Just exps) = returnRn (\n -> ExportAll)
+\end{code}
+
+rnSource `renames' the source module and export list.
+It simultaneously performs dependency analysis and precedence parsing.
+It also does the following error checks:
+\begin{enumerate}
+\item
+Checks that tyvars are used properly. This includes checking
+for undefined tyvars, and tyvars in contexts that are ambiguous.
+\item
+Checks that all variable occurences are defined.
+\item
+Checks the (..) etc constraints in the export list.
+\end{enumerate}
+
+
+\begin{code}
+rnSource :: [Module] -- imported modules
+ -> Bag RenamedFixityDecl -- fixity info for imported names
+ -> RdrNameHsModule
+ -> RnM s (RenamedHsModule,
+ Name -> ExportFlag, -- export info
+ Bag (RnName, RdrName)) -- occurrence info
+
+rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes
+ ty_decls specdata_sigs class_decls
+ inst_decls specinst_sigs defaults
+ binds _ src_loc)
+
+ = pushSrcLocRn src_loc $
+
+ rnExports (mod:imp_mods) exports `thenRn` \ exported_fn ->
+ rnFixes fixes `thenRn` \ src_fixes ->
+ let
+ pair_name (InfixL n i) = (n, i)
+ pair_name (InfixR n i) = (n, i)
+ pair_name (InfixN n i) = (n, i)
+
+ imp_fixes_fm = listToUFM (map pair_name (bagToList imp_fixes))
+ all_fixes_fm = addListToUFM imp_fixes_fm (map pair_name src_fixes)
+ in
+ setExtraRn {-all_fixes_fm-}(panic "rnSource:all_fixes_fm") $
+
+ mapRn rnTyDecl ty_decls `thenRn` \ new_ty_decls ->
+ mapRn rnSpecDataSig specdata_sigs `thenRn` \ new_specdata_sigs ->
+ mapRn rnClassDecl class_decls `thenRn` \ new_class_decls ->
+ mapRn rnInstDecl inst_decls `thenRn` \ new_inst_decls ->
+ mapRn rnSpecInstSig specinst_sigs `thenRn` \ new_specinst_sigs ->
+ rnDefaultDecl defaults `thenRn` \ new_defaults ->
+ rnTopBinds binds `thenRn` \ new_binds ->
+
+ getOccurrenceUpRn `thenRn` \ occ_info ->
+
+ returnRn (
+ HsModule mod version
+ trashed_exports trashed_imports
+ {-new_fixes-}(panic "rnSource:new_fixes (Hi, Patrick!)")
+ new_ty_decls new_specdata_sigs new_class_decls
+ new_inst_decls new_specinst_sigs new_defaults
+ new_binds [] src_loc,
+ exported_fn,
+ occ_info
+ )
+ where
+ trashed_exports = panic "rnSource:trashed_exports"
+ trashed_imports = panic "rnSource:trashed_imports"
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Type declarations}
+%* *
+%*********************************************************
+
+@rnTyDecl@ uses the `global name function' to create a new type
+declaration in which local names have been replaced by their original
+names, reporting any unknown names.
+
+Renaming type variables is a pain. Because they now contain uniques,
+it is necessary to pass in an association list which maps a parsed
+tyvar to its Name representation. In some cases (type signatures of
+values), it is even necessary to go over the type first in order to
+get the set of tyvars used by it, make an assoc list, and then go over
+it again to rename the tyvars! However, we can also do some scoping
+checks at the same time.
+
+\begin{code}
+rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
+
+rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
+ = pushSrcLocRn src_loc $
+ lookupTyCon tycon `thenRn` \ tycon' ->
+ mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
+ rnContext tv_env context `thenRn` \ context' ->
+ rnConDecls tv_env condecls `thenRn` \ condecls' ->
+ rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
+ ASSERT(isNoDataPragmas pragmas)
+ returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
+
+rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
+ = pushSrcLocRn src_loc $
+ lookupTyCon tycon `thenRn` \ tycon' ->
+ mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
+ rnContext tv_env context `thenRn` \ context' ->
+ rnConDecls tv_env condecl `thenRn` \ condecl' ->
+ rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
+ ASSERT(isNoDataPragmas pragmas)
+ returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
+
+rnTyDecl (TySynonym name tyvars ty src_loc)
+ = pushSrcLocRn src_loc $
+ lookupTyCon name `thenRn` \ name' ->
+ mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
+ rnMonoType tv_env ty `thenRn` \ ty' ->
+ returnRn (TySynonym name' tyvars' ty' src_loc)
+
+rn_derivs tycon2 locn Nothing -- derivs not specified
+ = returnRn Nothing
+
+rn_derivs tycon2 locn (Just ds)
+ = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
+ returnRn (Just derivs)
+ where
+ rn_deriv tycon2 locn clas
+ = lookupClass clas `thenRn` \ clas_name ->
+ addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
+ (derivingNonStdClassErr clas locn)
+ `thenRn_`
+ returnRn clas_name
+ where
+ not_elem = isn'tIn "rn_deriv"
+\end{code}
+
+@rnConDecls@ uses the `global name function' to create a new
+constructor in which local names have been replaced by their original
+names, reporting any unknown names.
+
+\begin{code}
+rnConDecls :: TyVarNamesEnv
+ -> [RdrNameConDecl]
+ -> RnM_Fixes s [RenamedConDecl]
+
+rnConDecls tv_env con_decls
+ = mapRn rn_decl con_decls
+ where
+ rn_decl (ConDecl name tys src_loc)
+ = pushSrcLocRn src_loc $
+ lookupValue name `thenRn` \ new_name ->
+ mapRn rn_bang_ty tys `thenRn` \ new_tys ->
+ returnRn (ConDecl new_name new_tys src_loc)
+
+ rn_decl (ConOpDecl ty1 op ty2 src_loc)
+ = pushSrcLocRn src_loc $
+ lookupValue op `thenRn` \ new_op ->
+ rn_bang_ty ty1 `thenRn` \ new_ty1 ->
+ rn_bang_ty ty2 `thenRn` \ new_ty2 ->
+ returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
+
+ rn_decl (NewConDecl name ty src_loc)
+ = pushSrcLocRn src_loc $
+ lookupValue name `thenRn` \ new_name ->
+ rn_mono_ty ty `thenRn` \ new_ty ->
+ returnRn (NewConDecl new_name new_ty src_loc)
+
+ rn_decl (RecConDecl con fields src_loc)
+ = panic "rnConDecls:RecConDecl"
+
+ ----------
+ rn_mono_ty = rnMonoType tv_env
+
+ rn_bang_ty (Banged ty)
+ = rn_mono_ty ty `thenRn` \ new_ty ->
+ returnRn (Banged new_ty)
+ rn_bang_ty (Unbanged ty)
+ = rn_mono_ty ty `thenRn` \ new_ty ->
+ returnRn (Unbanged new_ty)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{SPECIALIZE data pragmas}
+%* *
+%*********************************************************
+
+\begin{code}
+rnSpecDataSig :: RdrNameSpecDataSig
+ -> RnM_Fixes s RenamedSpecDataSig
+
+rnSpecDataSig (SpecDataSig tycon ty src_loc)
+ = pushSrcLocRn src_loc $
+ let
+ tyvars = extractMonoTyNames ty
+ in
+ mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
+ lookupTyCon tycon `thenRn` \ tycon' ->
+ rnMonoType tv_env ty `thenRn` \ ty' ->
+ returnRn (SpecDataSig tycon' ty' src_loc)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Class declarations}
+%* *
+%*********************************************************
+
+@rnClassDecl@ uses the `global name function' to create a new
+class declaration in which local names have been replaced by their
+original names, reporting any unknown names.
+
+\begin{code}
+rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
+
+rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
+ = pushSrcLocRn src_loc $
+ mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
+ rnContext tv_env context `thenRn` \ context' ->
+ lookupClass cname `thenRn` \ cname' ->
+ mapRn (rn_op cname' tv_env) sigs `thenRn` \ sigs' ->
+ rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
+ ASSERT(isNoClassPragmas pragmas)
+ returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
+ where
+ rn_op clas tv_env (ClassOpSig op ty pragmas locn)
+ = pushSrcLocRn locn $
+ lookupClassOp clas op `thenRn` \ op_name ->
+ rnPolyType tv_env ty `thenRn` \ new_ty ->
+
+{-
+*** Please check here that tyvar' appears in new_ty ***
+*** (used to be in tcClassSig, but it's better here)
+*** not_elem = isn'tIn "tcClassSigs"
+*** -- Check that the class type variable is mentioned
+*** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
+*** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
+-}
+
+ ASSERT(isNoClassOpPragmas pragmas)
+ returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Instance declarations}
+%* *
+%*********************************************************
+
+
+@rnInstDecl@ uses the `global name function' to create a new of
+instance declaration in which local names have been replaced by their
+original names, reporting any unknown names.
+
+\begin{code}
+rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
+
+rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
+ = pushSrcLocRn src_loc $
+ lookupClass cname `thenRn` \ cname' ->
+
+ rnPolyType [] ty `thenRn` \ ty' ->
+ -- [] tv_env ensures that tyvars will be foralled
+
+ rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
+ mapRn (rn_uprag cname') uprags `thenRn` \ new_uprags ->
+
+ ASSERT(isNoInstancePragmas pragmas)
+ returnRn (InstDecl cname' ty' mbinds'
+ from_here modname new_uprags noInstancePragmas src_loc)
+ where
+ rn_uprag class_name (SpecSig op ty using locn)
+ = pushSrcLocRn src_loc $
+ lookupClassOp class_name op `thenRn` \ op_name ->
+ rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
+ rn_using using `thenRn` \ new_using ->
+ returnRn (SpecSig op_name new_ty new_using locn)
+
+ rn_uprag class_name (InlineSig op locn)
+ = pushSrcLocRn locn $
+ lookupClassOp class_name op `thenRn` \ op_name ->
+ returnRn (InlineSig op_name locn)
+
+ rn_uprag class_name (DeforestSig op locn)
+ = pushSrcLocRn locn $
+ lookupClassOp class_name op `thenRn` \ op_name ->
+ returnRn (DeforestSig op_name locn)
+
+ rn_uprag class_name (MagicUnfoldingSig op str locn)
+ = pushSrcLocRn locn $
+ lookupClassOp class_name op `thenRn` \ op_name ->
+ returnRn (MagicUnfoldingSig op_name str locn)
+
+ rn_using Nothing
+ = returnRn Nothing
+ rn_using (Just v)
+ = lookupValue v `thenRn` \ new_v ->
+ returnRn (Just new_v)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{@SPECIALIZE instance@ user-pragmas}
+%* *
+%*********************************************************
+
+\begin{code}
+rnSpecInstSig :: RdrNameSpecInstSig
+ -> RnM_Fixes s RenamedSpecInstSig
+
+rnSpecInstSig (SpecInstSig clas ty src_loc)
+ = pushSrcLocRn src_loc $
+ let
+ tyvars = extractMonoTyNames ty
+ in
+ mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
+ lookupClass clas `thenRn` \ new_clas ->
+ rnMonoType tv_env ty `thenRn` \ new_ty ->
+ returnRn (SpecInstSig new_clas new_ty src_loc)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Default declarations}
+%* *
+%*********************************************************
+
+@rnDefaultDecl@ uses the `global name function' to create a new set
+of default declarations in which local names have been replaced by
+their original names, reporting any unknown names.
+
+\begin{code}
+rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
+
+rnDefaultDecl [] = returnRn []
+rnDefaultDecl [DefaultDecl tys src_loc]
+ = pushSrcLocRn src_loc $
+ mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
+ returnRn [DefaultDecl tys' src_loc]
+rnDefaultDecl defs@(d:ds)
+ = addErrRn (dupDefaultDeclErr defs) `thenRn_`
+ rnDefaultDecl [d]
+\end{code}
+
+%*************************************************************************
+%* *
+\subsection{Fixity declarations}
+%* *
+%*************************************************************************
+
+\begin{code}
+rnFixes :: [RdrNameFixityDecl] -> RnM s [RenamedFixityDecl]
+
+rnFixes fixities
+ = mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
+ returnRn (catMaybes fixes_maybe)
+ where
+ rn_fixity fix@(InfixL name i)
+ = rn_fixity_pieces InfixL name i fix
+ rn_fixity fix@(InfixR name i)
+ = rn_fixity_pieces InfixR name i fix
+ rn_fixity fix@(InfixN name i)
+ = rn_fixity_pieces InfixN name i fix
+
+ rn_fixity_pieces mk_fixity name i fix
+ = lookupValueMaybe name `thenRn` \ maybe_res ->
+ case maybe_res of
+ Just res | isLocallyDefined res
+ -> returnRn (Just (mk_fixity res i))
+ _ -> failButContinueRn Nothing (undefinedFixityDeclErr fix)
+
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Support code to rename types}
+%* *
+%*********************************************************
+
+\begin{code}
+rnPolyType :: TyVarNamesEnv
+ -> RdrNamePolyType
+ -> RnM_Fixes s RenamedPolyType
+
+rnPolyType tv_env (HsForAllTy tvs ctxt ty)
+ = rn_poly_help tv_env tvs ctxt ty
+
+rnPolyType tv_env poly_ty@(HsPreForAllTy ctxt ty)
+ = rn_poly_help tv_env forall_tyvars ctxt ty
+ where
+ mentioned_tyvars = extract_poly_ty_names poly_ty
+ forall_tyvars = mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
+
+------------
+extract_poly_ty_names (HsPreForAllTy ctxt ty)
+ = extractCtxtTyNames ctxt
+ `unionLists`
+ extractMonoTyNames ty
+
+------------
+rn_poly_help :: TyVarNamesEnv
+ -> [RdrName]
+ -> RdrNameContext
+ -> RdrNameMonoType
+ -> RnM_Fixes s RenamedPolyType
+
+rn_poly_help tv_env tyvars ctxt ty
+ = getSrcLocRn `thenRn` \ src_loc ->
+ mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
+ let
+ tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
+ in
+ rnContext tv_env2 ctxt `thenRn` \ new_ctxt ->
+ rnMonoType tv_env2 ty `thenRn` \ new_ty ->
+ returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
+\end{code}
+
+\begin{code}
+rnMonoType :: TyVarNamesEnv
+ -> RdrNameMonoType
+ -> RnM_Fixes s RenamedMonoType
+
+rnMonoType tv_env (MonoTyVar tyvar)
+ = lookupTyVarName tv_env tyvar `thenRn` \ tyvar' ->
+ returnRn (MonoTyVar tyvar')
+
+rnMonoType tv_env (MonoListTy ty)
+ = rnMonoType tv_env ty `thenRn` \ ty' ->
+ returnRn (MonoListTy ty')
+
+rnMonoType tv_env (MonoFunTy ty1 ty2)
+ = andRn MonoFunTy (rnMonoType tv_env ty1)
+ (rnMonoType tv_env ty2)
+
+rnMonoType tv_env (MonoTupleTy tys)
+ = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
+ returnRn (MonoTupleTy tys')
+
+rnMonoType tv_env (MonoTyApp name tys)
+ = let
+ lookup_fn = if isAvarid (getLocalName name)
+ then lookupTyVarName tv_env
+ else lookupTyCon
+ in
+ lookup_fn name `thenRn` \ name' ->
+ mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
+ returnRn (MonoTyApp name' tys')
+\end{code}
+
+\begin{code}
+rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
+
+rnContext tv_env ctxt
+ = mapRn rn_ctxt ctxt
+ where
+ rn_ctxt (clas, tyvar)
+ = lookupClass clas `thenRn` \ clas_name ->
+ lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
+ returnRn (clas_name, tyvar_name)
+\end{code}
+
+
+\begin{code}
+derivingNonStdClassErr clas locn sty
+ = ppHang (ppStr "Non-standard class in deriving")
+ 4 (ppCat [ppr sty clas, ppr sty locn])
+
+dupDefaultDeclErr defs sty
+ = ppHang (ppStr "Duplicate default declarations")
+ 4 (ppAboves (map pp_def_loc defs))
+ where
+ pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
+
+undefinedFixityDeclErr decl sty
+ = ppHang (ppStr "Fixity declaration for unknown operator")
+ 4 (ppr sty decl)
+\end{code}
#include "HsVersions.h"
module RnUtils (
- mkGlobalNameFun, mkNameFun,
- GlobalNameMapper(..), GlobalNameMappers(..),
- PreludeNameMapper(..), PreludeNameMappers(..),
-
- dupNamesErr -- used in various places
+ RnEnv(..), QualNames(..),
+ UnqualNames(..), ScopeStack(..),
+ emptyRnEnv, extendGlobalRnEnv, extendLocalRnEnv,
+ lookupRnEnv, lookupTcRnEnv,
+
+ unknownNameErr,
+ badClassOpErr,
+ qualNameErr,
+ dupNamesErr,
+ shadowedNameWarn,
+ multipleOccWarn,
+
+ -- ToDo: nuke/move? WDP 96/04/05
+ GlobalNameMapper(..), GlobalNameMappers(..)
) where
-import Ubiq{-uitous-}
+import Ubiq
-import Bag ( bagToList, Bag )
-import FiniteMap ( lookupFM, listToFM )
-import Name ( Name{-instances-} )
-import Outputable ( pprNonOp )
+import Bag ( Bag, emptyBag, snocBag, unionBags )
+import ErrUtils ( addShortErrLocLine, addErrLoc )
+import FiniteMap ( FiniteMap, emptyFM, isEmptyFM,
+ lookupFM, addListToFM, addToFM )
+import Maybes ( maybeToBool )
+import Name ( RdrName(..), isQual )
+import Outputable ( pprNonOp, getLocalName )
import PprStyle ( PprStyle(..) )
import Pretty
-import ProtoName ( ProtoName(..) )
-import Util ( cmpPString, removeDups, pprPanic, panic )
-\end{code}
+import RnHsSyn ( RnName )
+import Util ( assertPanic )
-\begin{code}
-type GlobalNameMapper = ProtoName -> Maybe Name
+type GlobalNameMapper = RnName -> Maybe Name
type GlobalNameMappers = (GlobalNameMapper, GlobalNameMapper)
-
-type PreludeNameMapper = FAST_STRING -> Maybe Name
-type PreludeNameMappers = (PreludeNameMapper, -- Values
- PreludeNameMapper -- Types and classes
- )
\end{code}
-\begin{code}
-mkGlobalNameFun :: FAST_STRING -- The module name
- -> PreludeNameMapper -- The prelude things
- -> [(ProtoName, Name)] -- The local and imported things
- -> GlobalNameMapper -- The global name function
+*********************************************************
+* *
+\subsection{RnEnv: renaming environment}
+* *
+*********************************************************
-mkGlobalNameFun this_module prel_nf alist
- = the_fun
- where
- the_fun (Prel n) = Just n
- the_fun (Unk s) = case (unk_fun s) of
- Just n -> Just n
- Nothing -> prel_nf s
- the_fun (Imp m d _ _) = imp_fun (d, m) -- NB: module-name 2nd!
-
- -- Things in the domain of the prelude function shouldn't be put
- -- in the unk_fun; because the prel_nf will catch them.
- -- This can arise if, for example, an interface gives a signature
- -- for a prelude thing.
- --
- -- Neither should they be in the domain of the imp_fun, because
- -- prelude things will have been converted to Prel x rather than
- -- Imp p q r s.
- --
- -- So we strip out prelude things from the alist; this is not just
- -- desirable, it's essential because get_orig and get_local don't handle
- -- prelude things.
-
- non_prel_alist = filter non_prel alist
-
- non_prel (Prel _, _) = False
- non_prel other = True
-
- -- unk_fun looks up local names (just strings),
- -- imp_fun looks up original names: (string,string) pairs
- unk_fun = lookupFM (listToFM [(get_local pn,n) | (pn,n) <- non_prel_alist])
- imp_fun = lookupFM (listToFM [(get_orig pn,n) | (pn,n) <- non_prel_alist])
-
- -- the lists *are* sorted by *some* ordering (by local
- -- names), but not generally, and not in some way we
- -- are going to rely on.
-
- get_local :: ProtoName -> FAST_STRING
- get_local (Unk s) = s
- get_local (Imp _ _ _ l) = l
- get_local (Prel n) = pprPanic "get_local: " (ppr PprShowAll n)
-
- get_orig :: ProtoName -> (FAST_STRING, FAST_STRING) -- **NB**! module-name 2nd!
- get_orig (Unk s) = (s, this_module)
- get_orig (Imp m d _ _) = (d, m)
- get_orig (Prel n) = pprPanic "get_orig: " (ppr PprShowAll n)
+Seperate FiniteMaps are kept for lookup up Qual names,
+Unqual names and Local names.
+
+\begin{code}
+type RnEnv = ((QualNames, UnqualNames, QualNames, UnqualNames), ScopeStack)
+
+type QualNames = FiniteMap (FAST_STRING,Module) RnName
+type UnqualNames = FiniteMap FAST_STRING RnName
+type ScopeStack = FiniteMap FAST_STRING RnName
+
+emptyRnEnv :: RnEnv
+extendGlobalRnEnv :: RnEnv -> [(RdrName,RnName)] -> [(RdrName,RnName)]
+ -> (RnEnv, Bag (RdrName, RnName, RnName))
+extendLocalRnEnv :: Bool -> RnEnv -> [RnName] -> (RnEnv, [RnName])
+lookupRnEnv :: RnEnv -> RdrName -> Maybe RnName
+lookupTcRnEnv :: RnEnv -> RdrName -> Maybe RnName
\end{code}
+If the @RdrName@ is a @Qual@, @lookupValue@ looks it up in the global
+value QualNames. If it is @Unqual@, it looks it up first in the
+ScopeStack, and if it isn't found there, then in the global
+vaule Unqual Names.
-@mkNameFun@ builds a function from @ProtoName@s to things, where a
-``thing'' is either a @ProtoName@ (in the case of values), or a
-@(ProtoName, ProtoName -> ProtoName)@ pair in the case of types and
-classes. It takes:
+@lookupTcRnEnv@ looks up tycons/classes in the alternative global
+name space.
-\begin{itemize}
-\item The name of the interface
-\item A bag of new string-to-thing bindings to add,
+@extendGlobalRnEnv@ adds global names to the RnEnv. It takes seperate
+value and tycon/class name lists. It returns any duplicate names
+seperatle.
-\item An extractor function, to get a @ProtoName@ out of a thing,
- for use in error messages.
-\end{itemize}
-The function it returns only expects to see @Unk@ things.
+@extendRnEnv@ adds new local names to the ScopeStack in an RnEnv.
+It optionally reports any shadowed names.
-@mkNameFun@ checks for clashes in the domain of the new bindings.
+\begin{code}
+emptyRnEnv
+ = ((emptyFM, emptyFM, emptyFM, emptyFM), emptyFM)
-ToDo: it should check for clashes with the prelude bindings too.
-\begin{code}
-mkNameFun :: Bag (FAST_STRING, thing) -- Value bindings
- -> (FAST_STRING -> Maybe thing, -- The function to use
- [[(FAST_STRING,thing)]]) -- Duplicates, if any
-
-mkNameFun the_bag
- = case (removeDups cmp (bagToList the_bag)) of { (no_dup_list, dups) ->
- case (lookupFM (listToFM no_dup_list)) of { the_fun ->
- (the_fun, dups) }}
+extendGlobalRnEnv ((qual, unqual, tc_qual, tc_unqual), stack) val_list tc_list
+ = ASSERT(isEmptyFM stack)
+ (((qual', unqual', tc_qual, tc_unqual), stack), tc_dups `unionBags` dups)
where
- cmp :: (FAST_STRING, a) -> (FAST_STRING, a) -> TAG_
+ (qual', unqual', dups) = extend_global qual unqual val_list
+ (tc_qual', tc_unqual', tc_dups) = extend_global tc_qual tc_unqual tc_list
+
+ extend_global qual unqual rdr_list = (qual', unqual', dups)
+ where
+ (qual_list, unqual_list) = partition (isQual.fst) rdr_list
+ qual_in = map mk_qual qual_list
+ unqual_in = map mk_unqual unqual_list
+ mk_qual (Qual m s, rn) = ((s,m), rn)
+ mk_unqual (Unqual s, rn) = (s, rn)
+
+ (qual', qual_dups) = do_dups qual_in qual emptyBag (\ (s,m) -> Qual m s)
+ (unqual', unqual_dups) = do_dups unqual_in unqual emptyBag Unqual
- cmp (s1,_) (s2,_) = _CMP_STRING_ s1 s2
+ dups = unqual_dups `unionBags` qual_dups
+
+ do_dups [] fm dups to_rdr = (fm, dups)
+ do_dups ((k,v):rest) fm dups to_rdr
+ = case lookupFM fm k of
+ Nothing -> do_dups rest (addToFM fm k v) dups to_rdr
+ Just cur -> do_dups rest fm (dups `snocBag` (to_rdr k, cur, v)) to_rdr
+
+
+extendLocalRnEnv report_shadows (global, stack) new_local
+ = ((global, new_stack), dups)
+ where
+ (new_stack, dups) = extend new_local stack
+
+ extend names stack
+ = if report_shadows then
+ do_shadows names stack []
+ else
+ (addListToFM stack [ (getLocalName n, n) | n <- names], [])
+
+ do_shadows [] stack dups = (stack, dups)
+ do_shadows (name:names) stack dups
+ = do_shadows names (addToFM stack str name) ext_dups
+ where
+ str = getLocalName name
+ ext_dups = if maybeToBool (lookupFM stack str)
+ then name:dups
+ else dups
+
+
+lookupRnEnv ((qual, unqual, _, _), stack) rdr
+ = case rdr of
+ Unqual str -> lookup stack str (lookup unqual str Nothing)
+ Qual mod str -> lookup qual (str,mod) Nothing
+ where
+ lookup fm thing do_on_fail
+ = case lookupFM fm thing of
+ found@(Just name) -> found
+ Nothing -> do_on_fail
+
+lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr
+ = case rdr of
+ Unqual str -> lookupFM tc_unqual str
+ Qual mod str -> lookupFM tc_qual (str,mod)
\end{code}
+*********************************************************
+* *
+\subsection{Errors used in RnMonad}
+* *
+*********************************************************
+
\begin{code}
-dupNamesErr descriptor ((first_pname,locn1) : dup_things) sty
- = ppAboves (first_item : map dup_item dup_things)
+unknownNameErr descriptor name locn
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonOp sty name] )
+
+badClassOpErr clas op locn
+ = addErrLoc locn "" ( \ sty ->
+ ppBesides [ppChar '`', pprNonOp sty op, ppStr "' is not an operation of class `",
+ ppr sty clas, ppStr "'"] )
+
+qualNameErr descriptor (name,locn)
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr "invalid use of qualified ", ppStr descriptor, ppStr ": ", pprNonOp sty name ] )
+
+dupNamesErr descriptor ((name1,locn1) : dup_things) sty
+ = ppAboves (item1 : map dup_item dup_things)
where
- first_item
+ item1
= ppBesides [ ppr PprForUser locn1,
ppStr ": multiple declarations of a ", ppStr descriptor, ppStr ": ",
- pprNonOp sty first_pname ]
+ pprNonOp sty name1 ]
- dup_item (pname, locn)
+ dup_item (name, locn)
= ppBesides [ ppr PprForUser locn,
- ppStr ": here was another declaration of `", pprNonOp sty pname, ppStr "'" ]
+ ppStr ": here was another declaration of `", pprNonOp sty name, ppStr "'" ]
+
+shadowedNameWarn locn shadow
+ = addShortErrLocLine locn ( \ sty ->
+ ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow] )
+
+multipleOccWarn (name, occs) sty
+ = ppBesides [ppStr "multiple names used to refer to `", ppr sty name, ppStr "': ",
+ ppInterleave ppComma (map (ppr sty) occs)]
\end{code}
+
= case (getUnique us) of { unique ->
(mkSysLocal new_str unique ty mkUnknownSrcLoc, env) }
where
- new_str = getOccurrenceName id _APPEND_ SLIT("_sat")
+ new_str = panic "SATMonad.newSATName (ToDo)" -- getOccName id _APPEND_ SLIT("_sat")
getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
getArgLists expr
-- A better fix is to use binder directly but with the TopLevel
-- tag (or Exported tag) modified.
fake_binder = mkSysLocal
- (getOccurrenceName binder _APPEND_ SLIT("_fsat"))
+ (getOccName binder _APPEND_ SLIT("_fsat"))
(getItsUnique binder)
(idType binder)
mkUnknownSrcLoc
IdEnv(..), IdSet(..), GenId )
import IdInfo ( StrictnessInfo )
import Literal ( isNoRepLit, Literal{-instances-} )
-import Outputable ( Outputable(..){-instances-} )
+import Outputable ( isLocallyDefined, Outputable(..){-instances-} )
import PprCore -- various instances
import PprStyle ( PprStyle(..) )
import PprType ( GenType, GenTyVar )
import IdInfo ( willBeDemanded, DemandInfo )
import Literal ( isNoRepLit )
import Maybes ( maybeToBool )
+import Outputable ( isLocallyDefined )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
import PrelInfo ( realWorldStateTy )
import StgUtils
import LambdaLift ( liftProgram )
+import Outputable ( isLocallyDefined )
import SCCfinal ( stgMassageForProfiling )
import SatStgRhs ( satStgRhs )
import StgLint ( lintStgBindings )
GenId{-instance Eq-}
)
import Maybes ( maybeToBool )
+import Outputable ( isLocallyDefined )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
import Util ( panic, pprPanic, assertPanic )
GenId {-instance NamedThing -}
)
import Maybes ( maybeToBool, catMaybes, firstJust )
-import Outputable ( isAvarop, pprNonOp )
+import Outputable ( isAvarop, pprNonOp, getOrigName )
import PprStyle ( PprStyle(..) )
import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
TyCon{-ditto-}, GenType{-ditto-}, GenTyVar
)
import Literal ( Literal{-instance Outputable-} )
import Maybes ( catMaybes, firstJust, maybeToBool )
-import Outputable ( interppSP, Outputable(..){-instance * []-} )
+import Outputable ( interppSP, isLocallyDefined, Outputable(..){-instance * []-} )
import PprStyle ( PprStyle(..) )
import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
GenType{-instance Outputable-}, GenTyVar{-ditto-},
)
import Literal ( literalType, Literal{-instance Outputable-} )
import Maybes ( catMaybes )
-import Outputable ( Outputable(..){-instance * []-} )
+import Outputable ( Outputable(..){-instance * []-},
+ isLocallyDefined, getSrcLoc
+ )
import PprType ( GenType{-instance Outputable-}, TyCon )
import Pretty -- quite a bit of it
import PrimOp ( primOpType )
import Class ( Class(..), GenClass, ClassInstEnv(..), getClassInstEnv )
import Id ( GenId, idType, mkInstId )
import MatchEnv ( lookupMEnv, insertMEnv )
-import Name ( Name )
-import NameTypes( ShortName, mkShortName )
+import Name ( mkLocalName, Name )
import Outputable
import PprType ( GenClass, TyCon, GenType, GenTyVar )
import PprStyle ( PprStyle(..) )
import Pretty
+import RnHsSyn ( RnName{-instance NamedThing-} )
import SpecEnv ( SpecEnv(..) )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import Type ( GenType, eqSimpleTy,
\begin{code}
instToId :: Inst s -> TcIdOcc s
-instToId (Dict uniq clas ty orig loc)
- = TcId (mkInstId uniq (mkDictTy clas ty) (mkShortName SLIT("dict") loc))
-instToId (Method uniq id tys rho_ty orig loc)
- = TcId (mkInstId uniq tau_ty (mkShortName (getOccurrenceName id) loc))
+instToId (Dict u clas ty orig loc)
+ = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u SLIT("dict") loc))
+instToId (Method u id tys rho_ty orig loc)
+ = TcId (mkInstId u tau_ty (mkLocalName u (getLocalName id) loc))
where
(_, tau_ty) = splitRhoTy rho_ty -- NB The method Id has just the tau type
-instToId (LitInst uniq list ty orig loc)
- = TcId (mkInstId uniq ty (mkShortName SLIT("lit") loc))
+instToId (LitInst u list ty orig loc)
+ = TcId (mkInstId u ty (mkLocalName u SLIT("lit") loc))
\end{code}
\begin{code}
\begin{code}
zonkInst :: Inst s -> NF_TcM s (Inst s)
-zonkInst (Dict uniq clas ty orig loc)
+zonkInst (Dict u clas ty orig loc)
= zonkTcType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (Dict uniq clas new_ty orig loc)
+ returnNF_Tc (Dict u clas new_ty orig loc)
-zonkInst (Method uniq id tys rho orig loc) -- Doesn't zonk the id!
+zonkInst (Method u id tys rho orig loc) -- Doesn't zonk the id!
= mapNF_Tc zonkTcType tys `thenNF_Tc` \ new_tys ->
zonkTcType rho `thenNF_Tc` \ new_rho ->
- returnNF_Tc (Method uniq id new_tys new_rho orig loc)
+ returnNF_Tc (Method u id new_tys new_rho orig loc)
-zonkInst (LitInst uniq lit ty orig loc)
+zonkInst (LitInst u lit ty orig loc)
= zonkTcType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (LitInst uniq lit new_ty orig loc)
+ returnNF_Tc (LitInst u lit new_ty orig loc)
\end{code}
GRHSsAndBinds, ArithSeqInfo, HsLit, Fake,
collectBinders )
import RnHsSyn ( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..),
- RenamedMonoBinds(..) )
+ RenamedMonoBinds(..), RnName(..)
+ )
import TcHsSyn ( TcHsBinds(..), TcBind(..), TcMonoBinds(..),
TcIdOcc(..), TcIdBndr(..) )
import Kind ( mkBoxedTypeKind, mkTypeKind )
import Id ( GenId, idType, mkUserId )
import IdInfo ( noIdInfo )
-import Name ( Name ) -- instances
import Maybes ( assocMaybe, catMaybes, Maybe(..) )
import Outputable ( pprNonOp )
import PragmaInfo ( PragmaInfo(..) )
import Pretty
+import RnHsSyn ( RnName ) -- instances
import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy,
mkSigmaTy, splitSigmaTy,
splitRhoTy, mkForAllTy, splitForAllTy )
binder_names = collectBinders bind
-tcBindAndSigs binder_names bind sigs prag_info_fn
- = recoverTc (
+tcBindAndSigs binder_rn_names bind sigs prag_info_fn
+ = let
+ binder_names = map de_rn binder_rn_names
+ de_rn (RnName n) = n
+ in
+ recoverTc (
-- If typechecking the binds fails, then return with each
-- binder given type (forall a.a), to minimise subsequent
-- error messages
-- Create a new identifier for each binder, with each being given
-- a type-variable type.
- newMonoIds binder_names kind (\ mono_ids ->
+ newMonoIds binder_rn_names kind (\ mono_ids ->
tcTySigs sigs `thenTc` \ sig_info ->
tc_bind bind `thenTc` \ (bind', lie) ->
returnTc (mono_ids, bind', lie, sig_info)
import HsPragmas ( ClassPragmas(..) )
import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
RenamedClassOpSig(..), RenamedMonoBinds(..),
- RenamedGenPragmas(..), RenamedContext(..) )
+ RenamedGenPragmas(..), RenamedContext(..),
+ RnName{-instance Uniquable-}
+ )
import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, unZonkId )
import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
idType )
import IdInfo ( noIdInfo )
-import Name ( Name, getNameFullName, getTagFromClassOpName )
+import Outputable ( isLocallyDefined, getOrigName, getLocalName )
import PrelVals ( pAT_ERROR_ID )
import PprStyle
import Pretty
tcGetUnique `thenNF_Tc` \ uniq ->
let
(ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
- clas = mkClass uniq (getNameFullName class_name) rec_tyvar
+ clas = mkClass uniq (getName class_name) rec_tyvar
scs sc_sel_ids ops op_sel_ids defm_ids
rec_class_inst_env
in
full_theta = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta
global_ty = mkSigmaTy full_tyvars full_theta tau
local_ty = mkSigmaTy tyvars theta tau
- class_op = mkClassOp (getOccurrenceName op_name)
- (getTagFromClassOpName op_name)
+ class_op = mkClassOp (getLocalName op_name)
+ (panic "(getTagFromClassOpName op_name)TcClassDecl"{-(getTagFromClassOpName op_name)-})
local_ty
in
-- Build the selector id and default method id
tcGetUnique `thenNF_Tc` \ d_uniq ->
let
- op_uniq = getItsUnique op_name
+ op_uniq = uniqueOf op_name
sel_id = mkMethodSelId op_uniq rec_clas class_op global_ty op_info
defm_id = mkDefaultMethodId d_uniq rec_clas class_op False global_ty defm_info
-- ToDo: improve the "False"
tcClassSigs :: E -> TVE -> Class -- Knot tying only!
-> (ClassOp -> SpecEnv) -- Ditto; the spec info for the class ops
-> TyVarTemplate -- The class type variable, used for error check only
- -> [Name] -- Names with default methods
+ -> [RnName] -- Names with default methods
-> [RenamedClassOpSig]
-> Baby_TcM ([ClassOp], -- class ops
GVE, -- env for looking up the class ops
import Inst ( InstOrigin(..), InstanceMapper(..) )
import TcEnv ( getEnv_TyCons )
import TcKind ( TcKind )
-import TcGenDeriv -- Deriv stuff
+--import TcGenDeriv -- Deriv stuff
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
import TcSimplify ( tcSimplifyThetas )
-import RnMonad4
+--import RnMonad4
import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
-import RnBinds4 ( rnMethodBinds, rnTopBinds )
+--import RnBinds4 ( rnMethodBinds, rnTopBinds )
import Bag ( Bag, isEmptyBag, unionBags, listToBag )
import Class ( GenClass, getClassKey )
-import ErrUtils ( pprBagOfErrors, addErrLoc )
+import CmdLineOpts ( opt_CompilingPrelude )
+import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) )
import Id ( dataConSig, dataConArity )
import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
-import Name ( Name(..) )
-import NameTypes ( mkPreludeCoreName, Provenance(..) )
+--import Name ( Name(..) )
import Outputable
import PprType ( GenType, GenTyVar, GenClass, TyCon )
import PprStyle
import Pretty
-import ProtoName ( eqProtoName, ProtoName(..), Name )
import SrcLoc ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
maybeTyConSingleCon, isEnumerationTyCon, TyCon )
%************************************************************************
\begin{code}
-tcDeriving :: FAST_STRING -- name of module under scrutiny
+tcDeriving :: Module -- name of module under scrutiny
-> GlobalNameMappers -- for "renaming" bits of generated code
-> Bag InstInfo -- What we already know about instances
-> [RenamedFixityDecl] -- Fixity info; used by Read and Show
RenamedHsBinds, -- Extra generated bindings
PprStyle -> Pretty) -- Printable derived instance decls;
-- for debugging via -ddump-derivings.
+tcDeriving = panic "tcDeriving: ToDo LATER"
+{- LATER:
tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
= -- Fish the "deriving"-related information out of the TcEnv
-- Take the equation list and solve it, to deliver a list of
-- solutions, a.k.a. the contexts for the instance decls
-- required for the corresponding equations.
- solveDerivEqns modname inst_decl_infos_in eqns
+ solveDerivEqns inst_decl_infos_in eqns
`thenTc` \ new_inst_infos ->
-- Now augment the InstInfos, adding in the rather boring
in
gen_tag_n_con_binds deriver_name_funs nm_alist_etc `thenTc` \ extra_binds ->
- mapTc (gen_inst_info modname fixities deriver_name_funs) new_inst_infos
+ mapTc (gen_inst_info maybe_mod fixities deriver_name_funs) new_inst_infos
`thenTc` \ really_new_inst_infos ->
returnTc (listToBag really_new_inst_infos,
extra_binds,
ddump_deriving really_new_inst_infos extra_binds)
where
+ maybe_mod = if opt_CompilingPrelude then Nothing else Just mod_name
+
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
ddump_deriving inst_infos extra_binds sty
\end{itemize}
\begin{code}
-solveDerivEqns :: FAST_STRING
- -> Bag InstInfo
+solveDerivEqns :: Bag InstInfo
-> [DerivEqn]
-> TcM s [InstInfo] -- Solns in same order as eqns.
-- This bunch is Absolutely minimal...
-solveDerivEqns modname inst_decl_infos_in orig_eqns
+solveDerivEqns inst_decl_infos_in orig_eqns
= iterateDeriv initial_solutions
where
-- The initial solutions for the equations claim that each
= -- Extend the inst info from the explicit instance decls
-- with the current set of solutions, giving a
- add_solns modname inst_decl_infos_in orig_eqns current_solns
+ add_solns inst_decl_infos_in orig_eqns current_solns
`thenTc` \ (new_inst_infos, inst_mapper) ->
-- Simplify each RHS, using a DerivingOrigin containing an
-- the eqns and solns move "in lockstep"; we have the eqns
-- because we need the LHS info for addClassInstance.
-add_solns modname inst_infos_in eqns solns
+add_solns inst_infos_in eqns solns
= buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
returnTc (new_inst_infos, inst_mapper)
where
\end{itemize}
\begin{code}
-gen_inst_info :: FAST_STRING -- Module name
+gen_inst_info :: Maybe Module -- Module name; Nothing => Prelude
-> [RenamedFixityDecl] -- all known fixities;
-- may be needed for Text
-> GlobalNameMappers -- lookup stuff for names we may use
\begin{code}
gen_tag_n_con_binds :: GlobalNameMappers
- -> [(ProtoName, Name, TyCon, TagThingWanted)]
+ -> [(RdrName, RnName, TyCon, TagThingWanted)]
-> TcM s RenamedHsBinds
gen_tag_n_con_binds deriver_name_funs nm_alist_etc
\begin{code}
gen_taggery_Names :: [DerivEqn]
- -> TcM s [(ProtoName, Name, -- for an assoc list
+ -> TcM s [(RdrName, RnName, -- for an assoc list
TyCon, -- related tycon
TagThingWanted)]
\end{code}
\begin{code}
-derivingEnumErr :: TyCon -> TcError
+derivingEnumErr :: TyCon -> Error
derivingEnumErr tycon
= addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
-derivingIxErr :: TyCon -> TcError
+derivingIxErr :: TyCon -> Error
derivingIxErr tycon
= addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
+-}
\end{code}
import TcMonad
-import Name ( Name(..), getNameShortName )
+import Name ( Name{-instance NamedThing-} )
+import Outputable ( getOccName, getSrcLoc )
import PprStyle
import Pretty
-import Type ( splitForAllTy )
-import Unique ( Unique )
-import UniqFM
-import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic )
+import RnHsSyn ( RnName(..) )
+import Type ( splitForAllTy )
+import Unique ( Unique )
+import UniqFM
+import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic )
\end{code}
Data type declarations
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
tcTyVarScopeGivenKinds
- :: [Name] -- Names of some type variables
+ :: [Name] -- Names of some type variables
-> [TcKind s]
- -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
- -> TcM s a -- Result
+ -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
+ -> TcM s a -- Result
tcTyVarScopeGivenKinds names kinds thing_inside
= fixTc (\ ~(rec_tyvars, _) ->
-- Construct the real TyVars
let
tyvars = zipWithEqual mk_tyvar names kinds'
- mk_tyvar name kind = mkTyVar (getNameShortName name) (getItsUnique name) kind
+ mk_tyvar name kind = mkTyVar name (uniqueOf name) kind
in
returnTc (tyvars, result)
) `thenTc` \ (_,result) ->
that the knot-tied TyVars, TyCons and Classes aren't looked at too early.
\begin{code}
-tcExtendTyConEnv :: [(Name,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r
+tcExtendTyConEnv :: [(RnName,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r
+
tcExtendTyConEnv names_w_arities tycons scope
= newKindVars (length names_w_arities) `thenNF_Tc` \ kinds ->
tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnTc result
-tcExtendClassEnv :: [Name] -> [Class] -> TcM s r -> TcM s r
+tcExtendClassEnv :: [RnName] -> [Class] -> TcM s r -> TcM s r
tcExtendClassEnv names classes scope
= newKindVars (length names) `thenNF_Tc` \ kinds ->
tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
tcExtendGlobalValEnv ids scope
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
let
- gve' = addListToUFM_Directly gve [(getItsUnique id, id) | id <- ids]
+ gve' = addListToUFM_Directly gve [(uniqueOf id, id) | id <- ids]
in
tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope
\end{code}
\begin{code}
-tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s))
+tcLookupLocalValue :: RnName -> NF_TcM s (Maybe (TcIdBndr s))
tcLookupLocalValue name
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupUFM lve name)
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupUFM_Directly lve uniq)
-tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s)
+tcLookupLocalValueOK :: String -> RnName -> NF_TcM s (TcIdBndr s)
tcLookupLocalValueOK err name
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
-tcLookupGlobalValue :: Name -> NF_TcM s Id
+tcLookupGlobalValue :: RnName -> NF_TcM s Id
-tcLookupGlobalValue (WiredInVal id) -- wired in ids
+tcLookupGlobalValue (WiredInId id) -- wired in ids
= returnNF_Tc id
tcLookupGlobalValue name
-- A useful function that takes an occurrence of a global thing
-- and instantiates its type with fresh type variables
-tcGlobalOcc :: Name
+tcGlobalOcc :: RnName
-> NF_TcM s (Id, -- The Id
[TcType s], -- Instance types
TcType s) -- Rest of its type
~~~~~~~~~~~~~~~~~~~~
\begin{code}
-newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
+newMonoIds :: [RnName] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
+
newMonoIds names kind m
= newTyVarTys no_of_names kind `thenNF_Tc` \ tys ->
tcGetUniques no_of_names `thenNF_Tc` \ uniqs ->
let
- new_ids = zipWith3Equal mk_id names uniqs tys
- mk_id name uniq ty = mkUserLocal (getOccurrenceName name) uniq ty
- (getSrcLoc name)
+ new_ids = zipWith3Equal mk_id names uniqs tys
+
+ mk_id name uniq ty
+ = let
+ name_str = case (getOccName name) of { Unqual n -> n }
+ in
+ mkUserLocal name_str uniq ty (getSrcLoc name)
in
tcExtendLocalValEnv names new_ids (m new_ids)
where
Match, Fake, InPat, OutPat, PolyType,
irrefutablePat, collectPatBinders )
import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..),
- RenamedStmt(..), RenamedRecordBinds(..)
+ RenamedStmt(..), RenamedRecordBinds(..),
+ RnName{-instance Outputable-}
)
import TcHsSyn ( TcExpr(..), TcQual(..), TcStmt(..),
TcIdOcc(..), TcRecordBinds(..),
import Id ( Id(..), GenId, idType, dataConFieldLabels )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals )
+import Name ( Name{-instance Eq-} )
import PrelInfo ( intPrimTy, charPrimTy, doublePrimTy,
floatPrimTy, addrPrimTy, addrTy,
boolTy, charTy, stringTy, mkListTy,
enumFromToClassOpKey, enumFromThenToClassOpKey,
monadClassKey, monadZeroClassKey )
-import Name ( Name ) -- Instance
+--import Name ( Name ) -- Instance
import Outputable ( interpp'SP )
import PprType ( GenType, GenTyVar ) -- Instances
import Maybes ( maybeToBool )
%************************************************************************
\begin{code}
-tcId :: Name -> TcM s (TcExpr s, LIE s, TcType s)
+tcId :: RnName -> TcM s (TcExpr s, LIE s, TcType s)
+
tcId name
= -- Look up the Id and instantiate its type
tcLookupLocalValue name `thenNF_Tc` \ maybe_local ->
where
data_con_fields = dataConFieldLabels data_con
- ok (field_name, _, _) = any (match field_name) data_con_fields
+ ok (field_name, _, _) = any (match (getName field_name)) data_con_fields
match field_name field_label = field_name == fieldLabelName field_label
\end{code}
\begin{code}
#include "HsVersions.h"
-module TcGenDeriv (
+module TcGenDeriv {- (
a_Expr,
a_PN,
a_Pat,
con2tag_PN, tag2con_PN, maxtag_PN,
TagThingWanted(..)
- ) where
+ ) -} where
import Ubiq
import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qual(..), Stmt,
ArithSeqInfo, Sig, PolyType, FixityDecl, Fake )
-import RdrHsSyn ( ProtoNameMonoBinds(..), ProtoNameHsExpr(..), ProtoNamePat(..) )
-import RnHsSyn ( RenamedFixityDecl(..) )
+import RdrHsSyn ( RdrNameMonoBinds(..), RdrNameHsExpr(..), RdrNamePat(..) )
+import RnHsSyn ( RnName(..), RenamedFixityDecl(..) )
-import RnMonad4 -- initRn4, etc.
+--import RnMonad4 -- initRn4, etc.
import RnUtils
import Id ( GenId, dataConArity, dataConTag,
isDataCon, DataCon(..), ConTag(..) )
import IdUtils ( primOpId )
import Maybes ( maybeToBool )
-import Name ( Name(..) )
-import NameTypes ( mkFullName, Provenance(..) )
+--import Name ( Name(..) )
import Outputable
import PrimOp
import PrelInfo
import Pretty
-import ProtoName ( ProtoName(..) )
import SrcLoc ( mkGeneratedSrcLoc )
import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
import Type ( eqTy, isPrimType )
\end{itemize}
\begin{code}
-gen_Eq_binds :: TyCon -> ProtoNameMonoBinds
+foo_TcGenDeriv = panic "Nothing in TcGenDeriv LATER ToDo"
+
+{- LATER:
+gen_Eq_binds :: TyCon -> RdrNameMonoBinds
gen_Eq_binds tycon
= case (partition (\ con -> dataConArity con == 0)
con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
- data_con_PN = Prel (WiredInVal data_con)
+ data_con_PN = Prel (WiredInId data_con)
as_needed = take (dataConArity data_con) as_PNs
bs_needed = take (dataConArity data_con) bs_PNs
tys_needed = case (dataConSig data_con) of
\end{itemize}
\begin{code}
-gen_Ord_binds :: TyCon -> ProtoNameMonoBinds
+gen_Ord_binds :: TyCon -> RdrNameMonoBinds
gen_Ord_binds tycon
= defaulted `AndMonoBinds` compare
con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
- data_con_PN = Prel (WiredInVal data_con)
+ data_con_PN = Prel (WiredInId data_con)
as_needed = take (dataConArity data_con) as_PNs
bs_needed = take (dataConArity data_con) bs_PNs
tys_needed = case (dataConSig data_con) of
For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
\begin{code}
-gen_Enum_binds :: TyCon -> ProtoNameMonoBinds
+gen_Enum_binds :: TyCon -> RdrNameMonoBinds
gen_Enum_binds tycon
= enum_from `AndMonoBinds` enum_from_then
(p.~147).
\begin{code}
-gen_Ix_binds :: TyCon -> ProtoNameMonoBinds
+gen_Ix_binds :: TyCon -> RdrNameMonoBinds
gen_Ix_binds tycon
= if isEnumerationTyCon tycon
dc
con_arity = dataConArity data_con
- data_con_PN = Prel (WiredInVal data_con)
+ data_con_PN = Prel (WiredInId data_con)
con_pat xs = ConPatIn data_con_PN (map VarPatIn xs)
con_expr xs = foldl HsApp (HsVar data_con_PN) (map HsVar xs)
Ignoring all the infix-ery mumbo jumbo (ToDo)
\begin{code}
-gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> ProtoNameMonoBinds
-gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> ProtoNameMonoBinds
+gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
+gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
gen_Read_binds fixities tycon
= reads_prec `AndMonoBinds` read_list
where
read_con data_con -- note: "b" is the string being "read"
= let
- data_con_PN = Prel (WiredInVal data_con)
+ data_con_PN = Prel (WiredInId data_con)
data_con_str= snd (getOrigName data_con)
as_needed = take (dataConArity data_con) as_PNs
bs_needed = take (dataConArity data_con) bs_PNs
where
pats_etc data_con
= let
- data_con_PN = Prel (WiredInVal data_con)
+ data_con_PN = Prel (WiredInId data_con)
bs_needed = take (dataConArity data_con) bs_PNs
con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
nullary_con = dataConArity data_con == 0
ToDo: NOT DONE YET.
\begin{code}
-gen_Binary_binds :: TyCon -> ProtoNameMonoBinds
+gen_Binary_binds :: TyCon -> RdrNameMonoBinds
gen_Binary_binds tycon
= panic "gen_Binary_binds"
= GenCon2Tag | GenTag2Con | GenMaxTag
gen_tag_n_con_monobind
- :: (ProtoName, Name, -- (proto)Name for the thing in question
+ :: (RdrName, RnName, -- (proto)Name for the thing in question
TyCon, -- tycon in question
TagThingWanted)
- -> ProtoNameMonoBinds
+ -> RdrNameMonoBinds
gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag)
= mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
where
- mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameHsExpr)
+ mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
mk_stuff var
= ASSERT(isDataCon var)
([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
where
pat = ConPatIn var_PN (nOfThem (dataConArity var) WildPatIn)
- var_PN = Prel (WiredInVal var)
+ var_PN = Prel (WiredInId var)
gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con)
= mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
where
- mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameHsExpr)
+ mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
mk_stuff var
= ASSERT(isDataCon var)
([lit_pat], HsVar var_PN)
where
lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
- var_PN = Prel (WiredInVal var)
+ var_PN = Prel (WiredInId var)
gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag)
= mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
\end{verbatim}
\begin{code}
-mk_easy_FunMonoBind :: ProtoName -> [ProtoNamePat]
- -> [ProtoNameMonoBinds] -> ProtoNameHsExpr
- -> ProtoNameMonoBinds
+mk_easy_FunMonoBind :: RdrName -> [RdrNamePat]
+ -> [RdrNameMonoBinds] -> RdrNameHsExpr
+ -> RdrNameMonoBinds
mk_easy_FunMonoBind fun pats binds expr
= FunMonoBind fun [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
-- "recursive" MonoBinds, and it is its job to sort things out
-- from there.
-mk_FunMonoBind :: ProtoName
- -> [([ProtoNamePat], ProtoNameHsExpr)]
- -> ProtoNameMonoBinds
+mk_FunMonoBind :: RdrName
+ -> [([RdrNamePat], RdrNameHsExpr)]
+ -> RdrNameMonoBinds
mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
mk_FunMonoBind fun pats_and_exprs
\begin{code}
compare_Case, cmp_eq_Expr ::
- ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
- -> ProtoNameHsExpr -> ProtoNameHsExpr
- -> ProtoNameHsExpr
+ RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
+ -> RdrNameHsExpr -> RdrNameHsExpr
+ -> RdrNameHsExpr
compare_gen_Case ::
- ProtoName
- -> ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
- -> ProtoNameHsExpr -> ProtoNameHsExpr
- -> ProtoNameHsExpr
+ RdrName
+ -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
+ -> RdrNameHsExpr -> RdrNameHsExpr
+ -> RdrNameHsExpr
careful_compare_Case :: -- checks for primitive types...
Type
- -> ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
- -> ProtoNameHsExpr -> ProtoNameHsExpr
- -> ProtoNameHsExpr
+ -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
+ -> RdrNameHsExpr -> RdrNameHsExpr
+ -> RdrNameHsExpr
compare_Case = compare_gen_Case compare_PN
cmp_eq_Expr = compare_gen_Case cmp_eq_PN
res = [id | (ty',id) <- tyids, eqTy ty ty']
eq_op_tbl = [
- (charPrimTy, Prel (WiredInVal (primOpId CharEqOp))),
- (intPrimTy, Prel (WiredInVal (primOpId IntEqOp))),
- (wordPrimTy, Prel (WiredInVal (primOpId WordEqOp))),
- (addrPrimTy, Prel (WiredInVal (primOpId AddrEqOp))),
- (floatPrimTy, Prel (WiredInVal (primOpId FloatEqOp))),
- (doublePrimTy, Prel (WiredInVal (primOpId DoubleEqOp))) ]
+ (charPrimTy, Prel (WiredInId (primOpId CharEqOp))),
+ (intPrimTy, Prel (WiredInId (primOpId IntEqOp))),
+ (wordPrimTy, Prel (WiredInId (primOpId WordEqOp))),
+ (addrPrimTy, Prel (WiredInId (primOpId AddrEqOp))),
+ (floatPrimTy, Prel (WiredInId (primOpId FloatEqOp))),
+ (doublePrimTy, Prel (WiredInId (primOpId DoubleEqOp))) ]
lt_op_tbl = [
- (charPrimTy, Prel (WiredInVal (primOpId CharLtOp))),
- (intPrimTy, Prel (WiredInVal (primOpId IntLtOp))),
- (wordPrimTy, Prel (WiredInVal (primOpId WordLtOp))),
- (addrPrimTy, Prel (WiredInVal (primOpId AddrLtOp))),
- (floatPrimTy, Prel (WiredInVal (primOpId FloatLtOp))),
- (doublePrimTy, Prel (WiredInVal (primOpId DoubleLtOp))) ]
+ (charPrimTy, Prel (WiredInId (primOpId CharLtOp))),
+ (intPrimTy, Prel (WiredInId (primOpId IntLtOp))),
+ (wordPrimTy, Prel (WiredInId (primOpId WordLtOp))),
+ (addrPrimTy, Prel (WiredInId (primOpId AddrLtOp))),
+ (floatPrimTy, Prel (WiredInId (primOpId FloatLtOp))),
+ (doublePrimTy, Prel (WiredInId (primOpId DoubleLtOp))) ]
-----------------------------------------------------------------------
-and_Expr, append_Expr :: ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
+and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
and_Expr a b = OpApp a (HsVar and_PN) b
append_Expr a b = OpApp a (HsVar append_PN) b
-----------------------------------------------------------------------
-eq_Expr :: Type -> ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
+eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
eq_Expr ty a b
= if not (isPrimType ty) then
OpApp a (HsVar eq_PN) b
\end{code}
\begin{code}
-untag_Expr :: TyCon -> [(ProtoName, ProtoName)] -> ProtoNameHsExpr -> ProtoNameHsExpr
+untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
untag_Expr tycon [] expr = expr
untag_Expr tycon ((untag_this, put_tag_here) : more) expr
= HsCase (HsApp (con2tag_Expr tycon) (HsVar untag_this)) {-of-}
where
grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
-cmp_tags_Expr :: ProtoName -- Comparison op
- -> ProtoName -> ProtoName -- Things to compare
- -> ProtoNameHsExpr -- What to return if true
- -> ProtoNameHsExpr -- What to return if false
- -> ProtoNameHsExpr
+cmp_tags_Expr :: RdrName -- Comparison op
+ -> RdrName -> RdrName -- Things to compare
+ -> RdrNameHsExpr -- What to return if true
+ -> RdrNameHsExpr -- What to return if false
+ -> RdrNameHsExpr
cmp_tags_Expr op a b true_case false_case
= HsIf (OpApp (HsVar a) (HsVar op) (HsVar b)) true_case false_case mkGeneratedSrcLoc
enum_from_to_Expr
- :: ProtoNameHsExpr -> ProtoNameHsExpr
- -> ProtoNameHsExpr
+ :: RdrNameHsExpr -> RdrNameHsExpr
+ -> RdrNameHsExpr
enum_from_then_to_Expr
- :: ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
- -> ProtoNameHsExpr
+ :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
+ -> RdrNameHsExpr
enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_PN) f) t2
enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_PN) f) t) t2
showParen_Expr, readParen_Expr
- :: ProtoNameHsExpr -> ProtoNameHsExpr
- -> ProtoNameHsExpr
+ :: RdrNameHsExpr -> RdrNameHsExpr
+ -> RdrNameHsExpr
showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_PN) e1) e2
readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_PN) e1) e2
-nested_compose_Expr :: [ProtoNameHsExpr] -> ProtoNameHsExpr
+nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
nested_compose_Expr [e] = e
nested_compose_Expr (e:es)
max_PN = prelude_method SLIT("Ord") SLIT("max")
min_PN = prelude_method SLIT("Ord") SLIT("min")
compare_PN = prelude_method SLIT("Ord") SLIT("compare")
-ltTag_PN = Prel (WiredInVal ltDataCon)
-eqTag_PN = Prel (WiredInVal eqDataCon)
-gtTag_PN = Prel (WiredInVal gtDataCon)
+ltTag_PN = Prel (WiredInId ltDataCon)
+eqTag_PN = Prel (WiredInId eqDataCon)
+gtTag_PN = Prel (WiredInId gtDataCon)
enumFrom_PN = prelude_method SLIT("Enum") SLIT("enumFrom")
enumFromTo_PN = prelude_method SLIT("Enum") SLIT("enumFromTo")
enumFromThen_PN = prelude_method SLIT("Enum") SLIT("enumFromThen")
plus_PN = prelude_method SLIT("Num") SLIT("+")
times_PN = prelude_method SLIT("Num") SLIT("*")
-false_PN = Prel (WiredInVal falseDataCon)
-true_PN = Prel (WiredInVal trueDataCon)
-eqH_PN = Prel (WiredInVal (primOpId IntEqOp))
-geH_PN = Prel (WiredInVal (primOpId IntGeOp))
-leH_PN = Prel (WiredInVal (primOpId IntLeOp))
-ltH_PN = Prel (WiredInVal (primOpId IntLtOp))
-minusH_PN = Prel (WiredInVal (primOpId IntSubOp))
+false_PN = Prel (WiredInId falseDataCon)
+true_PN = Prel (WiredInId trueDataCon)
+eqH_PN = Prel (WiredInId (primOpId IntEqOp))
+geH_PN = Prel (WiredInId (primOpId IntGeOp))
+leH_PN = Prel (WiredInId (primOpId IntLeOp))
+ltH_PN = Prel (WiredInId (primOpId IntLtOp))
+minusH_PN = Prel (WiredInId (primOpId IntSubOp))
and_PN = prelude_val pRELUDE SLIT("&&")
not_PN = prelude_val pRELUDE SLIT("not")
append_PN = prelude_val pRELUDE_LIST SLIT("++")
map_PN = prelude_val pRELUDE_LIST SLIT("map")
compose_PN = prelude_val pRELUDE SLIT(".")
-mkInt_PN = Prel (WiredInVal intDataCon)
-error_PN = Prel (WiredInVal eRROR_ID)
+mkInt_PN = Prel (WiredInId intDataCon)
+error_PN = Prel (WiredInId eRROR_ID)
showSpace_PN = prelude_val pRELUDE_TEXT SLIT("showSpace__") -- not quite std
showString_PN = prelude_val pRELUDE_TEXT SLIT("showString")
showParen_PN = prelude_val pRELUDE_TEXT SLIT("showParen")
d_Pat = VarPatIn d_PN
-con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> ProtoName
+con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName
con2tag_PN tycon
= let (mod, nm) = getOrigName tycon
Imp mod maxtag [mod] maxtag
-con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> FullName
+con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> RnName
tag2con_FN tycon
= let (mod, nm) = getOrigName tycon
con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
in
mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc
-
+-}
\end{code}
+
ppr sty (RealId id) = ppr sty id
instance NamedThing (TcIdOcc s) where
- getOccurrenceName (TcId id) = getOccurrenceName id
- getOccurrenceName (RealId id) = getOccurrenceName id
+ getName (TcId id) = getName id
+ getName (RealId id) = getName id
\end{code}
import TcMonoType ( tcPolyType )
import HsSyn ( Sig(..), PolyType )
-import RnHsSyn ( RenamedSig(..) )
+import RnHsSyn ( RenamedSig(..), RnName(..) )
import CmdLineOpts ( opt_CompilingPrelude )
import Id ( mkImported )
-import Name ( Name(..) )
+--import Name ( Name(..) )
import Pretty
import Util ( panic )
tcInterfaceSigs [] = returnTc []
-tcInterfaceSigs (Sig name@(ValName uniq full_name) ty pragmas src_loc : sigs)
+tcInterfaceSigs (Sig name@(RnName full_name) ty pragmas src_loc : sigs)
= tcAddSrcLoc src_loc (
tcPolyType ty `thenTc` \ sigma_ty ->
fixTc ( \ rec_id ->
tcGenPragmas (Just sigma_ty) rec_id pragmas
`thenNF_Tc` \ id_info ->
- returnTc (mkImported uniq full_name sigma_ty id_info)
+ returnTc (mkImported full_name sigma_ty id_info)
)) `thenTc` \ id ->
tcInterfaceSigs sigs `thenTc` \ sigs' ->
returnTc (id:sigs')
tcInterfaceSigs (Sig odd_name _ _ src_loc : sigs)
= case odd_name of
- WiredInVal _ | opt_CompilingPrelude
+ WiredInId _ | opt_CompilingPrelude
-> tcInterfaceSigs sigs
_ -> tcAddSrcLoc src_loc $
failTc (ifaceSigNameErr odd_name)
PolyType(..), MonoType )
import RnHsSyn ( RenamedHsBinds(..), RenamedMonoBinds(..),
RenamedInstDecl(..), RenamedFixityDecl(..),
- RenamedSig(..), RenamedSpecInstSig(..) )
+ RenamedSig(..), RenamedSpecInstSig(..),
+ RnName(..){-incl instance Outputable-}
+ )
import TcHsSyn ( TcIdOcc(..), TcHsBinds(..),
TcMonoBinds(..), TcExpr(..), tcIdType,
mkHsTyLam, mkHsTyApp,
import Id ( GenId, idType, isDefaultMethodId_maybe )
import ListSetOps ( minusList )
import Maybes ( maybeToBool, expectJust )
-import Name ( Name, getTagFromClassOpName )
-import Outputable
+import Outputable ( getLocalName, getOrigName )
import PrelInfo ( pAT_ERROR_ID )
import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
pprParendGenType )
import TysWiredIn ( stringTy )
import Unique ( Unique )
import Util ( panic )
-
\end{code}
Typechecking instance declarations is done in two passes. The first
\begin{code}
tcInstDecls1 :: Bag RenamedInstDecl
-> [RenamedSpecInstSig]
- -> FAST_STRING -- module name for deriving
+ -> Module -- module name for deriving
-> GlobalNameMappers -- renamer fns for deriving
-> [RenamedFixityDecl] -- fixities for deriving
-> TcM s (Bag InstInfo,
-- Look things up
tcLookupClass class_name `thenNF_Tc` \ (clas_kind, clas) ->
+ let
+ de_rn (RnName n) = n
+ in
-- Typecheck the context and instance type
- tcTyVarScope tyvar_names (\ tyvars ->
+ tcTyVarScope (map de_rn tyvar_names) (\ tyvars ->
tcContext context `thenTc` \ theta ->
tcMonoTypeKind inst_ty `thenTc` \ (tau_kind, tau) ->
unifyKind clas_kind tau_kind `thenTc_`
if (not from_here && (clas `derivedFor` inst_tycon)
&& all isTyVarTy arg_tys)
then
- if mod_name == inst_mod then
+ if not opt_CompilingPrelude && maybeToBool inst_mod &&
+ mod_name == expectJust "inst_mod" inst_mod
+ then
-- Imported instance came from this module;
-- discard and derive fresh instance
returnTc emptyBag
tcInstType [(clas_tyvar,inst_ty)]
(mkSigmaTy local_tyvars meth_theta sel_tau)
`thenNF_Tc` \ method_ty ->
- newLocalId (getOccurrenceName sel_id) method_ty `thenNF_Tc` \ meth_id ->
+ newLocalId (getLocalName sel_id) method_ty `thenNF_Tc` \ meth_id ->
returnNF_Tc (emptyLIE, meth_id)
\end{code}
-> [Id]
-> TcType s
-> Class
- -> FAST_STRING
+ -> Maybe Module
-> Int
-> NF_TcM s (TcExpr s)
error_msg = "%E" -- => No explicit method for \"
++ escErrorMsg error_str
- error_str = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "."
+ mod_str = case inst_mod of { Nothing -> SLIT("Prelude"); Just m -> m }
+
+ error_str = _UNPK_ mod_str ++ "." ++ _UNPK_ clas_name ++ "."
++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
FunMonoBind op _ locn -> (op, locn)
PatMonoBind (VarPatIn op) _ locn -> (op, locn)
- occ = getOccurrenceName op
+ occ = getLocalName op
origin = InstanceDeclOrigin
in
tcAddSrcLoc locn $
-- Make a method id for the method
- let tag = getTagFromClassOpName op
+ let tag = panic "processInstBinds1:getTagFromClassOpName"{-getTagFromClassOpName op-}
method_id = method_ids !! (tag-1)
TcId method_bndr = method_id
derivingWhenInstanceImportedErr inst_mod clas tycon sty
= ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
- 4 (ppBesides [ppStr "when an instance declared in module `", ppPStr inst_mod, ppStr "' has been imported"])
+ 4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"])
+ where
+ pp_mod = case inst_mod of
+ Nothing -> ppPStr SLIT("the standard Prelude")
+ Just m -> ppBesides [ppStr "module `", ppPStr m, ppStr "'"]
nonBoxedPrimCCallErr clas inst_ty sty
= ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
import MatchEnv ( nullMEnv, insertMEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
+import Outputable ( getSrcLoc )
import PprType ( GenClass, GenType, GenTyVar )
import Pretty
import SpecEnv ( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
[Id] -- Constant methods (either all or none)
RenamedMonoBinds -- Bindings, b
Bool -- True <=> local instance decl
- FAST_STRING -- Name of module where this instance was
- -- defined.
+ (Maybe Module) -- Name of module where this instance defined; Nothing => Prelude
SrcLoc -- Source location assoc'd with this instance's defn
[RenamedSig] -- User pragmas recorded for generating specialised instances
\end{code}
%************************************************************************
\begin{code}
-mkInstanceRelatedIds :: Bool -> FAST_STRING
+mkInstanceRelatedIds :: Bool
+ -> Maybe Module
-> RenamedInstancePragmas
-> Class
-> [TyVar]
import HsPat(InPat, OutPat)
import HsSyn(Fake)
import TcHsSyn(TcIdOcc)
-import Name(Name)
+import RnHsSyn(RnName)
import TcType(TcMaybe)
import SST(FSST_R)
import Unique(Unique)
import Type(GenType)
import Inst(Inst)
-tcGRHSsAndBinds :: GRHSsAndBinds Fake Fake Name (InPat Name)
+tcGRHSsAndBinds :: GRHSsAndBinds Fake Fake RnName (InPat RnName)
-> TcDown a
-> TcEnv a
-> State# a
import Unify ( unifyTauTy, unifyTauTyList )
import Kind ( Kind, mkTypeKind )
-import Name ( Name )
import Pretty
+import RnHsSyn ( RnName{-instance Outputable-} )
import Type ( isTyVarTy, mkFunTy, getFunTy_maybe )
import Util
\end{code}
same number of arguments before using @tcMatches@ to do the work.
\begin{code}
-tcMatchesFun :: Name
+tcMatchesFun :: RnName
-> TcType s -- Expected type
-> [RenamedMatch]
-> TcM s ([TcMatch s], LIE s)
\begin{code}
-data FunOrCase = MCase | MFun Name -- Records whether doing fun or case rhss;
+data FunOrCase = MCase | MFun RnName -- Records whether doing fun or case rhss;
-- used to produced better error messages
tcMatchesExpected :: TcType s
import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr,
TyDecl, SpecDataSig, ClassDecl, InstDecl,
SpecInstSig, DefaultDecl, Sig, Fake, InPat,
- FixityDecl, IE, ImportedInterface )
+ FixityDecl, IE, ImportDecl
+ )
import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
TcIdOcc(..), zonkBinds, zonkInst, zonkId )
import Class ( GenClass )
import Id ( GenId, isDataCon, isMethodSelId, idType )
import Maybes ( catMaybes )
-import Name ( Name(..) )
-import Outputable ( isExported )
+import Outputable ( isExported, isLocallyDefined )
import PrelInfo ( unitTy, mkPrimIoTy )
import Pretty
import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
PprStyle -> Pretty) -- -ddump-deriving info
tcModule renamer_name_funs
- (HsModule mod_name exports imports fixities
+ (HsModule mod_name verion exports imports fixities
ty_decls specdata_sigs cls_decls inst_decls specinst_sigs
default_decls val_decls sigs src_loc)
rn4MtoTcM,
- TcError(..), TcWarning(..), Message(..),
+ TcError(..), TcWarning(..),
mkTcErr, arityErr,
-- For closure
MutableVar(..), _MutableArray
) where
+import Ubiq{-uitous-}
import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
import Type ( Type(..), GenType )
import TyVar ( TyVar(..), GenTyVar )
import Usage ( Usage(..), GenUsage )
+import ErrUtils ( Error(..), Message(..), ErrCtxt(..),
+ Warning(..) )
import SST
-import RnMonad4
-import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
+--import RnMonad4
+--LATER:import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
import ErrUtils ( Error(..) )
import Maybes ( MaybeErr(..) )
-import Name ( Name )
-import ProtoName ( ProtoName )
+--import Name ( Name )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import UniqFM ( UniqFM, emptyUFM )
import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
initTc :: UniqSupply
-> TcM _RealWorld r
- -> MaybeErr (r, Bag TcWarning)
- (Bag TcError, Bag TcWarning)
+ -> MaybeErr (r, Bag Warning)
+ (Bag Error, Bag Warning)
initTc us do_this
= _runSST (
belong to the main thread. We throw away any error messages!
\begin{pseudocode}
-forkNF_Tc :: NF_TcM s r -> NF_TcM s r
-forkNF_Tc m down env
- = forkTcDown down `thenSST` \ down' ->
- returnSST (_runSST (m down' (forkTcEnv env)))
+forkNF_Tc :: NF_TcM s' r -> NF_TcM s r
+forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
+ = -- Get a fresh unique supply
+ readMutVarSST u_var `thenSST` \ us ->
+ let
+ (us1, us2) = splitUniqSupply us
+ in
+ writeMutVarSST u_var us1 `thenSST_`
+ returnSST (_runSST (
+ newMutVarSST us2 `thenSST` \ u_var' ->
+ newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
+ newMutVarSST emptyUFM `thenSST` \ tv_var' ->
+ let
+ down' = TcDown deflts us_var src_loc err_cxt err_var'
+ env' = forkEnv env tv_var'
+ in
+ m down' env'
+
+ -- ToDo: optionally dump any error messages
+ ))
+\end{pseudocode}
+
+@forkTcDown@ makes a new "down" blob for a lazily-computed fork
+of the type checker.
+
+\begin{pseudocode}
+forkTcDown (TcDown deflts u_var src_loc err_cxt err_var)
+ = -- Get a fresh unique supply
+ readMutVarSST u_var `thenSST` \ us ->
+ let
+ (us1, us2) = splitUniqSupply us
+ in
+ writeMutVarSST u_var us1 `thenSST_`
+
+ -- Make fresh MutVars for the unique supply and errors
+ newMutVarSST us2 `thenSST` \ u_var' ->
+ newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' ->
+
+ -- Done
+ returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
\end{pseudocode}
SrcLoc -- Source location
(ErrCtxt s) -- Error context
- (MutableVar s (Bag TcWarning,
- Bag TcError))
+ (MutableVar s (Bag Warning,
+ Bag Error))
type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
-- to deal with bound type variables just before error
getErrCtxt (TcDown def us loc ctxt errs) = ctxt
\end{code}
-@forkTcDown@ makes a new "down" blob for a lazily-computed fork
-of the type checker.
-
-\begin{code}
-forkTcDown (TcDown deflts u_var src_loc err_cxt err_var)
- = -- Get a fresh unique supply
- readMutVarSST u_var `thenSST` \ us ->
- let
- (us1, us2) = splitUniqSupply us
- in
- writeMutVarSST u_var us1 `thenSST_`
-
- -- Make fresh MutVars for the unique supply and errors
- newMutVarSST us2 `thenSST` \ u_var' ->
- newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' ->
-
- -- Done
- returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
-\end{code}
-
\section{rn4MtoTcM}
%~~~~~~~~~~~~~~~~~~
\begin{code}
+rn4MtoTcM = panic "TcMonad.rn4MtoTcM (ToDo LATER)"
+{- LATER:
rn4MtoTcM :: GlobalNameMappers -> Rn4M a -> NF_TcM s (a, Bag Error)
rn4MtoTcM name_funs rn_action down env
returnSST (rn_result, rn_errs)
where
u_var = getUniqSupplyVar down
+-}
\end{code}
~~~~~~~~~~~~~~~~~~~
\begin{code}
-type Message = PprStyle -> Pretty
type TcError = Message
type TcWarning = Message
-
mkTcErr :: SrcLoc -- Where
-> [Message] -- Context
-> Message -- What went wrong
import HsSyn ( PolyType(..), MonoType(..), Fake )
import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..),
- RenamedContext(..)
+ RenamedContext(..), RnName(..)
)
import Class ( cCallishClassKeys )
import TyCon ( TyCon, Arity(..) )
import Unique ( Unique )
-import Name ( Name(..), getNameShortName, isTyConName, getSynNameArity )
import PprStyle
import Pretty
+import RnHsSyn ( isRnLocal, isRnClass, isRnTyCon,
+ RnName{-instance NamedThing-}
+ )
import Util ( zipWithEqual, panic )
\end{code}
tcMonoType ty2 `thenTc` \ tau_ty2 ->
returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
-tcMonoTypeKind (MonoTyApp name@(Short _ _) tys)
- = -- Must be a type variable
- tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
+tcMonoTypeKind (MonoTyApp name tys)
+ | isRnLocal name -- Must be a type variable
+ = tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
tcMonoTyApp kind (mkTyVarTy tyvar) tys
tcMonoTypeKind (MonoTyApp name tys)
- | isTyConName name -- Must be a type constructor
+ | isRnTyCon name -- Must be a type constructor
= tcLookupTyCon name `thenNF_Tc` \ (kind,maybe_arity,tycon) ->
case maybe_arity of
Just arity -> tcSynApp name kind arity tycon tys -- synonum
returnTc (mkTcTypeKind, ty')
)
where
- (names, kinds) = unzip tyvars_w_kinds
+ (rn_names, kinds) = unzip tyvars_w_kinds
+ names = map de_rn rn_names
tc_kinds = map kindToTcKind kinds
+ de_rn (RnName n) = n
-- for unfoldings only:
tcMonoTypeKind (MonoDictTy class_name ty)
classes so we specifically check that this isn't being done.
\begin{code}
-canBeUsedInContext :: Name -> Bool
-canBeUsedInContext (ClassName uniq _ _) = not (uniq `elem` cCallishClassKeys)
-canBeUsedInContext other = True
+canBeUsedInContext :: RnName -> Bool
+canBeUsedInContext n
+ = isRnClass n && not (uniqueOf n `elem` cCallishClassKeys)
\end{code}
-
Polytypes
~~~~~~~~~
\begin{code}
tcPolyType :: RenamedPolyType -> TcM s Type
tcPolyType (HsForAllTy tyvar_names context ty)
- = tcTyVarScope tyvar_names (\ tyvars ->
+ = tcTyVarScope names (\ tyvars ->
tcContext context `thenTc` \ theta ->
tcMonoType ty `thenTc` \ tau ->
returnTc (mkSigmaTy tyvars theta tau)
)
+ where
+ names = map de_rn tyvar_names
+ de_rn (RnName n) = n
\end{code}
Errors and contexts
import Id ( GenId, idType )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
import Maybes ( maybeToBool )
-import Name ( Name )
import PprType ( GenType, GenTyVar )
import PrelInfo ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, charTy, stringTy, mkListTy,
mkTupleTy, addrTy, addrPrimTy )
import Pretty
+import RnHsSyn ( RnName{-instance Outputable-} )
import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
getFunTy_maybe, maybeAppDataTyCon,
Type(..), GenType
unifies the actual args against the expected ones.
\begin{code}
-matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
+matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s)
matchConArgTys con arg_tys
= tcGlobalOcc con `thenNF_Tc` \ (con_id, _, con_rho) ->
import HsSyn ( TyDecl(..), ConDecl(..), BangType(..),
ClassDecl(..), MonoType(..), PolyType(..),
Sig(..), MonoBinds, Fake, InPat, HsBinds(..), Bind, HsExpr )
-import RnHsSyn ( RenamedTyDecl(..), RenamedClassDecl(..) )
+import RnHsSyn ( isRnTyCon, RenamedTyDecl(..), RenamedClassDecl(..),
+ RnName(..){-instance Uniquable-}
+ )
import TcHsSyn ( TcHsBinds(..), TcIdOcc(..) )
import TcMonad
import Bag
import Class ( Class(..), getClassSelIds )
import Digraph ( findSCCs, SCC(..) )
-import Name ( Name, isTyConName )
+import Outputable ( getSrcLoc )
import PprStyle
import Pretty
import UniqSet ( UniqSet(..), emptyUniqSet,
returnTc (really_final_env, foldr ThenBinds EmptyBinds binds)
where
- (tyvar_names, tycon_names_w_arities, class_names) = get_binders decls
+ (tyvar_rn_names, tycon_names_w_arities, class_names) = get_binders decls
+
+ tyvar_names = map de_rn tyvar_rn_names
+ de_rn (RnName n) = n
combine do_a do_b
= do_a `thenTc` \ (a1,a2) ->
~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
mk_edges (TyD (TyData ctxt name _ condecls _ _ _))
- = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls))
+ = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls))
mk_edges (TyD (TyNew ctxt name _ condecl _ _ _))
- = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl))
+ = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl))
mk_edges (TyD (TySynonym name _ rhs _))
- = (getItsUnique name, set_to_bag (get_ty rhs))
+ = (uniqueOf name, set_to_bag (get_ty rhs))
mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
- = (getItsUnique name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
+ = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
get_ctxt ctxt
= unionManyUniqSets (map (set_name.fst) ctxt)
get_ty (MonoTyVar tv)
= emptyUniqSet
get_ty (MonoTyApp name tys)
- = (if isTyConName name then set_name name else emptyUniqSet)
+ = (if isRnTyCon name then set_name name else emptyUniqSet)
`unionUniqSets` get_tys tys
get_ty (MonoFunTy ty1 ty2)
= unionUniqSets (get_ty ty1) (get_ty ty2)
get_sig (ClassOpSig _ ty _ _) = get_pty ty
get_sig other = panic "TcTyClsDecls:get_sig"
-set_name name = unitUniqSet (getItsUnique name)
+set_name name = unitUniqSet (uniqueOf name)
set_to_bag set = listToBag (uniqSetToList set)
\end{code}
\begin{code}
get_binders :: Bag Decl
- -> ([Name], -- TyVars; no dups
- [(Name, Maybe Arity)], -- Tycons; no dups; arities for synonyms
- [Name]) -- Classes; no dups
+ -> ([RnName], -- TyVars; no dups
+ [(RnName, Maybe Arity)],-- Tycons; no dups; arities for synonyms
+ [RnName]) -- Classes; no dups
get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
where
HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo, PolyType,
Bind(..), MonoBinds(..), Sig,
MonoType )
-import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) )
+import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..),
+ RnName{-instance Outputable-}
+ )
import TcHsSyn ( TcHsBinds(..), TcIdOcc(..), mkHsTyLam )
import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext )
import TcMonad
import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
-import Id ( mkDataCon, dataConSig, mkRecordSelectorId,
+import Id ( mkDataCon, dataConSig, mkRecordSelId,
dataConFieldLabels, StrictnessMark(..)
)
import FieldLabel
import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
import SpecEnv ( SpecEnv(..), nullSpecEnv )
-import Name ( getNameFullName, Name(..) )
+import Name ( Name{-instance Ord3-} )
import Pretty
import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, tyConDataCons )
import Type ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy, applyTyCon,
final_tycon_kind = foldr (mkArrowKind . getTyVarKind) result_kind rec_tyvars
-- Construct the tycon
- tycon = mkSynTyCon (getItsUnique tycon_name)
- (getNameFullName tycon_name)
+ tycon = mkSynTyCon (getName tycon_name)
final_tycon_kind
(length tyvar_names)
rec_tyvars
final_tycon_kind :: Kind -- NB not TcKind!
final_tycon_kind = foldr (mkArrowKind . getTyVarKind) mkBoxedTypeKind rec_tyvars
- tycon = mkDataTyCon (getItsUnique tycon_name)
+ tycon = mkDataTyCon (getName tycon_name)
final_tycon_kind
- (getNameFullName tycon_name)
rec_tyvars
ctxt
con_ids
mkFunTy data_ty' $
field_ty'
- selector_id = mkRecordSelectorId first_field_label selector_ty
+ selector_id = mkRecordSelId first_field_label selector_ty
-- HsSyn is dreadfully verbose for defining the selector!
selector_rhs = mkHsTyLam tyvars' $
= tcAddSrcLoc src_loc $
tcMonoType ty `thenTc` \ arg_ty ->
let
- data_con = mkDataCon (getItsUnique name)
- (getNameFullName name)
+ data_con = mkDataCon (getName name)
[NotMarkedStrict]
[{- No labelled fields -}]
tyvars
stricts = [strict | (_, _, strict) <- field_label_infos]
arg_tys = [ty | (_, ty, _) <- field_label_infos]
- field_labels = [ mkFieldLabel name ty tag
+ field_labels = [ mkFieldLabel (getName name) ty tag
| ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags
]
- data_con = mkDataCon (getItsUnique name)
- (getNameFullName name)
+ data_con = mkDataCon (getName name)
stricts
field_labels
tyvars
in
mapTc tcMonoType tys `thenTc` \ arg_tys ->
let
- data_con = mkDataCon (getItsUnique name)
- (getNameFullName name)
+ data_con = mkDataCon (getName name)
stricts
[{- No field labels -}]
tyvars
import Ubiq
import Unique ( Unique )
import UniqFM ( UniqFM )
-import Name ( getNameShortName )
import Maybes ( assocMaybe )
import Util ( panic, pprPanic )
import RnHsSyn
import TcHsSyn
+import ErrUtils ( Warning(..), Error(..) )
import Pretty
import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
import Maybes ( MaybeErr(..) )
PprStyle->Pretty), -- stuff to print for -ddump-deriving
- Bag TcWarning) -- pretty-print this to get warnings
+ Bag Warning) -- pretty-print this to get warnings
-- FAILURE ...
- (Bag TcError, -- pretty-print this to get errors
- Bag TcWarning) -- pretty-print this to get warnings
+ (Bag Error, -- pretty-print this to get errors
+ Bag Warning) -- pretty-print this to get warnings
typecheckModule us renamer_name_funs mod
= initTc us (tcModule renamer_name_funs mod)
import Usage ( GenUsage, Usage(..), UVar(..) )
import Maybes ( assocMaybe, Maybe )
-import NameTypes ( FullName, ShortName )
+import Name ( Name )
import Unique -- Keys for built-in classes
import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
import Pretty ( Pretty(..), PrettyRep )
data GenClass tyvar uvar
= Class
Unique -- Key for fast comparison
- FullName
+ Name
tyvar -- The class type variable
The @mkClass@ function fills in the indirect superclasses.
\begin{code}
-mkClass :: Unique -> FullName -> TyVar
+mkClass :: Unique -> Name -> TyVar
-> [Class] -> [Id]
-> [ClassOp] -> [Id] -> [Id]
-> ClassInstEnv
\end{code}
\begin{code}
+instance Uniquable (GenClass tyvar uvar) where
+ uniqueOf (Class u _ _ _ _ _ _ _ _ _) = u
+
instance NamedThing (GenClass tyvar uvar) where
- getExportFlag (Class _ n _ _ _ _ _ _ _ _) = getExportFlag n
- isLocallyDefined (Class _ n _ _ _ _ _ _ _ _) = isLocallyDefined n
- getOrigName (Class _ n _ _ _ _ _ _ _ _) = getOrigName n
- getOccurrenceName (Class _ n _ _ _ _ _ _ _ _) = getOccurrenceName n
- getInformingModules (Class _ n _ _ _ _ _ _ _ _) = getInformingModules n
- getSrcLoc (Class _ n _ _ _ _ _ _ _ _) = getSrcLoc n
- fromPreludeCore (Class _ n _ _ _ _ _ _ _ _) = fromPreludeCore n
-
- getItsUnique (Class key _ _ _ _ _ _ _ _ _) = key
+ getName (Class _ n _ _ _ _ _ _ _ _) = n
\end{code}
(ClassOp _ i1 _) > (ClassOp _ i2 _) = i1 > i2
-- ToDo: something for _tagCmp? (WDP 94/10)
\end{code}
-
import Ubiq
import IdLoop -- for paranoia checking
import TyLoop -- for paranoia checking
-import NameLoop -- for paranoia checking
-- friends:
-- (PprType can see all the representations it's trying to print)
import CStrings ( identToC )
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( maybeToBool )
-import NameTypes ( ShortName, FullName )
-import Outputable ( ifPprShowAll, isAvarop, interpp'SP )
+import Name ( Name )
+import Outputable ( isAvarop, isPreludeDefined, getOrigName,
+ ifPprShowAll, interpp'SP
+ )
import PprStyle ( PprStyle(..), codeStyle, showUserishTypes )
import Pretty
import TysWiredIn ( listTyCon )
%* *
%************************************************************************
-ToDo; all this is suspiciously like getOccurrenceName!
+ToDo; all this is suspiciously like getOccName!
\begin{code}
showTyCon :: PprStyle -> TyCon -> String
pprTyCon sty (TupleTyCon arity) = ppBeside (ppPStr SLIT("Tuple")) (ppInt arity)
pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name
-pprTyCon sty tycon@(DataTyCon uniq kind name tyvars ctxt cons derivings nd)
+pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
= case sty of
PprDebug -> pp_tycon_and_uniq
PprShowAll -> pp_tycon_and_uniq
= case (maybeAppTyCon ty) of
Nothing -> true_bottom
Just (tycon,_) ->
- if fromPreludeCore tycon
+ if isPreludeDefined tycon
then true_bottom
else (False, fst (getOrigName tycon))
ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars,
ppEquals, ppr_ty sty lookup_fn tOP_PREC exp]
-pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings data_or_new) specs
+pprTyCon sty@PprInterface this_tycon@(DataTyCon u n k vs ctxt cons derivings data_or_new) specs
= ppHang (ppCat [pp_data_or_new,
pprContext sty ctxt,
ppr sty n,
) where
CHK_Ubiq() -- debugging consistency check
-import NameLoop -- for paranoia checking
import TyLoop ( Type(..), GenType,
Class(..), GenClass,
import PrelMods ( pRELUDE_BUILTIN )
import Maybes
-import NameTypes ( FullName )
+import Name ( Name, RdrName(..), appendRdr, nameUnique )
import Unique ( Unique, funTyConKey, mkTupleTyConUnique )
import Outputable
import Pretty ( Pretty(..), PrettyRep )
= FunTyCon -- Kind = Type -> Type -> Type
| DataTyCon Unique{-TyConKey-}
+ Name
Kind
- FullName
[TyVar]
[(Class,Type)] -- Its context
[Id] -- Its data constructors, with fully polymorphic types
| PrimTyCon -- Primitive types; cannot be defined in Haskell
Unique -- Always unboxed; hence never represented by a closure
- FullName -- Often represented by a bit-pattern for the thing
+ Name -- Often represented by a bit-pattern for the thing
Kind -- itself (eg Int#), but sometimes by a pointer to
| SpecTyCon -- A specialised TyCon; eg (Arr# Int#), or (List Int#)
| SynTyCon
Unique
- FullName
+ Name
Kind
Arity
[TyVar] -- Argument type variables
\end{code}
\begin{code}
-mkFunTyCon = FunTyCon
-mkDataTyCon = DataTyCon
-mkTupleTyCon = TupleTyCon
-mkPrimTyCon = PrimTyCon
-mkSpecTyCon = SpecTyCon
-mkSynTyCon = SynTyCon
+mkFunTyCon = FunTyCon
+mkTupleTyCon = TupleTyCon
+mkSpecTyCon = SpecTyCon
+
+mkDataTyCon name
+ = DataTyCon (nameUnique name) name
+mkPrimTyCon name
+ = PrimTyCon (nameUnique name) name
+mkSynTyCon name
+ = SynTyCon (nameUnique name) name
isFunTyCon FunTyCon = True
isFunTyCon _ = False
tyConKind :: TyCon -> Kind
tyConKind FunTyCon = kind2
-tyConKind (DataTyCon _ kind _ _ _ _ _ _) = kind
+tyConKind (DataTyCon _ _ kind _ _ _ _ _) = kind
tyConKind (PrimTyCon _ _ kind) = kind
tyConKind (SpecTyCon tc tys)
a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
_tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-\end{code}
-
-\begin{code}
-instance NamedThing TyCon where
- getExportFlag tc = case get_name tc of
- Nothing -> NotExported
- Just name -> getExportFlag name
-
-
- isLocallyDefined tc = case get_name tc of
- Nothing -> False
- Just name -> isLocallyDefined name
- getOrigName FunTyCon = (pRELUDE_BUILTIN, SLIT("(->)"))
- getOrigName (TupleTyCon a) = (pRELUDE_BUILTIN, _PK_ ("Tuple" ++ show a))
- getOrigName (SpecTyCon tc tys) = let (m,n) = getOrigName tc in
- (m, n _APPEND_ specMaybeTysSuffix tys)
- getOrigName other_tc = getOrigName (expectJust "tycon1" (get_name other_tc))
-
- getOccurrenceName FunTyCon = SLIT("(->)")
- getOccurrenceName (TupleTyCon 0) = SLIT("()")
- getOccurrenceName (TupleTyCon a) = _PK_ ( "(" ++ nOfThem (a-1) ',' ++ ")" )
- getOccurrenceName (SpecTyCon tc tys)= getOccurrenceName tc _APPEND_ specMaybeTysSuffix tys
- getOccurrenceName other_tc = getOccurrenceName (expectJust "tycon2" (get_name other_tc))
-
- getInformingModules tc = case get_name tc of
- Nothing -> panic "getInformingModule:TyCon"
- Just name -> getInformingModules name
-
- getSrcLoc tc = case get_name tc of
- Nothing -> mkBuiltinSrcLoc
- Just name -> getSrcLoc name
-
- getItsUnique tycon = tyConUnique tycon
-
- fromPreludeCore tc = case get_name tc of
- Nothing -> True
- Just name -> fromPreludeCore name
+instance Uniquable TyCon where
+ uniqueOf (DataTyCon u _ _ _ _ _ _ _) = u
+ uniqueOf (PrimTyCon u _ _) = u
+ uniqueOf (SynTyCon u _ _ _ _ _) = u
+ uniqueOf tc@(SpecTyCon _ _) = panic "uniqueOf:SpecTyCon"
+ uniqueOf tc = uniqueOf (getName tc)
\end{code}
-Emphatically un-exported:
-
\begin{code}
-get_name (DataTyCon _ _ n _ _ _ _ _) = Just n
-get_name (PrimTyCon _ n _) = Just n
-get_name (SpecTyCon tc _) = get_name tc
-get_name (SynTyCon _ n _ _ _ _) = Just n
-get_name other = Nothing
+instance NamedThing TyCon where
+ getName (DataTyCon _ n _ _ _ _ _ _) = n
+ getName (PrimTyCon _ n _) = n
+ getName (SpecTyCon tc _) = getName tc
+ getName (SynTyCon _ n _ _ _ _) = n
+{- LATER:
+ getName FunTyCon = (pRELUDE_BUILTIN, SLIT("(->)"))
+ getName (TupleTyCon a) = (pRELUDE_BUILTIN, _PK_ ("Tuple" ++ show a))
+-}
+ getName tc = panic "TyCon.getName"
+
+{- LATER:
+ getName (SpecTyCon tc tys) = let (m,n) = getOrigName tc in
+ (m, n _APPEND_ specMaybeTysSuffix tys)
+ getName other_tc = getOrigName (expectJust "tycon1" (getName other_tc))
+ getName other = Nothing
+-}
\end{code}
import PreludeStdIO ( Maybe )
import Unique ( Unique )
+import FieldLabel ( FieldLabel )
import Id ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon,
dataConSig, getInstantiatedDataConSig )
import PprType ( specMaybeTysSuffix )
-import NameTypes ( FullName )
+import Name ( Name )
import TyCon ( TyCon )
import TyVar ( GenTyVar, TyVar )
import Type ( GenType, Type )
-- Needed in TysWiredIn
data StrictnessMark = MarkedStrict | NotMarkedStrict
-mkDataCon :: Unique -> FullName -> [StrictnessMark]
+mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> [(Class,Type)] -> [Type] -> TyCon
-> Id
\end{code}
plusUFM, sizeUFM, UniqFM
)
import Maybes ( Maybe(..) )
-import NameTypes ( ShortName )
+import Name ( mkLocalName, Name, RdrName(..) )
import Pretty ( Pretty(..), PrettyRep, ppBeside, ppPStr )
import PprStyle ( PprStyle )
import Outputable ( Outputable(..), NamedThing(..), ExportFlag(..) )
= TyVar
Unique
Kind
- (Maybe ShortName) -- User name (if any)
+ (Maybe Name) -- User name (if any)
flexi_slot -- Extra slot used during type and usage
-- inference, and to contain usages.
Simple construction and analysis functions
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-mkTyVar :: ShortName -> Unique -> Kind -> TyVar
+mkTyVar :: Name -> Unique -> Kind -> TyVar
mkTyVar name uniq kind = TyVar uniq
kind
(Just name)
instance Ord3 (GenTyVar a) where
cmp (TyVar u1 _ _ _) (TyVar u2 _ _ _) = u1 `cmp` u2
-instance NamedThing (GenTyVar a) where
- getExportFlag (TyVar _ _ _ _) = NotExported
- isLocallyDefined (TyVar _ _ _ _) = True
-
- getOrigName (TyVar _ _ (Just n) _) = getOrigName n
- getOrigName (TyVar u _ _ _) = (panic "getOrigName:TyVar",
- showUnique u)
- getOccurrenceName (TyVar _ _ (Just n) _) = getOccurrenceName n
- getOccurrenceName (TyVar u _ _ _) = showUnique u
-
- getSrcLoc (TyVar _ _ (Just n) _) = getSrcLoc n
- getSrcLoc (TyVar _ _ _ _) = mkUnknownSrcLoc
- fromPreludeCore (TyVar _ _ _ _) = False
-
- getItsUnique (TyVar u _ _ _) = u
+instance Uniquable (GenTyVar a) where
+ uniqueOf (TyVar u _ _ _) = u
+instance NamedThing (GenTyVar a) where
+ getName (TyVar _ _ (Just n) _) = n
+ getName (TyVar u _ _ _) = mkLocalName u (showUnique u) mkUnknownSrcLoc
\end{code}
-- NAMED-THING-ERY
NamedThing(..), -- class
ExportFlag(..),
- isExported, getLocalName, ltLexical,
+
+ getItsUnique, getOrigName, getOccName, getExportFlag,
+ getSrcLoc, isLocallyDefined, isPreludeDefined, isExported,
+ getLocalName, getOrigNameRdr, ltLexical,
-- PRINTERY AND FORCERY
Outputable(..), -- class
isOpLexeme, pprOp, pprNonOp,
isConop, isAconop, isAvarid, isAvarop
-
- -- and to make the interface self-sufficient...
) where
import Ubiq{-uitous-}
+import Name ( nameUnique, nameOrigName, nameOccName,
+ nameExportFlag, nameSrcLoc,
+ isLocallyDefinedName, isPreludeDefinedName
+ )
import PprStyle ( PprStyle(..) )
import Pretty
import Util ( cmpPString )
\begin{code}
class NamedThing a where
- getExportFlag :: a -> ExportFlag
- isLocallyDefined :: a -> Bool
- getOrigName :: a -> (FAST_STRING{-module-}, FAST_STRING{-name therein-})
- getOccurrenceName :: a -> FAST_STRING
- getInformingModules :: a -> [FAST_STRING]
- getSrcLoc :: a -> SrcLoc
- getItsUnique :: a -> Unique
- fromPreludeCore :: a -> Bool
- -- see also friendly functions that follow...
-\end{code}
-
-\begin{description}
-\item[@getExportFlag@:]
-Obvious.
-
-\item[@getOrigName@:]
-Obvious.
-
-\item[@isLocallyDefined@:]
-Whether the thing is defined in this module or not.
-
-\item[@getOccurrenceName@:]
-Gets the name by which a thing is known in this module (e.g., if
-renamed, or whatever)...
-
-\item[@getInformingModules@:]
-Gets the name of the modules that told me about this @NamedThing@.
+ getName :: a -> Name
+
+getItsUnique :: NamedThing a => a -> Unique
+getOrigName :: NamedThing a => a -> (Module, FAST_STRING)
+getOccName :: NamedThing a => a -> RdrName
+getExportFlag :: NamedThing a => a -> ExportFlag
+getSrcLoc :: NamedThing a => a -> SrcLoc
+isLocallyDefined :: NamedThing a => a -> Bool
+isPreludeDefined :: NamedThing a => a -> Bool
+
+getItsUnique = nameUnique . getName
+getOrigName = nameOrigName . getName
+getOccName = nameOccName . getName
+getExportFlag = nameExportFlag . getName
+getSrcLoc = nameSrcLoc . getName
+isLocallyDefined = isLocallyDefinedName . getName
+isPreludeDefined = isPreludeDefinedName . getName
-\item[@getSrcLoc@:]
-Obvious.
-
-\item[@fromPreludeCore@:]
-Tests a quite-delicate property: it is \tr{True} iff the entity is
-actually defined in \tr{PreludeCore} (or \tr{PreludeBuiltin}), or if
-it is re-exported by \tr{PreludeCore}. See the @FullName@ type in
-module \tr{NameTypes}.
-
-NB: Some of the types in, e.g., \tr{PreludeGlaST} {\em fail} this test.
-This is a bummer for types that are wired into the compiler.
-\end{description}
-
-Some functions to go with:
-\begin{code}
isExported a
= case (getExportFlag a) of
NotExported -> False
_ -> True
getLocalName :: (NamedThing a) => a -> FAST_STRING
-
getLocalName = snd . getOrigName
+getOrigNameRdr :: (NamedThing a) => a -> RdrName
+getOrigNameRdr n | isPreludeDefined n = Unqual str
+ | otherwise = Qual mod str
+ where
+ (mod,str) = getOrigName n
+
#ifdef USE_ATTACK_PRAGMAS
{-# SPECIALIZE isExported :: Class -> Bool #-}
{-# SPECIALIZE isExported :: Id -> Bool #-}
{-# SPECIALIZE isExported :: TyCon -> Bool #-}
-{-# SPECIALIZE getLocalName :: ShortName -> FAST_STRING #-}
#endif
\end{code}
{-# SPECIALIZE interpp'SP :: PprStyle -> [(Id, Id)] -> Pretty #-}
{-# SPECIALIZE interpp'SP :: PprStyle -> [Id] -> Pretty #-}
-{-# SPECIALIZE interpp'SP :: PprStyle -> [ProtoName] -> Pretty #-}
{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVarTemplate] -> Pretty #-}
{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVar] -> Pretty #-}
{-# SPECIALIZE interpp'SP :: PprStyle -> [Type] -> Pretty #-}
\end{code}
These functions test strings to see if they fit the lexical categories
-defined in the Haskell report. Normally applied as in, e.g.,
-@isConop (getOccurrenceName foo)@... [just for pretty-printing]
+defined in the Haskell report.
+Normally applied as in e.g. @isConop (getLocalName foo)@
\begin{code}
isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
isOpLexeme :: NamedThing a => a -> Bool
isOpLexeme v
- = let str = getOccurrenceName v in isAvarop str || isAconop str
+ = let str = snd (getOrigName v) in isAvarop str || isAconop str
-- print `vars`, (op) correctly
pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
module SST(
SST(..), SST_R, FSST(..), FSST_R,
- _runSST,
+ _runSST, sstToST, stToSST,
thenSST, thenSST_, returnSST,
thenFSST, thenFSST_, returnFSST, failFSST,
recoverFSST, recoverSST, fixFSST,
newMutVarSST, readMutVarSST, writeMutVarSST
) where
-import PreludeGlaST( MutableVar(..), _MutableArray(..) )
+import PreludeGlaST( MutableVar(..), _MutableArray(..), ST(..) )
CHK_Ubiq() -- debugging consistency check
\end{code}
\end{code}
\begin{code}
+-- converting to/from ST
+
+sstToST :: SST s r -> ST s r
+stToSST :: ST s r -> SST s r
+
+sstToST sst (S# s)
+ = case sst s of SST_R r s' -> (r, S# s')
+stToSST st s
+ = case st (S# s) of (r, S# s') -> SST_R r s'
+
+
-- Type of runSST should be builtin ...
-- runSST :: forall r. (forall s. SST s r) -> r
import HeapOffs ( HeapOffset )
import HsCore ( UnfoldingCoreExpr )
import HsPat ( OutPat )
-import HsPragmas ( ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas,
- InstancePragmas
- )
+import HsPragmas ( ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas, InstancePragmas )
import Id ( StrictnessMark, GenId, Id(..) )
import IdInfo ( IdInfo, OptIdInfo(..), ArityInfo, DeforestInfo, Demand, StrictnessInfo, UpdateInfo )
import Kind ( Kind )
import Literal ( Literal )
import Maybes ( MaybeErr )
import MatchEnv ( MatchEnv )
-import Name ( Name )
-import NameTypes ( FullName, ShortName )
+import Name ( Module(..), RdrName, Name )
import Outputable ( ExportFlag, NamedThing(..), Outputable(..) )
import PprStyle ( PprStyle )
import PragmaInfo ( PragmaInfo )
import Pretty ( PrettyRep )
import PrimOp ( PrimOp )
import PrimRep ( PrimRep )
-import ProtoName ( ProtoName )
+import RnHsSyn ( RnName )
import SMRep ( SMRep )
import SrcLoc ( SrcLoc )
import TcType ( TcMaybe )
import Type ( GenType, Type(..) )
import UniqFM ( UniqFM )
import UniqSupply ( UniqSupply )
-import Unique ( Unique )
+import Unique ( Unique, Uniquable(..) )
import Usage ( GenUsage, Usage(..) )
import Util ( Ord3(..) )
-- to try to contain their visibility.
class NamedThing a where
- getExportFlag :: a -> ExportFlag
- isLocallyDefined :: a -> Bool
- getOrigName :: a -> (_PackedString, _PackedString)
- getOccurrenceName :: a -> _PackedString
- getInformingModules :: a -> [_PackedString]
- getSrcLoc :: a -> SrcLoc
- getItsUnique :: a -> Unique
- fromPreludeCore :: a -> Bool
+ getName :: a -> Name
class OptIdInfo a where
noInfo :: a
getInfo :: IdInfo -> a
cmp :: a -> a -> Int#
class Outputable a where
ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
+class Uniquable a where
+ uniqueOf :: a -> Unique
-- For datatypes, we ubiquitize those types that (a) are
-- used everywhere and (b) the compiler doesn't lose much
data ExportFlag
data FieldLabel
data FiniteMap a b
-data FullName -- NB: fails the optimisation criterion
data GenClass a b
data GenClassOp a
data GenCoreArg a b c
data MaybeErr a b
data MatchEnv a b
data Name
+data RdrName = Unqual _PackedString | Qual _PackedString _PackedString
data OutPat a b c
data PprStyle
data PragmaInfo
data PrettyRep
data PrimOp
data PrimRep -- NB: an enumeration
-data ProtoName
-data ShortName -- NB: fails the optimisation criterion
+data RnName
data SimplifierSwitch
data SMRep
data SrcLoc
-- don't get clever and unexpand some of these synonyms
-- (GHC 0.26 will barf)
+type Module = _PackedString
type Arity = Int
type Class = GenClass (GenTyVar (GenUsage Unique)) Unique
type ClassOp = GenClassOp (GenType (GenTyVar (GenUsage Unique)) Unique)
Based on @FiniteMaps@ (as you would expect).
-Basically, the things need to be in class @NamedThing@, and we use the
-@getItsUnique@ method to grab their @Uniques@.
+Basically, the things need to be in class @Uniquable@, and we use the
+@uniqueOf@ method to grab their @Uniques@.
(A similar thing to @UniqSet@, as opposed to @Set@.)
addToUFM_Directly,
addListToUFM_Directly,
IF_NOT_GHC(addToUFM_C COMMA)
- IF_NOT_GHC(addListToUFM_C COMMA)
+ addListToUFM_C,
delFromUFM,
delListFromUFM,
plusUFM,
CHK_Ubiq() -- debugging consistency check
#endif
-import Unique ( Unique, u2i, mkUniqueGrimily )
+import Unique ( Unique, Uniquable(..), u2i, mkUniqueGrimily )
import Util
-import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
+import Outputable ( Outputable(..), ExportFlag )
import Pretty ( Pretty(..), PrettyRep )
import PprStyle ( PprStyle )
import SrcLoc ( SrcLoc )
%* *
%************************************************************************
-We use @FiniteMaps@, with a (@getItsUnique@-able) @Unique@ as ``key''.
+We use @FiniteMaps@, with a (@uniqueOf@-able) @Unique@ as ``key''.
\begin{code}
emptyUFM :: UniqFM elt
isNullUFM :: UniqFM elt -> Bool
-unitUFM :: NamedThing key => key -> elt -> UniqFM elt
+unitUFM :: Uniquable key => key -> elt -> UniqFM elt
unitDirectlyUFM -- got the Unique already
:: Unique -> elt -> UniqFM elt
-listToUFM :: NamedThing key => [(key,elt)] -> UniqFM elt
+listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
listToUFM_Directly
:: [(Unique, elt)] -> UniqFM elt
-addToUFM :: NamedThing key => UniqFM elt -> key -> elt -> UniqFM elt
-addListToUFM :: NamedThing key => UniqFM elt -> [(key,elt)] -> UniqFM elt
+addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
+addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
addToUFM_Directly
:: UniqFM elt -> Unique -> elt -> UniqFM elt
-addToUFM_C :: NamedThing key => (elt -> elt -> elt)
+addToUFM_C :: Uniquable key => (elt -> elt -> elt)
-> UniqFM elt -> key -> elt -> UniqFM elt
-addListToUFM_C :: NamedThing key => (elt -> elt -> elt)
+addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
-> UniqFM elt -> [(key,elt)]
-> UniqFM elt
-delFromUFM :: NamedThing key => UniqFM elt -> key -> UniqFM elt
-delListFromUFM :: NamedThing key => UniqFM elt -> [key] -> UniqFM elt
+delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
+delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
sizeUFM :: UniqFM elt -> Int
-lookupUFM :: NamedThing key => UniqFM elt -> key -> Maybe elt
+lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM_Directly -- when you've got the Unique already
:: UniqFM elt -> Unique -> Maybe elt
lookupWithDefaultUFM
- :: NamedThing key => UniqFM elt -> elt -> key -> elt
+ :: Uniquable key => UniqFM elt -> elt -> key -> elt
lookupWithDefaultUFM_Directly
:: UniqFM elt -> elt -> Unique -> elt
\begin{code}
emptyUFM = EmptyUFM
-unitUFM key elt = mkLeafUFM (u2i (getItsUnique key)) elt
+unitUFM key elt = mkLeafUFM (u2i (uniqueOf key)) elt
unitDirectlyUFM key elt = mkLeafUFM (u2i key) elt
listToUFM key_elt_pairs
addToUFM_Directly fm u elt = insert_ele use_snd fm (u2i u) elt
addToUFM_C combiner fm key elt
- = insert_ele combiner fm (u2i (getItsUnique key)) elt
+ = insert_ele combiner fm (u2i (uniqueOf key)) elt
addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs
addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs
addListToUFM_C combiner fm key_elt_pairs
- = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (getItsUnique k)) e)
+ = foldl (\ fm (k, e) -> insert_ele combiner fm (u2i (uniqueOf k)) e)
fm key_elt_pairs
addListToUFM_directly_C combiner fm uniq_elt_pairs
\begin{code}
delListFromUFM fm lst = foldl delFromUFM fm lst
-delFromUFM fm key = delete fm (u2i (getItsUnique key))
+delFromUFM fm key = delete fm (u2i (uniqueOf key))
delete EmptyUFM _ = EmptyUFM
delete fm key = del_ele fm
Lookup up a binary tree is easy (and fast).
\begin{code}
-lookupUFM fm key = lookup fm (u2i (getItsUnique key))
+lookupUFM fm key = lookup fm (u2i (uniqueOf key))
lookupUFM_Directly fm key = lookup fm (u2i key)
lookupWithDefaultUFM fm deflt key
- = case lookup fm (u2i (getItsUnique key)) of
+ = case lookup fm (u2i (uniqueOf key)) of
Nothing -> deflt
Just elt -> elt
Based on @UniqFMs@ (as you would expect).
-Basically, the things need to be in class @NamedThing@.
+Basically, the things need to be in class @Uniquable@.
\begin{code}
#include "HsVersions.h"
import Maybes ( maybeToBool, Maybe )
import UniqFM
-import Unique ( Unique )
-import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
+import Unique ( Uniquable(..), Unique )
+import Outputable ( Outputable(..), ExportFlag )
import SrcLoc ( SrcLoc )
import Pretty ( Pretty(..), PrettyRep )
import PprStyle ( PprStyle )
emptyUniqSet :: UniqSet a
emptyUniqSet = MkUniqSet emptyUFM
-unitUniqSet :: NamedThing a => a -> UniqSet a
+unitUniqSet :: Uniquable a => a -> UniqSet a
unitUniqSet x = MkUniqSet (unitUFM x x)
uniqSetToList :: UniqSet a -> [a]
uniqSetToList (MkUniqSet set) = eltsUFM set
-mkUniqSet :: NamedThing a => [a] -> UniqSet a
+mkUniqSet :: Uniquable a => [a] -> UniqSet a
mkUniqSet xs = MkUniqSet (listToUFM [ (x, x) | x <- xs])
-addOneToUniqSet :: NamedThing a => UniqSet a -> a -> UniqSet a
+addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet set x = set `unionUniqSets` unitUniqSet x
unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (intersectUFM set1 set2)
-elementOfUniqSet :: NamedThing a => a -> UniqSet a -> Bool
+elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet x (MkUniqSet set) = maybeToBool (lookupUFM set x)
isEmptyUniqSet :: UniqSet a -> Bool
isEmptyUniqSet (MkUniqSet set) = isNullUFM set {-SLOW: sizeUFM set == 0-}
-mapUniqSet :: NamedThing b => (a -> b) -> UniqSet a -> UniqSet b
+mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b
mapUniqSet f (MkUniqSet set)
= MkUniqSet (listToUFM [ let
mapped_thing = f thing
projects / ghc-hetmet.git / commitdiff