From: partain Date: Sun, 7 Apr 1996 15:44:00 +0000 (+0000) Subject: [project @ 1996-04-07 15:41:24 by partain] X-Git-Tag: Approximately_1000_patches_recorded~930 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f9120c200bcf613b58d742802172fb4c08171f0d [project @ 1996-04-07 15:41:24 by partain] Sansom 1.3 changes through 960407 --- diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile index 55a455e..8498896 100644 --- a/ghc/compiler/Jmakefile +++ b/ghc/compiler/Jmakefile @@ -59,9 +59,7 @@ NATIVEGEN_DIR=$(TOP_PWD)/$(CURRENT_DIR)/nativeGen 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 \ @@ -76,7 +74,6 @@ parser/U_ttype.hs parser/UgenUtil.lhs \ parser/UgenAll.lhs \ reader/ReadPrefix.lhs \ -reader/ReadPragmas.lhs \ \ reader/PrefixSyn.lhs \ reader/PrefixToHs.lhs \ @@ -101,10 +98,8 @@ basicTypes/IdInfo.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 \ @@ -121,18 +116,15 @@ specialise/SpecEnv.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 \ @@ -359,14 +351,15 @@ NOT_SO_BASICSRCS_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. @@ -487,8 +480,6 @@ absCSyn/AbsCLoop.hi : absCSyn/AbsCLoop.lhi $(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 @@ -501,8 +492,6 @@ nativeGen/NcgLoop.hi : nativeGen/NcgLoop.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 @@ -540,10 +529,8 @@ compile(basicTypes/IdInfo,lhs,-K2m) 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,) @@ -626,21 +613,17 @@ compile(profiling/CostCentre,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,) @@ -772,9 +755,7 @@ CPP_DEFINES = $(D_DEBUG) 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 \ @@ -794,9 +775,7 @@ HSP_SRCS_C = parser/constr.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 \ @@ -841,14 +820,12 @@ MakeDirectories(install, $(INSTLIBDIR_GHC)) 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) @@ -860,14 +837,12 @@ UgenTarget(parser/ttype) 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 @@ -882,9 +857,7 @@ compile(parser/UgenUtil,lhs,$(PARSER_HS_OPTS) '-#include"hspincl.h"') 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"') diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs index d28c6c5..d8f61d3 100644 --- a/ghc/compiler/basicTypes/FieldLabel.lhs +++ b/ghc/compiler/basicTypes/FieldLabel.lhs @@ -40,6 +40,6 @@ instance Eq FieldLabel where 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} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 6c1d19b..75f1520 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -95,18 +95,23 @@ module Id {- ( 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, @@ -160,23 +165,23 @@ data IdDetails ---------------- 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 @@ -184,7 +189,7 @@ data IdDetails ---------------- Data constructors - | DataConId FullName + | DataConId Name ConTag [StrictnessMark] -- Strict args; length = arity [FieldLabel] -- Field labels for this constructor @@ -194,9 +199,10 @@ data IdDetails -- 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 @@ -230,7 +236,7 @@ data IdDetails -- 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 @@ -238,11 +244,11 @@ data IdDetails 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 @@ -359,7 +365,7 @@ their @IdInfo@). %---------------------------------------------------------------------- \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. @@ -453,14 +459,14 @@ unsafeGenId2Id (Id u ty d p i) = Id u (panic "unsafeGenId2Id:ty") d p i 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 @@ -492,8 +498,8 @@ toplevelishId (Id _ _ details _ _) = 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 @@ -514,8 +520,8 @@ idHasNoFreeTyVars (Id _ _ details _ info) = 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 @@ -588,7 +594,7 @@ pprIdInUnfolding in_scopes v 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 @@ -610,7 +616,7 @@ pprIdInUnfolding in_scopes v 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 @@ -657,7 +663,7 @@ pprIdInUnfolding in_scopes v 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] @@ -822,7 +828,7 @@ externallyVisibleId id@(Id _ _ details _ _) -} 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} @@ -1004,13 +1010,12 @@ getIdNamePieces show_uniqs id 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 @@ -1020,11 +1025,11 @@ getIdNamePieces show_uniqs id 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 @@ -1033,20 +1038,22 @@ getIdNamePieces show_uniqs id 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] @@ -1054,14 +1061,13 @@ getIdNamePieces show_uniqs id 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", @@ -1084,10 +1090,10 @@ getIdNamePieces show_uniqs id 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 @@ -1137,11 +1143,11 @@ mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInf 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 @@ -1173,8 +1179,8 @@ getConstMethodId clas op ty %************************************************************************ \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 @@ -1193,19 +1199,20 @@ no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty) 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} @@ -1236,7 +1243,7 @@ localiseId :: Id -> Id 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 -} @@ -1309,22 +1316,21 @@ addIdArity (Id u ty details pinfo info) arity %************************************************************************ \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 @@ -1402,8 +1408,9 @@ mkDataCon k n stricts fields tvs ctxt args_tys tycon 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)) @@ -1449,12 +1456,12 @@ fIRST_TAG = 1 -- Tags allocated from here for real constructors \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 @@ -1462,7 +1469,7 @@ dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon) 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 @@ -1473,17 +1480,17 @@ dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields \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 @@ -1767,20 +1774,6 @@ instance_export_flag clas inst_ty from_here -} \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 @@ -1799,8 +1792,8 @@ pprId other_sty id 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, @@ -1811,22 +1804,22 @@ pprId other_sty id (\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 @@ -1840,68 +1833,31 @@ pprId other_sty id \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 -> @@ -1922,16 +1878,6 @@ instance NamedThing (GenId ty) where 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 @@ -1942,69 +1888,11 @@ instance NamedThing (GenId ty) where 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. %************************************************************************ %* * diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 8f35f6a..6eebe45 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -138,7 +138,7 @@ data IdInfo -- 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} diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs index d5071b0..c1aa203 100644 --- a/ghc/compiler/basicTypes/IdUtils.lhs +++ b/ghc/compiler/basicTypes/IdUtils.lhs @@ -15,12 +15,11 @@ import CoreSyn 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 ) @@ -28,10 +27,10 @@ import Util ( panic ) \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 @@ -62,14 +61,12 @@ primOpId op (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} @@ -88,7 +85,7 @@ mk_prim_unfold prim_op tvs arg_tys = 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 diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index c809a49..f4667bb 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -7,139 +7,171 @@ #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} @@ -149,17 +181,8 @@ getNameFullName n = get_nm "getNameFullName" n \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 @@ -167,14 +190,8 @@ cmpName n1 n2 = c n1 n2 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} @@ -190,106 +207,68 @@ instance Ord Name where 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("") - 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} + diff --git a/ghc/compiler/basicTypes/NameLoop.lhi b/ghc/compiler/basicTypes/NameLoop.lhi deleted file mode 100644 index 70ed981..0000000 --- a/ghc/compiler/basicTypes/NameLoop.lhi +++ /dev/null @@ -1,20 +0,0 @@ -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} diff --git a/ghc/compiler/basicTypes/NameTypes.lhs b/ghc/compiler/basicTypes/NameTypes.lhs deleted file mode 100644 index b82c0fa..0000000 --- a/ghc/compiler/basicTypes/NameTypes.lhs +++ /dev/null @@ -1,306 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/basicTypes/ProtoName.lhs b/ghc/compiler/basicTypes/ProtoName.lhs deleted file mode 100644 index d8e3601..0000000 --- a/ghc/compiler/basicTypes/ProtoName.lhs +++ /dev/null @@ -1,245 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index 1915538..47b54a8 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -201,7 +201,7 @@ mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, 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 diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index e097564..d3ee26e 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -21,7 +21,7 @@ Haskell). -- UniqSupply module Unique ( - Unique, + Unique, Uniquable(..), u2i, -- hack: used in UniqFM pprUnique, pprUnique10, showUnique, @@ -106,7 +106,6 @@ module Unique ( monadZeroClassKey, mutableArrayPrimTyConKey, mutableByteArrayPrimTyConKey, - negateClassOpKey, nilDataConKey, numClassKey, ordClassKey, @@ -290,6 +289,12 @@ instance Ord Unique where 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: @@ -313,9 +318,6 @@ instance Outputable Unique where 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} %************************************************************************ @@ -579,7 +581,6 @@ enumFromToClassOpKey = mkPreludeMiscIdUnique 38 enumFromThenToClassOpKey= mkPreludeMiscIdUnique 39 eqClassOpKey = mkPreludeMiscIdUnique 40 geClassOpKey = mkPreludeMiscIdUnique 41 -negateClassOpKey = mkPreludeMiscIdUnique 42 \end{code} diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 4d17fc1..e678d18 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -44,6 +44,7 @@ import Id ( idPrimRep, toplevelishId, isDataCon, GenId{-instance NamedThing-} ) import Maybes ( catMaybes ) +import Outputable ( isLocallyDefined ) import PprAbsC ( pprAmode ) import PprStyle ( PprStyle(..) ) import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) ) @@ -122,7 +123,7 @@ newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo) 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 diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 5ed617d..1caec5f 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -50,7 +50,7 @@ import HeapOffs ( VirtualSpBOffset(..), VirtualHeapOffset(..) ) 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(..) ) @@ -407,7 +407,7 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default) -- 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 diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index 4252890..a3113e4 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -40,6 +40,7 @@ import Id ( dataConTag, dataConSig, emptyIdSet, GenId{-instance NamedThing-} ) +import Outputable ( getLocalName ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import TyCon ( tyConDataCons, mkSpecTyCon ) import Type ( typePrimRep ) @@ -208,7 +209,7 @@ genConInfo comp_info tycon data_con 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 @@ -314,7 +315,7 @@ genPhantomUpdInfo comp_info tycon data_con 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 diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index ae3bc5c..6256db0 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -86,6 +86,7 @@ import Id ( idType, idPrimRep, getIdArity, ) import IdInfo ( arityMaybe ) import Maybes ( assocMaybe, maybeToBool ) +import Outputable ( isLocallyDefined, getLocalName ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) import PrimRep ( getPrimRepSize, separateByPtrFollowness ) @@ -1322,7 +1323,7 @@ closureKind (MkClosureInfo _ lf _) 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} diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs index ecae173..9020e0b 100644 --- a/ghc/compiler/coreSyn/CoreLift.lhs +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -25,6 +25,7 @@ import Id ( idType, mkSysLocal, nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..), GenId{-instances-} ) +import Outputable ( isLocallyDefined, getSrcLoc ) import PrelInfo ( liftDataCon, mkLiftTy, statePrimTyCon ) import TyCon ( isBoxedTyCon, TyCon{-instance-} ) import Type ( maybeAppDataTyCon, eqTy ) @@ -274,7 +275,7 @@ mkLiftedId id u = 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) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index e31af01..6cff5a1 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -22,7 +22,9 @@ import Id ( idType, isBottomingId, 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 ) diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 51446f2..bcc9133 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -10,14 +10,12 @@ Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@. 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 ) diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 08bce62..aac5fd6 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -14,27 +14,22 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and #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} @@ -215,128 +210,3 @@ pprUfId sty (WorkerUfId unwrkr) = 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} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 18f817a..6952ef0 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -11,19 +11,17 @@ Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@, 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} @@ -34,9 +32,6 @@ import Util ( cmpList, panic#{-ToDo:rm eventually-} ) %* * %************************************************************************ -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 @@ -173,28 +168,6 @@ data BangType name | 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 @@ -237,12 +210,17 @@ instance (NamedThing name, Outputable name, Outputable pat, => 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} %************************************************************************ @@ -265,10 +243,8 @@ data InstDecl tyvar uvar name pat -- 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 @@ -293,11 +269,10 @@ instance (NamedThing name, Outputable name, Outputable pat, 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; diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index fc9356a..8c62d18 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -45,17 +45,20 @@ data HsExpr tyvar uvar id pat | 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 @@ -198,6 +201,7 @@ pprExpr sty expr@(HsApp e1 e2) 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 @@ -212,6 +216,13 @@ pprExpr sty (OpApp e1 op e2) 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 diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index f5c579b..031bf93 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -8,17 +8,12 @@ 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} %************************************************************************ @@ -29,22 +24,19 @@ import SrcLoc ( SrcLoc{-instances-} ) 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" @@ -71,7 +63,7 @@ data IE name | 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} @@ -85,60 +77,3 @@ instance (Outputable name) => Outputable (IE name) where 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} diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 11e4d26..9cf88be 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -47,6 +47,12 @@ data InPat name | 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 @@ -124,8 +130,15 @@ pprInPat sty (ConPatIn c pats) 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] @@ -185,7 +198,7 @@ pprOutPat sty (DictPat dicts methods) ppBesides [ppBracket (interpp'SP sty methods), ppRparen]] pprConPatTy sty ty - = ppBesides [ppLparen, ppr sty ty, ppRparen] + = ppParens (ppr sty ty) \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs index 1e5d9d1..59a29b3 100644 --- a/ghc/compiler/hsSyn/HsPragmas.lhs +++ b/ghc/compiler/hsSyn/HsPragmas.lhs @@ -9,23 +9,22 @@ 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} @@ -34,12 +33,16 @@ Certain pragmas expect to be pinned onto certain constructs. 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: @@ -57,6 +60,9 @@ data GenPragmas name noGenPragmas = NoGenPragmas +isNoGenPragmas NoGenPragmas = True +isNoGenPragmas _ = False + data ImpUnfolding name = NoImpUnfolding | ImpMagicUnfolding FAST_STRING -- magic "unfolding" @@ -78,6 +84,11 @@ For a class's super-class dictionary selectors: 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: @@ -87,7 +98,11 @@ data ClassOpPragmas name | ClassOpPragmas (GenPragmas name) -- for method selector (GenPragmas name) -- for default method + noClassOpPragmas = NoClassOpPragmas + +isNoClassOpPragmas NoClassOpPragmas = True +isNoClassOpPragmas _ = False \end{code} \begin{code} @@ -106,6 +121,11 @@ data InstancePragmas name [([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) diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 447027c..aa4a6bd 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -27,7 +27,7 @@ module HsSyn ( ) where -import Ubiq{-uitous-} +import Ubiq -- friends: import HsBinds @@ -39,13 +39,12 @@ import HsMatches 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. @@ -57,29 +56,28 @@ instance Outputable Fake 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} @@ -88,11 +86,12 @@ instance (NamedThing name, Outputable name, Outputable pat, 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 [ @@ -100,14 +99,21 @@ instance (NamedThing name, Outputable name, Outputable pat, 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} diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 471c620..13292e2 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -15,20 +15,19 @@ module HsTypes ( 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} @@ -83,79 +82,9 @@ data MonoType name #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 @@ -230,23 +159,22 @@ ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty) #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 @@ -254,12 +182,79 @@ extractMonoTyNames eq ty 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} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index cf03645..8f7ce33 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -207,7 +207,7 @@ opt_HideMostBuiltinNames = lookup SLIT("-fmin-builtin-names") 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") diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index d588f68..89866b7 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -7,11 +7,11 @@ #include "HsVersions.h" module ErrUtils ( - - Error(..), - addErrLoc, addShortErrLocLine, - dontAddErrLoc, pprBagOfErrors - + Error(..), Warning(..), Message(..), + addErrLoc, + addShortErrLocLine, + dontAddErrLoc, + pprBagOfErrors ) where import Ubiq{-uitous-} @@ -24,6 +24,8 @@ import SrcLoc ( mkUnknownSrcLoc, SrcLoc{-instance-} ) \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 @@ -47,4 +49,3 @@ pprBagOfErrors sty bag_of_errors = let pretties = map ( \ e -> e sty ) (bagToList bag_of_errors) in ppAboves (map (\ p -> ppAbove ppSP p) pretties) \end{code} - diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 7e84618..9d20713 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -44,15 +44,14 @@ import PprStyle ( PprStyle(..) ) 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} @@ -77,7 +76,7 @@ doIt (core_cmds, stg_cmds) input_pgm show_pass "Reader" `thenMn_` rdModule `thenMn` - \ (mod_name, export_list_fns, absyn_tree) -> + \ (mod_name, rdr_module) -> let -- reader things used much later @@ -88,10 +87,10 @@ doIt (core_cmds, stg_cmds) input_pgm 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 @@ -107,30 +106,38 @@ doIt (core_cmds, stg_cmds) input_pgm 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) @@ -138,20 +145,22 @@ doIt (core_cmds, stg_cmds) input_pgm 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... @@ -245,7 +254,7 @@ doIt (core_cmds, stg_cmds) input_pgm 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 @@ -287,8 +296,13 @@ doIt (core_cmds, stg_cmds) input_pgm 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: @@ -337,7 +351,7 @@ doIt (core_cmds, stg_cmds) input_pgm 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 @@ -433,7 +447,7 @@ ppSourceStats (HsModule name exports imports fixities typedecls typesigs 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 diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 46bb220..1e60923 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -326,7 +326,7 @@ get_tycon_pair tycon 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} @@ -381,7 +381,7 @@ do_value better_id_fn inline_env val = 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 @@ -513,10 +513,10 @@ is_exportable_tycon_or_class export_list_fns tc 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 diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index b122217..420f501 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -342,13 +342,11 @@ instance Ord Reg where 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} diff --git a/ghc/compiler/parser/UgenAll.lhs b/ghc/compiler/parser/UgenAll.lhs index 3600897..9bb3e80 100644 --- a/ghc/compiler/parser/UgenAll.lhs +++ b/ghc/compiler/parser/UgenAll.lhs @@ -11,9 +11,7 @@ module UgenAll ( -- re-exported ugen-generated stuff U_binding.. , U_constr.. , - U_coresyn.. , U_entidt.. , - U_hpragma.. , U_list.. , U_literal.. , U_maybe.. , @@ -32,9 +30,7 @@ import Ubiq{-uitous-} -- 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 diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs index 95001bf..7018511 100644 --- a/ghc/compiler/parser/UgenUtil.lhs +++ b/ghc/compiler/parser/UgenUtil.lhs @@ -9,46 +9,39 @@ module UgenUtil ( 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} @@ -60,13 +53,7 @@ rdU_VOID_STAR x = returnUgn x 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 @@ -88,13 +75,24 @@ rdU_hstring x \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} diff --git a/ghc/compiler/parser/binding.ugn b/ghc/compiler/parser/binding.ugn index 9337aaa..3b130ae 100644 --- a/ghc/compiler/parser/binding.ugn +++ b/ghc/compiler/parser/binding.ugn @@ -7,10 +7,7 @@ import Ubiq -- debugging consistency check 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 @@ -20,14 +17,12 @@ type binding; 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; >; @@ -37,37 +32,24 @@ type binding; 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) */ - 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; diff --git a/ghc/compiler/parser/coresyn.ugn b/ghc/compiler/parser/coresyn.ugn deleted file mode 100644 index feeb5ac..0000000 --- a/ghc/compiler/parser/coresyn.ugn +++ /dev/null @@ -1,121 +0,0 @@ -%{ -#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 : ; - corec : ; - corec_pair: ; - - 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; diff --git a/ghc/compiler/parser/hpragma.ugn b/ghc/compiler/parser/hpragma.ugn deleted file mode 100644 index e3f9c49..0000000 --- a/ghc/compiler/parser/hpragma.ugn +++ /dev/null @@ -1,63 +0,0 @@ -%{ -#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; diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex index 892d2f9..e54bb0b 100644 --- a/ghc/compiler/parser/hslexer.flex +++ b/ghc/compiler/parser/hslexer.flex @@ -144,12 +144,12 @@ static int hslineno_save = 0, /* Line Number */ 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 */ @@ -237,7 +237,7 @@ static int StateDepth = -1; 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] @@ -292,67 +292,11 @@ NL [\n\r] new_filename(tempf); hsplineno = hslineno; hscolno = 0; hspcolno = 0; } -"{-# GHC_PRAGMA INTERFACE VERSION "{D}+" #-}" { - sscanf(yytext+33,"%d ",&thisIfacePragmaVersion); - } -"{-# GHC_PRAGMA " { - if ( ignorePragmas || - thisIfacePragmaVersion < minAcceptablePragmaVersion || - thisIfacePragmaVersion > maxAcceptablePragmaVersion) { - nested_comments = 1; - PUSH_STATE(Comment); - } else { - PUSH_STATE(GhcPragma); - RETURN(GHC_PRAGMA); - } - } -"_N_" { RETURN(NO_PRAGMA); } -"_NI_" { RETURN(NOINFO_PRAGMA); } -"_DEFOREST_" { RETURN(DEFOREST_PRAGMA); } -"_SPECIALISE_" { RETURN(SPECIALISE_PRAGMA); } -"_A_" { RETURN(ARITY_PRAGMA); } -"_U_" { RETURN(UPDATE_PRAGMA); } -"_S_" { RETURN(STRICTNESS_PRAGMA); } -"_K_" { RETURN(KIND_PRAGMA); } -"_MF_" { RETURN(MAGIC_UNFOLDING_PRAGMA); } -"_F_" { RETURN(UNFOLDING_PRAGMA); } - -"_!_" { RETURN(COCON); } -"_#_" { RETURN(COPRIM); } -"_APP_" { RETURN(COAPP); } -"_TYAPP_" { RETURN(COTYAPP); } -"_ALG_" { RETURN(CO_ALG_ALTS); } -"_PRIM_" { RETURN(CO_PRIM_ALTS); } -"_NO_DEFLT_" { RETURN(CO_NO_DEFAULT); } -"_LETREC_" { RETURN(CO_LETREC); } - -"_PRELUDE_DICTS_CC_" { RETURN(CO_PRELUDE_DICTS_CC); } -"_ALL_DICTS_CC_" { RETURN(CO_ALL_DICTS_CC); } -"_USER_CC_" { RETURN(CO_USER_CC); } -"_AUTO_CC_" { RETURN(CO_AUTO_CC); } -"_DICT_CC_" { RETURN(CO_DICT_CC); } - -"_DUPD_CC_" { RETURN(CO_DUPD_CC); } -"_CAF_CC_" { RETURN(CO_CAF_CC); } - -"_SDSEL_" { RETURN(CO_SDSEL_ID); } -"_METH_" { RETURN(CO_METH_ID); } -"_DEFM_" { RETURN(CO_DEFM_ID); } -"_DFUN_" { RETURN(CO_DFUN_ID); } -"_CONSTM_" { RETURN(CO_CONSTM_ID); } -"_SPEC_" { RETURN(CO_SPEC_ID); } -"_WRKR_" { RETURN(CO_WRKR_ID); } -"_ORIG_" { RETURN(CO_ORIG_NM); /* fully-qualified original name*/ } - -"_ALWAYS_" { RETURN(UNFOLD_ALWAYS); } -"_IF_ARGS_" { RETURN(UNFOLD_IF_ARGS); } - -"_NOREP_I_" { RETURN(NOREP_INTEGER); } -"_NOREP_R_" { RETURN(NOREP_RATIONAL); } -"_NOREP_S_" { RETURN(NOREP_STRING); } - -" #-}" { POP_STATE; RETURN(END_PRAGMA); } +"{-#"{WS}*"INTERFACE" { + PUSH_STATE(UserPragma); + RETURN(INTERFACE_UPRAGMA); + } "{-#"{WS}*"SPECIALI"[SZ]E { PUSH_STATE(UserPragma); RETURN(SPECIALISE_UPRAGMA); @@ -386,7 +330,7 @@ NL [\n\r] */ %} -"case" { RETURN(CASE); } +"case" { RETURN(CASE); } "class" { RETURN(CLASS); } "data" { RETURN(DATA); } "default" { RETURN(DEFAULT); } @@ -395,15 +339,15 @@ NL [\n\r] "else" { RETURN(ELSE); } "if" { RETURN(IF); } "import" { RETURN(IMPORT); } -"in" { RETURN(IN); } +"in" { RETURN(IN); } "infix" { RETURN(INFIX); } "infixl" { RETURN(INFIXL); } "infixr" { RETURN(INFIXR); } "instance" { RETURN(INSTANCE); } -"let" { RETURN(LET); } +"let" { RETURN(LET); } "module" { RETURN(MODULE); } "newtype" { RETURN(NEWTYPE); } -"of" { RETURN(OF); } +"of" { RETURN(OF); } "then" { RETURN(THEN); } "type" { RETURN(TYPE); } "where" { RETURN(WHERE); } @@ -411,14 +355,12 @@ NL [\n\r] "as" { RETURN(AS); } "hiding" { RETURN(HIDING); } "qualified" { RETURN(QUALIFIED); } -"interface" { RETURN(INTERFACE); } -"_scc_" { RETURN(SCC); } -"_ccall_" { RETURN(CCALL); } -"_ccall_GC_" { RETURN(CCALL_GC); } -"_casm_" { RETURN(CASM); } -"_casm_GC_" { RETURN(CASM_GC); } -"_forall_" { RETURN(FORALL); } +"_scc_" { RETURN(SCC); } +"_ccall_" { RETURN(CCALL); } +"_ccall_GC_" { RETURN(CCALL_GC); } +"_casm_" { RETURN(CASM); } +"_casm_GC_" { RETURN(CASM_GC); } %{ /* @@ -426,32 +368,30 @@ NL [\n\r] */ %} -"(" { RETURN(OPAREN); } -")" { RETURN(CPAREN); } -"[" { RETURN(OBRACK); } -"]" { RETURN(CBRACK); } -"{" { RETURN(OCURLY); } -"}" { RETURN(CCURLY); } -"," { RETURN(COMMA); } -";" { RETURN(SEMI); } -"`" { RETURN(BQUOTE); } -"_" { RETURN(WILDCARD); } - -".." { RETURN(DOTDOT); } -"::" { RETURN(DCOLON); } -"=" { RETURN(EQUAL); } -"\\" { RETURN(LAMBDA); } -"|" { RETURN(VBAR); } -"<-" { RETURN(LARROW); } -"->" { RETURN(RARROW); } -"-" { RETURN(MINUS); } - -"=>" { RETURN(DARROW); } -"@" { RETURN(AT); } -"!" { RETURN(BANG); } -"~" { RETURN(LAZY); } - -"_/\\_" { RETURN(TYLAMBDA); } +"(" { RETURN(OPAREN); } +")" { RETURN(CPAREN); } +"[" { RETURN(OBRACK); } +"]" { RETURN(CBRACK); } +"{" { RETURN(OCURLY); } +"}" { RETURN(CCURLY); } +"," { RETURN(COMMA); } +";" { RETURN(SEMI); } +"`" { RETURN(BQUOTE); } +"_" { RETURN(WILDCARD); } + +".." { RETURN(DOTDOT); } +"::" { RETURN(DCOLON); } +"=" { RETURN(EQUAL); } +"\\" { RETURN(LAMBDA); } +"|" { RETURN(VBAR); } +"<-" { RETURN(LARROW); } +"->" { RETURN(RARROW); } +"-" { RETURN(MINUS); } + +"=>" { RETURN(DARROW); } +"@" { RETURN(AT); } +"!" { RETURN(BANG); } +"~" { RETURN(LAZY); } %{ /* @@ -477,11 +417,11 @@ NL [\n\r] yylval.uid = xstrndup(yytext, yyleng); RETURN(INTEGER); } -("-")?{N}"#" { +("-")?{N}"#" { yylval.uid = xstrndup(yytext, yyleng - 1); RETURN(INTPRIM); } -{N} { +{N} { yylval.uid = xstrndup(yytext, yyleng); RETURN(INTEGER); } @@ -492,11 +432,11 @@ NL [\n\r] */ %} -("-")?{F}"##" { +("-")?{F}"##" { yylval.uid = xstrndup(yytext, yyleng - 2); RETURN(DOUBLEPRIM); } -("-")?{F}"#" { +("-")?{F}"#" { yylval.uid = xstrndup(yytext, yyleng - 1); RETURN(FLOATPRIM); } @@ -511,7 +451,7 @@ NL [\n\r] */ %} -"``"[^']+"''" { +"``"[^']+"''" { hsnewid(yytext + 2, yyleng - 4); RETURN(CLITLIT); } @@ -523,14 +463,11 @@ NL [\n\r] */ %} -"_NIL_" { hsnewid(yytext, yyleng); RETURN(CONID); } -"_TUP_"{D}+ { hsnewid(yytext, yyleng); RETURN(CONID); } -[a-z]{i}*"$"[a-z]{i}* { hsnewid(yytext, yyleng); RETURN(TYVAR_TEMPLATE_ID); } %{ /* These SHOULDNAE work in "Code" (sigh) */ %} -{Id}"#" { +{Id}"#" { if (! (nonstandardFlag || in_interface)) { char errbuf[ERR_BUF_SIZE]; sprintf(errbuf, "Non-standard identifier (trailing `#'): %s\n", yytext); @@ -539,7 +476,7 @@ NL [\n\r] hsnewid(yytext, yyleng); RETURN(_isconstr(yytext) ? CONID : VARID); } -_+{Id} { +_+{Id} { if (! (nonstandardFlag || in_interface)) { char errbuf[ERR_BUF_SIZE]; sprintf(errbuf, "Non-standard identifier (leading underscore): %s\n", yytext); @@ -549,19 +486,19 @@ NL [\n\r] RETURN(isconstr(yytext) ? CONID : VARID); /* NB: ^^^^^^^^ : not the macro! */ } -{Id} { +{Id} { hsnewid(yytext, yyleng); RETURN(_isconstr(yytext) ? CONID : VARID); } -{SId} { +{SId} { hsnewid(yytext, yyleng); RETURN(_isconstr(yytext) ? CONSYM : VARSYM); } -{Mod}"."{Id} { +{Mod}"."{Id} { BOOLEAN isconstr = hsnewqid(yytext, yyleng); RETURN(isconstr ? QCONID : QVARID); } -{Mod}"."{SId} { +{Mod}"."{SId} { BOOLEAN isconstr = hsnewqid(yytext, yyleng); RETURN(isconstr ? QCONSYM : QVARSYM); } @@ -576,7 +513,7 @@ NL [\n\r] */ %} -"`"{Id}"#`" { +"`"{Id}"#`" { hsnewid(yytext + 1, yyleng - 2); RETURN(_isconstr(yytext+1) ? CONSYM : VARSYM); } @@ -595,7 +532,7 @@ NL [\n\r] */ %} -'({CHAR}|"\"")"'#" { +'({CHAR}|"\"")"'#" { yylval.uhstring = installHstring(1, yytext+1); RETURN(CHARPRIM); } @@ -607,7 +544,7 @@ NL [\n\r] sprintf(errbuf, "'' is not a valid character (or string) literal\n"); hsperror(errbuf); } -'({CHAR}|"\"")* { +'({CHAR}|"\"")* { hsmlcolno = hspcolno; cleartext(); addtext(yytext+1, yyleng-1); @@ -675,16 +612,16 @@ NL [\n\r] */ %} -"\""({CHAR}|"'")*"\""# { +"\""({CHAR}|"'")*"\""# { yylval.uhstring = installHstring(yyleng-3, yytext+1); /* the -3 accounts for the " on front, "# on the end */ RETURN(STRINGPRIM); } -"\""({CHAR}|"'")*"\"" { +"\""({CHAR}|"'")*"\"" { yylval.uhstring = installHstring(yyleng-2, yytext+1); RETURN(STRING); } -"\""({CHAR}|"'")* { +"\""({CHAR}|"'")* { hsmlcolno = hspcolno; cleartext(); addtext(yytext+1, yyleng-1); @@ -838,7 +775,7 @@ NL [\n\r] %} "--".*{NL}?{WS}* | -{WS}+ { noGap = FALSE; } +{WS}+ { noGap = FALSE; } %{ /* @@ -848,7 +785,7 @@ NL [\n\r] */ %} -"{-" { +"{-" { noGap = FALSE; nested_comments = 1; PUSH_STATE(Comment); } @@ -867,7 +804,7 @@ NL [\n\r] */ %} -(.|\n) { +(.|\n) { fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `", input_filename, hsplineno, hspcolno + 1); format_string(stderr, (unsigned char *) yytext, 1); @@ -939,10 +876,6 @@ NL [\n\r] hsplineno = hslineno; hspcolno = hscolno; hsperror("unterminated string literal"); } -<> { - hsplineno = hslineno; hspcolno = hscolno; - hsperror("unterminated interface pragma"); - } <> { hsplineno = hslineno; hspcolno = hscolno; hsperror("unterminated user-specified pragma"); @@ -1171,7 +1104,10 @@ yylex() 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(); } @@ -1182,7 +1118,7 @@ yylex() /********************************************************************** * * * * -* Input Processing for Interfaces * +* Input Processing for Interfaces -- Not currently used !!! * * * * * **********************************************************************/ diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index 0743c55..907e08a 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -40,24 +40,13 @@ **********************************************************************/ 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 */ @@ -80,28 +69,13 @@ extern int endlineno; * * **********************************************************************/ -/* 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 { @@ -121,8 +95,6 @@ extern int thisIfacePragmaVersion; float ufloat; char *ustring; hstring uhstring; - hpragma uhpragma; - coresyn ucoresyn; } @@ -186,7 +158,7 @@ extern int thisIfacePragmaVersion; %token MODULE NEWTYPE OF %token THEN TYPE WHERE -%token INTERFACE SCC +%token SCC %token CCALL CCALL_GC CASM CASM_GC @@ -210,20 +182,9 @@ extern int thisIfacePragmaVersion; * * **********************************************************************/ -%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 /********************************************************************** * * @@ -275,19 +236,8 @@ extern int thisIfacePragmaVersion; 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 maybeexports impas maybeimpspec - type_maybe core_type_maybe +%type maybeexports impas maybeimpspec deriving %type impspec @@ -302,7 +252,6 @@ extern int thisIfacePragmaVersion; %type 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 @@ -317,13 +266,7 @@ extern int thisIfacePragmaVersion; %type 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 valrhs1 altrest @@ -331,7 +274,6 @@ extern int thisIfacePragmaVersion; gtyconapp ntyconapp ntycon gtyconvars bbtype batype btyconapp class restrict_inst general_inst tyvar - core_type %type constr field @@ -342,18 +284,6 @@ extern int thisIfacePragmaVersion; %type export import -%type 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 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 commas impqual /********************************************************************** @@ -364,67 +294,57 @@ extern int thisIfacePragmaVersion; * * **********************************************************************/ -%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); } @@ -460,46 +380,32 @@ impdecls: impdecl { $$ = $1; } ; -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: @@ -521,546 +427,6 @@ iname : var { $$ = mknoqual($1); } | 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); } - ; - - /********************************************************************** * * * * @@ -1091,16 +457,8 @@ fix : INFIXL INTEGER { Precedence = checkfixity($2); Fixity = INFIXL; } 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 @@ -1121,7 +479,7 @@ topdecls: topdecl $$ = $3; SAMEFN = 0; } - ; + ; topdecl : typed { $$ = $1; } | datad { $$ = $1; } @@ -1136,28 +494,26 @@ typed : typekey simple EQUAL type { $$ = mknbind($2,$4,startlineno); } ; -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(); } @@ -1166,14 +522,14 @@ 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); } @@ -1194,8 +550,8 @@ defaultd: defaultkey OPAREN types CPAREN { $$ = mkdbind($3,startlineno); | defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); } ; -decls : decl - | decls SEMI decl +decls : decl + | decls SEMI decl { if(SAMEFN) { @@ -1207,17 +563,17 @@ decls : decl } ; - /* 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. @@ -1313,8 +669,6 @@ ctype : type DARROW type { $$ = mkcontext(type2context($1),$3); } /* 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 */ @@ -1339,10 +693,7 @@ ntycon : tyvar { $$ = $1; } | 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); } @@ -1563,7 +914,7 @@ exp : oexp DCOLON ctype { $$ = mkrestr($1,$3); } 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 ; @@ -1571,7 +922,7 @@ oexp : oexp qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); precparse($$); } 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 ; @@ -1582,17 +933,17 @@ dexp : MINUS kexp { $$ = mknegate($2,NULL,NULL); } 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 ; @@ -1661,9 +1012,9 @@ fexp : fexp aexp { $$ = mkap($1,$2); } 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))); @@ -1711,8 +1062,10 @@ texps : exp { $$ = mkpar($1); } /* mkpar: so we don't flatten last element in t | 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 */ ; @@ -1807,33 +1160,11 @@ leftexp : LARROW exp { $$ = $2; } */ 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); } ; /* @@ -1842,7 +1173,7 @@ opat : dpat */ -dpat : MINUS fpat { $$ = mknegate($2,NULL,NULL); } +dpat : MINUS fpat { $$ = mknegate($2); } | fpat ; @@ -1851,7 +1182,7 @@ fpat : fpat aapat { $$ = mkap($1,$2); } | aapat ; -dpatk : minuskey fpat { $$ = mknegate($2,NULL,NULL); } +dpatk : minuskey fpat { $$ = mknegate($2); } | fpatk ; @@ -1907,7 +1238,7 @@ pats : pat COMMA pats { $$ = mklcons($1, $3); } /* right recursion? (WDP) */ ; -pat : pat qconop bpat { $$ = mkinfixap($2,$1,$3); precparse($$); } +pat : pat qconop bpat { $$ = mkinfixap($2,$1,$3); } | bpat ; @@ -1947,11 +1278,7 @@ lit_constant: | 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); } @@ -2141,7 +1468,6 @@ varid : VARID | AS { $$ = install_literal("as"); } | HIDING { $$ = install_literal("hiding"); } | QUALIFIED { $$ = install_literal("qualified"); } - | INTERFACE { $$ = install_literal("interface"); } ; /* DARROW BANG are valid varsyms */ @@ -2154,7 +1480,7 @@ ccallid : VARID | CONID ; -tyvar : varid { $$ = mknamedtvar($1); } +tyvar : varid { $$ = mknamedtvar(mknoqual($1)); } ; tycon : CONID ; @@ -2216,6 +1542,14 @@ vccurly1: * * **********************************************************************/ +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". diff --git a/ghc/compiler/parser/hspincl.h b/ghc/compiler/parser/hspincl.h index 0f3530f..6446ddd 100644 --- a/ghc/compiler/parser/hspincl.h +++ b/ghc/compiler/parser/hspincl.h @@ -50,8 +50,6 @@ #include "either.h" #include "ttype.h" #include "constr.h" -#include "coresyn.h" -#include "hpragma.h" #include "binding.h" #include "entidt.h" #include "tree.h" diff --git a/ghc/compiler/parser/literal.ugn b/ghc/compiler/parser/literal.ugn index d8424a4..fea4048 100644 --- a/ghc/compiler/parser/literal.ugn +++ b/ghc/compiler/parser/literal.ugn @@ -16,10 +16,5 @@ type literal; 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; diff --git a/ghc/compiler/parser/syntax.c b/ghc/compiler/parser/syntax.c index ad5d3d6..fec0ae8 100644 --- a/ghc/compiler/parser/syntax.c +++ b/ghc/compiler/parser/syntax.c @@ -35,8 +35,6 @@ qid fns[MAX_CONTEXTS] = { NULL }; 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)); @@ -85,13 +83,6 @@ checksamefn(fn) } -void -checkinpat() -{ - if(!inpat) - hsperror("pattern syntax used in expression"); -} - /* ------------------------------------------------------------------------ */ @@ -327,9 +318,6 @@ lhs_is_patt(tree e) case ident: return(TRUE); - /* This change might break ap infixop below. BEWARE. - return (isconstr(qid_to_string(gident(e)))); - */ case ap: { @@ -433,107 +421,6 @@ binding rule; 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) @@ -550,6 +437,7 @@ createpat(guards,where) return(mkpgrhs(PREVPATT,guards,where,func,endlineno)); } + char * ineg(i) char *i; @@ -561,21 +449,6 @@ ineg(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. @@ -611,7 +484,6 @@ checkorder2(decls,sigs) return(checksig(sigs,decls)); } - static BOOLEAN checksig(sig,decl) BOOLEAN sig; @@ -644,38 +516,6 @@ checkdostmts(stmts) /* - 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. */ @@ -718,3 +558,145 @@ splittyconapp(app, tyc, tys) 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 */ + diff --git a/ghc/compiler/parser/tree.ugn b/ghc/compiler/parser/tree.ugn index 60974fa..79bbabc 100644 --- a/ghc/compiler/parser/tree.ugn +++ b/ghc/compiler/parser/tree.ugn @@ -22,10 +22,11 @@ type tree; 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; >; @@ -35,13 +36,7 @@ type tree; 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; diff --git a/ghc/compiler/parser/ttype.ugn b/ghc/compiler/parser/ttype.ugn index 3b03cd3..f548b32 100644 --- a/ghc/compiler/parser/ttype.ugn +++ b/ghc/compiler/parser/ttype.ugn @@ -11,7 +11,7 @@ import U_qid %}} type ttype; tname : < gtypeid : qid; >; - namedtvar : < gnamedtvar : unkId; /* ToDo: rm unkIds entirely??? */ >; + namedtvar : < gnamedtvar : qid; >; tllist : < gtlist : ttype; >; ttuple : < gttuple : list; >; tfun : < gtin : ttype; @@ -21,11 +21,5 @@ type ttype; tbang : < gtbang : ttype; >; context : < gtcontextl : list; gtcontextt : ttype; >; - - unidict : < gunidict_clas : qid; - gunidict_ty : ttype; >; - unityvartemplate: ; - uniforall : < guniforall_tv : list; - guniforall_ty : ttype; >; end; diff --git a/ghc/compiler/parser/utils.h b/ghc/compiler/parser/utils.h index 282bfc7..c396992 100644 --- a/ghc/compiler/parser/utils.h +++ b/ghc/compiler/parser/utils.h @@ -118,12 +118,15 @@ tree function PROTO((tree)); 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 *)); diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index e60b8d6..f857b89 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -13,8 +13,9 @@ module PrelInfo ( 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, @@ -96,13 +97,19 @@ import TysPrim -- TYPES 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} @@ -117,74 +124,93 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and @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, @@ -221,12 +247,14 @@ min_nonprim_tycon_list -- used w/ HideMostBuiltinNames ratioTyCon, liftTyCon, return2GMPsTyCon, -- ADR asked for these last two (WDP 94/11) - returnIntAndGMPTyCon ] + returnIntAndGMPTyCon + ] + data_tycons - = [addrTyCon, + = [ + addrTyCon, boolTyCon, --- byteArrayTyCon, charTyCon, orderingTyCon, doubleTyCon, @@ -235,8 +263,6 @@ data_tycons integerTyCon, liftTyCon, mallocPtrTyCon, --- mutableArrayTyCon, --- mutableByteArrayTyCon, ratioTyCon, return2GMPsTyCon, returnIntAndGMPTyCon, @@ -260,78 +286,74 @@ data_tycons ] 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(">#")), @@ -350,56 +372,56 @@ funny_name_primops (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} diff --git a/ghc/compiler/prelude/PrelLoop.lhi b/ghc/compiler/prelude/PrelLoop.lhi index 2293431..9d17859 100644 --- a/ghc/compiler/prelude/PrelLoop.lhi +++ b/ghc/compiler/prelude/PrelLoop.lhi @@ -8,18 +8,18 @@ import PreludePS ( _PackedString ) 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} diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index 88b17a8..08bcc1a 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -13,7 +13,7 @@ module PrelMods ( 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 @@ -33,4 +33,7 @@ pRELUDE_PRIMIO = SLIT("PreludePrimIO") 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} diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index b4845f7..5c5375a 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -20,13 +20,10 @@ import TysWiredIn -- 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 ) @@ -40,7 +37,7 @@ 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} %************************************************************************ diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 0fd25b7..fe5fce6 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -37,7 +37,6 @@ import TysWiredIn 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 diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 092a9f4..a64821d 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -14,7 +14,7 @@ module TysPrim where 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(..) ) @@ -38,11 +38,12 @@ alphaTys = mkTyVarTys alphaTyVars \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 [] @@ -113,14 +114,14 @@ statePrimTyCon = pcPrimTyCon statePrimTyConKey SLIT("State#") 1 \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} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 977758f..327b209 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -96,8 +96,8 @@ import TysPrim -- 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 @@ -114,19 +114,21 @@ addOneToSpecEnv = error "TysWiredIn:addOneToSpecEnv = " 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 @@ -432,11 +434,9 @@ mkStateTransformerTy s a = mkSynTy stTyCon [s, a] 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} @@ -453,12 +453,9 @@ mkPrimIoTy a = mkSynTy primIoTyCon [a] 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} %************************************************************************ @@ -649,12 +646,9 @@ ratioDataCon = pcDataCon ratioDataConKey pRELUDE_RATIO SLIT(":%") 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} %************************************************************************ @@ -709,10 +703,7 @@ stringTy = mkListTy charTy stringTyCon = mkSynTyCon - stringTyConKey - (mkPreludeCoreName pRELUDE_CORE SLIT("String")) + (mkBuiltinName stringTyConKey pRELUDE_CORE SLIT("String")) mkBoxedTypeKind - 0 - [] -- type variables - stringTy + 0 [] stringTy \end{code} diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index f9d5a61..f60cff3 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -30,6 +30,7 @@ module CostCentre ( 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(..) ) @@ -400,8 +401,8 @@ uppCostCentre sty print_as_string cc 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 _ = "" diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs index 47e802e..e6c65c4 100644 --- a/ghc/compiler/reader/PrefixSyn.lhs +++ b/ghc/compiler/reader/PrefixSyn.lhs @@ -14,7 +14,6 @@ module PrefixSyn ( RdrBinding(..), RdrId(..), RdrMatch(..), - RdrTySigPragmas(..), SigConverter(..), SrcFile(..), SrcFun(..), @@ -23,16 +22,16 @@ module PrefixSyn ( 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} @@ -40,51 +39,43 @@ data RdrBinding = 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} diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index c30abba..b24230c 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -9,14 +9,13 @@ Support routines for reading prefix-form from the Lex/Yacc parser. #include "HsVersions.h" module PrefixToHs ( - cvBinds, + cvValSig, cvClassOpSig, cvInstDeclSig, + cvBinds, cvMatches, cvMonoBinds, cvSepdBinds, - cvValSig, - sepDeclsForInterface, sepDeclsForTopBinds, sepDeclsIntoSigsAndBinds ) where @@ -28,7 +27,6 @@ import HsSyn import RdrHsSyn import HsPragmas ( noGenPragmas, noClassOpPragmas ) -import ProtoName ( ProtoName(..) ) import SrcLoc ( mkSrcLoc2 ) import Util ( panic, assertPanic ) \end{code} @@ -44,17 +42,11 @@ these conversion functions: \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 ] @@ -73,11 +65,11 @@ initially, and non recursive definitions are discovered by the dependency 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) @@ -85,7 +77,7 @@ cvSepdBinds sf sig_cvtr bindings 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) @@ -100,7 +92,7 @@ cvMonoBinds sf bindings mkMonoBindsAndSigs :: SrcFile -> SigConverter -> [RdrBinding] - -> (ProtoNameMonoBinds, [ProtoNameSig]) + -> (RdrNameMonoBinds, [RdrNameSig]) mkMonoBindsAndSigs sf sig_cvtr fbs = foldl mangle_bind (EmptyMonoBinds, []) fbs @@ -113,7 +105,7 @@ mkMonoBindsAndSigs sf sig_cvtr 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) @@ -149,7 +141,7 @@ mkMonoBindsAndSigs sf sig_cvtr fbs \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) @@ -157,7 +149,7 @@ cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr 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) @@ -166,8 +158,8 @@ cvFunMonoBind sf 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 @@ -201,7 +193,7 @@ cvMatch sf is_case rdr_match 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} @@ -223,7 +215,6 @@ defaults RdrDefaultDecl 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, @@ -232,99 +223,84 @@ then checks that what it got is appropriate for that situation. \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 } @@ -333,7 +309,7 @@ sepDeclsIntoSigsAndBinds binding 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) @@ -342,18 +318,4 @@ sepDeclsIntoSigsAndBinds binding 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} diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index 3df812b..29f69cb 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -3,159 +3,93 @@ % \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} %************************************************************************ @@ -164,47 +98,17 @@ getNonPrelOuterTyCon _ = Nothing %* * %************************************************************************ -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) @@ -213,183 +117,6 @@ 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} diff --git a/ghc/compiler/reader/RdrLoop.lhi b/ghc/compiler/reader/RdrLoop.lhi deleted file mode 100644 index debf4fc..0000000 --- a/ghc/compiler/reader/RdrLoop.lhi +++ /dev/null @@ -1,25 +0,0 @@ -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} - diff --git a/ghc/compiler/reader/ReadPragmas.lhs b/ghc/compiler/reader/ReadPragmas.lhs deleted file mode 100644 index c62eb58..0000000 --- a/ghc/compiler/reader/ReadPragmas.lhs +++ /dev/null @@ -1,547 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 733dd7f..1ed9bd2 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -7,30 +7,26 @@ #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} @@ -61,16 +57,20 @@ wlkMaybe wlk_it (U_just x) \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} %************************************************************************ @@ -80,57 +80,46 @@ wlkQid (U_gid n name) %************************************************************************ \begin{code} -rdModule :: MainIO - (FAST_STRING, -- this module's name - (FAST_STRING -> Bool, -- a function to chk if is in the export list - FAST_STRING -> Bool), -- a function to chk if 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} %************************************************************************ @@ -140,19 +129,20 @@ rdModule %************************************************************************ \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 -> @@ -179,9 +169,9 @@ wlkExpr 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 @@ -191,9 +181,9 @@ wlkExpr expr ) 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 @@ -201,10 +191,10 @@ wlkExpr expr 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 @@ -216,23 +206,23 @@ wlkExpr expr 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 -> @@ -312,9 +302,9 @@ wlkExpr expr 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 -> @@ -335,17 +325,17 @@ wlkExpr expr 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 @@ -364,8 +354,9 @@ a series of ``applications''. \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 -> @@ -378,16 +369,6 @@ wlkPat pat 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) @@ -395,7 +376,7 @@ wlkPat pat U_ident nn -> -- simple identifier wlkQid nn `thenUgn` \ n -> returnUgn ( - if isConopPN n + if isConopRdr n then ConPatIn n [] else VarPatIn n ) @@ -403,16 +384,21 @@ wlkPat pat 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 @@ -424,12 +410,16 @@ wlkPat pat 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) @@ -460,16 +450,16 @@ wlkLiteral :: U_literal -> UgnM HsLit 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 @@ -489,54 +479,59 @@ wlkBinding :: U_binding -> UgnM RdrBinding 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 @@ -545,50 +540,42 @@ wlkBinding 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) @@ -598,56 +585,59 @@ 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} %************************************************************************ @@ -657,24 +647,17 @@ wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline) %************************************************************************ \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 -> @@ -686,7 +669,8 @@ wlkPolyType ttype 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 @@ -700,15 +684,16 @@ wlkMonoType ttype 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" @@ -725,16 +710,12 @@ wlkMonoType ttype 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) -> @@ -751,7 +732,7 @@ wlkClassAssertTy xs = 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 @@ -761,39 +742,39 @@ 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 -> @@ -803,7 +784,7 @@ wlkConDecl (U_constrrec ccon cfields srcline) ----------------- 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) @@ -821,10 +802,10 @@ rdMatch :: ParseTree -> UgnM RdrMatch 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 -> @@ -850,51 +831,35 @@ rdMatch pt %************************************************************************ \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 @@ -909,7 +874,7 @@ rdEntities pt = 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 -> diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 3b7cdf2..386dcbe 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -8,115 +8,145 @@ 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} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs new file mode 100644 index 0000000..d934449 --- /dev/null +++ b/ghc/compiler/rename/RnBinds.lhs @@ -0,0 +1,688 @@ +% +% (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} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs new file mode 100644 index 0000000..86ba680 --- /dev/null +++ b/ghc/compiler/rename/RnExpr.lhs @@ -0,0 +1,517 @@ +% +% (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} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 278fc65..9c8ab0d 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -8,49 +8,150 @@ 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) @@ -59,3 +160,4 @@ collectQualBinders quals collect (FilterQual expr) = [] collect (LetQual binds) = collectTopLevelBinders binds \end{code} + diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs new file mode 100644 index 0000000..797f8aa --- /dev/null +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -0,0 +1,112 @@ +% +% (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} diff --git a/ghc/compiler/rename/RnLoop.lhi b/ghc/compiler/rename/RnLoop.lhi index 92b7d41..f228aee 100644 --- a/ghc/compiler/rename/RnLoop.lhi +++ b/ghc/compiler/rename/RnLoop.lhi @@ -1,22 +1,18 @@ -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} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs new file mode 100644 index 0000000..49765f1 --- /dev/null +++ b/ghc/compiler/rename/RnMonad.lhs @@ -0,0 +1,493 @@ +% +% (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} diff --git a/ghc/compiler/rename/RnMonad12.lhs b/ghc/compiler/rename/RnMonad12.lhs deleted file mode 100644 index bfb7814..0000000 --- a/ghc/compiler/rename/RnMonad12.lhs +++ /dev/null @@ -1,97 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/rename/RnMonad3.lhs b/ghc/compiler/rename/RnMonad3.lhs deleted file mode 100644 index ca69b1d..0000000 --- a/ghc/compiler/rename/RnMonad3.lhs +++ /dev/null @@ -1,209 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/rename/RnMonad4.lhs b/ghc/compiler/rename/RnMonad4.lhs deleted file mode 100644 index a9e2e37..0000000 --- a/ghc/compiler/rename/RnMonad4.lhs +++ /dev/null @@ -1,501 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs new file mode 100644 index 0000000..384f9f8 --- /dev/null +++ b/ghc/compiler/rename/RnNames.lhs @@ -0,0 +1,296 @@ +% +% (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} diff --git a/ghc/compiler/rename/RnPass2.lhs b/ghc/compiler/rename/RnPass2.lhs deleted file mode 100644 index 3feb281..0000000 --- a/ghc/compiler/rename/RnPass2.lhs +++ /dev/null @@ -1,845 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/rename/RnPass3.lhs b/ghc/compiler/rename/RnPass3.lhs deleted file mode 100644 index ce905ed..0000000 --- a/ghc/compiler/rename/RnPass3.lhs +++ /dev/null @@ -1,620 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs new file mode 100644 index 0000000..235e945 --- /dev/null +++ b/ghc/compiler/rename/RnSource.lhs @@ -0,0 +1,510 @@ +% +% (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} diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs index 1d4e45b..f79e7c4 100644 --- a/ghc/compiler/rename/RnUtils.lhs +++ b/ghc/compiler/rename/RnUtils.lhs @@ -7,132 +7,186 @@ #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} + diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs index b61deb3..1b6b20c 100644 --- a/ghc/compiler/simplCore/SATMonad.lhs +++ b/ghc/compiler/simplCore/SATMonad.lhs @@ -141,7 +141,7 @@ newSATName id ty us env = 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 @@ -216,7 +216,7 @@ saTransform binder rhs -- 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 diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index ee87e0a..f2d0fe6 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -64,7 +64,7 @@ import Id ( idType, getIdUnfolding, getIdStrictness, 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 ) diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 962b6d0..3bbb88a 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -26,6 +26,7 @@ import Id ( idType, idWantsToBeINLINEd, import IdInfo ( willBeDemanded, DemandInfo ) import Literal ( isNoRepLit ) import Maybes ( maybeToBool ) +import Outputable ( isLocallyDefined ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) import PrelInfo ( realWorldStateTy ) diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 7ecb01c..51ea249 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -14,6 +14,7 @@ import StgSyn import StgUtils import LambdaLift ( liftProgram ) +import Outputable ( isLocallyDefined ) import SCCfinal ( stgMassageForProfiling ) import SatStgRhs ( satStgRhs ) import StgLint ( lintStgBindings ) diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index c43d816..097251a 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -25,6 +25,7 @@ import Id ( emptyIdSet, mkIdSet, minusIdSet, GenId{-instance Eq-} ) import Maybes ( maybeToBool ) +import Outputable ( isLocallyDefined ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) import Util ( panic, pprPanic, assertPanic ) diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index c360e61..e1aa070 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -33,7 +33,7 @@ import Id ( idType, isDictFunId, isConstMethodId_maybe, 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 diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 42cd011..18d1d07 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -44,7 +44,7 @@ import Id ( idType, isDefaultMethodId_maybe, toplevelishId, ) 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-}, diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 74abea7..8d1ccfa 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -21,7 +21,9 @@ import Id ( idType, isDataCon, ) 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 ) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index e4a9584..71d7651 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -45,12 +45,12 @@ import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag ) 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, @@ -226,14 +226,14 @@ newOverloadedLit orig lit ty \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} @@ -252,18 +252,18 @@ need, and it's a lot of extra work. \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} diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 912a415..16e8069 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -15,7 +15,8 @@ import HsSyn ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..), GRHSsAndBinds, ArithSeqInfo, HsLit, Fake, collectBinders ) import RnHsSyn ( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..), - RenamedMonoBinds(..) ) + RenamedMonoBinds(..), RnName(..) + ) import TcHsSyn ( TcHsBinds(..), TcBind(..), TcMonoBinds(..), TcIdOcc(..), TcIdBndr(..) ) @@ -34,11 +35,11 @@ import Unify ( unifyTauTy ) 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 ) @@ -177,8 +178,12 @@ tcBindAndThen combiner bind sigs do_next 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 @@ -193,7 +198,7 @@ tcBindAndSigs binder_names bind sigs prag_info_fn -- 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) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index e5cb1f3..ea8e477 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -19,7 +19,9 @@ import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..), 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 ) @@ -39,7 +41,7 @@ import CoreUtils ( escErrorMsg ) 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 @@ -88,7 +90,7 @@ tcClassDecl1 rec_inst_mapper 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 @@ -174,8 +176,8 @@ tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn 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 @@ -189,7 +191,7 @@ tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn -- 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" diff --git a/ghc/compiler/typecheck/TcClassSig.lhs b/ghc/compiler/typecheck/TcClassSig.lhs index 999bc0d..048b9e2 100644 --- a/ghc/compiler/typecheck/TcClassSig.lhs +++ b/ghc/compiler/typecheck/TcClassSig.lhs @@ -23,7 +23,7 @@ import Util 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 diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 06e15fc..8d3aad6 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -25,26 +25,25 @@ import TcMonad 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 ) @@ -156,7 +155,7 @@ type DerivSoln = DerivRhs %************************************************************************ \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 @@ -164,6 +163,8 @@ tcDeriving :: FAST_STRING -- name of module under scrutiny 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 @@ -173,7 +174,7 @@ tcDeriving modname renamer_name_funs inst_decl_infos_in fixities -- 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 @@ -205,13 +206,15 @@ tcDeriving modname renamer_name_funs inst_decl_infos_in fixities 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 @@ -340,13 +343,12 @@ ordered by sorting on type varible, tv, (major key) and then class, k, \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 @@ -365,7 +367,7 @@ solveDerivEqns modname inst_decl_infos_in orig_eqns = -- 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 @@ -412,7 +414,7 @@ add_solns :: FAST_STRING -- 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 @@ -506,7 +508,7 @@ the renamer. What a great hack! \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 @@ -579,7 +581,7 @@ maxtag_Foo :: Int -- ditto (NB: not unboxed) \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 @@ -624,7 +626,7 @@ If we have a @tag2con@ function, we also generate a @maxtag@ constant. \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)] @@ -673,13 +675,14 @@ gen_taggery_Names eqns \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} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 8ca0034..98800bd 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -36,13 +36,15 @@ import Class ( Class(..), GenClass, getClassSig ) 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 @@ -75,10 +77,10 @@ Making new TcTyVars, with knot tying! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \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, _) -> @@ -97,7 +99,7 @@ tcTyVarScopeGivenKinds names kinds thing_inside -- 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) -> @@ -116,7 +118,8 @@ Extending the environments. Notice the uses of @zipLazy@, which makes sure 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) -> @@ -131,7 +134,7 @@ tcExtendTyConEnv names_w_arities tycons scope 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) -> @@ -190,7 +193,7 @@ Extending and consulting the value environment 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 @@ -222,7 +225,7 @@ tcGetGlobalTyVars \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) @@ -232,15 +235,15 @@ tcLookupLocalValueByKey uniq = 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 @@ -255,7 +258,7 @@ 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 @@ -288,14 +291,19 @@ Constructing new Ids ~~~~~~~~~~~~~~~~~~~~ \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 diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 660c970..d2e9b48 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -16,7 +16,8 @@ import HsSyn ( HsExpr(..), Qual(..), Stmt(..), 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(..), @@ -46,6 +47,7 @@ import FieldLabel ( fieldLabelName ) 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, @@ -63,7 +65,7 @@ import Unique ( Unique, cCallableClassKey, cReturnableClassKey, enumFromToClassOpKey, enumFromThenToClassOpKey, monadClassKey, monadZeroClassKey ) -import Name ( Name ) -- Instance +--import Name ( Name ) -- Instance import Outputable ( interpp'SP ) import PprType ( GenType, GenTyVar ) -- Instances import Maybes ( maybeToBool ) @@ -621,7 +623,8 @@ tcArg expected_arg_ty arg %************************************************************************ \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 -> @@ -826,7 +829,7 @@ checkRecordFields rbinds data_con 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} diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 3dfcc03..d414786 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -11,7 +11,7 @@ This is where we do all the grimy bindings' generation. \begin{code} #include "HsVersions.h" -module TcGenDeriv ( +module TcGenDeriv {- ( a_Expr, a_PN, a_Pat, @@ -60,17 +60,17 @@ module TcGenDeriv ( 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, @@ -78,13 +78,11 @@ 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 ) @@ -172,7 +170,10 @@ instance ... Eq (Foo ...) where \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) @@ -200,7 +201,7 @@ gen_Eq_binds tycon 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 @@ -315,7 +316,7 @@ cmp_eq _ _ = EQ \end{itemize} \begin{code} -gen_Ord_binds :: TyCon -> ProtoNameMonoBinds +gen_Ord_binds :: TyCon -> RdrNameMonoBinds gen_Ord_binds tycon = defaulted `AndMonoBinds` compare @@ -354,7 +355,7 @@ gen_Ord_binds tycon 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 @@ -427,7 +428,7 @@ instance ... Enum (Foo ...) where 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 @@ -509,7 +510,7 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report (p.~147). \begin{code} -gen_Ix_binds :: TyCon -> ProtoNameMonoBinds +gen_Ix_binds :: TyCon -> RdrNameMonoBinds gen_Ix_binds tycon = if isEnumerationTyCon tycon @@ -578,7 +579,7 @@ gen_Ix_binds 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) @@ -632,8 +633,8 @@ gen_Ix_binds tycon 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 @@ -653,7 +654,7 @@ gen_Read_binds fixities tycon 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 @@ -700,7 +701,7 @@ gen_Show_binds fixities tycon 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 @@ -739,7 +740,7 @@ gen_Show_binds fixities tycon ToDo: NOT DONE YET. \begin{code} -gen_Binary_binds :: TyCon -> ProtoNameMonoBinds +gen_Binary_binds :: TyCon -> RdrNameMonoBinds gen_Binary_binds tycon = panic "gen_Binary_binds" @@ -767,34 +768,34 @@ data TagThingWanted = 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))) @@ -824,9 +825,9 @@ multi-clause definitions; it generates: \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 @@ -842,9 +843,9 @@ mk_easy_Match pats binds expr -- "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 @@ -858,19 +859,19 @@ 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 @@ -907,31 +908,31 @@ assoc_ty_id tyids ty 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 @@ -942,7 +943,7 @@ eq_Expr ty a 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-} @@ -952,33 +953,33 @@ untag_Expr tycon ((untag_this, put_tag_here) : more) expr 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) @@ -1010,9 +1011,9 @@ gt_PN = prelude_method SLIT("Ord") SLIT(">") 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") @@ -1027,20 +1028,20 @@ showList_PN = prelude_method SLIT("Show") SLIT("showList") 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") @@ -1070,7 +1071,7 @@ c_Pat = VarPatIn c_PN 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 @@ -1091,7 +1092,7 @@ maxtag_PN 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 @@ -1110,5 +1111,6 @@ con2tag_FN tycon con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#") in mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc - +-} \end{code} + diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 996658b..97b1f4e 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -128,8 +128,8 @@ instance Outputable (TcIdOcc s) where 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} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 114d1ff..65e2950 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -14,11 +14,11 @@ import TcMonad 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 ) @@ -41,13 +41,13 @@ tcInterfaceSigs :: [RenamedSig] -> TcM s [Id] 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') @@ -55,7 +55,7 @@ tcInterfaceSigs (Sig name@(ValName uniq full_name) ty pragmas src_loc : 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) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 43d29fb..0d43182 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -23,7 +23,9 @@ import HsSyn ( InstDecl(..), FixityDecl, Sig(..), 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, @@ -61,8 +63,7 @@ import CoreUtils ( escErrorMsg ) 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 ) @@ -77,7 +78,6 @@ import TyVar ( GenTyVar, mkTyVarSet ) import TysWiredIn ( stringTy ) import Unique ( Unique ) import Util ( panic ) - \end{code} Typechecking instance declarations is done in two passes. The first @@ -156,7 +156,7 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. \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, @@ -207,8 +207,11 @@ tcInstDecl1 mod_name -- 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_` @@ -224,7 +227,9 @@ tcInstDecl1 mod_name 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 @@ -482,7 +487,7 @@ newMethodId sel_id inst_ty origin loc 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} @@ -525,7 +530,7 @@ makeInstanceDeclNoDefaultExpr -> [Id] -> TcType s -> Class - -> FAST_STRING + -> Maybe Module -> Int -> NF_TcM s (TcExpr s) @@ -553,7 +558,9 @@ makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag 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)) ++ "\"" @@ -647,13 +654,13 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind 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 @@ -935,7 +942,11 @@ derivingWhenInstanceExistsErr clas tycon sty 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") diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index 6853735..a0e452c 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -30,6 +30,7 @@ import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp ) 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 ) @@ -63,8 +64,7 @@ data InstInfo [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} @@ -76,7 +76,8 @@ data InstInfo %************************************************************************ \begin{code} -mkInstanceRelatedIds :: Bool -> FAST_STRING +mkInstanceRelatedIds :: Bool + -> Maybe Module -> RenamedInstancePragmas -> Class -> [TyVar] diff --git a/ghc/compiler/typecheck/TcLoop.lhi b/ghc/compiler/typecheck/TcLoop.lhi index 3eb8d36..452dc7a 100644 --- a/ghc/compiler/typecheck/TcLoop.lhi +++ b/ghc/compiler/typecheck/TcLoop.lhi @@ -9,7 +9,7 @@ import HsMatches(GRHSsAndBinds) 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) @@ -21,7 +21,7 @@ import Bag(Bag) 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 diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index d5bae68..47968f2 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -25,8 +25,8 @@ import TcType ( TcType(..), TcMaybe, zonkTcType ) 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} @@ -37,7 +37,7 @@ is used in error messages. It checks that all the equations have the 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) @@ -81,7 +81,7 @@ tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches \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 diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index de24068..39122d3 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -15,7 +15,8 @@ import Ubiq 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 ) @@ -38,8 +39,7 @@ import Bag ( listToBag ) 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(..) ) @@ -82,7 +82,7 @@ tcModule :: GlobalNameMappers -- final renamer info for derivings 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) diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 2ea7586..5614273 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -26,23 +26,26 @@ module TcMonad( 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 ) @@ -50,8 +53,7 @@ import FiniteMap ( FiniteMap, emptyFM ) 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 ) @@ -78,8 +80,8 @@ type TcM s r = TcDown s -> TcEnv s -> FSST s r () 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 ( @@ -216,10 +218,46 @@ This elegantly ensures that it can't zap any type variables that 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} @@ -376,8 +414,8 @@ data TcDown s 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 @@ -403,31 +441,13 @@ addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs 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 @@ -443,6 +463,7 @@ rn4MtoTcM name_funs rn_action down env returnSST (rn_result, rn_errs) where u_var = getUniqSupplyVar down +-} \end{code} @@ -450,11 +471,9 @@ TypeChecking Errors ~~~~~~~~~~~~~~~~~~~ \begin{code} -type Message = PprStyle -> Pretty type TcError = Message type TcWarning = Message - mkTcErr :: SrcLoc -- Where -> [Message] -- Context -> Message -- What went wrong diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 1825cdf..bd27cbd 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -12,7 +12,7 @@ import Ubiq{-uitous-} import HsSyn ( PolyType(..), MonoType(..), Fake ) import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..), - RenamedContext(..) + RenamedContext(..), RnName(..) ) @@ -34,9 +34,11 @@ import Type ( mkDictTy ) 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} @@ -78,13 +80,13 @@ tcMonoTypeKind (MonoFunTy ty1 ty2) 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 @@ -98,8 +100,10 @@ tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty) 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) @@ -161,22 +165,24 @@ Doing this utterly wrecks the whole point of introducing these 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 diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index dfd92d1..23d73af 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -31,12 +31,12 @@ import CmdLineOpts ( opt_IrrefutableTuples ) 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 @@ -313,7 +313,7 @@ tcPats (pat:pats) 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) -> diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index b2afd9f..56fa41c 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -15,7 +15,9 @@ import Ubiq{-uitous-} 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 @@ -30,7 +32,7 @@ import TcTyDecls ( tcTyDecl, tcRecordSelectors ) 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, @@ -135,7 +137,10 @@ tcGroup inst_mapper decls 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) -> @@ -205,13 +210,13 @@ Edges in Type/Class decls ~~~~~~~~~~~~~~~~~~~~~~~~~ \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) @@ -234,7 +239,7 @@ get_cons cons 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) @@ -257,7 +262,7 @@ get_sigs sigs 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} @@ -287,9 +292,9 @@ Monad c in bop's type signature means that D must have kind Type->Type. \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 diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 8e37985..8c03384 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -19,7 +19,9 @@ import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), 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 ) @@ -30,13 +32,13 @@ import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass, 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, @@ -80,8 +82,7 @@ tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc) 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 @@ -126,9 +127,8 @@ tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pra 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 @@ -213,7 +213,7 @@ tcRecordSelector tycon fields@((first_con, first_field_label) : other_fields) 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' $ @@ -252,8 +252,7 @@ tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc) = 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 @@ -272,12 +271,11 @@ tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc) 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 @@ -300,8 +298,7 @@ tcDataCon tycon tyvars ctxt name btys src_loc 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 diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 530e41a..f3f0452 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -47,7 +47,6 @@ import TcMonad import Ubiq import Unique ( Unique ) import UniqFM ( UniqFM ) -import Name ( getNameShortName ) import Maybes ( assocMaybe ) import Util ( panic, pprPanic ) diff --git a/ghc/compiler/typecheck/Typecheck.lhs b/ghc/compiler/typecheck/Typecheck.lhs index 64b33b7..5c260a2 100644 --- a/ghc/compiler/typecheck/Typecheck.lhs +++ b/ghc/compiler/typecheck/Typecheck.lhs @@ -19,6 +19,7 @@ import HsSyn import RnHsSyn import TcHsSyn +import ErrUtils ( Warning(..), Error(..) ) import Pretty import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) import Maybes ( MaybeErr(..) ) @@ -61,11 +62,11 @@ typecheckModule 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) diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 9045886..12b4231 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -37,7 +37,7 @@ import TyVar ( TyVar(..), GenTyVar ) 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 ) @@ -71,7 +71,7 @@ data GenClassOp ty data GenClass tyvar uvar = Class Unique -- Key for fast comparison - FullName + Name tyvar -- The class type variable @@ -112,7 +112,7 @@ type ClassInstEnv = MatchEnv Type Id -- The Ids are dfuns The @mkClass@ function fills in the indirect superclasses. \begin{code} -mkClass :: Unique -> FullName -> TyVar +mkClass :: Unique -> Name -> TyVar -> [Class] -> [Id] -> [ClassOp] -> [Id] -> [Id] -> ClassInstEnv @@ -250,16 +250,11 @@ instance Ord (GenClass tyvar uvar) where \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} @@ -335,4 +330,3 @@ instance Ord (GenClassOp ty) where (ClassOp _ i1 _) > (ClassOp _ i2 _) = i1 > i2 -- ToDo: something for _tagCmp? (WDP 94/10) \end{code} - diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index be52e99..506c4d2 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -23,7 +23,6 @@ module PprType( 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) @@ -39,8 +38,10 @@ import Kind ( Kind(..) ) 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 ) @@ -302,7 +303,7 @@ pprGenTyVar sty (TyVar uniq kind name usage) %* * %************************************************************************ -ToDo; all this is suspiciously like getOccurrenceName! +ToDo; all this is suspiciously like getOccName! \begin{code} showTyCon :: PprStyle -> TyCon -> String @@ -314,7 +315,7 @@ pprTyCon sty FunTyCon = ppStr "(->)" 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 @@ -391,7 +392,7 @@ getTypeString ty = case (maybeAppTyCon ty) of Nothing -> true_bottom Just (tycon,_) -> - if fromPreludeCore tycon + if isPreludeDefined tycon then true_bottom else (False, fst (getOrigName tycon)) @@ -442,7 +443,7 @@ pprTyCon sty@PprInterface (SynonymTyCon k n a vs exp unabstract) specs 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, diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 36b70dc..4e03f96 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -37,7 +37,6 @@ module TyCon( ) where CHK_Ubiq() -- debugging consistency check -import NameLoop -- for paranoia checking import TyLoop ( Type(..), GenType, Class(..), GenClass, @@ -52,7 +51,7 @@ import Kind ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind ) 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 ) @@ -68,8 +67,8 @@ data TyCon = FunTyCon -- Kind = Type -> Type -> Type | DataTyCon Unique{-TyConKey-} + Name Kind - FullName [TyVar] [(Class,Type)] -- Its context [Id] -- Its data constructors, with fully polymorphic types @@ -84,7 +83,7 @@ data TyCon | 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#) @@ -100,7 +99,7 @@ data TyCon | SynTyCon Unique - FullName + Name Kind Arity [TyVar] -- Argument type variables @@ -114,12 +113,16 @@ data NewOrData \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 @@ -147,7 +150,7 @@ kind2 = mkBoxedTypeKind `mkArrowKind` kind1 tyConKind :: TyCon -> Kind tyConKind FunTyCon = kind2 -tyConKind (DataTyCon _ kind _ _ _ _ _ _) = kind +tyConKind (DataTyCon _ _ kind _ _ _ _ _) = kind tyConKind (PrimTyCon _ _ kind) = kind tyConKind (SpecTyCon tc tys) @@ -300,52 +303,31 @@ instance Ord TyCon where 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} diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi index a97c27d..36506e6 100644 --- a/ghc/compiler/types/TyLoop.lhi +++ b/ghc/compiler/types/TyLoop.lhi @@ -7,10 +7,11 @@ import PreludePS(_PackedString) 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 ) @@ -39,7 +40,7 @@ getInstantiatedDataConSig :: Id -> [Type] -> ([Type],[Type],Type) -- Needed in TysWiredIn data StrictnessMark = MarkedStrict | NotMarkedStrict -mkDataCon :: Unique -> FullName -> [StrictnessMark] +mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel] -> [TyVar] -> [(Class,Type)] -> [Type] -> TyCon -> Id \end{code} diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs index f59382a..0a9675e 100644 --- a/ghc/compiler/types/TyVar.lhs +++ b/ghc/compiler/types/TyVar.lhs @@ -35,7 +35,7 @@ import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM, 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(..) ) @@ -49,7 +49,7 @@ data GenTyVar flexi_slot = 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. @@ -60,7 +60,7 @@ type TyVar = GenTyVar Usage -- Usage slot makes sense only if Kind = Type 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) @@ -143,20 +143,10 @@ instance Eq (GenTyVar a) where 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} diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 3ba5f55..3d12384 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -13,7 +13,10 @@ module Outputable ( -- 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 @@ -26,12 +29,14 @@ module Outputable ( 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 ) @@ -45,63 +50,42 @@ 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} @@ -181,7 +165,6 @@ interpp'SP sty xs {-# 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 #-} @@ -198,8 +181,8 @@ ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p \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 @@ -249,7 +232,7 @@ And one ``higher-level'' interface to those: 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 diff --git a/ghc/compiler/utils/SST.lhs b/ghc/compiler/utils/SST.lhs index de9c036..631d9c5 100644 --- a/ghc/compiler/utils/SST.lhs +++ b/ghc/compiler/utils/SST.lhs @@ -7,7 +7,7 @@ module SST( SST(..), SST_R, FSST(..), FSST_R, - _runSST, + _runSST, sstToST, stToSST, thenSST, thenSST_, returnSST, thenFSST, thenFSST_, returnFSST, failFSST, recoverFSST, recoverSST, fixFSST, @@ -16,7 +16,7 @@ module SST( newMutVarSST, readMutVarSST, writeMutVarSST ) where -import PreludeGlaST( MutableVar(..), _MutableArray(..) ) +import PreludeGlaST( MutableVar(..), _MutableArray(..), ST(..) ) CHK_Ubiq() -- debugging consistency check \end{code} @@ -27,6 +27,17 @@ type SST s r = State# s -> SST_R s r \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 diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi index a416851..2b02a6a 100644 --- a/ghc/compiler/utils/Ubiq.lhi +++ b/ghc/compiler/utils/Ubiq.lhi @@ -23,24 +23,21 @@ import FiniteMap ( FiniteMap ) 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 ) @@ -49,7 +46,7 @@ import TyVar ( GenTyVar, TyVar(..) ) import Type ( GenType, Type(..) ) import UniqFM ( UniqFM ) import UniqSupply ( UniqSupply ) -import Unique ( Unique ) +import Unique ( Unique, Uniquable(..) ) import Usage ( GenUsage, Usage(..) ) import Util ( Ord3(..) ) @@ -57,14 +54,7 @@ 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 @@ -74,6 +64,8 @@ class Ord3 a where 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 @@ -95,7 +87,6 @@ data Demand 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 @@ -118,14 +109,14 @@ data Literal 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 @@ -144,6 +135,7 @@ data Unique -- NB: fails the optimisation criterion -- 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) diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index 73b325c..f23ef1f 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -5,8 +5,8 @@ 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@.) @@ -32,7 +32,7 @@ module UniqFM ( addToUFM_Directly, addListToUFM_Directly, IF_NOT_GHC(addToUFM_C COMMA) - IF_NOT_GHC(addListToUFM_C COMMA) + addListToUFM_C, delFromUFM, delListFromUFM, plusUFM, @@ -57,9 +57,9 @@ module UniqFM ( 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 ) @@ -77,31 +77,31 @@ 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 @@ -119,11 +119,11 @@ filterUFM :: (elt -> Bool) -> 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 @@ -285,7 +285,7 @@ First the ways of building a UniqFM. \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 @@ -308,13 +308,13 @@ addToUFM fm key elt = addToUFM_C use_snd fm key elt 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 @@ -327,7 +327,7 @@ Now ways of removing things from UniqFM. \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 @@ -596,11 +596,11 @@ looking up in a hurry is the {\em whole point} of this binary tree lark. 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 diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs index eb9511c..67db337 100644 --- a/ghc/compiler/utils/UniqSet.lhs +++ b/ghc/compiler/utils/UniqSet.lhs @@ -5,7 +5,7 @@ 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" @@ -24,8 +24,8 @@ CHK_Ubiq() -- debugging consistency check 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 ) @@ -56,16 +56,16 @@ type UniqSet a = UniqFM a 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 @@ -83,13 +83,13 @@ minusUniqSet (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (minusUFM set1 set2) 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