#endif {- ! __GLASGOW_HASKELL__ -}
-#if __GLASGOW_HASKELL__ >= 23 && __GLASGOW_HASKELL__ < 200
+#if __GLASGOW_HASKELL__ >= 23
#define USE_FAST_STRINGS 1
#define FAST_STRING _PackedString
#define SLIT(x) (_packCString (A# x#))
| UPD_BH_SINGLE_ENTRY
| PUSH_STD_UPD_FRAME
| POP_STD_UPD_FRAME
- | SET_ARITY
- | CHK_ARITY
| SET_TAG
| GRAN_FETCH -- for GrAnSim only -- HWL
| GRAN_RESCHEDULE -- for GrAnSim only -- HWL
\begin{code}
instance Eq MagicId where
- reg1 == reg2 = tagOf_MagicId reg1 _EQ_ tagOf_MagicId reg2
-
-tagOf_MagicId BaseReg = (ILIT(0) :: FAST_INT)
-tagOf_MagicId StkOReg = ILIT(1)
-tagOf_MagicId TagReg = ILIT(2)
-tagOf_MagicId RetReg = ILIT(3)
-tagOf_MagicId SpA = ILIT(4)
-tagOf_MagicId SuA = ILIT(5)
-tagOf_MagicId SpB = ILIT(6)
-tagOf_MagicId SuB = ILIT(7)
-tagOf_MagicId Hp = ILIT(8)
-tagOf_MagicId HpLim = ILIT(9)
-tagOf_MagicId LivenessReg = ILIT(10)
-tagOf_MagicId StdUpdRetVecReg = ILIT(12)
-tagOf_MagicId StkStubReg = ILIT(13)
-tagOf_MagicId CurCostCentre = ILIT(14)
-tagOf_MagicId VoidReg = ILIT(15)
-
-tagOf_MagicId (VanillaReg _ i) = ILIT(15) _ADD_ i
-
-tagOf_MagicId (FloatReg i) = ILIT(15) _ADD_ maxv _ADD_ i
- where
- maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
-
-tagOf_MagicId (DoubleReg i) = ILIT(15) _ADD_ maxv _ADD_ maxf _ADD_ i
- where
- maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
- maxf = case mAX_Float_REG of { IBOX(x) -> x }
+ reg1 == reg2 = tag reg1 _EQ_ tag reg2
+ where
+ tag BaseReg = (ILIT(0) :: FAST_INT)
+ tag StkOReg = ILIT(1)
+ tag TagReg = ILIT(2)
+ tag RetReg = ILIT(3)
+ tag SpA = ILIT(4)
+ tag SuA = ILIT(5)
+ tag SpB = ILIT(6)
+ tag SuB = ILIT(7)
+ tag Hp = ILIT(8)
+ tag HpLim = ILIT(9)
+ tag LivenessReg = ILIT(10)
+ tag StdUpdRetVecReg = ILIT(12)
+ tag StkStubReg = ILIT(13)
+ tag CurCostCentre = ILIT(14)
+ tag VoidReg = ILIT(15)
+
+ tag (VanillaReg _ i) = ILIT(15) _ADD_ i
+
+ tag (FloatReg i) = ILIT(15) _ADD_ maxv _ADD_ i
+ where
+ maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
+
+ tag (DoubleReg i) = ILIT(15) _ADD_ maxv _ADD_ maxf _ADD_ i
+ where
+ maxv = case mAX_Vanilla_REG of { IBOX(x) -> x }
+ maxf = case mAX_Float_REG of { IBOX(x) -> x }
\end{code}
Returns True for any register that {\em potentially} dies across
UPD_BH_SINGLE_ENTRY -> Cost (3, 0, 0, 1, 0) {- SMupdate.lh -}
PUSH_STD_UPD_FRAME -> Cost (3, 0, 0, 4, 0) {- SMupdate.lh -}
POP_STD_UPD_FRAME -> Cost (1, 0, 3, 0, 0) {- SMupdate.lh -}
- SET_ARITY -> nullCosts {- StgMacros.lh -}
- CHK_ARITY -> nullCosts {- StgMacros.lh -}
SET_TAG -> nullCosts {- COptRegs.lh -}
GRAN_FETCH -> nullCosts {- GrAnSim bookkeeping -}
GRAN_RESCHEDULE -> nullCosts {- GrAnSim bookkeeping -}
mkSpecId, mkSameSpecCon,
selectIdInfoForSpecId,
mkTemplateLocals,
- mkImported, mkPreludeId,
+ mkImported,
mkDataCon, mkTupleCon,
mkIdWithNewUniq,
mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId,
import IdInfo
import Maybes ( maybeToBool )
import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
- isLocallyDefinedName, isPreludeDefinedName,
+ isLocallyDefinedName,
mkTupleDataConName, mkCompoundName, mkCompoundName2,
- isLexSym, isLexSpecialSym, getLocalName,
- isLocallyDefined, isPreludeDefined, changeUnique,
- getOccName, moduleNamePair, origName, nameOf,
+ isLexSym, isLexSpecialSym,
+ isLocallyDefined, changeUnique,
+ getOccName, origName, moduleOf,
isExported, ExportFlag(..),
RdrName(..), Name
)
| ImportedId -- Global name (Imported or Implicit); Id imported from an interface
- | PreludeId -- Global name (Builtin); Builtin prelude Ids
-
| TopLevId -- Global name (LocalDef); Top-level in the orig source pgm
-- (not moved there by transformations).
-- The "a" is irrelevant. As it is too painful to
-- actually do comparisons that way, we kindly supply
-- a Unique for that purpose.
- (Maybe Module) -- module where instance came from; Nothing => Prelude
+ Module -- module where instance came from
-- see below
| ConstMethodId -- A method which depends only on the type of the
Class -- Uniquely identified by:
Type -- (class, type, classop) triple
ClassOp
- (Maybe Module) -- module where instance came from; Nothing => Prelude
+ Module -- module where instance came from
| InstId -- An instance of a dictionary, class operation,
-- or overloaded value (Local name)
their @IdInfo@).
%----------------------------------------------------------------------
-\item[@PreludeId@:] ToDo
-
-%----------------------------------------------------------------------
\item[@TopLevId@:] These are values defined at the top-level in this
module; i.e., those which {\em might} be exported (hence, a
@Name@). It does {\em not} include those which are moved to the
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
- chk PreludeId = True
chk TopLevId = True -- NB: see notes
chk (SuperDictSelId _ _) = True
chk (MethodSelId _ _) = True
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
- chk PreludeId = True
chk TopLevId = True
chk (SuperDictSelId _ _) = True
chk (MethodSelId _ _) = True
case v_details of
-- these ones must have been exported by their original module
ImportedId -> pp_full_name
- PreludeId -> pp_full_name
-- these ones' exportedness checked later...
TopLevId -> pp_full_name
pp_full_name
= let
- (m_str, n_str) = moduleNamePair v
+ (OrigName m_str n_str) = origName "Id:ppr_Unfolding" v
pp_n =
if isLexSym n_str && not (isLexSpecialSym n_str) then
-- type might be wrong, but it hardly matters
-- at this stage (just before printing C) ToDo
where
- name = getLocalName name
+ name = nameOf (origName "Id.unlocaliseId" name)
full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
unlocaliseId mod other_id = Nothing
\begin{code}
mkSuperDictSelId u c sc ty info
- = Id u n ty (SuperDictSelId c sc) NoPragmaInfo info
- where
- cname = getName c -- we get other info out of here
-
- n = mkCompoundName u SLIT("sdsel") [origName cname, origName sc] cname
+ = mk_classy_id (SuperDictSelId c sc) SLIT("sdsel") (Left (origName "mkSuperDictSelId" sc)) u c ty info
mkMethodSelId u rec_c op ty info
- = Id u n ty (MethodSelId rec_c op) NoPragmaInfo info
- where
- cname = getName rec_c -- we get other info out of here
-
- n = mkCompoundName u SLIT("meth") [origName cname, Unqual (classOpString op)] cname
+ = mk_classy_id (MethodSelId rec_c op) SLIT("meth") (Right (classOpString op)) u rec_c ty info
mkDefaultMethodId u rec_c op gen ty info
- = Id u n ty (DefaultMethodId rec_c op gen) NoPragmaInfo info
+ = mk_classy_id (DefaultMethodId rec_c op gen) SLIT("defm") (Right (classOpString op)) u rec_c ty info
+
+mk_classy_id details str op_str u rec_c ty info
+ = Id u n ty details NoPragmaInfo info
where
cname = getName rec_c -- we get other info out of here
+ cname_orig = origName "mk_classy_id" cname
+ cmod = moduleOf cname_orig
- n = mkCompoundName u SLIT("defm") [origName cname, Unqual (classOpString op)] cname
+ n = mkCompoundName u cmod str [Left cname_orig, op_str] cname
mkDictFunId u c ity full_ty from_here locn mod info
= Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info
where
- n = mkCompoundName2 u SLIT("dfun") [origName c] (getTypeString ity) from_here locn
+ n = mkCompoundName2 u mod SLIT("dfun") (Left (origName "mkDictFunId" c) : map Right (getTypeString ity)) from_here locn
mkConstMethodId u c op ity full_ty from_here locn mod info
= Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info
where
- n = mkCompoundName2 u SLIT("const") [origName c, Unqual (classOpString op)] (getTypeString ity) from_here locn
+ n = mkCompoundName2 u mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : map Right (getTypeString ity)) from_here locn
mkWorkerId u unwrkr ty info
= Id u n ty (WorkerId unwrkr) NoPragmaInfo info
where
unwrkr_name = getName unwrkr
+ unwrkr_orig = trace "mkWorkerId:origName:" $ origName "mkWorkerId" unwrkr_name
+ umod = moduleOf unwrkr_orig
- n = mkCompoundName u SLIT("wrk") [origName unwrkr_name] unwrkr_name
+ n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name
mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
\begin{code}
mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
-mkPreludeId n ty info = Id (nameUnique n) n ty PreludeId NoPragmaInfo info
{-LATER:
updateIdType :: Id -> Type -> Id
showId :: PprStyle -> Id -> String
showId sty id = ppShow 80 (pprId sty id)
-
--- [used below]
--- for DictFuns (instances) and const methods (instance code bits we
--- can call directly): exported (a) if *either* the class or
--- ***OUTERMOST*** tycon [arbitrary...] is exported; or (b) *both*
--- class and tycon are from PreludeCore [non-std, but convenient]
--- *and* the thing was defined in this module.
-
-instance_export_flag :: Class -> Type -> Bool -> ExportFlag
-
-instance_export_flag clas inst_ty from_here
- = panic "Id:instance_export_flag"
-{-LATER
- = if instanceIsExported clas inst_ty from_here
- then ExportAll
- else NotExported
--}
\end{code}
Default printing code (not used for interfaces):
instance NamedThing (GenId ty) where
getName this_id@(Id u n _ details _ _) = n
-{- OLD:
- = get details
- where
- get (LocalId _) = n
- get (SysLocalId _) = n
- get (SpecPragmaId _ _) = n
- get ImportedId = n
- get PreludeId = n
- get TopLevId = n
- get (InstId n _) = n
- get (DataConId _ _ _ _ _ _ _) = n
- get (TupleConId _) = n
- get (RecordSelId l) = getName l
- get _ = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id)
--}
-{- LATER:
- get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ???
- mod -> (mod, classOpString op)
-
- get (SpecId unspec ty_maybes _)
- = case moduleNamePair unspec of { (mod, unspec_nm) ->
- case specMaybeTysSuffix ty_maybes of { tys_suffix ->
- (mod,
- unspec_nm _APPEND_
- (if not (toplevelishId unspec)
- then showUnique u
- else tys_suffix)
- ) }}
-
- get (WorkerId unwrkr)
- = case moduleNamePair unwrkr of { (mod, unwrkr_nm) ->
- (mod,
- unwrkr_nm _APPEND_
- (if not (toplevelishId unwrkr)
- then showUnique u
- else SLIT(".wrk"))
- ) }
-
- get other_details
- -- the remaining internally-generated flavours of
- -- Ids really do not have meaningful "original name" stuff,
- -- but we need to make up something (usually for debugging output)
-
- = case (getIdNamePieces True this_id) of { (piece1:pieces) ->
- case [ _CONS_ '.' p | p <- pieces ] of { dotted_pieces ->
- (_NIL_, _CONCAT_ (piece1 : dotted_pieces)) }}
--}
\end{code}
Note: The code generator doesn't carry a @UniqueSupply@, so it uses
IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and
+IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and
-- we break those loops by using IdLoop and
-- *not* importing much of anything else,
-- except from the very general "utils".
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( firstJust )
import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList )
-import OccurAnal ( occurAnalyseGlobalExpr )
import Outputable ( ifPprInterface, Outputable(..){-instances-} )
import PprStyle ( PprStyle(..) )
import Pretty
import IdInfo ( IdInfo )
import Literal ( Literal )
import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun )
+import OccurAnal ( occurAnalyseGlobalExpr )
import Outputable ( Outputable(..) )
import PprEnv ( NmbrEnv )
import PprStyle ( PprStyle )
import Util ( Ord3(..) )
import WwLib ( mAX_WORKER_ARGS )
+occurAnalyseGlobalExpr :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique
externallyVisibleId :: Id -> Bool
isDataCon :: GenId ty -> Bool
isWorkerId :: GenId ty -> Bool
import CoreSyn
import CoreUnfold ( UnfoldingGuidance(..) )
-import Id ( mkPreludeId, mkTemplateLocals )
+import Id ( mkImported, mkTemplateLocals )
import IdInfo -- quite a few things
-import Name ( mkBuiltinName )
-import PrelMods ( pRELUDE_BUILTIN )
+import Name ( mkPrimitiveName, OrigName(..) )
+import PrelMods ( gHC_BUILTINS )
import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
PrimOpInfo(..), PrimOpResultInfo(..) )
import RnHsSyn ( RnName(..) )
primOpId op
= case (primOpInfo op) of
Dyadic str ty ->
- mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (dyadic_fun_ty ty) 2
+ mk_prim_Id op str [] [ty,ty] (dyadic_fun_ty ty) 2
Monadic str ty ->
- mk_prim_Id op pRELUDE_BUILTIN str [] [ty] (monadic_fun_ty ty) 1
+ mk_prim_Id op str [] [ty] (monadic_fun_ty ty) 1
Compare str ty ->
- mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (compare_fun_ty ty) 2
+ mk_prim_Id op str [] [ty,ty] (compare_fun_ty ty) 2
Coercing str ty1 ty2 ->
- mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (mkFunTys [ty1] ty2) 1
+ mk_prim_Id op str [] [ty1] (mkFunTys [ty1] ty2) 1
PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
- mk_prim_Id op pRELUDE_BUILTIN str
+ mk_prim_Id op str
tyvars
arg_tys
(mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
(length arg_tys) -- arity
AlgResult str tyvars arg_tys tycon res_tys ->
- mk_prim_Id op pRELUDE_BUILTIN str
+ mk_prim_Id op str
tyvars
arg_tys
(mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
(length arg_tys) -- arity
where
- mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity
- = mkPreludeId (mkBuiltinName key mod name) ty
+ mk_prim_Id prim_op name tyvar_tmpls arg_tys ty arity
+ = mkImported (mkPrimitiveName key (OrigName gHC_BUILTINS name)) ty
(noIdInfo `addInfo` (mkArityInfo arity)
`addInfo_UF` (mkUnfolding EssentialUnfolding
(mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
module Name (
Module(..),
+ OrigName(..), -- glorified pair
+ qualToOrigName, -- a Qual to an OrigName
+
RdrName(..),
+ preludeQual,
+ moduleNamePair,
isUnqual,
isQual,
isRdrLexCon, isRdrLexConOrSpecial,
Name,
Provenance,
mkLocalName, isLocalName,
- mkTopLevName, mkImportedName,
+ mkTopLevName, mkImportedName, oddlyImportedName,
mkImplicitName, isImplicitName,
- mkBuiltinName, mkCompoundName, mkCompoundName2,
+ mkPrimitiveName, mkWiredInName,
+ mkCompoundName, mkCompoundName2,
mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
mkTupNameStr,
nameUnique, changeUnique,
nameOccName,
- nameOrigName,
+-- nameOrigName, : not exported
nameExportFlag,
nameSrcLoc,
nameImpLocs,
nameImportFlag,
- isLocallyDefinedName,
- isPreludeDefinedName,
+ isLocallyDefinedName, isWiredInName,
- origName, moduleOf, nameOf, moduleNamePair,
+ origName, moduleOf, nameOf,
getOccName, getExportFlag,
getSrcLoc, getImpLocs,
- isLocallyDefined, isPreludeDefined,
- getLocalName, ltLexical,
+ isLocallyDefined,
+ getLocalName,
isSymLexeme, pprSym, pprNonSym,
isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
IMP_Ubiq()
+import CmdLineOpts ( maybe_CompilingPrelude )
import CStrings ( identToC, cSEP )
import Outputable ( Outputable(..) )
import PprStyle ( PprStyle(..), codeStyle )
-import PrelMods ( pRELUDE, pRELUDE_BUILTIN, fromPrelude )
+import PrelMods ( pRELUDE )
import Pretty
import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc )
import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
\begin{code}
type Module = FAST_STRING
+data OrigName = OrigName Module FAST_STRING
+
+qualToOrigName (Qual m n) = OrigName m n
+
data RdrName
= Unqual FAST_STRING
| Qual Module FAST_STRING
+preludeQual n = Qual pRELUDE n
+
+moduleNamePair (Qual m n) = (m, n) -- we make *no* claim whether this
+ -- constitutes an original name or
+ -- an occurrence name, or anything else
+
isUnqual (Unqual _) = True
isUnqual (Qual _ _) = False
isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n
appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
-appendRdr (Qual m n) str = ASSERT(not (fromPrelude m))
- Qual m (n _APPEND_ str)
+appendRdr (Qual m n) str = Qual m (n _APPEND_ str)
-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) = _CMP_STRING_ m1 m2 `thenCmp` _CMP_STRING_ n1 n2
+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) = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2
+ -- always compare module-names *second*
+
+cmpOrig (OrigName m1 n1) (OrigName m2 n2)
+ = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2 -- again; module-names *second*
instance Eq RdrName where
a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
instance NamedThing RdrName where
-- We're sorta faking it here
- getName rdr_name
- = Global u rdr_name prov ex [rdr_name]
+ getName (Unqual n)
+ = Local u n True locn
+ where
+ u = panic "NamedThing.RdrName:Unique1"
+ locn = panic "NamedThing.RdrName:locn"
+
+ getName rdr_name@(Qual m n)
+ = Global u m n prov ex [rdr_name]
where
u = panic "NamedThing.RdrName:Unique"
prov = panic "NamedThing.RdrName:Provenance"
| otherwise = ppPStr n
showRdr sty rdr = ppShow 100 (ppr sty rdr)
+
+-------------------------
+instance Eq OrigName where
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+
+instance Ord OrigName 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 OrigName where
+ cmp = cmpOrig
+
+instance NamedThing OrigName where -- faking it
+ getName (OrigName m n) = getName (Qual m n)
+
+instance Outputable OrigName where -- ditto
+ ppr sty (OrigName m n) = ppr sty (Qual m n)
\end{code}
%************************************************************************
SrcLoc
| Global Unique
- RdrName -- original name; Unqual => prelude
+ Module -- original name
+ FAST_STRING
Provenance -- where it came from
ExportFlag -- is it exported?
[RdrName] -- ordered occurrence names (usually just one);
[SrcLoc] -- any import source location(s)
| Implicit
- | Builtin
+ | Primitive -- really and truly primitive thing (not
+ -- definable in Haskell)
+ | WiredIn Bool -- something defined in Haskell; True <=>
+ -- definition is in the module in question;
+ -- this probably comes from the -fcompiling-prelude=...
+ -- flag.
\end{code}
\begin{code}
mkLocalName = Local
-mkTopLevName u orig locn exp occs = Global u orig (LocalDef locn) exp occs
-mkImportedName u orig imp locn imp_locs exp occs = Global u orig (Imported imp locn imp_locs) exp occs
+mkTopLevName u (OrigName m n) locn exp occs = Global u m n (LocalDef locn) exp occs
+mkImportedName u (OrigName m n) imp locn imp_locs exp occs = Global u m n (Imported imp locn imp_locs) exp occs
-mkImplicitName :: Unique -> RdrName -> Name
-mkImplicitName u o = Global u o Implicit NotExported []
+mkImplicitName :: Unique -> OrigName -> Name
+mkImplicitName u (OrigName m n) = Global u m n Implicit NotExported []
-mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
-mkBuiltinName u m n
- = Global u (if fromPrelude m then Unqual n else Qual m n) Builtin NotExported []
+mkPrimitiveName :: Unique -> OrigName -> Name
+mkPrimitiveName u (OrigName m n) = Global u m n Primitive NotExported []
+
+mkWiredInName :: Unique -> OrigName -> Name
+mkWiredInName u (OrigName m n)
+ = Global u m n (WiredIn from_here) (if from_here then ExportAll else NotExported) []
+ where
+ from_here
+ = case maybe_CompilingPrelude of
+ Nothing -> False
+ Just mod -> mod == _UNPK_ m
mkCompoundName :: Unique
+ -> Module
-> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel")
- -> [RdrName] -- "dot" these names together
+ -> [Either OrigName FAST_STRING] -- "dot" these names together
-> Name -- from which we get provenance, etc....
-> Name -- result!
-mkCompoundName u str ns (Local _ _ _ _) = panic "mkCompoundName:Local?"
-mkCompoundName u str ns (Global _ _ prov exp _)
- = Global u (Unqual{-???-} (_CONCAT_ (glue ns [str]))) prov exp []
+mkCompoundName u m str ns (Local _ _ _ _) = panic "mkCompoundName:Local?"
+mkCompoundName u m str ns (Global _ _ _ prov exp _)
+ = Global u m (_CONCAT_ (glue ns [str])) prov exp []
-glue [] acc = reverse acc
-glue (Unqual n:ns) acc = glue ns (_CONS_ '.' n : acc)
-glue (Qual m n:ns) acc = glue ns (_CONS_ '.' n : _CONS_ '.' m : acc)
+glue [] acc = reverse acc
+glue (Left (OrigName m n):ns) acc = glue ns (_CONS_ '.' n : _CONS_ '.' m : acc)
+glue (Right n :ns) acc = glue ns (_CONS_ '.' n : acc)
-- this ugly one is used for instance-y things
mkCompoundName2 :: Unique
- -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel")
- -> [RdrName] -- "dot" these names together
- -> [FAST_STRING] -- type-name strings
- -> Bool -- True <=> defined in this module
- -> SrcLoc
- -> Name -- result!
-
-mkCompoundName2 u str ns ty_strs from_here locn
- = Global u (Unqual{-???-} ((_CONCAT_ (glue ns [str])) _APPEND_ (_CONS_ '.' (_CONCAT_ ty_strs))))
+ -> Module
+ -> FAST_STRING -- indicates what kind of compound thing it is
+ -> [Either OrigName FAST_STRING] -- "dot" these names together
+ -> Bool -- True <=> defined in this module
+ -> SrcLoc
+ -> Name -- result!
+
+mkCompoundName2 u m str ns from_here locn
+ = Global u m (_CONCAT_ (glue ns [str]))
(if from_here then LocalDef locn else Imported ExportAll locn [])
ExportAll{-instances-}
[]
mkFunTyConName
- = mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->")
+ = mkPrimitiveName funTyConKey (OrigName pRELUDE SLIT("->"))
mkTupleDataConName arity
- = mkBuiltinName (mkTupleDataConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
+ = mkWiredInName (mkTupleDataConUnique arity) (OrigName pRELUDE (mkTupNameStr arity))
mkTupleTyConName arity
- = mkBuiltinName (mkTupleTyConUnique arity) pRELUDE_BUILTIN (mkTupNameStr arity)
+ = mkWiredInName (mkTupleTyConUnique arity) (OrigName pRELUDE (mkTupNameStr arity))
mkTupNameStr 0 = SLIT("()")
mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
isLocalName (Local _ _ _ _) = True
isLocalName _ = False
-isImplicitName (Global _ _ Implicit _ _) = True
-isImplicitName _ = False
+-- things the compiler "knows about" are in some sense
+-- "imported". When we are compiling the module where
+-- the entities are defined, we need to be able to pick
+-- them out, often in combination with isLocallyDefined.
+oddlyImportedName (Global _ _ _ Primitive _ _) = True
+oddlyImportedName (Global _ _ _ (WiredIn _) _ _) = True
+oddlyImportedName _ = False
-isBuiltinName (Global _ _ Builtin _ _) = True
-isBuiltinName _ = False
+isImplicitName (Global _ _ _ Implicit _ _) = True
+isImplicitName _ = False
\end{code}
-
-
%************************************************************************
%* *
\subsection[Name-instances]{Instance declarations}
\begin{code}
cmpName n1 n2 = c n1 n2
where
- 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
- tag2 = tag_Name n2
- in
- if tag1 _LT_ tag2 then LT_ else GT_
-
- tag_Name (Local _ _ _ _) = (ILIT(1) :: FAST_INT)
- tag_Name (Global _ _ _ _ _) = ILIT(2)
+ c (Local u1 _ _ _) (Local u2 _ _ _) = cmp u1 u2
+ c (Local _ _ _ _) _ = LT_
+ c (Global u1 _ _ _ _ _) (Global u2 _ _ _ _ _) = cmp u1 u2
+ c (Global _ _ _ _ _ _) _ = GT_
\end{code}
\begin{code}
\end{code}
\begin{code}
-nameUnique (Local u _ _ _) = u
-nameUnique (Global u _ _ _ _) = u
+nameUnique (Local u _ _ _) = u
+nameUnique (Global u _ _ _ _ _) = u
-- when we renumber/rename things, we need to be
-- able to change a Name's Unique to match the cached
-- one in the thing it's the name of. If you know what I mean.
changeUnique (Local _ n b l) u = Local u n b l
-changeUnique n@(Global _ o p e os) u = ASSERT(not (isBuiltinName n))
- Global u o p e os
+changeUnique (Global _ m n p e os) u = Global u m n p e os
-nameOrigName (Local _ n _ _) = Unqual n
-nameOrigName (Global _ orig _ _ _) = orig
-
-nameModuleNamePair (Local _ n _ _) = (panic "nameModuleNamePair", n)
-nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n)
-nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n)
+nameOrigName msg (Global _ m n _ _ _) = OrigName m n
+#ifdef DEBUG
+nameOrigName msg (Local _ n _ _) = panic ("nameOrigName:Local:"++msg++":"++ _UNPK_ n)
+#endif
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
+nameOccName (Global _ m n _ _ [] ) = Qual m n
+nameOccName (Global _ m n _ _ (o:_)) = o
+
+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 _ _ _ Primitive _ _) = mkBuiltinSrcLoc
+nameSrcLoc (Global _ _ _ (WiredIn _) _ _) = mkBuiltinSrcLoc
-nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs
-nameImpLocs _ = []
-
-nameImportFlag (Local _ _ _ _) = NotExported
-nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll
-nameImportFlag (Global _ _ (Imported exp _ _) _ _) = exp
-nameImportFlag (Global _ _ Implicit _ _) = ExportAll
-nameImportFlag (Global _ _ Builtin _ _) = ExportAll
-
-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
+nameImpLocs (Global _ _ _ (Imported _ _ locs) _ _) = locs
+nameImpLocs _ = []
+
+nameImportFlag (Local _ _ _ _) = NotExported
+nameImportFlag (Global _ _ _ (LocalDef _) _ _) = ExportAll
+nameImportFlag (Global _ _ _ (Imported exp _ _) _ _) = exp
+nameImportFlag (Global _ _ _ Implicit _ _) = ExportAll
+nameImportFlag (Global _ _ _ Primitive _ _) = ExportAll
+nameImportFlag (Global _ _ _ (WiredIn _) _ _) = ExportAll
+
+isLocallyDefinedName (Local _ _ _ _) = True
+isLocallyDefinedName (Global _ _ _ (LocalDef _) _ _) = True
+isLocallyDefinedName (Global _ _ _ (Imported _ _ _) _ _) = False
+isLocallyDefinedName (Global _ _ _ Implicit _ _) = False
+isLocallyDefinedName (Global _ _ _ Primitive _ _) = False
+isLocallyDefinedName (Global _ _ _ (WiredIn from_here) _ _) = from_here
+
+isWiredInName (Global _ _ _ (WiredIn _) _ _) = True
+isWiredInName _ = False
\end{code}
\begin{code}
| emph_uniq = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"]
| otherwise = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"]
- ppr PprDebug (Global u o _ _ _) = ppBesides [ppr PprDebug o, ppStr "{-", pprUnique u, ppStr "-}"]
- 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 PprDebug (Global u m n _ _ _) = ppBesides [ppr PprDebug (Qual m n), ppStr "{-", pprUnique u, ppStr "-}"]
+ ppr PprForUser (Global u m n _ _ [] ) = ppr PprForUser (Qual m n)
+ ppr PprForUser (Global u m n _ _ occs) = ppr PprForUser (head occs)
+ ppr PprShowAll (Global u m n prov exp occs) = pp_all (Qual m n) prov exp occs
+ ppr sty (Global u m n _ _ _) = ppr sty (Qual m n)
pp_all orig prov exp occs
= ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
pp_exp ExportAll = ppPStr SLIT("/EXP(..)")
pp_exp ExportAbs = ppPStr SLIT("/EXP")
-pp_prov Implicit = ppPStr SLIT("/IMPLICIT")
-pp_prov Builtin = ppPStr SLIT("/BUILTIN")
-pp_prov _ = ppNil
+pp_prov Implicit = ppPStr SLIT("/IMPLICIT")
+pp_prov Primitive = ppPStr SLIT("/PRIMITIVE")
+pp_prov (WiredIn _) = ppPStr SLIT("/WIREDIN")
+pp_prov _ = ppNil
\end{code}
%************************************************************************
\end{code}
\begin{code}
-origName :: NamedThing a => a -> RdrName
-moduleOf :: RdrName -> Module
-nameOf :: RdrName -> FAST_STRING
-moduleNamePair :: NamedThing a => a -> (Module, FAST_STRING)
+origName :: NamedThing a => String -> a -> OrigName
+moduleOf :: OrigName -> Module
+nameOf :: OrigName -> FAST_STRING
getOccName :: NamedThing a => a -> RdrName
getLocalName :: NamedThing a => a -> FAST_STRING
getSrcLoc :: NamedThing a => a -> SrcLoc
getImpLocs :: NamedThing a => a -> [SrcLoc]
isLocallyDefined :: NamedThing a => a -> Bool
-isPreludeDefined :: NamedThing a => a -> Bool
-
--- ToDo: specialise for RdrNames?
-origName = nameOrigName . getName
-moduleNamePair = nameModuleNamePair . getName
-moduleOf (Unqual n) = pRELUDE
-moduleOf (Qual m n) = m
+origName str n = nameOrigName str (getName n)
-nameOf (Unqual n) = n
-nameOf (Qual m n) = n
+moduleOf (OrigName m n) = m
+nameOf (OrigName m n) = n
-getLocalName = nameOf . origName
+getLocalName n
+ = case (getName n) of
+ Global _ m n _ _ _ -> n
+ Local _ n _ _ -> n
getOccName = nameOccName . getName
getExportFlag = nameExportFlag . getName
getSrcLoc = nameSrcLoc . getName
getImpLocs = nameImpLocs . getName
isLocallyDefined = isLocallyDefinedName . getName
-isPreludeDefined = isPreludeDefinedName . getName
-\end{code}
-
-@ltLexical@ is used for sorting things into lexicographical order, so
-as to canonicalize interfaces. [Regular @(<)@ should be used for fast
-comparison.]
-
-\begin{code}
-a `ltLexical` b = origName a < origName b
\end{code}
These functions test strings to see if they fit the lexical categories
isLexConId cs
| _NULL_ cs = False
- | c == '_' = isLexConId (_TAIL_ cs) -- allow for leading _'s
| otherwise = isUpper c || isUpperISO c
where
c = _HEAD_ cs
isLexVarId cs
| _NULL_ cs = False
- | c == '_' = isLexVarId (_TAIL_ cs) -- allow for leading _'s
| otherwise = isLower c || isLowerISO c
where
c = _HEAD_ cs
isSymLexeme :: NamedThing a => a -> Bool
isSymLexeme v
- = let str = nameOf (origName v) in isLexSym str
+ = let str = getLocalName v in isLexSym str
-- print `vars`, (op) correctly
pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
pprSym sty var
= let
- str = nameOf (origName var)
+ str = getLocalName var
in
if isLexSym str && not (isLexSpecialSym str)
then ppr sty var
GenId{-instance NamedThing-}
)
import Maybes ( catMaybes )
-import Name ( isLocallyDefined )
+import Name ( isLocallyDefined, oddlyImportedName, Name{-instance NamedThing-} )
#ifdef DEBUG
import PprAbsC ( pprAmode )
#endif
\begin{code}
getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
-getCAddrModeAndInfo name
- | not (isLocallyDefined name)
- = returnFC (global_amode, mkLFImported name)
+getCAddrModeAndInfo id
+ | not (isLocallyDefined name) || oddlyImportedName name
+ = returnFC (global_amode, mkLFImported id)
- | isDataCon name
- = returnFC (global_amode, mkConLFInfo name)
+ | isDataCon id
+ = returnFC (global_amode, mkConLFInfo id)
| otherwise = -- *might* be a nested defn: in any case, it's something whose
-- definition we will know about...
- lookupBindC name `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
+ lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
returnFC (amode, lf_info)
where
- global_amode = CLbl (mkClosureLabel name) kind
- kind = idPrimRep name
+ name = getName id
+ global_amode = CLbl (mkClosureLabel id) kind
+ kind = idPrimRep id
getCAddrMode :: Id -> FCode CAddrMode
getCAddrMode name
emptyIdSet,
GenId{-instance NamedThing-}
)
-import Name ( getLocalName )
+import Name ( nameOf, origName )
import PrelInfo ( maybeIntLikeTyCon )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import TyCon ( tyConDataCons, mkSpecTyCon )
body_code))
entry_addr = CLbl entry_label CodePtrRep
- con_descr = _UNPK_ (getLocalName data_con)
+ con_descr = _UNPK_ (nameOf (origName "con_descr" data_con))
closure_code = CClosureInfoAndCode closure_info body Nothing
stdUpd con_descr
phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
- con_descr = _UNPK_ (getLocalName data_con)
+ con_descr = _UNPK_ (nameOf (origName "con_descr2" data_con))
con_arity = dataConArity data_con
)
import IdInfo ( arityMaybe )
import Maybes ( assocMaybe, maybeToBool )
-import Name ( isLocallyDefined, getLocalName )
+import Name ( isLocallyDefined, nameOf, origName )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon )
closureTypeDescr :: ClosureInfo -> String
closureTypeDescr (MkClosureInfo id lf _)
- = if (isDataCon id) then -- DataCon has function types
- _UNPK_ (getLocalName (dataConTyCon id)) -- We want the TyCon not the ->
+ = if (isDataCon id) then -- DataCon has function types
+ _UNPK_ (nameOf (origName "closureTypeDescr" (dataConTyCon id))) -- We want the TyCon not the ->
else
getTyDescription (idType id)
\end{code}
import CoreSyn
import Bag
-import Kind ( Kind{-instance-} )
+import Kind ( hasMoreBoxityInfo, Kind{-instance-} )
import Literal ( literalType, Literal{-instance-} )
import Id ( idType, isBottomingId,
- dataConArgTys, GenId{-instances-}
+ dataConArgTys, GenId{-instances-},
+ emptyIdSet, mkIdSet, intersectIdSets,
+ unionIdSets, elementOfIdSet, IdSet(..)
)
import Maybes ( catMaybes )
-import Name ( isLocallyDefined, getSrcLoc )
+import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-} )
import Outputable ( Outputable(..){-instance * []-} )
import PprCore
import PprStyle ( PprStyle(..) )
)
import TyCon ( isPrimTyCon )
import TyVar ( tyVarKind, GenTyVar{-instances-} )
-import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets,
- unionUniqSets, elementOfUniqSet, UniqSet(..)
- )
import Unique ( Unique )
import Usage ( GenUsage )
import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic )
lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
lintCoreExpr (SCC _ expr) = lintCoreExpr expr
lintCoreExpr (Coerce _ ty expr)
- = _trace "lintCoreExpr:Coerce" $
- lintCoreExpr expr `seqL` returnL (Just ty)
+ = lintCoreExpr expr `seqL` returnL (Just ty)
lintCoreExpr (Let binds body)
= lintCoreBinding binds `thenL` \binders ->
tyvar_kind = tyVarKind tyvar
argty_kind = typeKind arg_ty
in
- if tyvar_kind == argty_kind
--- SUSPICIOUS! (tyvar_kind `isSubKindOf` argty_kind
--- || argty_kind `isSubKindOf` tyvar_kind)
+ if argty_kind `hasMoreBoxityInfo` tyvar_kind
+ -- Arg type might be boxed for a function with an uncommitted
+ -- tyvar; notably this is used so that we can give
+ -- error :: forall a:*. String -> a
+ -- and then apply it to both boxed and unboxed types.
then
returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
else
\begin{code}
type LintM a = Bool -- True <=> specialisation has been done
-> [LintLocInfo] -- Locations
- -> UniqSet Id -- Local vars in scope
+ -> IdSet -- Local vars in scope
-> Bag ErrMsg -- Error messages so far
-> (a, Bag ErrMsg) -- Result and error messages (if any)
\begin{code}
initL :: LintM a -> Bool -> Maybe ErrMsg
initL m spec_done
- = case (m spec_done [] emptyUniqSet emptyBag) of { (_, errs) ->
+ = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) ->
if isEmptyBag errs then
Nothing
else
-- For now, it's just a "trace"; we may make
-- a real error out of it...
let
- new_set = mkUniqSet ids
+ new_set = mkIdSet ids
- shadowed = scope `intersectUniqSets` new_set
+-- shadowed = scope `intersectIdSets` new_set
in
-- After adding -fliberate-case, Simon decided he likes shadowed
-- names after all. WDP 94/07
-- (if isEmptyUniqSet shadowed
-- then id
-- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
- m spec loc (scope `unionUniqSets` new_set) errs
+ m spec loc (scope `unionIdSets` new_set) errs
-- )
\end{code}
\begin{code}
checkInScope :: Id -> LintM ()
checkInScope id spec loc scope errs
- = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then
- ((),addErr errs (\sty -> ppCat [ppr sty id,ppStr "is out of scope"]) loc)
+ = let
+ id_name = getName id
+ in
+ if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then
+ ((),addErr errs (\sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc)
else
((),errs)
manifestlyWHNF (Lit _) = True
manifestlyWHNF (Con _ _) = True
manifestlyWHNF (SCC _ e) = manifestlyWHNF e
-manifestlyWHNF (Coerce _ _ e) = _trace "manifestlyWHNF:Coerce" $ manifestlyWHNF e
+manifestlyWHNF (Coerce _ _ e) = manifestlyWHNF e
manifestlyWHNF (Let _ e) = False
manifestlyWHNF (Case _ _) = False
manifestlyBottom (Con _ _) = False
manifestlyBottom (Prim _ _) = False
manifestlyBottom (SCC _ e) = manifestlyBottom e
-manifestlyBottom (Coerce _ _ e) = _trace "manifestlyBottom:Coerce" $ manifestlyBottom e
+manifestlyBottom (Coerce _ _ e) = manifestlyBottom e
manifestlyBottom (Let _ e) = manifestlyBottom e
-- We do not assume \x.bottom == bottom:
(map coreExprType final_args)
final_result_ty
in
- mkPrimDs the_ccall_op
- [] -- ***NOTE*** no ty apps; the types are inside the_ccall_op.
- final_args `thenDs` \ the_prim_app ->
+ mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
let
the_body = foldr apply (res_wrapper the_prim_app) arg_wrappers
in
| arg_ty `eqTy` stringTy
-- ToDo (ADR): - allow synonyms of Strings too?
= newSysLocalDs byteArrayPrimTy `thenDs` \ prim_arg ->
- mkAppDs (Var packStringForCId) [] [arg] `thenDs` \ pack_appn ->
+ mkAppDs (Var packStringForCId) [VarArg arg] `thenDs` \ pack_appn ->
returnDs (Var prim_arg,
\body -> Case pack_appn (PrimAlts []
(BindDefault prim_arg body))
not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
isPrimType the_prim_result_ty -- of primitive type
=
- newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
- newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
+ newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
- mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
- mkConDs the_data_con tycon_arg_tys [Var prim_result_id] `thenDs` \ the_result ->
+ mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)] `thenDs` \ new_state ->
+ mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
mkConDs tuple_con_2
- [result_ty, realWorldStateTy]
- [the_result, new_state] `thenDs` \ the_pair ->
+ [TyArg result_ty, TyArg realWorldStateTy, VarArg the_result, VarArg new_state]
+ `thenDs` \ the_pair ->
let
the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
in
(null other_data_cons) && -- Just one constr
(null data_con_arg_tys)
=
- newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
-
- mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
+ mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)]
+ `thenDs` \ new_state ->
mkConDs tuple_con_2
- [result_ty, realWorldStateTy]
- [covar_tuple_con_0, new_state] `thenDs` \ the_pair ->
+ [TyArg result_ty, TyArg realWorldStateTy, VarArg covar_tuple_con_0, VarArg new_state]
+ `thenDs` \ the_pair ->
let
the_alt = (stateDataCon, [prim_state_id], the_pair)
import HsSyn ( failureFreePat,
HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
- Stmt(..), Match(..), Qual, HsBinds, PolyType,
+ Stmt(..), Match(..), Qualifier, HsBinds, PolyType,
GRHSsAndBinds
)
import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
import DsListComp ( dsListComp )
import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom,
mkErrorAppDs, showForErr, EquationInfo,
- MatchResult
+ MatchResult, DsCoreArg(..)
)
import Match ( matchWrapper )
getAppDataTyConExpandingDicts, getAppTyCon, applyTy,
maybeBoxedPrimType
)
-import TysWiredIn ( mkTupleTy, voidTy, nilDataCon, consDataCon,
+import TysPrim ( voidTy )
+import TysWiredIn ( mkTupleTy, nilDataCon, consDataCon,
charDataCon, charTy
)
import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} )
the_char = mkCon charDataCon [] [] [LitArg (MachChar (_HEAD_ s))]
the_nil = mk_nil_con charTy
in
- mkConDs consDataCon [charTy] [the_char, the_nil]
+ mkConDs consDataCon [TyArg charTy, VarArg the_char, VarArg the_nil]
-- "_" => build (\ c n -> c 'c' n) -- LATER
dsExpr (SectionL expr op)
= dsExpr op `thenDs` \ core_op ->
dsExpr expr `thenDs` \ core_expr ->
- dsExprToAtom core_expr $ \ y_atom ->
+ dsExprToAtom (VarArg core_expr) $ \ y_atom ->
-- for the type of x, we need the type of op's 2nd argument
let
dsExpr (SectionR op expr)
= dsExpr op `thenDs` \ core_op ->
dsExpr expr `thenDs` \ core_expr ->
- dsExprToAtom core_expr $ \ y_atom ->
+ dsExprToAtom (VarArg core_expr) $ \ y_atom ->
-- for the type of x, we need the type of op's 1st argument
let
(y:ys) ->
dsExpr y `thenDs` \ core_hd ->
dsExpr (ExplicitListOut ty ys) `thenDs` \ core_tl ->
- mkConDs consDataCon [ty] [core_hd, core_tl]
+ mkConDs consDataCon [TyArg ty, VarArg core_hd, VarArg core_tl]
dsExpr (ExplicitTuple expr_list)
= mapDs dsExpr expr_list `thenDs` \ core_exprs ->
mkConDs (mkTupleCon (length expr_list))
- (map coreExprType core_exprs)
- core_exprs
+ (map (TyArg . coreExprType) core_exprs ++ map VarArg core_exprs)
-- Two cases, one for ordinary constructors and one for newtype constructors
dsExpr (HsCon con tys args)
| isDataTyCon tycon -- The usual datatype case
= mapDs dsExpr args `thenDs` \ args_exprs ->
- mkConDs con tys args_exprs
+ mkConDs con (map TyArg tys ++ map VarArg args_exprs)
| otherwise -- The newtype case
= ASSERT( isNewTyCon tycon )
dsExpr (ArithSeqOut expr (From from))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
- mkAppDs expr2 [] [from2]
+ mkAppDs expr2 [VarArg from2]
dsExpr (ArithSeqOut expr (FromTo from two))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
dsExpr two `thenDs` \ two2 ->
- mkAppDs expr2 [] [from2, two2]
+ mkAppDs expr2 [VarArg from2, VarArg two2]
dsExpr (ArithSeqOut expr (FromThen from thn))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
dsExpr thn `thenDs` \ thn2 ->
- mkAppDs expr2 [] [from2, thn2]
+ mkAppDs expr2 [VarArg from2, VarArg thn2]
dsExpr (ArithSeqOut expr (FromThenTo from thn two))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
dsExpr thn `thenDs` \ thn2 ->
dsExpr two `thenDs` \ two2 ->
- mkAppDs expr2 [] [from2, thn2, two2]
+ mkAppDs expr2 [VarArg from2, VarArg thn2, VarArg two2]
\end{code}
Record construction and update
[] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl)
in
mapDs mk_arg (zipEqual "dsExpr:RecordCon" arg_tys (dataConFieldLabels con_id)) `thenDs` \ con_args ->
- mkAppDs con_expr' [] con_args
+ mkAppDs con_expr' (map VarArg con_args)
where
-- "con_expr'" is simply an application of the constructor Id
-- to types and (perhaps) dictionaries. This gets the constructor...
_ -> -- tuple 'em up
mkConDs (mkTupleCon num_of_d_and_ms)
- (map coreExprType core_d_and_ms)
- core_d_and_ms
+ (map (TyArg . coreExprType) core_d_and_ms ++ map VarArg core_d_and_ms)
)
where
dicts_and_methods = dicts ++ methods
possible).
\begin{code}
-type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar
-
dsApp :: TypecheckedHsExpr -- expr to desugar
-> [DsCoreArg] -- accumulated ty/val args: NB:
-> DsM CoreExpr -- final result
dsApp (HsVar v) args
= lookupEnvDs v `thenDs` \ maybe_expr ->
case maybe_expr of
- Just expr -> apply_to_args expr args
+ Just expr -> mkAppDs expr args
Nothing -> -- we're only saturating constructors and PrimOps
case getIdUnfolding v of
GenForm _ the_unfolding EssentialUnfolding
-> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args
- _ -> apply_to_args (Var v) args
+ _ -> mkAppDs (Var v) args
dsApp anything_else args
= dsExpr anything_else `thenDs` \ core_expr ->
- apply_to_args core_expr args
-
--- a DsM version of mkGenApp:
-apply_to_args :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
-
-apply_to_args fun args
- = let
- (ty_args, val_args) = foldr sep ([],[]) args
- in
- mkAppDs fun ty_args val_args
- where
- sep a@(LitArg l) (tys,vals) = (tys, (Lit l):vals)
- sep a@(VarArg e) (tys,vals) = (tys, e:vals)
- sep a@(TyArg ty) (tys,vals) = (ty:tys, vals)
- sep a@(UsageArg _) _ = panic "DsExpr:apply_to_args:UsageArg"
+ mkAppDs core_expr args
\end{code}
-
\begin{code}
dsRbinds :: TypecheckedRecordBinds -- The field bindings supplied
-> ([(Id, CoreArg)] -> DsM CoreExpr) -- A continuation taking the field
= continue_with []
dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with
- = dsExpr rhs `thenDs` \ rhs' ->
- dsExprToAtom rhs' $ \ rhs_atom ->
- dsRbinds rbinds $ \ rbinds' ->
+ = dsExpr rhs `thenDs` \ rhs' ->
+ dsExprToAtom (VarArg rhs') $ \ rhs_atom ->
+ dsRbinds rbinds $ \ rbinds' ->
continue_with ((sel_id, rhs_atom) : rbinds')
\end{code}
do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args)
= do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args
-do_unfold ty_env val_env (Lam (ValBinder binder) body) (VarArg expr : args)
- = dsExprToAtom expr $ \ arg_atom ->
+do_unfold ty_env val_env (Lam (ValBinder binder) body) (arg@(VarArg expr) : args)
+ = dsExprToAtom arg $ \ arg_atom ->
do_unfold ty_env
(addOneToIdEnv val_env binder (argToExpr arg_atom))
body args
uniqSMtoDsM (substCoreExpr val_env ty_env body) `thenDs` \ body' ->
-- Apply result to remaining arguments
- apply_to_args body' args
+ mkAppDs body' args
\end{code}
Basically does the translation given in the Haskell~1.3 report:
ExprStmtOut expr locn a b ->
do_expr expr locn `thenDs` \ expr2 ->
ds_rest `thenDs` \ rest ->
- dsApp (HsVar then_id) [TyArg a, TyArg b, VarArg expr2, VarArg rest]
+ newSysLocalDs a `thenDs` \ ignored_result_id ->
+ dsApp (HsVar then_id) [TyArg a, TyArg b, VarArg expr2,
+ VarArg (mkValLam [ignored_result_id] rest)]
LetStmt binds ->
dsBinds binds `thenDs` \ binds2 ->
IMP_Ubiq()
IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop
-import HsSyn ( Qual(..), HsExpr, HsBinds )
+import HsSyn ( Qualifier(..), HsExpr, HsBinds )
import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) , TypecheckedHsBinds(..) )
import DsHsSyn ( outPatType )
import CoreSyn
deListComp :: CoreExpr -> [TypecheckedQual] -> CoreExpr -> DsM CoreExpr
deListComp expr [] list -- Figure 7.4, SLPJ, p 135, rule C above
- = mkConDs consDataCon [coreExprType expr] [expr, list]
+ = mkConDs consDataCon [TyArg (coreExprType expr), VarArg expr, VarArg list]
deListComp expr (FilterQual filt : quals) list -- rule B above
= dsExpr filt `thenDs` \ core_filt ->
else h'
in
-- the "fail" value ...
- mkAppDs (Var h) [] [Var u3] `thenDs` \ core_fail ->
+ mkAppDs (Var h) [VarArg (Var u3)] `thenDs` \ core_fail ->
deListComp expr quals core_fail `thenDs` \ rest_expr ->
matchSimply (Var u2) pat res_ty rest_expr core_fail `thenDs` \ core_match ->
- mkAppDs (Var h) [] [core_list1] `thenDs` \ letrec_body ->
+ mkAppDs (Var h) [VarArg core_list1] `thenDs` \ letrec_body ->
returnDs (
mkCoLetrecAny [
-> DsM CoreExpr
dfListComp expr expr_ty c_ty c_id n_ty n_id []
- = mkAppDs (Var c_id) [] [expr, Var n_id]
+ = mkAppDs (Var c_id) [VarArg expr, VarArg (Var n_id)]
dfListComp expr expr_ty c_ty c_id n_ty n_id (FilterQual filt : quals)
= dsExpr filt `thenDs` \ core_filt ->
combineGRHSMatchResults,
combineMatchResults,
- dsExprToAtom,
+ dsExprToAtom, DsCoreArg(..),
mkCoAlgCaseMatchResult,
mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
mkCoLetsMatchResult,
IMPORT_DELOOPER(DsLoop) ( match, matchSimply )
import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
- Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
+ Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
import TcHsSyn ( TypecheckedPat(..) )
import DsHsSyn ( outPatType )
import CoreSyn
import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
mkTheta, isUnboxedType, applyTyCon, getAppTyCon
)
-import TysWiredIn ( voidTy )
+import TysPrim ( voidTy )
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
import PprCore{-ToDo:rm-}
%************************************************************************
\begin{code}
-dsExprToAtom :: CoreExpr -- The argument expression
+dsExprToAtom :: DsCoreArg -- The argument expression
-> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*,
-- and delivering an expression E
-> DsM CoreExpr -- Either E or let x=arg-expr in E
-dsExprToAtom (Var v) continue_with = continue_with (VarArg v)
-dsExprToAtom (Lit v) continue_with = continue_with (LitArg v)
+dsExprToAtom (UsageArg u) continue_with = continue_with (UsageArg u)
+dsExprToAtom (TyArg t) continue_with = continue_with (TyArg t)
+dsExprToAtom (LitArg l) continue_with = continue_with (LitArg l)
-dsExprToAtom arg_expr continue_with
+dsExprToAtom (VarArg (Var v)) continue_with = continue_with (VarArg v)
+dsExprToAtom (VarArg (Lit v)) continue_with = continue_with (LitArg v)
+
+dsExprToAtom (VarArg arg_expr) continue_with
= let
ty = coreExprType arg_expr
in
else Let (NonRec arg_id arg_expr) body
)
-dsExprsToAtoms :: [CoreExpr]
+dsExprsToAtoms :: [DsCoreArg]
-> ([CoreArg] -> DsM CoreExpr)
-> DsM CoreExpr
-dsExprsToAtoms [] continue_with
- = continue_with []
+dsExprsToAtoms [] continue_with = continue_with []
dsExprsToAtoms (arg:args) continue_with
= dsExprToAtom arg $ \ arg_atom ->
%************************************************************************
\begin{code}
-mkAppDs :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr
-mkConDs :: Id -> [Type] -> [CoreExpr] -> DsM CoreExpr
-mkPrimDs :: PrimOp -> [Type] -> [CoreExpr] -> DsM CoreExpr
+type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar
+
+mkAppDs :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
+mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr
+mkPrimDs :: PrimOp -> [DsCoreArg] -> DsM CoreExpr
-mkAppDs fun tys arg_exprs
- = dsExprsToAtoms arg_exprs $ \ vals ->
- returnDs (mkApp fun [] tys vals)
+mkAppDs fun args
+ = dsExprsToAtoms args $ \ atoms ->
+ returnDs (mkGenApp fun atoms)
-mkConDs con tys arg_exprs
- = dsExprsToAtoms arg_exprs $ \ vals ->
- returnDs (mkCon con [] tys vals)
+mkConDs con args
+ = dsExprsToAtoms args $ \ atoms ->
+ returnDs (Con con atoms)
-mkPrimDs op tys arg_exprs
- = dsExprsToAtoms arg_exprs $ \ vals ->
- returnDs (mkPrim op [] tys vals)
+mkPrimDs op args
+ = dsExprsToAtoms args $ \ atoms ->
+ returnDs (Prim op atoms)
\end{code}
\begin{code}
IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops
import HsSyn ( HsLit(..), OutPat(..), HsExpr(..),
- Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
+ Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
TypecheckedPat(..)
)
-- module being compiled; False <=> It is from
-- an imported interface.
- (Maybe Module) -- The name of the module where the instance decl
- -- originally came from; Nothing => Prelude
+ Module -- The name of the module where the instance decl
+ -- originally came from
[Sig name] -- actually user-supplied pragmatic info
(InstancePragmas name) -- interface-supplied pragmatic info
id -- id for zero, typed applied
SrcLoc
- | ListComp (HsExpr tyvar uvar id pat) -- list comprehension
- [Qual tyvar uvar id pat] -- at least one Qual(ifier)
+ | ListComp (HsExpr tyvar uvar id pat) -- list comprehension
+ [Qualifier tyvar uvar id pat] -- at least one Qualifier
| ExplicitList -- syntactic list
[HsExpr tyvar uvar id pat]
where
pp_expr = pprParendExpr sty expr
- pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op])
- 4 (ppCat [pp_expr, ppStr "_x )"])
+ pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op])
+ 4 (ppCat [pp_expr, ppStr "x_ )"])
pp_infixly v
= ppSep [ ppBeside ppLparen pp_expr,
ppBeside (pprSym sty v) ppRparen ]
where
pp_expr = pprParendExpr sty expr
- pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op, ppPStr SLIT("_x")])
+ pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op, ppPStr SLIT("x_")])
4 (ppBeside pp_expr ppRparen)
pp_infixly v
= ppSep [ ppBeside ppLparen (pprSym sty v),
``Qualifiers'' in list comprehensions:
\begin{code}
-data Qual tyvar uvar id pat
+data Qualifier tyvar uvar id pat
= GeneratorQual pat
(HsExpr tyvar uvar id pat)
| LetQual (HsBinds tyvar uvar id pat)
\begin{code}
instance (NamedThing id, Outputable id, Outputable pat,
Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
- Outputable (Qual tyvar uvar id pat) where
+ Outputable (Qualifier tyvar uvar id pat) where
ppr sty (GeneratorQual pat expr)
= ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
ppr sty (LetQual binds)
opt_AutoSccsOnAllToplevs = lookup SLIT("-fauto-sccs-on-all-toplevs")
opt_AutoSccsOnExportedToplevs = lookup SLIT("-fauto-sccs-on-exported-toplevs")
opt_AutoSccsOnIndividualCafs = lookup SLIT("-fauto-sccs-on-individual-cafs")
-opt_CompilingPrelude = lookup SLIT("-fcompiling-prelude")
opt_D_dump_absC = lookup SLIT("-ddump-absC")
opt_D_dump_asm = lookup SLIT("-ddump-asm")
opt_D_dump_deforest = lookup SLIT("-ddump-deforest")
opt_SpecialiseUnboxed = lookup SLIT("-fspecialise-unboxed")
opt_StgDoLetNoEscapes = lookup SLIT("-flet-no-escape")
opt_Verbose = lookup SLIT("-v")
+opt_CompilingPrelude = maybeToBool maybe_CompilingPrelude
+maybe_CompilingPrelude = lookup_str "-fcompiling-prelude="
opt_SccGroup = lookup_str "-G="
opt_ProduceC = lookup_str "-C="
opt_ProduceS = lookup_str "-S="
dataConStrictMarks, StrictnessMark(..),
GenId{-instance NamedThing/Outputable-}
)
-import Name ( nameOrigName, origName, nameOf,
+import Name ( origName, nameOf, moduleOf,
exportFlagOn, nameExportFlag, ExportFlag(..),
- ltLexical, isExported, getExportFlag,
- isLexSym, isLocallyDefined,
+ isExported, getExportFlag,
+ isLexSym, isLocallyDefined, isWiredInName,
RdrName(..){-instance Outputable-},
+ OrigName(..){-instance Ord-},
Name{-instance NamedThing-}
)
import ParseUtils ( UsagesMap(..), VersionsMap(..) )
import PprEnv -- not sure how much...
import PprStyle ( PprStyle(..) )
import PprType -- most of it (??)
+import PrelMods ( modulesWithBuiltins )
import Pretty ( prettyToUn )
import Unpretty -- ditto
import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} )
ppr_ty ty = prettyToUn (pprType PprInterface ty)
ppr_tyvar tv = prettyToUn (ppr PprInterface tv)
ppr_name n
- = let
- on = origName n
- s = nameOf on
- pp = prettyToUn (ppr PprInterface on)
- in
- (if isLexSym s then uppParens else id) pp
-{-OLD:
-ppr_unq_name n
- = let
- on = origName n
- s = nameOf on
- pp = uppPStr s
- in
- (if isLexSym s then uppParens else id) pp
--}
+ = case (origName "ppr_name" n) of { OrigName m s ->
+ uppBesides [uppPStr m, uppChar '.', uppPStr s] }
\end{code}
We have a function @startIface@ to open the output file and put
= hPutStr if_hdl "\n__usages__\n" >>
hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list)))
where
- usages_list = fmToList usages
+ usages_list = filter has_no_builtins (fmToList usages)
+
+ has_no_builtins (m, _)
+ = m `notElem` modulesWithBuiltins
+ -- Don't *have* to do this; save gratuitous spillage in
+ -- every interface. Could be flag-controlled...
upp_uses (m, (mv, versions))
= uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
upp_versions (fmToList versions), uppSemi]
upp_versions nvs
- = uppIntersperse uppSP [ uppCat [(if isLexSym n then uppParens else id) (uppPStr n), uppInt v] | (n,v) <- nvs ]
+ = uppIntersperse uppSP [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ]
\end{code}
\begin{code}
| otherwise
= hPutStr if_hdl "\n__versions__\n" >>
hPutStr if_hdl (uppShow 0 (upp_versions version_list))
+ -- NB: when compiling Prelude.hs, this will spew out
+ -- stuff for [], (), (,), etc. [i.e., builtins], which
+ -- we'd rather it didn't. The version-mangling in
+ -- the driver will ignore them.
where
version_list = fmToList version_info
upp_versions nvs
- = uppAboves [ (if isLexSym n then uppParens else id) (uppPStr n) | (n,v) <- nvs ]
+ = uppAboves [ uppPStr n | (n,v) <- nvs ]
\end{code}
\begin{code}
ifaceExportList (Just if_hdl)
(HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _)
= let
- name_flag_pairs :: Bag (Name, ExportFlag)
+ name_flag_pairs :: Bag (OrigName, ExportFlag)
name_flag_pairs
= foldr from_ty
(foldr from_cls
from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
--------------
- maybe_add :: Bag (Name, ExportFlag) -> RnName -> Bag (Name, ExportFlag)
+ maybe_add :: Bag (OrigName, ExportFlag) -> RnName -> Bag (OrigName, ExportFlag)
maybe_add acc rn
- | exportFlagOn ef = acc `snocBag` (n, ef)
+ | exportFlagOn ef = acc `snocBag` (origName "maybe_add" n, ef)
| otherwise = acc
where
n = getName rn
maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n
--------------
- lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2
+ lexical_lt (n1,_) (n2,_) = n1 < n2
--------------
- upp_pair (n, ef)
- = uppBeside (ppr_name n) (upp_export ef)
+ upp_pair (OrigName m n, ef)
+ = uppBesides [uppPStr m, uppSP, uppPStr n, uppSP, upp_export ef]
where
upp_export ExportAll = uppPStr SLIT("(..)")
upp_export ExportAbs = uppNil
ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
= let
- local_fixities = filter from_here fixities
+ pp_fixities = foldr go [] fixities
in
- if null local_fixities then
+ if null pp_fixities then
return ()
else
hPutStr if_hdl "\n__fixities__\n" >>
- hPutStr if_hdl (uppShow 0 (uppAboves (map uppSemid local_fixities)))
+ hPutStr if_hdl (uppShow 0 (uppAboves pp_fixities))
where
- from_here (InfixL v _) = isLocallyDefined v
- from_here (InfixR v _) = isLocallyDefined v
- from_here (InfixN v _) = isLocallyDefined v
+ go (InfixL v i) acc = (if isLocallyDefined v then (:) (print_fix "l" i v) else id) acc
+ go (InfixR v i) acc = (if isLocallyDefined v then (:) (print_fix "r" i v) else id) acc
+ go (InfixN v i) acc = (if isLocallyDefined v then (:) (print_fix "" i v) else id) acc
+
+ print_fix suff prec var
+ = uppBesides [uppPStr SLIT("infix"), uppStr suff, uppSP, uppInt prec, uppSP, ppr_name var, uppSemi]
\end{code}
\begin{code}
ASSERT(all isLocallyDefined tycons)
ASSERT(all isLocallyDefined classes)
let
- sorted_classes = sortLt ltLexical classes
- sorted_tycons = sortLt ltLexical tycons
- sorted_vals = sortLt ltLexical vals
+ non_wired x = not (isWiredInName (getName x))
+
+ nonwired_classes = filter non_wired classes
+ nonwired_tycons = filter non_wired tycons
+ nonwired_vals = filter non_wired vals
+
+ lt_lexical a b = origName "lt_lexical" a < origName "lt_lexical" b
+
+ sorted_classes = sortLt lt_lexical nonwired_classes
+ sorted_tycons = sortLt lt_lexical nonwired_tycons
+ sorted_vals = sortLt lt_lexical nonwired_vals
in
if (null sorted_classes && null sorted_tycons && null sorted_vals) then
-- You could have a module with just instances in it
tycon1 = fst (getAppTyCon ty1)
tycon2 = fst (getAppTyCon ty2)
in
- case (origName clas1 `cmp` origName clas2) of
+ case (origName "lt_inst" clas1 `cmp` origName "lt_inst" clas2) of
LT_ -> True
GT_ -> False
- EQ_ -> origName tycon1 < origName tycon2
+ EQ_ -> origName "lt_inst2" tycon1 < origName "lt_inst2" tycon2
-------
pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
case (initNmbr (nmbrClass c)) of { -- renumber it!
Class _ n tyvar super_classes sdsels ops sels defms insts links ->
- uppCat [uppPStr SLIT("class"), ppr_theta tyvar super_classes,
+ uppCat [uppPStr SLIT("class"), ppr_context tyvar super_classes,
ppr_name n, ppr_tyvar tyvar,
if null ops
then uppSemi
else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]]
}
where
- ppr_theta :: TyVar -> [Class] -> Unpretty
+ ppr_context :: TyVar -> [Class] -> Unpretty
- ppr_theta tv [] = uppNil
- ppr_theta tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>"))
- ppr_theta tv super_classes
- = uppBesides [uppLparen,
+ ppr_context tv [] = uppNil
+-- ppr_context tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>"))
+ ppr_context tv super_classes
+ = uppBesides [uppStr "{{",
uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes),
- uppStr ") =>"]
+ uppStr "}} =>"]
ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv]
- ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty
+ clas_mod = moduleOf (origName "ppr_class" c)
+
+ ppr_op (ClassOp o _ ty) = pp_sig (Qual clas_mod o) ty
\end{code}
\begin{code}
NewType -> uppPStr SLIT("newtype")
ppr_context [] = uppNil
- ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")]
+-- ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")]
ppr_context cs
- = uppBesides[uppLparen,
+ = uppBesides[uppStr "{{",
uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
- uppRparen, uppPStr SLIT(" =>")]
+ uppStr "}}", uppPStr SLIT(" =>")]
pp_condecls
= let
returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
\end{code}
-The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal''
-compilation.
-\begin{code}
-macroCode SET_ARITY args = returnUs id
-macroCode CHK_ARITY args = returnUs id
-\end{code}
-
This one only applies if we have a machine register devoted to TagReg.
\begin{code}
macroCode SET_TAG [tag]
#define _O 0x8
#define _C 0x10
-#define _isconstr(s) (CharTable[*s]&(_C))
-BOOLEAN isconstr PROTO((char *)); /* fwd decl */
-
static unsigned char CharTable[NCHARS] = {
/* nul */ 0, 0, 0, 0, 0, 0, 0, 0,
/* bs */ 0, _S, _S, _S, _S, 0, 0, 0,
/* */ 0, 0, 0, 0, 0, 0, 0, 0,
};
+BOOLEAN
+isconstr (char *s)
+{
+ return(CharTable[*s]&(_C));
+}
+
/**********************************************************************
* *
* *
static int nested_comments; /* For counting comment nesting depth */
-/* Hacky definition of yywrap: see flex doc.
+/* OLD: Hacky definition of yywrap: see flex doc.
If we don't do this, then we'll have to get the default
yywrap from the flex library, which is often something
we are not good at locating. This avoids that difficulty.
(Besides which, this is the way old flexes (pre 2.4.x) did it.)
WDP 94/09/05
-*/
#define yywrap() 1
+*/
/* Essential forward declarations */
#endif
/* Each time we enter a new start state, we push it onto the state stack.
- Note that the rules do not allow us to underflow or overflow the stack.
- (At least, they shouldn't.) The maximum expected depth is 4:
- 0: Code -> 1: String -> 2: StringEsc -> 3: Comment
*/
-static int StateStack[5];
-static int StateDepth = -1;
-
-#ifdef HSP_DEBUG
-#define PUSH_STATE(n) do {\
- fprintf(stderr,"Pushing %d (%d)\n", n, StateDepth + 1);\
- StateStack[++StateDepth] = (n); BEGIN(n);} while(0)
-#define POP_STATE do {--StateDepth;\
- fprintf(stderr,"Popping %d (%d)\n", StateStack[StateDepth], StateDepth);\
- BEGIN(StateStack[StateDepth]);} while(0)
-#else
-#define PUSH_STATE(n) do {StateStack[++StateDepth] = (n); BEGIN(n);} while(0)
-#define POP_STATE do {--StateDepth; BEGIN(StateStack[StateDepth]);} while(0)
-#endif
+#define PUSH_STATE(n) yy_push_state(n)
+#define POP_STATE yy_pop_state()
%}
+/* Options:
+ 8bit (8-bit input)
+ noyywrap (do not call yywrap on end of file; avoid use of -lfl)
+ never-interactive (to go a bit faster)
+ stack (use a start-condition stack)
+*/
+%option 8bit
+%option noyywrap
+%option never-interactive
+%option stack
/* The start states are:
Code -- normal Haskell code (principal lexer)
hsperror(errbuf);
}
hsnewid(yytext, yyleng);
- RETURN(_isconstr(yytext) ? CONID : VARID);
- }
-<Code,GlaExt,UserPragma>_+{Id} {
- if (! nonstandardFlag) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Non-standard identifier (leading underscore): %s\n", yytext);
- hsperror(errbuf);
- }
- hsnewid(yytext, yyleng);
RETURN(isconstr(yytext) ? CONID : VARID);
- /* NB: ^^^^^^^^ : not the macro! */
}
<Code,GlaExt,UserPragma>{Id} {
hsnewid(yytext, yyleng);
- RETURN(_isconstr(yytext) ? CONID : VARID);
+ RETURN(isconstr(yytext) ? CONID : VARID);
}
<Code,GlaExt,UserPragma>{SId} {
hsnewid(yytext, yyleng);
- RETURN(_isconstr(yytext) ? CONSYM : VARSYM);
+ RETURN(isconstr(yytext) ? CONSYM : VARSYM);
}
<Code,GlaExt,UserPragma>{Mod}"."{Id} {
- BOOLEAN isconstr = hsnewqid(yytext, yyleng);
- RETURN(isconstr ? QCONID : QVARID);
+ BOOLEAN is_constr = hsnewqid(yytext, yyleng);
+ RETURN(is_constr ? QCONID : QVARID);
}
<Code,GlaExt,UserPragma>{Mod}"."{SId} {
- BOOLEAN isconstr = hsnewqid(yytext, yyleng);
- RETURN(isconstr ? QCONSYM : QVARSYM);
+ BOOLEAN is_constr = hsnewqid(yytext, yyleng);
+ RETURN(is_constr ? QCONSYM : QVARSYM);
}
%{
<GlaExt,UserPragma>"`"{Id}"#`" {
hsnewid(yytext + 1, yyleng - 2);
- RETURN(_isconstr(yytext+1) ? CONSYM : VARSYM);
+ RETURN(isconstr(yytext+1) ? CONSYM : VARSYM);
}
%{
*dot = '.';
name[length] = save;
- return _isconstr(dot+1);
-}
-
-BOOLEAN
-isconstr(char *s) /* walks past leading underscores before using the macro */
-{
- char *temp = s;
-
- for ( ; temp != NULL && *temp == '_' ; temp++ );
-
- return _isconstr(temp);
+ return isconstr(dot+1);
}
import FiniteMap ( FiniteMap, emptyFM, listToFM )
import Id ( mkTupleCon, GenId, Id(..) )
import Maybes ( catMaybes )
-import Name ( moduleNamePair )
+import Name ( origName, OrigName(..) )
import RnHsSyn ( RnName(..) )
import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon )
import Type
\begin{code}
builtinNameInfo :: ( BuiltinNames, BuiltinKeys, BuiltinIdInfos )
-type BuiltinNames = (FiniteMap (FAST_STRING,Module) RnName, -- WiredIn Ids
- FiniteMap (FAST_STRING,Module) RnName) -- WiredIn TyCons
+type BuiltinNames = (FiniteMap OrigName RnName, -- WiredIn Ids
+ FiniteMap OrigName RnName) -- WiredIn TyCons
-- Two maps because "[]" is in both...
-type BuiltinKeys = FiniteMap (FAST_STRING,Module) (Unique, Name -> RnName)
+type BuiltinKeys = FiniteMap OrigName (Unique, Name -> RnName)
-- Names with known uniques
type BuiltinIdInfos = UniqFM IdInfo -- Info for known unique Ids
-- values
map pcIdWiredInInfo wired_in_ids,
- map pcIdWiredInInfo parallel_ids,
primop_ids
]
assoc_tc_wired
, stateAndSynchVarPrimTyCon
, stateAndWordPrimTyCon
, stateTyCon
+ , voidTyCon
, wordTyCon
]
\end{code}
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
+ = [ aBSENT_ERROR_ID
, augmentId
+ , buildId
+ , copyableId
+ , eRROR_ID
, foldlId
, foldrId
+ , forkId
+ , iRREFUT_PAT_ERROR_ID
+ , integerMinusOneId
+ , integerPlusOneId
+ , integerPlusTwoId
+ , integerZeroId
+ , nON_EXHAUSTIVE_GUARDS_ERROR_ID
+ , nO_DEFAULT_METHOD_ERROR_ID
+ , nO_EXPLICIT_METHOD_ERROR_ID
+ , noFollowId
+ , pAR_ERROR_ID
+ , pAT_ERROR_ID
+ , packStringForCId
+ , parAtAbsId
+ , parAtForNowId
+ , parAtId
+ , parAtRelId
+ , parGlobalId
+ , parId
+ , parLocalId
+ , rEC_CON_ERROR_ID
+ , rEC_UPD_ERROR_ID
+ , realWorldPrimId
+ , runSTId
+ , seqId
+ , tRACE_ID
+ , tRACE_ID
+ , unpackCString2Id
, unpackCStringAppendId
, unpackCStringFoldrId
+ , unpackCStringId
+ , voidId
]
-parallel_ids
- = if not opt_ForConcurrent then
- []
- else
- [ parId
- , forkId
- , copyableId
- , noFollowId
- , parAtAbsId
- , parAtForNowId
- , parAtId
- , parAtRelId
- , parGlobalId
- , parLocalId
- ]
-
-
-pcTyConWiredInInfo :: TyCon -> ((FAST_STRING,Module), RnName)
-pcTyConWiredInInfo tc = (swap (moduleNamePair tc), WiredInTyCon tc)
-
-pcDataConWiredInInfo :: TyCon -> [((FAST_STRING,Module), RnName)]
-pcDataConWiredInInfo tycon
- = [ (swap (moduleNamePair con), WiredInId con) | con <- tyConDataCons tycon ]
+pcTyConWiredInInfo :: TyCon -> (OrigName, RnName)
+pcTyConWiredInInfo tc = (origName "pcTyConWiredInInfo" tc, WiredInTyCon tc)
-pcIdWiredInInfo :: Id -> ((FAST_STRING,Module), RnName)
-pcIdWiredInInfo id = (swap (moduleNamePair id), WiredInId id)
+pcDataConWiredInInfo :: TyCon -> [(OrigName, RnName)]
+pcDataConWiredInInfo tycon
+ = [ (origName "pcDataConWiredInInfo" con, WiredInId con) | con <- tyConDataCons tycon ]
-swap (x,y) = (y,x)
+pcIdWiredInInfo :: Id -> (OrigName, RnName)
+pcIdWiredInInfo id = (origName "pcIdWiredInInfo" id, WiredInId id)
\end{code}
WiredIn primitive numeric operations ...
primop_ids
= map prim_fn allThePrimOps ++ map funny_fn funny_name_primops
where
- prim_fn op = case (primOpNameInfo op) of (s,n) -> ((s,pRELUDE),n)
- funny_fn (op,s) = case (primOpNameInfo op) of (_,n) -> ((s,pRELUDE),n)
+ prim_fn op = case (primOpNameInfo op) of (s,n) -> ((OrigName gHC_BUILTINS s),n)
+ funny_fn (op,s) = case (primOpNameInfo op) of (_,n) -> ((OrigName gHC_BUILTINS s),n)
funny_name_primops
= [ (IntAddOp, SLIT("+#"))
Ids, Synonyms, Classes and ClassOps with builtin keys.
For the Ids we may also have some builtin IdInfo.
\begin{code}
-id_keys_infos :: [((FAST_STRING,Module), Unique, Maybe IdInfo)]
+id_keys_infos :: [(OrigName, Unique, Maybe IdInfo)]
id_keys_infos
= [ -- here so we can check the type of main/mainPrimIO
- ((SLIT("main"),SLIT("Main")), mainIdKey, Nothing)
- , ((SLIT("mainPrimIO"),SLIT("Main")), mainPrimIOIdKey, Nothing)
+ (OrigName SLIT("Main") SLIT("main"), mainIdKey, Nothing)
+ , (OrigName SLIT("Main") SLIT("mainPrimIO"), mainPrimIOIdKey, Nothing)
-- here because we use them in derived instances
- , ((SLIT("&&"), pRELUDE), andandIdKey, Nothing)
- , ((SLIT("."), pRELUDE), composeIdKey, Nothing)
- , ((SLIT("lex"), pRELUDE), lexIdKey, Nothing)
- , ((SLIT("not"), pRELUDE), notIdKey, Nothing)
- , ((SLIT("readParen"), pRELUDE), readParenIdKey, Nothing)
- , ((SLIT("showParen"), pRELUDE), showParenIdKey, Nothing)
- , ((SLIT("showString"), pRELUDE), showStringIdKey,Nothing)
- , ((SLIT("__readList"), pRELUDE), ureadListIdKey, Nothing)
- , ((SLIT("__showList"), pRELUDE), ushowListIdKey, Nothing)
- , ((SLIT("__showSpace"), pRELUDE), showSpaceIdKey, Nothing)
+ , (OrigName pRELUDE SLIT("&&"), andandIdKey, Nothing)
+ , (OrigName pRELUDE SLIT("."), composeIdKey, Nothing)
+ , (OrigName pRELUDE SLIT("lex"), lexIdKey, Nothing)
+ , (OrigName pRELUDE SLIT("not"), notIdKey, Nothing)
+ , (OrigName pRELUDE SLIT("readParen"), readParenIdKey, Nothing)
+ , (OrigName pRELUDE SLIT("showParen"), showParenIdKey, Nothing)
+ , (OrigName pRELUDE SLIT("showString"), showStringIdKey,Nothing)
+ , (OrigName gHC__ SLIT("readList__"), ureadListIdKey, Nothing)
+ , (OrigName gHC__ SLIT("showList__"), ushowListIdKey, Nothing)
+ , (OrigName gHC__ SLIT("showSpace"), showSpaceIdKey, Nothing)
]
tysyn_keys
- = [ ((SLIT("IO"),pRELUDE), (iOTyConKey, RnImplicitTyCon))
- , ((SLIT("Rational"),rATIO), (rationalTyConKey, RnImplicitTyCon))
- , ((SLIT("Ratio"),rATIO), (ratioTyConKey, RnImplicitTyCon))
- , ((SLIT("Ordering"),pRELUDE), (orderingTyConKey, RnImplicitTyCon))
+ = [ (OrigName gHC__ SLIT("IO"), (iOTyConKey, RnImplicitTyCon))
+ , (OrigName pRELUDE SLIT("Ordering"), (orderingTyConKey, RnImplicitTyCon))
+ , (OrigName rATIO SLIT("Rational"), (rationalTyConKey, RnImplicitTyCon))
+ , (OrigName rATIO SLIT("Ratio"), (ratioTyConKey, RnImplicitTyCon))
]
-- this "class_keys" list *must* include:
class_keys
= [ (str_mod, (k, RnImplicitClass)) | (str_mod,k) <-
- [ ((SLIT("Eq"),pRELUDE), eqClassKey) -- mentioned, derivable
- , ((SLIT("Eval"),pRELUDE), evalClassKey) -- mentioned
- , ((SLIT("Ord"),pRELUDE), ordClassKey) -- derivable
- , ((SLIT("Num"),pRELUDE), numClassKey) -- mentioned, numeric
- , ((SLIT("Real"),pRELUDE), realClassKey) -- numeric
- , ((SLIT("Integral"),pRELUDE), integralClassKey) -- numeric
- , ((SLIT("Fractional"),pRELUDE), fractionalClassKey) -- numeric
- , ((SLIT("Floating"),pRELUDE), floatingClassKey) -- numeric
- , ((SLIT("RealFrac"),pRELUDE), realFracClassKey) -- numeric
- , ((SLIT("RealFloat"),pRELUDE), realFloatClassKey) -- numeric
- , ((SLIT("Ix"),iX), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm)
- , ((SLIT("Bounded"),pRELUDE), boundedClassKey) -- derivable
- , ((SLIT("Enum"),pRELUDE), enumClassKey) -- derivable
- , ((SLIT("Show"),pRELUDE), showClassKey) -- derivable
- , ((SLIT("Read"),pRELUDE), readClassKey) -- derivable
- , ((SLIT("Monad"),pRELUDE), monadClassKey)
- , ((SLIT("MonadZero"),pRELUDE), monadZeroClassKey)
- , ((SLIT("MonadPlus"),pRELUDE), monadPlusClassKey)
- , ((SLIT("Functor"),pRELUDE), functorClassKey)
- , ((SLIT("_CCallable"),pRELUDE), cCallableClassKey) -- mentioned, ccallish
- , ((SLIT("_CReturnable"),pRELUDE), cReturnableClassKey) -- mentioned, ccallish
+ [ (OrigName pRELUDE SLIT("Eq"), eqClassKey) -- mentioned, derivable
+ , (OrigName pRELUDE SLIT("Eval"), evalClassKey) -- mentioned
+ , (OrigName pRELUDE SLIT("Ord"), ordClassKey) -- derivable
+ , (OrigName pRELUDE SLIT("Num"), numClassKey) -- mentioned, numeric
+ , (OrigName pRELUDE SLIT("Real"), realClassKey) -- numeric
+ , (OrigName pRELUDE SLIT("Integral"), integralClassKey) -- numeric
+ , (OrigName pRELUDE SLIT("Fractional"), fractionalClassKey) -- numeric
+ , (OrigName pRELUDE SLIT("Floating"), floatingClassKey) -- numeric
+ , (OrigName pRELUDE SLIT("RealFrac"), realFracClassKey) -- numeric
+ , (OrigName pRELUDE SLIT("RealFloat"), realFloatClassKey) -- numeric
+ , (OrigName iX SLIT("Ix"), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm)
+ , (OrigName pRELUDE SLIT("Bounded"), boundedClassKey) -- derivable
+ , (OrigName pRELUDE SLIT("Enum"), enumClassKey) -- derivable
+ , (OrigName pRELUDE SLIT("Show"), showClassKey) -- derivable
+ , (OrigName pRELUDE SLIT("Read"), readClassKey) -- derivable
+ , (OrigName pRELUDE SLIT("Monad"), monadClassKey)
+ , (OrigName pRELUDE SLIT("MonadZero"), monadZeroClassKey)
+ , (OrigName pRELUDE SLIT("MonadPlus"), monadPlusClassKey)
+ , (OrigName pRELUDE SLIT("Functor"), functorClassKey)
+ , (OrigName gHC__ SLIT("CCallable"), cCallableClassKey) -- mentioned, ccallish
+ , (OrigName gHC__ SLIT("CReturnable"), cReturnableClassKey) -- mentioned, ccallish
]]
class_op_keys
= [ (str_mod, (k, RnImplicit)) | (str_mod,k) <-
- [ ((SLIT("fromInt"),pRELUDE), fromIntClassOpKey)
- , ((SLIT("fromInteger"),pRELUDE), fromIntegerClassOpKey)
- , ((SLIT("fromRational"),pRELUDE), fromRationalClassOpKey)
- , ((SLIT("enumFrom"),pRELUDE), enumFromClassOpKey)
- , ((SLIT("enumFromThen"),pRELUDE), enumFromThenClassOpKey)
- , ((SLIT("enumFromTo"),pRELUDE), enumFromToClassOpKey)
- , ((SLIT("enumFromThenTo"),pRELUDE),enumFromThenToClassOpKey)
- , ((SLIT("=="),pRELUDE), eqClassOpKey)
- , ((SLIT(">>="),pRELUDE), thenMClassOpKey)
- , ((SLIT("zero"),pRELUDE), zeroClassOpKey)
+ [ (OrigName pRELUDE SLIT("fromInt"), fromIntClassOpKey)
+ , (OrigName pRELUDE SLIT("fromInteger"), fromIntegerClassOpKey)
+ , (OrigName pRELUDE SLIT("fromRational"), fromRationalClassOpKey)
+ , (OrigName pRELUDE SLIT("enumFrom"), enumFromClassOpKey)
+ , (OrigName pRELUDE SLIT("enumFromThen"), enumFromThenClassOpKey)
+ , (OrigName pRELUDE SLIT("enumFromTo"), enumFromToClassOpKey)
+ , (OrigName pRELUDE SLIT("enumFromThenTo"),enumFromThenToClassOpKey)
+ , (OrigName pRELUDE SLIT("=="), eqClassOpKey)
+ , (OrigName pRELUDE SLIT(">>="), thenMClassOpKey)
+ , (OrigName pRELUDE SLIT("zero"), zeroClassOpKey)
]]
\end{code}
import Class ( GenClass )
import CoreUnfold ( mkMagicUnfolding, UnfoldingDetails )
import IdUtils ( primOpNameInfo )
-import Name ( Name, mkBuiltinName )
+import Name ( Name, OrigName, mkPrimitiveName, mkWiredInName )
import PrimOp ( PrimOp )
import RnHsSyn ( RnName )
import Type ( mkSigmaTy, mkFunTys, GenType )
import Usage ( GenUsage )
mkMagicUnfolding :: Unique -> UnfoldingDetails
-mkBuiltinName :: Unique -> _PackedString -> _PackedString -> Name
+mkPrimitiveName :: Unique -> OrigName -> Name
+mkWiredInName :: Unique -> OrigName -> 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
#include "HsVersions.h"
module PrelMods (
- pRELUDE, pRELUDE_BUILTIN,
- pRELUDE_LIST, pRELUDE_TEXT,
- pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
- gLASGOW_ST, gLASGOW_MISC,
- pRELUDE_FB,
+ gHC_BUILTINS, -- things that are really and truly primitive
+ pRELUDE, gHC__,
rATIO, iX,
-
- fromPrelude
+ modulesWithBuiltins
) where
CHK_Ubiq() -- debugging consistency check
\begin{code}
-gLASGOW_MISC = SLIT("PreludeGlaMisc")
-gLASGOW_ST = SLIT("PreludeGlaST")
-pRELUDE = SLIT("Prelude")
-pRELUDE_BUILTIN = SLIT("PreludeBuiltin")
-pRELUDE_FB = SLIT("PreludeFoldrBuild")
-pRELUDE_IO = SLIT("PreludeIO")
-pRELUDE_LIST = SLIT("PreludeList")
-pRELUDE_PRIMIO = SLIT("PreludePrimIO")
-pRELUDE_PS = SLIT("PreludePS")
-pRELUDE_TEXT = SLIT("PreludeText")
+pRELUDE = SLIT("Prelude")
+gHC_BUILTINS = SLIT("GHCbuiltins") -- the truly-primitive things
+gHC__ = SLIT("GHCbase") -- all GHC basics, add-ons, extras, everything
+ -- (which can be defined in Haskell)
+rATIO = SLIT("Ratio")
+iX = SLIT("Ix")
-rATIO = SLIT("Ratio")
-iX = SLIT("Ix")
-
-fromPrelude :: FAST_STRING -> Bool
-fromPrelude s = (_SUBSTR_ s 0 6 == SLIT("Prelude"))
- where
- substr str beg end
- = take (end - beg + 1) (drop beg str)
+modulesWithBuiltins = [ gHC_BUILTINS, gHC__, pRELUDE, rATIO, iX ]
\end{code}
IMP_Ubiq()
IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..) )
-import Id ( Id(..), GenId, mkPreludeId, mkTemplateLocals )
+import Id ( Id(..), GenId, mkImported, mkUserId, mkTemplateLocals )
IMPORT_DELOOPER(PrelLoop)
-- friends:
import TysWiredIn
-- others:
+import CmdLineOpts ( maybe_CompilingPrelude )
import CoreSyn -- quite a bit
import IdInfo -- quite a bit
import Literal ( mkMachInt )
+import PragmaInfo
import PrimOp ( PrimOp(..) )
import SpecEnv ( SpecEnv(..), nullSpecEnv )
+import Type ( mkTyVarTy )
import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar )
import Unique -- lots of *Keys
import Util ( panic )
-- only used herein:
pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
-pcMiscPrelId key mod name ty info
- = mkPreludeId (mkBuiltinName key mod name) ty info
+pcMiscPrelId key m n ty info
+ = let
+ name = mkWiredInName key (OrigName m n)
+ imp = mkImported name ty info -- the usual case...
+ in
+ imp
+ -- We lie and say the thing is imported; otherwise, we get into
+ -- a mess with dependency analysis; e.g., core2stg may heave in
+ -- random calls to GHCbase.unpackPS. If GHCbase is the module
+ -- being compiled, then it's just a matter of luck if the definition
+ -- will be in "the right place" to be in scope.
+{- ???
+ case maybe_CompilingPrelude of
+ Nothing -> imp
+ Just modname ->
+ if modname == _UNPK_ m -- we are compiling the module where this thing is defined...
+ then mkUserId name ty NoPragmaInfo
+ else imp
+-}
\end{code}
%************************************************************************
GHC randomly injects these into the code.
-@patError#@ is just a version of @error@ for pattern-matching
+@patError@ is just a version of @error@ for pattern-matching
failures. It knows various ``codes'' which expand to longer
strings---this saves space!
-@absent#@ is a thing we put in for ``absent'' arguments. They jolly
+@absentErr@ is a thing we put in for ``absent'' arguments. They jolly
well shouldn't be yanked on, but if one is, then you will get a
-friendly message from @absent#@ (rather a totally random crash).
+friendly message from @absentErr@ (rather a totally random crash).
-@parError#@ is a special version of @error@ which the compiler does
+@parError@ is a special version of @error@ which the compiler does
not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
templates, but we don't ever expect to generate code for it.
-- these "bottom" out, no matter what their arguments
eRROR_ID
- = pc_bottoming_Id errorIdKey pRELUDE_BUILTIN SLIT("error") errorTy
+ = pc_bottoming_Id errorIdKey pRELUDE SLIT("error") errorTy
generic_ERROR_ID u n
- = pc_bottoming_Id u pRELUDE_BUILTIN n errorTy
+ = pc_bottoming_Id u gHC__ n errorTy
pAT_ERROR_ID
- = generic_ERROR_ID patErrorIdKey SLIT("patError#")
+ = generic_ERROR_ID patErrorIdKey SLIT("patError")
rEC_CON_ERROR_ID
- = generic_ERROR_ID recConErrorIdKey SLIT("recConError#")
+ = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
rEC_UPD_ERROR_ID
- = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError#")
+ = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
iRREFUT_PAT_ERROR_ID
- = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError#")
+ = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
nON_EXHAUSTIVE_GUARDS_ERROR_ID
- = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError#")
+ = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
nO_DEFAULT_METHOD_ERROR_ID
- = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError#")
+ = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError")
nO_EXPLICIT_METHOD_ERROR_ID
- = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError#")
+ = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError")
aBSENT_ERROR_ID
- = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#")
+ = pc_bottoming_Id absentErrorIdKey gHC__ SLIT("absentErr")
(mkSigmaTy [alphaTyVar] [] alphaTy)
pAR_ERROR_ID
- = pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#")
+ = pcMiscPrelId parErrorIdKey gHC__ SLIT("parError")
(mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo
errorTy :: Type
-errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy)
+errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] (mkTyVarTy openAlphaTyVar))
\end{code}
We want \tr{_trace} (NB: name not in user namespace) to be wired in
importing-subsequently module needs to know it's magic.
\begin{code}
tRACE_ID
- = pcMiscPrelId traceIdKey pRELUDE_BUILTIN SLIT("_trace") traceTy
+ = pcMiscPrelId traceIdKey gHC__ SLIT("trace") traceTy
(noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
where
traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
\begin{code}
packStringForCId
- = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC")
+ = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC")
(mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
--------------------------------------------------------------------
unpackCStringId
- = pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackPS#")
+ = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS")
(mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
-- Andy says:
-- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
-- but I don't like wired-in IdInfos (WDP)
unpackCString2Id -- for cases when a string has a NUL in it
- = pcMiscPrelId unpackCString2IdKey pRELUDE_BUILTIN SLIT("unpackPS2#")
+ = pcMiscPrelId unpackCString2IdKey gHC__ SLIT("unpackPS2")
(mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
noIdInfo
--------------------------------------------------------------------
unpackCStringAppendId
- = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackAppendPS#")
+ = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS")
(mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
((noIdInfo
{-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-})
`addInfo` mkArityInfo 2)
unpackCStringFoldrId
- = pcMiscPrelId unpackCStringFoldrIdKey pRELUDE_BUILTIN SLIT("unpackFoldrPS#")
+ = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS")
(mkSigmaTy [alphaTyVar] []
(mkFunTys [addrPrimTy{-a "char *" pointer-},
mkFunTys [charTy, alphaTy] alphaTy,
+1, +2, and -1 (go ahead, fire me):
\begin{code}
integerZeroId
- = pcMiscPrelId integerZeroIdKey pRELUDE SLIT("__integer0") integerTy noIdInfo
+ = pcMiscPrelId integerZeroIdKey gHC__ SLIT("integer_0") integerTy noIdInfo
integerPlusOneId
- = pcMiscPrelId integerPlusOneIdKey pRELUDE SLIT("__integer1") integerTy noIdInfo
+ = pcMiscPrelId integerPlusOneIdKey gHC__ SLIT("integer_1") integerTy noIdInfo
integerPlusTwoId
- = pcMiscPrelId integerPlusTwoIdKey pRELUDE SLIT("__integer2") integerTy noIdInfo
+ = pcMiscPrelId integerPlusTwoIdKey gHC__ SLIT("integer_2") integerTy noIdInfo
integerMinusOneId
- = pcMiscPrelId integerMinusOneIdKey pRELUDE SLIT("__integerm1") integerTy noIdInfo
+ = pcMiscPrelId integerMinusOneIdKey gHC__ SLIT("integer_m1") integerTy noIdInfo
\end{code}
%************************************************************************
\begin{code}
--------------------------------------------------------------------
--- seqId :: "_seq_", used w/ GRIP, etc., is really quite similar to
+-- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
-- dangerousEval
{-
OLDER:
- _seq_ = /\ a b -> \ x y -> case x of { _ -> y }
+ seq = /\ a b -> \ x y -> case x of { _ -> y }
OLD:
- _seq_ = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
+ seq = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' }
NEW (95/05):
- _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
+ seq = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; }
-}
-seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_")
+seqId = pcMiscPrelId seqIdKey gHC__ SLIT("seq")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
(BindDefault z (Var y))))
--------------------------------------------------------------------
--- parId :: "_par_", also used w/ GRIP, etc.
+-- parId :: "par", also used w/ GRIP, etc.
{-
OLDER:
OLD:
- _par_ = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
+ par = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' }
NEW (95/05):
- _par_ = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
+ par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
-}
-parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_")
+parId = pcMiscPrelId parIdKey gHC__ SLIT("par")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
[(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
(BindDefault z (Var y))))
--- forkId :: "_fork_", for *required* concurrent threads
+-- forkId :: "fork", for *required* concurrent threads
{-
_fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
-}
-forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_")
+forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
GranSim ones:
\begin{code}
-parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_")
+parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
[(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
(BindDefault z (Var y))))
-parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_")
+parGlobalId = pcMiscPrelId parGlobalIdKey gHC__ SLIT("parGlobal")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
(BindDefault z (Var y))))
-parAtId = pcMiscPrelId parAtIdKey pRELUDE_BUILTIN SLIT("_parAt_")
+parAtId = pcMiscPrelId parAtIdKey gHC__ SLIT("parAt")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
alphaTy, betaTy, gammaTy] gammaTy))
[(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
(BindDefault z (Var y))))
-parAtAbsId = pcMiscPrelId parAtAbsIdKey pRELUDE_BUILTIN SLIT("_parAtAbs_")
+parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtAbs_template))
[(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
(BindDefault z (Var y))))
-parAtRelId = pcMiscPrelId parAtRelIdKey pRELUDE_BUILTIN SLIT("_parAtRel_")
+parAtRelId = pcMiscPrelId parAtRelIdKey gHC__ SLIT("parAtRel")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtRel_template))
[(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
(BindDefault z (Var y))))
-parAtForNowId = pcMiscPrelId parAtForNowIdKey pRELUDE_BUILTIN SLIT("_parAtForNow_")
+parAtForNowId = pcMiscPrelId parAtForNowIdKey gHC__ SLIT("parAtForNow")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
alphaTy, betaTy, gammaTy] gammaTy))
-- copyable and noFollow are currently merely hooks: they are translated into
-- calls to the macros COPYABLE and NOFOLLOW -- HWL
-copyableId = pcMiscPrelId copyableIdKey pRELUDE_BUILTIN SLIT("_copyable_")
+copyableId = pcMiscPrelId copyableIdKey gHC__ SLIT("copyable")
(mkSigmaTy [alphaTyVar] []
alphaTy)
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding copyable_template))
copyable_template
= mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
-noFollowId = pcMiscPrelId noFollowIdKey pRELUDE_BUILTIN SLIT("_noFollow_")
+noFollowId = pcMiscPrelId noFollowIdKey gHC__ SLIT("noFollow")
(mkSigmaTy [alphaTyVar] []
alphaTy)
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding noFollow_template))
%************************************************************************
%* *
-\subsection[PrelVals-void]{@void@: Magic value of type @Void@}
-%* *
-%************************************************************************
-
-\begin{code}
-voidId = pcMiscPrelId voidIdKey pRELUDE_BUILTIN SLIT("_void") voidTy noIdInfo
-\end{code}
-
-%************************************************************************
-%* *
\subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function}
%* *
%************************************************************************
We unfold always, just for simplicity:
\begin{code}
runSTId
- = pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info
+ = pcMiscPrelId runSTIdKey gHC__ SLIT("runST") run_ST_ty id_info
where
s_tv = betaTyVar
s = betaTy
nasty as-is, change it back to a literal (@Literal@).
\begin{code}
realWorldPrimId
- = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#")
+ = pcMiscPrelId realWorldPrimIdKey gHC_BUILTINS SLIT("realWorld#")
realWorldStatePrimTy
noIdInfo
\end{code}
+\begin{code}
+voidId = pcMiscPrelId voidIdKey gHC_BUILTINS SLIT("void") voidTy noIdInfo
+\end{code}
+
%************************************************************************
%* *
\subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''}
\begin{code}
buildId
- = pcMiscPrelId buildIdKey pRELUDE_BUILTIN SLIT("_build") buildTy
+ = pcMiscPrelId buildIdKey gHC__ SLIT("build") buildTy
((((noIdInfo
{-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
`addInfo` mkStrictnessInfo [WwStrict] Nothing)
\begin{code}
augmentId
- = pcMiscPrelId augmentIdKey pRELUDE_BUILTIN SLIT("_augment") augmentTy
+ = pcMiscPrelId augmentIdKey gHC__ SLIT("augment") augmentTy
(((noIdInfo
{-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
\end{code}
\begin{code}
-foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr")
+foldrId = pcMiscPrelId foldrIdKey pRELUDE SLIT("foldr")
foldrTy idInfo
where
foldrTy =
`addInfo` mkUpdateInfo [2,2,1])
`addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
-foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl")
+foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl")
foldlTy idInfo
where
foldlTy =
-- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
-- the prelude.
--
-
+{- OLD: doesn't apply with 1.3
appendId
= pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
where
`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
`addInfo` mkArityInfo 2)
`addInfo` mkUpdateInfo [1,2])
+-}
\end{code}
%************************************************************************
\begin{code}
primOp_str op
= case (primOpInfo op) of
- Dyadic str _ -> str
- Monadic str _ -> str
- Compare str _ -> str
- Coercing str _ _ -> str
+ Dyadic str _ -> str
+ Monadic str _ -> str
+ Compare str _ -> str
+ Coercing str _ _ -> str
PrimResult str _ _ _ _ _ -> str
- AlgResult str _ _ _ _ -> str
+ AlgResult str _ _ _ _ -> str
\end{code}
@primOpType@ duplicates some work of @primOpId@, but since we
IMP_Ubiq(){-uitous-}
import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
-import Name ( mkBuiltinName )
-import PrelMods ( pRELUDE_BUILTIN )
+import Name ( mkPrimitiveName )
+import PrelMods ( gHC_BUILTINS )
import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn
import TyCon ( mkPrimTyCon, mkDataTyCon, NewOrData(..) )
+import Type ( mkTyConTy )
import TyVar ( GenTyVar(..), alphaTyVars )
import Type ( applyTyCon, mkTyVarTys )
import Usage ( usageOmega )
pcPrimTyCon key str arity primrep
= mkPrimTyCon name (mk_kind arity) primrep
where
- name = mkBuiltinName key pRELUDE_BUILTIN str
+ name = mkPrimitiveName key (OrigName gHC_BUILTINS str)
mk_kind 0 = mkUnboxedTypeKind
mk_kind n = mkTypeKind `mkArrowKind` mk_kind (n-1)
[{-no derivings-}]
DataType
where
- name = mkBuiltinName realWorldTyConKey pRELUDE_BUILTIN SLIT("_RealWorld")
+ name = mkPrimitiveName realWorldTyConKey (OrigName gHC_BUILTINS SLIT("RealWorld"))
realWorldStatePrimTy = mkStatePrimTy realWorldTy
\end{code}
Note: the ``state-pairing'' types are not truly primitive, so they are
defined in \tr{TysWiredIn.lhs}, not here.
+\begin{code}
+-- The Void type is represented as a data type with no constructors
+-- It's a built in type (i.e. there's no way to define it in Haskell;
+-- the nearest would be
+--
+-- data Void = -- No constructors!
+--
+-- ) It's boxed; there is only one value of this
+-- type, namely "void", whose semantics is just bottom.
+voidTy = mkTyConTy voidTyCon
+
+voidTyCon
+ = mkDataTyCon name mkBoxedTypeKind
+ [{-no tyvars-}]
+ [{-no context-}]
+ [{-no data cons!-}]
+ [{-no derivings-}]
+ DataType
+ where
+ name = mkPrimitiveName voidTyConKey (OrigName gHC_BUILTINS SLIT("Void"))
+\end{code}
+
%************************************************************************
%* *
\subsection[TysPrim-arrays]{The primitive array types}
stringTy,
trueDataCon,
unitTy,
- voidTy, voidTyCon,
wordDataCon,
wordTy,
wordTyCon
-
) where
--ToDo:rm
-- others:
import SpecEnv ( SpecEnv(..) )
import Kind ( mkBoxedTypeKind, mkArrowKind )
-import Name ( mkBuiltinName )
+import Name ( mkWiredInName )
import SrcLoc ( mkBuiltinSrcLoc )
import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
NewOrData(..), TyCon
pcNewTyCon = pc_tycon NewType
pc_tycon new_or_data key mod str tyvars cons
- = mkDataTyCon (mkBuiltinName key mod str) tycon_kind
+ = mkDataTyCon (mkWiredInName key (OrigName mod str)) tycon_kind
tyvars [{-no context-}] cons [{-no derivings-}]
new_or_data
where
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)
+ = mkDataCon (mkWiredInName key (OrigName mod str))
[ NotMarkedStrict | a <- arg_tys ]
[ {- no labelled fields -} ]
tyvars context arg_tys tycon
%************************************************************************
\begin{code}
--- The Void type is represented as a data type with no constructors
--- It's a built in type (i.e. there's no way to define it in Haskell
--- the nearest would be
---
--- data Void = -- No constructors!
---
--- It's boxed; there is only one value of this
--- type, namely "void", whose semantics is just bottom.
-voidTy = mkTyConTy voidTyCon
-
-voidTyCon = pcDataTyCon voidTyConKey pRELUDE_BUILTIN SLIT("Void") [] []
-\end{code}
-
-\begin{code}
charTy = mkTyConTy charTyCon
-charTyCon = pcDataTyCon charTyConKey pRELUDE_BUILTIN SLIT("Char") [] [charDataCon]
-charDataCon = pcDataCon charDataConKey pRELUDE_BUILTIN SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv
+charTyCon = pcDataTyCon charTyConKey pRELUDE SLIT("Char") [] [charDataCon]
+charDataCon = pcDataCon charDataConKey pRELUDE SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv
+
+stringTy = mkListTy charTy -- convenience only
\end{code}
\begin{code}
intTy = mkTyConTy intTyCon
-intTyCon = pcDataTyCon intTyConKey pRELUDE_BUILTIN SLIT("Int") [] [intDataCon]
-intDataCon = pcDataCon intDataConKey pRELUDE_BUILTIN SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv
+intTyCon = pcDataTyCon intTyConKey pRELUDE SLIT("Int") [] [intDataCon]
+intDataCon = pcDataCon intDataConKey pRELUDE SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv
\end{code}
\begin{code}
wordTy = mkTyConTy wordTyCon
-wordTyCon = pcDataTyCon wordTyConKey pRELUDE_BUILTIN SLIT("_Word") [] [wordDataCon]
-wordDataCon = pcDataCon wordDataConKey pRELUDE_BUILTIN SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv
+wordTyCon = pcDataTyCon wordTyConKey gHC__ SLIT("Word") [] [wordDataCon]
+wordDataCon = pcDataCon wordDataConKey gHC__ SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv
\end{code}
\begin{code}
addrTy = mkTyConTy addrTyCon
-addrTyCon = pcDataTyCon addrTyConKey pRELUDE_BUILTIN SLIT("_Addr") [] [addrDataCon]
-addrDataCon = pcDataCon addrDataConKey pRELUDE_BUILTIN SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv
+addrTyCon = pcDataTyCon addrTyConKey gHC__ SLIT("Addr") [] [addrDataCon]
+addrDataCon = pcDataCon addrDataConKey gHC__ SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv
\end{code}
\begin{code}
floatTy = mkTyConTy floatTyCon
-floatTyCon = pcDataTyCon floatTyConKey pRELUDE_BUILTIN SLIT("Float") [] [floatDataCon]
-floatDataCon = pcDataCon floatDataConKey pRELUDE_BUILTIN SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv
+floatTyCon = pcDataTyCon floatTyConKey pRELUDE SLIT("Float") [] [floatDataCon]
+floatDataCon = pcDataCon floatDataConKey pRELUDE SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv
\end{code}
\begin{code}
doubleTy = mkTyConTy doubleTyCon
-doubleTyCon = pcDataTyCon doubleTyConKey pRELUDE_BUILTIN SLIT("Double") [] [doubleDataCon]
-doubleDataCon = pcDataCon doubleDataConKey pRELUDE_BUILTIN SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv
+doubleTyCon = pcDataTyCon doubleTyConKey pRELUDE SLIT("Double") [] [doubleDataCon]
+doubleDataCon = pcDataCon doubleDataConKey pRELUDE SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv
\end{code}
\begin{code}
mkStateTy ty = applyTyCon stateTyCon [ty]
realWorldStateTy = mkStateTy realWorldTy -- a common use
-stateTyCon = pcDataTyCon stateTyConKey pRELUDE_BUILTIN SLIT("_State") alpha_tyvar [stateDataCon]
+stateTyCon = pcDataTyCon stateTyConKey gHC__ SLIT("State") alpha_tyvar [stateDataCon]
stateDataCon
- = pcDataCon stateDataConKey pRELUDE_BUILTIN SLIT("S#")
+ = pcDataCon stateDataConKey gHC__ SLIT("S#")
alpha_tyvar [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv
\end{code}
\begin{code}
stablePtrTyCon
- = pcDataTyCon stablePtrTyConKey gLASGOW_MISC SLIT("_StablePtr")
+ = pcDataTyCon stablePtrTyConKey gHC__ SLIT("StablePtr")
alpha_tyvar [stablePtrDataCon]
where
stablePtrDataCon
- = pcDataCon stablePtrDataConKey gLASGOW_MISC SLIT("_StablePtr")
+ = pcDataCon stablePtrDataConKey gHC__ SLIT("StablePtr")
alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv
\end{code}
\begin{code}
foreignObjTyCon
- = pcDataTyCon foreignObjTyConKey gLASGOW_MISC SLIT("_ForeignObj")
+ = pcDataTyCon foreignObjTyConKey gHC__ SLIT("ForeignObj")
[] [foreignObjDataCon]
where
foreignObjDataCon
- = pcDataCon foreignObjDataConKey gLASGOW_MISC SLIT("_ForeignObj")
+ = pcDataCon foreignObjDataConKey gHC__ SLIT("ForeignObj")
[] [] [foreignObjPrimTy] foreignObjTyCon nullSpecEnv
\end{code}
integerTy :: GenType t u
integerTy = mkTyConTy integerTyCon
-integerTyCon = pcDataTyCon integerTyConKey pRELUDE_BUILTIN SLIT("Integer") [] [integerDataCon]
+integerTyCon = pcDataTyCon integerTyConKey pRELUDE SLIT("Integer") [] [integerDataCon]
-integerDataCon = pcDataCon integerDataConKey pRELUDE_BUILTIN SLIT("J#")
+integerDataCon = pcDataCon integerDataConKey pRELUDE SLIT("J#")
[] [] [intPrimTy, intPrimTy, byteArrayPrimTy] integerTyCon nullSpecEnv
\end{code}
And the other pairing types:
\begin{code}
return2GMPsTyCon = pcDataTyCon return2GMPsTyConKey
- pRELUDE_BUILTIN SLIT("_Return2GMPs") [] [return2GMPsDataCon]
+ gHC__ SLIT("Return2GMPs") [] [return2GMPsDataCon]
return2GMPsDataCon
- = pcDataCon return2GMPsDataConKey pRELUDE_BUILTIN SLIT("_Return2GMPs") [] []
+ = pcDataCon return2GMPsDataConKey gHC__ SLIT("Return2GMPs") [] []
[intPrimTy, intPrimTy, byteArrayPrimTy,
intPrimTy, intPrimTy, byteArrayPrimTy] return2GMPsTyCon nullSpecEnv
returnIntAndGMPTyCon = pcDataTyCon returnIntAndGMPTyConKey
- pRELUDE_BUILTIN SLIT("_ReturnIntAndGMP") [] [returnIntAndGMPDataCon]
+ gHC__ SLIT("ReturnIntAndGMP") [] [returnIntAndGMPDataCon]
returnIntAndGMPDataCon
- = pcDataCon returnIntAndGMPDataConKey pRELUDE_BUILTIN SLIT("_ReturnIntAndGMP") [] []
+ = pcDataCon returnIntAndGMPDataConKey gHC__ SLIT("ReturnIntAndGMP") [] []
[intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy] returnIntAndGMPTyCon nullSpecEnv
\end{code}
\begin{code}
stateAndPtrPrimTyCon
- = pcDataTyCon stateAndPtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndPtr#")
+ = pcDataTyCon stateAndPtrPrimTyConKey gHC__ SLIT("StateAndPtr#")
alpha_beta_tyvars [stateAndPtrPrimDataCon]
stateAndPtrPrimDataCon
- = pcDataCon stateAndPtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndPtr#")
+ = pcDataCon stateAndPtrPrimDataConKey gHC__ SLIT("StateAndPtr#")
alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy]
stateAndPtrPrimTyCon nullSpecEnv
stateAndCharPrimTyCon
- = pcDataTyCon stateAndCharPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndChar#")
+ = pcDataTyCon stateAndCharPrimTyConKey gHC__ SLIT("StateAndChar#")
alpha_tyvar [stateAndCharPrimDataCon]
stateAndCharPrimDataCon
- = pcDataCon stateAndCharPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndChar#")
+ = pcDataCon stateAndCharPrimDataConKey gHC__ SLIT("StateAndChar#")
alpha_tyvar [] [mkStatePrimTy alphaTy, charPrimTy]
stateAndCharPrimTyCon nullSpecEnv
stateAndIntPrimTyCon
- = pcDataTyCon stateAndIntPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndInt#")
+ = pcDataTyCon stateAndIntPrimTyConKey gHC__ SLIT("StateAndInt#")
alpha_tyvar [stateAndIntPrimDataCon]
stateAndIntPrimDataCon
- = pcDataCon stateAndIntPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndInt#")
+ = pcDataCon stateAndIntPrimDataConKey gHC__ SLIT("StateAndInt#")
alpha_tyvar [] [mkStatePrimTy alphaTy, intPrimTy]
stateAndIntPrimTyCon nullSpecEnv
stateAndWordPrimTyCon
- = pcDataTyCon stateAndWordPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndWord#")
+ = pcDataTyCon stateAndWordPrimTyConKey gHC__ SLIT("StateAndWord#")
alpha_tyvar [stateAndWordPrimDataCon]
stateAndWordPrimDataCon
- = pcDataCon stateAndWordPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndWord#")
+ = pcDataCon stateAndWordPrimDataConKey gHC__ SLIT("StateAndWord#")
alpha_tyvar [] [mkStatePrimTy alphaTy, wordPrimTy]
stateAndWordPrimTyCon nullSpecEnv
stateAndAddrPrimTyCon
- = pcDataTyCon stateAndAddrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndAddr#")
+ = pcDataTyCon stateAndAddrPrimTyConKey gHC__ SLIT("StateAndAddr#")
alpha_tyvar [stateAndAddrPrimDataCon]
stateAndAddrPrimDataCon
- = pcDataCon stateAndAddrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndAddr#")
+ = pcDataCon stateAndAddrPrimDataConKey gHC__ SLIT("StateAndAddr#")
alpha_tyvar [] [mkStatePrimTy alphaTy, addrPrimTy]
stateAndAddrPrimTyCon nullSpecEnv
stateAndStablePtrPrimTyCon
- = pcDataTyCon stateAndStablePtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#")
+ = pcDataTyCon stateAndStablePtrPrimTyConKey gHC__ SLIT("StateAndStablePtr#")
alpha_beta_tyvars [stateAndStablePtrPrimDataCon]
stateAndStablePtrPrimDataCon
- = pcDataCon stateAndStablePtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#")
+ = pcDataCon stateAndStablePtrPrimDataConKey gHC__ SLIT("StateAndStablePtr#")
alpha_beta_tyvars []
[mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]]
stateAndStablePtrPrimTyCon nullSpecEnv
stateAndForeignObjPrimTyCon
- = pcDataTyCon stateAndForeignObjPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#")
+ = pcDataTyCon stateAndForeignObjPrimTyConKey gHC__ SLIT("StateAndForeignObj#")
alpha_tyvar [stateAndForeignObjPrimDataCon]
stateAndForeignObjPrimDataCon
- = pcDataCon stateAndForeignObjPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#")
+ = pcDataCon stateAndForeignObjPrimDataConKey gHC__ SLIT("StateAndForeignObj#")
alpha_tyvar []
[mkStatePrimTy alphaTy, applyTyCon foreignObjPrimTyCon []]
stateAndForeignObjPrimTyCon nullSpecEnv
stateAndFloatPrimTyCon
- = pcDataTyCon stateAndFloatPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndFloat#")
+ = pcDataTyCon stateAndFloatPrimTyConKey gHC__ SLIT("StateAndFloat#")
alpha_tyvar [stateAndFloatPrimDataCon]
stateAndFloatPrimDataCon
- = pcDataCon stateAndFloatPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndFloat#")
+ = pcDataCon stateAndFloatPrimDataConKey gHC__ SLIT("StateAndFloat#")
alpha_tyvar [] [mkStatePrimTy alphaTy, floatPrimTy]
stateAndFloatPrimTyCon nullSpecEnv
stateAndDoublePrimTyCon
- = pcDataTyCon stateAndDoublePrimTyConKey pRELUDE_BUILTIN SLIT("StateAndDouble#")
+ = pcDataTyCon stateAndDoublePrimTyConKey gHC__ SLIT("StateAndDouble#")
alpha_tyvar [stateAndDoublePrimDataCon]
stateAndDoublePrimDataCon
- = pcDataCon stateAndDoublePrimDataConKey pRELUDE_BUILTIN SLIT("StateAndDouble#")
+ = pcDataCon stateAndDoublePrimDataConKey gHC__ SLIT("StateAndDouble#")
alpha_tyvar [] [mkStatePrimTy alphaTy, doublePrimTy]
stateAndDoublePrimTyCon nullSpecEnv
\end{code}
\begin{code}
stateAndArrayPrimTyCon
- = pcDataTyCon stateAndArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndArray#")
+ = pcDataTyCon stateAndArrayPrimTyConKey gHC__ SLIT("StateAndArray#")
alpha_beta_tyvars [stateAndArrayPrimDataCon]
stateAndArrayPrimDataCon
- = pcDataCon stateAndArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndArray#")
+ = pcDataCon stateAndArrayPrimDataConKey gHC__ SLIT("StateAndArray#")
alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy]
stateAndArrayPrimTyCon nullSpecEnv
stateAndMutableArrayPrimTyCon
- = pcDataTyCon stateAndMutableArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#")
+ = pcDataTyCon stateAndMutableArrayPrimTyConKey gHC__ SLIT("StateAndMutableArray#")
alpha_beta_tyvars [stateAndMutableArrayPrimDataCon]
stateAndMutableArrayPrimDataCon
- = pcDataCon stateAndMutableArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#")
+ = pcDataCon stateAndMutableArrayPrimDataConKey gHC__ SLIT("StateAndMutableArray#")
alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy]
stateAndMutableArrayPrimTyCon nullSpecEnv
stateAndByteArrayPrimTyCon
- = pcDataTyCon stateAndByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#")
+ = pcDataTyCon stateAndByteArrayPrimTyConKey gHC__ SLIT("StateAndByteArray#")
alpha_tyvar [stateAndByteArrayPrimDataCon]
stateAndByteArrayPrimDataCon
- = pcDataCon stateAndByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#")
+ = pcDataCon stateAndByteArrayPrimDataConKey gHC__ SLIT("StateAndByteArray#")
alpha_tyvar [] [mkStatePrimTy alphaTy, byteArrayPrimTy]
stateAndByteArrayPrimTyCon nullSpecEnv
stateAndMutableByteArrayPrimTyCon
- = pcDataTyCon stateAndMutableByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#")
+ = pcDataTyCon stateAndMutableByteArrayPrimTyConKey gHC__ SLIT("StateAndMutableByteArray#")
alpha_tyvar [stateAndMutableByteArrayPrimDataCon]
stateAndMutableByteArrayPrimDataCon
- = pcDataCon stateAndMutableByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#")
+ = pcDataCon stateAndMutableByteArrayPrimDataConKey gHC__ SLIT("StateAndMutableByteArray#")
alpha_tyvar [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon alpha_ty]
stateAndMutableByteArrayPrimTyCon nullSpecEnv
stateAndSynchVarPrimTyCon
- = pcDataTyCon stateAndSynchVarPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#")
+ = pcDataTyCon stateAndSynchVarPrimTyConKey gHC__ SLIT("StateAndSynchVar#")
alpha_beta_tyvars [stateAndSynchVarPrimDataCon]
stateAndSynchVarPrimDataCon
- = pcDataCon stateAndSynchVarPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#")
+ = pcDataCon stateAndSynchVarPrimDataConKey gHC__ SLIT("StateAndSynchVar#")
alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy]
stateAndSynchVarPrimTyCon nullSpecEnv
\end{code}
\begin{code}
mkStateTransformerTy s a = applyTyCon stTyCon [s, a]
-stTyCon = pcNewTyCon stTyConKey pRELUDE SLIT("_ST") alpha_beta_tyvars [stDataCon]
+stTyCon = pcNewTyCon stTyConKey gHC__ SLIT("ST") alpha_beta_tyvars [stDataCon]
where
ty = mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy])
- stDataCon = pcDataCon stDataConKey pRELUDE SLIT("_ST")
+ stDataCon = pcDataCon stDataConKey gHC__ SLIT("ST")
alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv
\end{code}
\begin{code}
mkPrimIoTy a = applyTyCon primIoTyCon [a]
-primIoTyCon = pcNewTyCon primIoTyConKey pRELUDE SLIT("_PrimIO") alpha_tyvar [primIoDataCon]
+primIoTyCon = pcNewTyCon primIoTyConKey gHC__ SLIT("PrimIO") alpha_tyvar [primIoDataCon]
where
ty = mkFunTys [mkStateTy realWorldTy] (mkTupleTy 2 [alphaTy, mkStateTy realWorldTy])
- primIoDataCon = pcDataCon primIoDataConKey pRELUDE SLIT("_PrimIO")
+ primIoDataCon = pcDataCon primIoDataConKey gHC__ SLIT("PrimIO")
alpha_tyvar [] [ty] primIoTyCon nullSpecEnv
\end{code}
alphaListTy = mkSigmaTy alpha_tyvar [] (applyTyCon listTyCon alpha_ty)
-listTyCon = pcDataTyCon listTyConKey pRELUDE_BUILTIN SLIT("[]")
+listTyCon = pcDataTyCon listTyConKey pRELUDE SLIT("[]")
alpha_tyvar [nilDataCon, consDataCon]
-nilDataCon = pcDataCon nilDataConKey pRELUDE_BUILTIN SLIT("[]") alpha_tyvar [] [] listTyCon
+nilDataCon = pcDataCon nilDataConKey pRELUDE SLIT("[]") alpha_tyvar [] [] listTyCon
(pcGenerateDataSpecs alphaListTy)
-consDataCon = pcDataCon consDataConKey pRELUDE_BUILTIN SLIT(":")
+consDataCon = pcDataCon consDataConKey pRELUDE SLIT(":")
alpha_tyvar [] [alphaTy, applyTyCon listTyCon alpha_ty] listTyCon
(pcGenerateDataSpecs alphaListTy)
-- Interesting: polymorphic recursion would help here.
alphaLiftTy = mkSigmaTy alpha_tyvar [] (applyTyCon liftTyCon alpha_ty)
liftTyCon
- = pcDataTyCon liftTyConKey pRELUDE_BUILTIN SLIT("_Lift") alpha_tyvar [liftDataCon]
+ = pcDataTyCon liftTyConKey gHC__ SLIT("Lift") alpha_tyvar [liftDataCon]
liftDataCon
- = pcDataCon liftDataConKey pRELUDE_BUILTIN SLIT("_Lift")
+ = pcDataCon liftDataConKey gHC__ SLIT("Lift")
alpha_tyvar [] alpha_ty liftTyCon
((pcGenerateDataSpecs alphaLiftTy) `addOneToSpecEnv`
(mkSpecInfo [Just realWorldStatePrimTy] 0 bottom))
where
bottom = panic "liftDataCon:State# _RealWorld"
\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[TysWiredIn-for-convenience]{Types wired in for convenience (e.g., @String@)}
-%* *
-%************************************************************************
-
-\begin{code}
-stringTy = mkListTy charTy
-\end{code}
type RdrNameMonoType = MonoType RdrName
type RdrNamePat = InPat RdrName
type RdrNamePolyType = PolyType RdrName
-type RdrNameQual = Qual Fake Fake RdrName RdrNamePat
+type RdrNameQual = Qualifier Fake Fake RdrName RdrNamePat
type RdrNameSig = Sig RdrName
type RdrNameSpecInstSig = SpecInstSig RdrName
type RdrNameStmt = Stmt Fake Fake RdrName RdrNamePat
import RdrHsSyn
import PrefixToHs
-import CmdLineOpts ( opt_CompilingPrelude )
import ErrUtils ( addErrLoc, ghcExit )
import FiniteMap ( elemFM, FiniteMap )
-import Name ( RdrName(..), isRdrLexConOrSpecial )
+import Name ( RdrName(..), isRdrLexConOrSpecial, preludeQual )
import PprStyle ( PprStyle(..) )
-import PrelMods ( fromPrelude, pRELUDE )
+import PrelMods ( pRELUDE )
import Pretty
import SrcLoc ( SrcLoc )
import Util ( nOfThem, pprError, panic )
wlkQid (U_noqual name)
= returnUgn (Unqual name)
wlkQid (U_aqual mod name)
- | fromPrelude mod
- = returnUgn (Unqual name)
- | otherwise
= returnUgn (Qual mod name)
wlkQid (U_gid n name)
- = returnUgn (Unqual name)
+ = returnUgn (preludeQual name)
cvFlag :: U_long -> Bool
cvFlag 0 = False
wlkExpr nexp `thenUgn` \ expr ->
-- this is a hack
let
- neg = SLIT("negate")
- rdr = if opt_CompilingPrelude
- then Unqual neg
- else Qual pRELUDE neg
+ rdr = preludeQual SLIT("negate")
in
returnUgn (NegApp expr (HsVar rdr))
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 True maybe_mod uprags noInstancePragmas src_loc))
+ (InstDecl clas ctxt_inst_ty binds True modname uprags noInstancePragmas src_loc))
-- "default" declaration
U_dbind dbindts srcline ->
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM )
-import Name ( ExportFlag(..), mkTupNameStr,
+import Name ( ExportFlag(..), mkTupNameStr, preludeQual,
RdrName(..){-instance Outputable:ToDo:rm-}
)
import Outputable -- ToDo:rm
DECLARATIONS_PART { ITdeclarations }
PRAGMAS_PART { ITpragmas }
BANG { ITbang }
- BQUOTE { ITbquote }
CBRACK { ITcbrack }
CCURLY { ITccurly }
+ DCCURLY { ITdccurly }
CLASS { ITclass }
COMMA { ITcomma }
CPAREN { ITcparen }
NEWTYPE { ITnewtype }
OBRACK { ITobrack }
OCURLY { ITocurly }
+ DOCURLY { ITdocurly }
OPAREN { IToparen }
RARROW { ITrarrow }
SEMI { ITsemi }
{ $1 `snocBag` $2 }
name_version_pair :: { (FAST_STRING, Int) }
-name_version_pair : iname INTEGER
+name_version_pair : name INTEGER
{ ($1, fromInteger $2)
--------------------------------------------------------------------------
}
exports_part : EXPORTS_PART export_items { bagToFM $2 }
| { emptyFM }
-export_items :: { Bag (FAST_STRING, (RdrName, ExportFlag)) }
+export_items :: { Bag (FAST_STRING, (OrigName, ExportFlag)) }
export_items : export_item { unitBag $1 }
| export_items export_item { $1 `snocBag` $2 }
-export_item :: { (FAST_STRING, (RdrName, ExportFlag)) }
-export_item : qiname maybe_dotdot { (de_qual $1, ($1, $2)) }
+export_item :: { (FAST_STRING, (OrigName, ExportFlag)) }
+export_item : CONID name maybe_dotdot { ($2, (OrigName $1 $2, $3)) }
maybe_dotdot :: { ExportFlag }
maybe_dotdot : DOTDOT { ExportAll }
| fixes fix { case $2 of (k,v) -> addToFM $1 k v }
fix :: { (FAST_STRING, RdrNameFixityDecl) }
-fix : INFIXL INTEGER qop SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) }
- | INFIXR INTEGER qop SEMI { (de_qual $3, InfixR $3 (fromInteger $2)) }
- | INFIX INTEGER qop SEMI { (de_qual $3, InfixN $3 (fromInteger $2))
+fix : INFIXL INTEGER qname SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) }
+ | INFIXR INTEGER qname SEMI { (de_qual $3, InfixR $3 (fromInteger $2)) }
+ | INFIX INTEGER qname SEMI { (de_qual $3, InfixN $3 (fromInteger $2))
--------------------------------------------------------------------------
}
decl : var DCOLON ctype SEMI { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) }
context :: { RdrNameContext }
-context : OPAREN context_list CPAREN { reverse $2 }
- | class { [$1] }
+context : DOCURLY context_list DCCURLY { reverse $2 }
context_list :: { RdrNameContext{-reversed-} }
context_list : class { [$1] }
class : gtycon VARID { ($1, Unqual $2) }
ctype :: { RdrNamePolyType }
-ctype : type DARROW type { HsPreForAllTy (type2context $1) $3 }
- | type { HsPreForAllTy [] $1 }
+ctype : context DARROW type { HsPreForAllTy $1 $3 }
+ | type { HsPreForAllTy [] $1 }
type :: { RdrNameMonoType }
type : btype { $1 }
case ty1 of {
MonoTyVar tv -> MonoTyApp tv tys;
MonoTyApp tc ts -> MonoTyApp tc (ts++tys);
- MonoFunTy t1 t2 -> MonoTyApp (Unqual SLIT("->")) (t1:t2:tys);
- MonoListTy ty -> MonoTyApp (Unqual SLIT("[]")) (ty:tys);
- MonoTupleTy ts -> MonoTyApp (Unqual (mkTupNameStr (length ts)))
+ MonoFunTy t1 t2 -> MonoTyApp (preludeQual SLIT("->")) (t1:t2:tys);
+ MonoListTy ty -> MonoTyApp (preludeQual SLIT("[]")) (ty:tys);
+ MonoTupleTy ts -> MonoTyApp (preludeQual (mkTupNameStr (length ts)))
(ts++tys);
_ -> pprPanic "test:" (ppr PprDebug $1)
}}
gtycon :: { RdrName }
gtycon : QCONID { $1 }
- | CONID { Unqual $1 }
- | OPAREN RARROW CPAREN { Unqual SLIT("->") }
- | OBRACK CBRACK { Unqual SLIT("[]") }
- | OPAREN CPAREN { Unqual SLIT("()") }
- | OPAREN commas CPAREN { Unqual (mkTupNameStr $2) }
+ | OPAREN RARROW CPAREN { preludeQual SLIT("->") }
+ | OBRACK CBRACK { preludeQual SLIT("[]") }
+ | OPAREN CPAREN { preludeQual SLIT("()") }
+ | OPAREN commas CPAREN { preludeQual (mkTupNameStr $2) }
commas :: { Int }
commas : COMMA { 2{-1 comma => arity 2-} }
constr :: { (RdrName, RdrNameConDecl) }
constr : btyconapp
{ case $1 of (con, tys) -> (con, ConDecl con tys mkIfaceSrcLoc) }
- | OPAREN QCONSYM CPAREN { ($2, ConDecl $2 [] mkIfaceSrcLoc) }
- | OPAREN QCONSYM CPAREN batypes { ($2, ConDecl $2 $4 mkIfaceSrcLoc) }
- | OPAREN CONSYM CPAREN { (Unqual $2, ConDecl (Unqual $2) [] mkIfaceSrcLoc) }
- | OPAREN CONSYM CPAREN batypes { (Unqual $2, ConDecl (Unqual $2) $4 mkIfaceSrcLoc) }
+ | QCONSYM { ($1, ConDecl $1 [] mkIfaceSrcLoc) }
+ | QCONSYM batypes { ($1, ConDecl $1 $2 mkIfaceSrcLoc) }
| gtycon OCURLY fields CCURLY
{ ($1, RecConDecl $1 $3 mkIfaceSrcLoc) }
constr1 : gtycon atype { ($1, $2) }
var :: { RdrName }
-var : QVARID { $1 }
- | OPAREN QVARSYM CPAREN { $2 }
- | VARID { Unqual $1 }
- | OPAREN VARSYM CPAREN { Unqual $2 }
-
-op :: { FAST_STRING }
-op : BQUOTE VARID BQUOTE { $2 }
- | BQUOTE CONID BQUOTE { $2 }
- | VARSYM { $1 }
- | CONSYM { $1 }
-
-qop :: { RdrName }
-qop : BQUOTE QVARID BQUOTE { $2 }
- | BQUOTE QCONID BQUOTE { $2 }
+var : QVARID { $1 }
+ | QVARSYM { $1 }
+
+qname :: { RdrName }
+qname : QVARID { $1 }
+ | QCONID { $1 }
| QVARSYM { $1 }
| QCONSYM { $1 }
- | op { Unqual $1 }
-
-iname :: { FAST_STRING }
-iname : VARID { $1 }
- | CONID { $1 }
- | OPAREN VARSYM CPAREN { $2 }
- | OPAREN BANG CPAREN { SLIT("!"){-sigh, double-sigh-} }
- | OPAREN CONSYM CPAREN { $2 }
-
-qiname :: { RdrName }
-qiname : QVARID { $1 }
- | QCONID { $1 }
- | OPAREN QVARSYM CPAREN { $2 }
- | OPAREN QCONSYM CPAREN { $2 }
- | iname { Unqual $1 }
+
+name :: { FAST_STRING }
+name : VARID { $1 }
+ | CONID { $1 }
+ | VARSYM { $1 }
+ | BANG { SLIT("!"){-sigh, double-sigh-} }
+ | CONSYM { $1 }
instances_part :: { Bag RdrIfaceInst }
instances_part : INSTANCES_PART instdecls { $2 }
import FiniteMap ( unitFM, listToFM, lookupFM, plusFM, FiniteMap )
import Maybes ( maybeToBool, MaybeErr(..) )
import Name ( isLexConId, isLexVarId, isLexConSym,
- mkTupNameStr,
+ mkTupNameStr, preludeQual, isRdrLexCon,
RdrName(..){-instance Outputable:ToDo:rm-}
)
import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging
-import PrelMods ( fromPrelude )
+import PrelMods ( pRELUDE )
import Pretty ( ppCat, ppPStr, ppInt, ppShow, ppStr )
import SrcLoc ( mkIfaceSrcLoc )
import Util ( startsWith, isIn, panic, assertPanic )
-- representing all the instances def'd in that module
type VersionsMap = FiniteMap FAST_STRING Version
-- Versions for things def'd in this module
-type ExportsMap = FiniteMap FAST_STRING (RdrName, ExportFlag)
+type ExportsMap = FiniteMap FAST_STRING (OrigName, ExportFlag)
type FixitiesMap = FiniteMap FAST_STRING RdrNameFixityDecl
type LocalTyDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for TyCon/Class
type LocalValDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for values incl DataCon
data RdrIfaceDecl
= TypeSig RdrName SrcLoc RdrNameTyDecl
- | NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl
+ | NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl
| DataSig RdrName [RdrName] [RdrName] SrcLoc RdrNameTyDecl
| ClassSig RdrName [RdrName] SrcLoc RdrNameClassDecl
| ValSig RdrName SrcLoc RdrNamePolyType
data RdrIfaceInst
- = InstSig RdrName RdrName SrcLoc RdrNameInstDecl
+ = InstSig RdrName RdrName SrcLoc (Module -> RdrNameInstDecl)
+ -- InstDecl minus a Module name
\end{code}
\begin{code}
| ITinfix
| ITbang -- magic symbols
| ITvbar
- | ITbquote
| ITdcolon
| ITcomma
| ITdarrow
| ITdotdot
| ITequal
| ITocurly
+ | ITdccurly
+ | ITdocurly
| ITobrack
| IToparen
| ITrarrow
en_mono :: FAST_STRING -> RdrNameMonoType
en_mono tv = MonoTyVar (Unqual tv)
+{-OLD:
type2context (MonoTupleTy tys) = map type2class_assertion tys
type2context other_ty = [ type2class_assertion other_ty ]
type2class_assertion (MonoTyApp clas [MonoTyVar tyvar]) = (clas, tyvar)
type2class_assertion _ = panic "type2class_assertion: bad format"
+-}
-----------------------------------------------------------------
mk_type :: (RdrName, [FAST_STRING])
-> RdrNameMonoType
-> LocalTyDefsMap
-mk_type (qtycon, tyvars) ty
+mk_type (qtycon@(Qual mod tycon), tyvars) ty
= let
- tycon = de_qual qtycon
qtyvars = map Unqual tyvars
in
- unitFM tycon (TypeSig qtycon mkIfaceSrcLoc (
- TySynonym qtycon qtyvars ty mkIfaceSrcLoc))
+ unitFM tycon (TypeSig qtycon mkIfaceSrcLoc $
+ TySynonym qtycon qtyvars ty mkIfaceSrcLoc)
mk_data :: RdrNameContext
-> (RdrName, [FAST_STRING])
-> [(RdrName, RdrNameConDecl)]
-> (LocalTyDefsMap, LocalValDefsMap)
-mk_data ctxt (qtycon, tyvars) names_and_constrs
+mk_data ctxt (qtycon@(Qual mod tycon), tyvars) names_and_constrs
= let
- (qconnames, constrs) = unzip names_and_constrs
- qfieldnames = [] -- ToDo ...
- tycon = de_qual qtycon
- connames = map de_qual qconnames
- fieldnames = map de_qual qfieldnames
+ (qthingnames, constrs) = unzip names_and_constrs
+ (qconnames, qfieldnames) = partition isRdrLexCon qthingnames
+ thingnames = [ t | (Qual _ t) <- qthingnames]
qtyvars = map Unqual tyvars
- decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc (
- TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc)
+ decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc $
+ TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc
in
- (unitFM tycon decl, listToFM [(c,decl) | c <- connames]
- `plusFM`
- listToFM [(f,decl) | f <- fieldnames])
+ (unitFM tycon decl, listToFM [(t,decl) | t <- thingnames])
mk_new :: RdrNameContext
-> (RdrName, [FAST_STRING])
-> (RdrName, RdrNameMonoType)
-> (LocalTyDefsMap, LocalValDefsMap)
-mk_new ctxt (qtycon, tyvars) (qconname, ty)
- = let
- tycon = de_qual qtycon
- conname = de_qual qconname
+mk_new ctxt (qtycon@(Qual mod1 tycon), tyvars) (qconname@(Qual mod2 conname), ty)
+ = ASSERT(mod1 == mod2)
+ let
qtyvars = map Unqual tyvars
constr = NewConDecl qconname ty mkIfaceSrcLoc
- decl = NewTypeSig qtycon qconname mkIfaceSrcLoc (
- TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc)
+ decl = NewTypeSig qtycon qconname mkIfaceSrcLoc $
+ TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc
in
(unitFM tycon decl, unitFM conname decl)
-> [(FAST_STRING, RdrNameSig)]
-> (LocalTyDefsMap, LocalValDefsMap)
-mk_class ctxt (qclas, tyvar) ops_and_sigs
+mk_class ctxt (qclas@(Qual mod clas), tyvar) ops_and_sigs
= case (unzip ops_and_sigs) of { (opnames, sigs) ->
let
- qopnames = map Unqual opnames
- clas = de_qual qclas
+ qopnames = map (Qual mod) opnames
op_sigs = map opify sigs
- decl = ClassSig qclas qopnames mkIfaceSrcLoc (
- ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc)
+ decl = ClassSig qclas qopnames mkIfaceSrcLoc $
+ ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc
in
(unitFM clas decl, listToFM [(o,decl) | o <- opnames]) }
where
-> RdrNameMonoType -- fish the tycon out yourself...
-> RdrIfaceInst
-mk_inst ctxt clas mono_ty
- = InstSig clas (tycon_name mono_ty) mkIfaceSrcLoc (
- InstDecl clas (HsPreForAllTy ctxt mono_ty)
- EmptyMonoBinds False Nothing{-lying-} [{-sigs-}]
- noInstancePragmas mkIfaceSrcLoc)
+mk_inst ctxt qclas@(Qual cmod cname) mono_ty
+ = InstSig qclas (tycon_name mono_ty) mkIfaceSrcLoc $ \ mod ->
+ InstDecl qclas (HsPreForAllTy ctxt mono_ty)
+ EmptyMonoBinds False mod [{-sigs-}]
+ noInstancePragmas mkIfaceSrcLoc
where
tycon_name (MonoTyApp tc _) = tc
- tycon_name (MonoListTy _) = Unqual SLIT("[]")
- tycon_name (MonoFunTy _ _) = Unqual SLIT("->")
- tycon_name (MonoTupleTy ts) = Unqual (mkTupNameStr (length ts))
+ tycon_name (MonoListTy _) = preludeQual SLIT("[]")
+ tycon_name (MonoFunTy _ _) = preludeQual SLIT("->")
+ tycon_name (MonoTupleTy ts) = preludeQual (mkTupNameStr (length ts))
-----------------------------------------------------------------
lexIface :: String -> [IfaceToken]
-lexIface str
+lexIface input
= _scc_ "Lexer"
- case str of
+ case input of
[] -> []
-- whitespace and comments
'{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
'(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs
+ '{' : '{' : cs -> ITdocurly : lexIface cs
+ '}' : '}' : cs -> ITdccurly : lexIface cs
+ '{' : cs -> ITocurly : lexIface cs
+ '}' : cs -> ITccurly : lexIface cs
'(' : cs -> IToparen : lexIface cs
')' : cs -> ITcparen : lexIface cs
'[' : cs -> ITobrack : lexIface cs
']' : cs -> ITcbrack : lexIface cs
- '{' : cs -> ITocurly : lexIface cs
- '}' : cs -> ITccurly : lexIface cs
',' : cs -> ITcomma : lexIface cs
';' : cs -> ITsemi : lexIface cs
- '`' : cs -> ITbquote : lexIface cs
- '_' : cs -> lex_name Nothing is_var_sym str
- c : cs | isUpper c -> lex_word str -- don't know if "Module." on front or not
- | isDigit c -> lex_num str
- | isAlpha c -> lex_name Nothing is_var_sym str
- | is_sym_sym c -> lex_name Nothing is_sym_sym str
+ '_' : '_' : cs -> lex_keyword cs
+
+ c : cs | isUpper c -> lex_word input -- don't know if "Module." on front or not
+ | isDigit c -> lex_num input
+ | isAlpha c -> lex_name Nothing is_var_sym input
+ | is_sym_sym c -> lex_name Nothing is_sym_sym input
other -> error ("lexing:"++other)
where
is_var_sym1 '\'' = False
is_var_sym1 '#' = False
+ is_var_sym1 '_' = False
is_var_sym1 c = is_var_sym c
is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
where
in_the_club [] = panic "lex_word:in_the_club"
- in_the_club (c:_) | isAlpha c = is_var_sym
- | c == '_' = is_var_sym
- | is_sym_sym c = is_sym_sym
- | otherwise = panic ("lex_word:in_the_club="++[c])
+ in_the_club (x:_) | isAlpha x = is_var_sym
+ | is_sym_sym x = is_sym_sym
+ | otherwise = panic ("lex_word:in_the_club="++[x])
module_dot (c:cs)
= if not (isUpper c) || c == '\'' then
_ -> Nothing
}
+ lex_keyword str
+ = case (span is_var_sym str) of { (kw, rest) ->
+ case (lookupFM keywordsFM kw) of
+ Nothing -> panic ("lex_keyword:"++str)
+ Just xx -> xx : lexIface rest
+ }
+
lex_name module_dot in_the_club str
= case (span in_the_club str) of { (word, rest) ->
case (lookupFM keywordsFM word) of
categ n (ITconid n) (ITvarid n) (ITconsym n) (ITvarsym n)
Just m ->
let
- q = if fromPrelude m then Unqual n else Qual m n
+ q = Qual m n
in
categ n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q)
keywordsFM = listToFM [
("interface", ITinterface)
- ,("__usages__", ITusages)
- ,("__versions__", ITversions)
- ,("__exports__", ITexports)
- ,("__instance_modules__",ITinstance_modules)
- ,("__instances__", ITinstances)
- ,("__fixities__", ITfixities)
- ,("__declarations__", ITdeclarations)
- ,("__pragmas__", ITpragmas)
+ ,("usages__", ITusages)
+ ,("versions__", ITversions)
+ ,("exports__", ITexports)
+ ,("instance_modules__", ITinstance_modules)
+ ,("instances__", ITinstances)
+ ,("fixities__", ITfixities)
+ ,("declarations__", ITdeclarations)
+ ,("pragmas__", ITpragmas)
,("data", ITdata)
,("type", ITtype)
import ErrUtils ( Error(..), Warning(..) )
import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} )
import Maybes ( catMaybes )
-import Name ( isLocallyDefined, mkBuiltinName, Name, RdrName(..) )
+import Name ( isLocallyDefined, mkWiredInName, Name, RdrName(..) )
import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
-import PrelMods ( pRELUDE )
import Unique ( ixClassKey )
import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
import UniqSupply ( splitUniqSupply )
ToDo: Deal with instances (instance version, this module on instance list ???)
\begin{code}
-renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
+renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
= let
(b_names, b_keys, _) = builtinNameInfo
else
-- No top-level name errors so rename source ...
- case initRn True mod occ_env us2
+ case initRn True modname occ_env us2
(rnSource imp_mods unqual_imps imp_fixes input) of {
((rn_module, export_fn, src_occs), src_errs, src_warns) ->
-- including those for which we have definitions
(orig_def_env, orig_def_dups)
- = extendGlobalRnEnv emptyRnEnv (map pair_orig def_vals)
- (map pair_orig def_tcs)
+ = extendGlobalRnEnv emptyRnEnv (map pairify_rn def_vals)
+ (map pairify_rn def_tcs)
(orig_occ_env, orig_occ_dups)
- = extendGlobalRnEnv emptyRnEnv (map pair_orig occ_vals)
- (map pair_orig occ_tcs)
-
- pair_orig rn = (origName rn, rn)
+ = extendGlobalRnEnv emptyRnEnv (map pairify_rn occ_vals)
+ (map pairify_rn occ_tcs)
+
+ -- This stuff is pretty dodgy right now: I think original
+ -- names and occurrence names may be getting entangled
+ -- when they shouldn't be... WDP 96/06
+
+ pairify_rn rn -- ToDo: move to Name?
+ = let
+ name = getName rn
+ in
+ (if isLocalName name
+ then Unqual (getLocalName name)
+ else case (origName "pairify_rn" name) of { OrigName m n ->
+ Qual m n }
+ , rn)
must_haves
| opt_NoImplicitPrelude
= [{-no Prelude.hi, no point looking-}]
| otherwise
- = [ name_fn (mkBuiltinName u mod str)
- | ((str, mod), (u, name_fn)) <- fmToList b_keys,
+ = [ name_fn (mkWiredInName u orig)
+ | (orig@(OrigName mod str), (u, name_fn)) <- fmToList b_keys,
str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
in
-- ASSERT (isEmptyBag orig_occ_dups)
= ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ",
ppInterleave ppComma (map (ppr sty) occs)]
\end{code}
-
-\begin{code}
-{- TESTING:
-pprPIface (ParsedIface m ms v mv usgs lcm exm ims lfx ltdm lvdm lids ldp)
- = ppAboves [
- ppCat [ppPStr SLIT("interface"), ppPStr m, ppInt v,
- case mv of { Nothing -> ppNil; Just n -> ppInt n }],
-
- ppPStr SLIT("__versions__"),
- ppAboves [ ppCat[ppPStr n, ppInt v] | (n,v) <- fmToList lcm ],
-
- ppPStr SLIT("__exports__"),
- ppAboves [ ppBesides[ppPStr n, ppSP, ppr PprDebug rn,
- case ex of {ExportAll -> ppStr "(..)"; _ -> ppNil}]
- | (n,(rn,ex)) <- fmToList exm ],
-
- pp_ims (bagToList ims),
- pp_fixities lfx,
- pp_decls ltdm lvdm,
- pp_insts (bagToList lids),
- pp_pragmas ldp
- ]
- where
- pp_ims [] = ppNil
- pp_ims ms = ppAbove (ppPStr SLIT("__instance_modules__"))
- (ppCat (map ppPStr ms))
-
- pp_fixities fx
- | isEmptyFM fx = ppNil
- | otherwise = ppAboves (ppPStr SLIT("__fixities__")
- : [ ppr PprDebug fix | (n, fix) <- fmToList fx])
-
- pp_decls tds vds = ppAboves (ppPStr SLIT("__declarations__")
- : [ pprRdrIfaceDecl d | (n, d) <- fmToList tds ++ fmToList vds])
-
- pp_insts [] = ppNil
- pp_insts is = ppAboves (ppPStr SLIT("__instances__")
- : [ pprRdrInstDecl i | i <- is])
-
- pp_pragmas ps | isEmptyFM ps = ppNil
- | otherwise = panic "Rename.pp_pragmas"
-
-pprRdrIfaceDecl (TypeSig tc _ decl)
- = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; ", ppr PprDebug decl]
-
-pprRdrIfaceDecl (NewTypeSig tc dc _ decl)
- = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacon=", ppr PprDebug dc,
- ppStr "; ", ppr PprDebug decl]
-
-pprRdrIfaceDecl (DataSig tc dcs dfs _ decl)
- = ppBesides [ppStr "tycon=", ppr PprDebug tc, ppStr "; datacons=", ppr PprDebug dcs,
- ppStr "; fields=", ppr PprDebug dfs, ppStr "; ", ppr PprDebug decl]
-
-pprRdrIfaceDecl (ClassSig c ops _ decl)
- = ppBesides [ppStr "class=", ppr PprDebug c, ppStr "; ops=", ppr PprDebug ops,
- ppStr "; ", ppr PprDebug decl]
-
-pprRdrIfaceDecl (ValSig f _ ty)
- = ppBesides [ppr PprDebug f, ppStr " :: ", ppr PprDebug ty]
-
-pprRdrInstDecl (InstSig c t _ decl)
- = ppBesides [ppStr "class=", ppr PprDebug c, ppStr " type=", ppr PprDebug t, ppStr "; ",
- ppr PprDebug decl]
--}
-\end{code}
import ErrUtils ( addErrLoc, addShortErrLocLine )
import Name ( RdrName )
import Maybes ( catMaybes )
+import PprStyle--ToDo:rm
import Pretty
import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
unionUniqSets, unionManyUniqSets,
elementOfUniqSet, uniqSetToList, UniqSet(..) )
-import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic )
+import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic, pprTrace{-ToDo:rm-} )
\end{code}
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
-- Do the SCC analysis
let vertices = mkVertices mbinds_info
- edges = mkEdges vertices mbinds_info
+ edges = mkEdges mbinds_info
scc_result = stronglyConnComp (==) edges vertices
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) ->
+flattenMonoBinds uniq sigs (AndMonoBinds bs1 bs2)
+ = flattenMonoBinds uniq sigs bs1 `thenRn` \ (uniq1, flat1) ->
+ flattenMonoBinds uniq1 sigs bs2 `thenRn` \ (uniq2, flat2) ->
returnRn (uniq2, flat1 ++ flat2)
flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
]
mkVertices :: FlatMonoBindsInfo -> [VertexTag]
-mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
+mkEdges :: FlatMonoBindsInfo -> [Edge]
-mkEdges :: [VertexTag] -> FlatMonoBindsInfo -> [Edge]
+mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
-mkEdges vertices flat_info
+mkEdges 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
- ]
+ = -- pprTrace "mkEdges:" (ppAboves [ppAboves[ppInt v, ppCat [ppr PprDebug d|d <- uniqSetToList defd], ppCat [ppr PprDebug u|u <- uniqSetToList used]] | (v,defd,used,_,_) <- flat_info]) $
+ [ (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}
Basically dependency analysis.
-Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qual@ datatypes. In
+Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qualifier@ datatypes. In
general, all of these functions return a renamed thing, and a set of
free variables.
%************************************************************************
%* *
-\subsubsection{@Qual@s: in list comprehensions}
+\subsubsection{@Qualifier@s: in list comprehensions}
%* *
%************************************************************************
type RenamedPat = InPat RnName
type RenamedPolyType = PolyType RnName
type RenamedRecordBinds = HsRecordBinds Fake Fake RnName RenamedPat
-type RenamedQual = Qual Fake Fake RnName RenamedPat
+type RenamedQual = Qualifier Fake Fake RnName RenamedPat
type RenamedSig = Sig RnName
type RenamedSpecInstSig = SpecInstSig RnName
type RenamedStmt = Stmt Fake Fake RnName RenamedPat
#include "HsVersions.h"
module RnIfaces (
--- findHiFiles,
cachedIface,
cachedDecl,
- readIface,
rnIfaces,
IfaceCache(..)
) where
IMP_Ubiq()
-import LibDirectory
import PreludeGlaST ( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) )
import HsSyn
plusFM_C, addListToFM, keysFM{-ToDo:rm-}
)
import Maybes ( maybeToBool )
-import Name ( moduleNamePair, origName, isRdrLexCon, RdrName(..), Name{-instance NamedThing-} )
+import Name ( origName, moduleOf, nameOf, qualToOrigName, OrigName(..),
+ isLexCon, RdrName(..), Name{-instance NamedThing-} )
import PprStyle -- ToDo:rm
import Outputable -- ToDo:rm
import PrelInfo ( builtinNameInfo )
-import PrelMods ( pRELUDE )
import Pretty
import Maybes ( MaybeErr(..) )
import UniqFM ( emptyUFM )
*********************************************************
* *
-\subsection{Looking for interface files}
-* *
-*********************************************************
-
-Return a mapping from module-name to
-absolute-filename-for-that-interface.
-\begin{code}
-{- OLD:
-findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)
-
-findHiFiles dirs sysdirs
- = --hPutStr stderr " findHiFiles " >>
- do_dirs emptyFM (dirs ++ sysdirs) >>= \ result ->
- --hPutStr stderr " done\n" >>
- return result
- where
- do_dirs env [] = return env
- do_dirs env (dir:dirs)
- = do_dir env dir >>= \ new_env ->
- do_dirs new_env dirs
- -------
- do_dir env dir
- = --hPutStr stderr "D" >>
- getDirectoryContents dir >>= \ entries ->
- do_entries env entries
- where
- do_entries env [] = return env
- do_entries env (e:es)
- = do_entry env e >>= \ new_env ->
- do_entries new_env es
- -------
- do_entry env e
- = case (acceptable_hi (reverse e)) of
- Nothing -> --trace ("Deemed uncool:"++e) $
- --hPutStr stderr "." >>
- return env
- Just mod ->
- let
- pmod = _PK_ mod
- in
- case (lookupFM env pmod) of
- Nothing -> --trace ("Adding "++mod++" -> "++e) $
- --hPutStr stderr "!" >>
- return (addToFM env pmod (dir ++ '/':e))
- -- ToDo: use DIR_SEP, not /
-
- Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $
- --hPutStr stderr "." >>
- return env
- -------
- acceptable_hi rev_e -- looking at pathname *backwards*
- = case (startsWith (reverse opt_HiSuffix) rev_e) of
- Nothing -> Nothing
- Just xs -> plausible_modname xs{-reversed-}
-
- -------
- de_dot ('.' : '/' : xs) = xs
- de_dot xs = xs
-
- -------
- plausible_modname rev_e
- = let
- cand = reverse (takeWhile is_modname_char rev_e)
- in
- if null cand || not (isUpper (head cand))
- then Nothing
- else Just cand
- where
- is_modname_char c = isAlphanum c || c == '_'
--}
-\end{code}
-
-*********************************************************
-* *
\subsection{Reading interface files}
* *
*********************************************************
-> Module
-> IO (MaybeErr ParsedIface Error)
-cachedIface want_orig_iface iface_cache mod
+cachedIface want_orig_iface iface_cache modname
= readVar iface_cache `thenPrimIO` \ (iface_fm, orig_fm, file_fm) ->
- case (lookupFM iface_fm mod) of
+ case (lookupFM iface_fm modname) of
Just iface -> return (want_iface iface orig_fm)
Nothing ->
- case (lookupFM file_fm mod) of
- Nothing -> return (Failed (noIfaceErr mod))
+ case (lookupFM file_fm modname) of
+ Nothing -> return (Failed (noIfaceErr modname))
Just file ->
- readIface file mod >>= \ read_iface ->
+ readIface file modname >>= \ read_iface ->
case read_iface of
Failed err -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $
return (Failed err)
Succeeded iface ->
let
- iface_fm' = addToFM iface_fm mod iface
+ iface_fm' = addToFM iface_fm modname iface
orig_fm' = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface
in
writeVar iface_cache (iface_fm', orig_fm', file_fm) `seqPrimIO`
where
want_iface iface orig_fm
| want_orig_iface
- = case lookupFM orig_fm mod of
- Nothing -> Failed (noOrigIfaceErr mod)
+ = case lookupFM orig_fm modname of
+ Nothing -> Failed (noOrigIfaceErr modname)
Just orig_iface -> Succeeded orig_iface
| otherwise
= Succeeded iface
----------
cachedDecl :: IfaceCache
-> Bool -- True <=> tycon or class name
- -> RdrName
+ -> OrigName
-> IO (MaybeErr RdrIfaceDecl Error)
-cachedDecl iface_cache class_or_tycon orig
- = -- pprTrace "cachedDecl:" (ppr PprDebug orig) $
+cachedDecl iface_cache class_or_tycon name@(OrigName mod str)
+ = -- pprTrace "cachedDecl:" (ppr PprDebug name) $
cachedIface True iface_cache mod >>= \ maybe_iface ->
case maybe_iface of
Failed err -> --pprTrace "cachedDecl:fail:" (ppr PprDebug orig) $
case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
Just decl -> return (Succeeded decl)
Nothing -> return (Failed (noDeclInIfaceErr mod str))
- where
- (mod, str) = moduleNamePair orig
----------
cachedDeclByType :: IfaceCache
-- the idea is: check that, e.g., if we're given an
-- RnClass, then we really get back a ClassDecl from
-- the cache (not an RnData, or something silly)
- = cachedDecl iface_cache (isRnTyConOrClass rn) (origName rn) >>= \ maybe_decl ->
+ = cachedDecl iface_cache (isRnTyConOrClass rn) (origName "cachedDeclByType" rn) >>= \ maybe_decl ->
let
return_maybe_decl = return maybe_decl
return_failed msg = return (Failed msg)
\end{code}
\begin{code}
-readIface :: FilePath -> Module
- -> IO (MaybeErr ParsedIface Error)
+readIface :: FilePath -> Module -> IO (MaybeErr ParsedIface Error)
-readIface file mod
+readIface file modname
= hPutStr stderr (" reading "++file) >>
readFile file `thenPrimIO` \ read_result ->
case read_result of
return (
case parsed of
Failed _ -> parsed
- Succeeded p -> Succeeded (init_merge mod p)
+ Succeeded p -> Succeeded (init_merge modname p)
)
where
init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags)
if_errs_warns)
where
decls_and_insts todo def_env occ_env to_return us
- = do_decls todo -- initial batch of names to process
+ = let
+ (us1,us2) = splitUniqSupply us
+ in
+ do_decls todo -- initial batch of names to process
(def_env, occ_env, us1) -- init stuff down
to_return -- acc results
>>= \ (decls_return,
do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM
(add_errs errs decls_return) us2
- where
- (us1,us2) = splitUniqSupply us
+ --------
do_insts def_env occ_env prev_env done_insts to_return us
| size_tc_env occ_env == size_tc_env prev_env
= return (to_return, occ_env)
do_decls ns down to_return
Nothing
- | fst (moduleNamePair n) == modname ->
+ | moduleOf (origName "do_decls" n) == modname ->
-- avoid looking in interface for the module being compiled
--pprTrace "do_decls:this module error:" (ppr PprDebug n) $
do_decls ns down (add_warn (thisModImplicitWarn modname n) to_return)
)
lookup_defd (def_env, _, _) n
- | isRnTyConOrClass n
- = lookupTcRnEnv def_env (origName n)
- | otherwise
- = lookupRnEnv def_env (origName n)
+ = (if isRnTyConOrClass n then lookupTcRnEnv else lookupRnEnv) def_env
+ (case (origName "lookup_defd" n) of { OrigName m s -> Qual m s })
+ -- this is hack because we are reusing the RnEnv technology
defenv (def_env, _, _) = def_env
occenv (_, occ_env, _) = occ_env
(if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
-- ASSERT(isEmptyBag def_dups)
let
- val_occs = val_defds ++ fmToList val_imps
- tc_occs = tc_defds ++ fmToList tc_imps
+ de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ]
+ -- again, this hackery because we are reusing the RnEnv technology
+
+ val_occs = val_defds ++ de_orig val_imps
+ tc_occs = tc_defds ++ de_orig tc_imps
in
case (extendGlobalRnEnv occ_env val_occs tc_occs) of { (new_occ_env, occ_dups) ->
= ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs)
add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
- = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs)
+ = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs)
add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns))
add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv
sub (val_ment, tc_ment) (val_defds, tc_defds)
- = (delListFromFM val_ment (map fst val_defds),
- delListFromFM tc_ment (map fst tc_defds))
+ = (delListFromFM val_ment (map (qualToOrigName . fst) val_defds),
+ delListFromFM tc_ment (map (qualToOrigName . fst) tc_defds))
\end{code}
% ------------------------------
@rnIfaceInstStuff@: Deal with instance declarations from interface files.
\begin{code}
-type InstanceEnv = FiniteMap (RdrName, RdrName) Int
+type InstanceEnv = FiniteMap (OrigName, OrigName) Int
rnIfaceInstStuff
:: IfaceCache -- all about ifaces we've read
case (initRn False{-iface-} modname occ_env us (
setExtraRn emptyUFM{-no fixities-} $
- mapRn rnIfaceInst interesting_insts `thenRn` \ insts ->
- getImplicitUpRn `thenRn` \ implicits ->
+ mapRn (rnIfaceInst modname) interesting_insts `thenRn` \ insts ->
+ getImplicitUpRn `thenRn` \ implicits ->
returnRn (insts, implicits))) of {
((if_insts, if_implicits), if_errs, if_warns) ->
where
get_insts (ParsedIface _ _ _ _ _ _ _ _ _ _ _ insts _) = insts
+ tycon_class clas tycon = (qualToOrigName clas, qualToOrigName tycon)
+
add_done_inst (InstSig clas tycon _ _) inst_env
- = addToFM_C (+) inst_env (tycon,clas) 1
+ = addToFM_C (+) inst_env (tycon_class clas tycon) 1
is_done_inst (InstSig clas tycon _ _)
- = maybeToBool (lookupFM done_inst_env (tycon,clas))
+ = maybeToBool (lookupFM done_inst_env (tycon_class clas tycon))
add_imp_occs (val_imps, tc_imps) occ_env
- = case extendGlobalRnEnv occ_env (fmToList val_imps) (fmToList tc_imps) of
+ = case (extendGlobalRnEnv occ_env (de_orig val_imps) (de_orig tc_imps)) of
(ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups)
ext_occ_env
+ where
+ de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ]
+ -- again, this hackery because we are reusing the RnEnv technology
want_inst i@(InstSig clas tycon _ _)
= -- it's a "good instance" (one to hang onto) if we have a
= case lookupTcRnEnv occ_env nm of
Just _ -> True
Nothing -> -- maybe it's builtin
- let str_mod = case nm of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
- in case (lookupFM b_tc_names str_mod) of
- Just _ -> True
- Nothing -> maybeToBool (lookupFM b_keys str_mod)
+ let orig = qualToOrigName nm in
+ case (lookupFM b_tc_names orig) of
+ Just _ -> True
+ Nothing -> maybeToBool (lookupFM b_keys orig)
(b_tc_names, b_keys) -- pretty UGLY ...
= case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys)
-
+{-
ppr_insts insts
= ppAboves (map ppr_inst insts)
where
ppr_inst (InstSig c t _ inst_decl)
= ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl]
+-}
\end{code}
\begin{code}
-rnIfaceInst :: RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl
+rnIfaceInst :: Module -> RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl
-rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl
+rnIfaceInst mod (InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl mod)
\end{code}
\begin{code}
irrelevant (RnConstr _ _) = True -- We don't report these in their
irrelevant (RnField _ _) = True -- own right in usages/etc.
irrelevant (RnClassOp _ _) = True
- irrelevant (RnImplicit n) = isRdrLexCon (origName n) -- really a RnConstr
+ irrelevant (RnImplicit n) = isLexCon (nameOf (origName "irrelevant" n)) -- really a RnConstr
irrelevant _ = False
\end{code}
\begin{code}
thisModImplicitWarn mod n sty
- = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppPStr mod, ppChar '.', ppr sty n, ppPStr SLIT("; assuming this module will provide it.")]
+ = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppr sty n, ppPStr SLIT("; assuming this module will provide it.")]
noIfaceErr mod sty
= ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]
import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, fmToList{-ToDo:rm-} )
import Maybes ( assocMaybe )
import Name ( Module(..), RdrName(..), isQual,
- Name, mkLocalName, mkImplicitName,
+ OrigName(..), Name, mkLocalName, mkImplicitName,
getOccName, pprNonSym
)
import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
-- Renaming interface; creating and returning implicit names
-- ImplicitEnv: one map for Values and one for TyCons/Classes.
-type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
+type ImplicitEnv = (FiniteMap OrigName RnName, FiniteMap OrigName RnName)
emptyImplicitEnv :: ImplicitEnv
emptyImplicitEnv = (emptyFM, emptyFM)
lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
= case lookup env rdr of
- Just name -> returnSST name
- Nothing -> lookup_nonexisting_val b_names b_key imp_var us_var rdr
-
-lookup_nonexisting_val (b_names,_) b_key imp_var us_var rdr
- = let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
- in case (lookupFM b_names str_mod) of
- Nothing -> lookup_or_create_implicit_val b_key imp_var us_var rdr
- Just xx -> returnSST xx
+ Just name -> returnSST name
+ Nothing -> case rdr of
+ Unqual n -> panic ("lookup_val:"++ _UNPK_ n)
+ Qual m n ->
+ lookup_nonexisting_val b_names b_key imp_var us_var (OrigName m n)
+
+lookup_nonexisting_val (b_names,_) b_key imp_var us_var orig
+ = case (lookupFM b_names orig) of
+ Just xx -> returnSST xx
+ Nothing -> lookup_or_create_implicit_val b_key imp_var us_var orig
-lookup_or_create_implicit_val b_key imp_var us_var rdr
+lookup_or_create_implicit_val b_key imp_var us_var orig
= readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
- case lookupFM implicit_val_fm rdr of
+ case (lookupFM implicit_val_fm orig) of
Just implicit -> returnSST implicit
Nothing ->
- (let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
- in case (lookupFM b_key str_mod) of
+ (case (lookupFM b_key orig) of
Just (u,_) -> returnSST u
_ -> get_unique us_var
) `thenSST` \ uniq ->
let
- implicit = mkRnImplicit (mkImplicitName uniq rdr)
- new_val_fm = addToFM implicit_val_fm rdr implicit
+ implicit = mkRnImplicit (mkImplicitName uniq orig)
+ new_val_fm = addToFM implicit_val_fm orig implicit
in
writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
returnSST implicit
returnSST name
fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
-lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
+lookup_tc rdr@(Qual m n) check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
= case lookupTcRnEnv env rdr of
Just name | check name -> returnSST name
| otherwise -> fail
- Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var rdr
+ Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var (OrigName m n)
where
fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
-lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr
- = let
- str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
- in
- --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $
- case (lookupFM b_names str_mod) of
- Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
+lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var orig--@(OrigName m n)
+ = --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $
+ case (lookupFM b_names orig) of
Just xx -> returnSST xx
+ Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
-lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
+lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
= readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
- case lookupFM implicit_tc_fm rdr of
+ case (lookupFM implicit_tc_fm orig) of
Just implicit | check implicit -> returnSST implicit
| otherwise -> fail
Nothing ->
- (let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
- in case (lookupFM b_key str_mod) of
+ (case (lookupFM b_key orig) of
Just (u,_) -> returnSST u
_ -> get_unique us_var
) `thenSST` \ uniq ->
let
- implicit = mk_implicit (mkImplicitName uniq rdr)
- new_tc_fm = addToFM implicit_tc_fm rdr implicit
+ implicit = mk_implicit (mkImplicitName uniq orig)
+ new_tc_fm = addToFM implicit_tc_fm orig implicit
in
writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_`
returnSST implicit
import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv,
lubExportFlag, qualNameErr, dupNamesErr
)
-import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst )
+import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst )
import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
unionManyBags, mapBag, filterBag, listToBag, bagToList )
import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingPrelude )
import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine, addShortWarnLocLine )
-import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} )
+import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} )
import Id ( GenId )
import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
-import Name ( RdrName(..), Name, isQual, mkTopLevName, origName,
- mkImportedName, nameExportFlag, nameImportFlag,
- getLocalName, getSrcLoc, getImpLocs, moduleNamePair,
- pprNonSym, isLexCon, isRdrLexCon, ExportFlag(..)
+import Name ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName,
+ nameOf, qualToOrigName, mkImportedName,
+ nameExportFlag, nameImportFlag,
+ getLocalName, getSrcLoc, getImpLocs,
+ moduleNamePair, pprNonSym,
+ isLexCon, ExportFlag(..), OrigName(..)
)
import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) )
-import PrelMods ( fromPrelude, pRELUDE_BUILTIN, pRELUDE, rATIO, iX )
+import PrelMods ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins )
import Pretty
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import TyCon ( tyConDataCons )
import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM )
import UniqSupply ( splitUniqSupply )
import Util ( isIn, assoc, cmpPString, sortLt, removeDups,
- equivClasses, panic, assertPanic, pprTrace{-ToDo:rm-}
+ equivClasses, panic, assertPanic, pprPanic{-ToDo:rm-}, pprTrace{-ToDo:rm-}
)
+import PprStyle --ToDo:rm
\end{code}
-
\begin{code}
type GlobalNameInfo = (BuiltinNames,
BuiltinKeys,
Name -> ExportFlag, -- export flag
- Name -> [RdrName]) -- occurence names
+ Name -> [RdrName]) -- occurrence names
+ -- NB: both of the functions are in a *knot* and
+ -- must be tugged on oh-so-gently...
type RnM_Info s r = RnMonad GlobalNameInfo s r
getGlobalNames iface_cache info us
(HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _)
- = case initRn True mod emptyRnEnv us1
+ = let
+ (us1, us2) = splitUniqSupply us
+ in
+ case initRn True mod emptyRnEnv us1
(setExtraRn info $
getSourceNames ty_decls cls_decls binds)
of { ((src_vals, src_tcs), src_errs, src_warns) ->
-- remove dups of the same imported thing
diff_imp_dups = filterBag diff_orig imp_dups
- diff_orig (_,rn1,rn2) = origName rn1 /= origName rn2
+ diff_orig (_,rn1,rn2) = origName "diff_orig" rn1 /= origName "diff_orig" rn2
all_dups = bagToList (src_dups `unionBags` diff_imp_dups)
dup_errs = map dup_err (equivClasses cmp_rdr all_dups)
all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
all_warns = src_warns `unionBags` imp_warns
in
- return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns)
- }
- where
- (us1, us2) = splitUniqSupply us
+ return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) }
\end{code}
*********************************************************
unionManyBags cls_ops_s `unionBags` bind_names,
listToBag tycon_s `unionBags` listToBag cls_s)
-
+--------------
getTyDeclNames :: RdrNameTyDecl
-> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields
getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
- = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
+ = --getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
+ --pprTrace "getTyDeclNames:" (ppr PprDebug tycon) $
+ --pprTrace "getTDN1:" (ppAboves [ ppCat [ppPStr m, ppPStr n] | ((OrigName m n), _) <- fmToList b_tc_names]) $
+
+ newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM
condecls `thenRn` \ (con_names, field_names) ->
let
= newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
returnRn (RnSyn tycon_name, emptyBag, emptyBag)
+----------------
+getConFieldNames :: Maybe ExportFlag
+ -> Bag Name -> Bag Name
+ -> FiniteMap RdrName ()
+ -> [RdrNameConDecl]
+ -> RnM_Info s ([Name], [Name])
getConFieldNames exp constrs fields have []
= returnRn (bagToList constrs, bagToList fields)
new_fields = filter (not . maybeToBool . lookupFM have) uniq_fields
new_have = addListToFM have (zip new_fields (repeat ()))
+-------------
getClassNames :: RdrNameClassDecl
-> RnM_Info s (RnName, Bag RnName) -- class and class ops
returnRn (RnClass class_name op_names,
listToBag (map (\ n -> RnClassOp n class_name) op_names))
-getClassOpNames exp []
- = returnRn []
+---------------
+getClassOpNames :: Maybe ExportFlag
+ -> [RdrNameSig]
+ -> RnM_Info s [Name]
+
+getClassOpNames exp [] = returnRn []
+
getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
= newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name ->
getClassOpNames exp sigs `thenRn` \ op_names ->
*********************************************************
\begin{code}
-newGlobalName :: SrcLoc -> Maybe ExportFlag -> Bool{-True<=>value name,False<=>tycon/class-}
- -> RdrName -> RnM_Info s Name
+newGlobalName :: SrcLoc
+ -> Maybe ExportFlag
+ -> Bool{-True<=>value name,False<=>tycon/class-}
+ -> RdrName
+ -> RnM_Info s Name
+
+newGlobalName locn maybe_exp is_val_name (Unqual name)
+ = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
+ getModuleRn `thenRn` \ mod ->
+ rnGetUnique `thenRn` \ u ->
+ let
+ orig = OrigName mod name
+
+ (uniq, is_toplev)
+ = case (lookupFM b_keys orig) of
+ Just (key,_) -> (key, True)
+ Nothing -> if not opt_CompilingPrelude then (u,True) else -- really here just to save gratuitous lookup
+ case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
+ Nothing -> (u, True)
+ Just xx -> (uniqueOf xx, False{-builtin!-})
--- ToDo: b_names and b_keys being defined in this module !!!
+ exp = case maybe_exp of
+ Just flag -> flag
+ Nothing -> rec_exp_fn n
-newGlobalName locn maybe_exp is_val_name rdr
- = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,exp_fn,occ_fn) ->
- getModuleRn `thenRn` \ mod ->
- rnGetUnique `thenRn` \ u ->
+ n = if is_toplev
+ then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
+ else mkWiredInName uniq orig
+ in
+ returnRn n
+
+newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name)
+ | opt_CompilingPrelude
+ -- we are actually defining something that compiler knows about (e.g., Bool)
+
+ = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
let
- unqual = case rdr of { Qual m n -> n; Unqual n -> n }
-
- orig = if fromPrelude mod
- then (Unqual unqual)
- else (Qual mod unqual)
-
- uniq
- = let
- str_mod = case orig of { Qual m n -> (n, m); Unqual n -> (n, pRELUDE) }
- n = fst str_mod
- m = snd str_mod
- in
- --pprTrace "newGlobalName:" (ppAboves ((ppCat [ppPStr n, ppPStr m]) : [ ppCat [ppPStr x, ppPStr y] | (x,y) <- keysFM b_keys])) $
- case (lookupFM b_keys str_mod) of
- Just (key,_) -> key
- Nothing -> if not opt_CompilingPrelude then u else
- case (lookupFM (if is_val_name then b_val_names else b_tc_names) str_mod) of
- Nothing -> u
- Just xx -> --pprTrace "Using Unique for:" (ppCat [ppPStr n, ppPStr m]) $
- uniqueOf xx
+ orig = OrigName mod name
+
+ (uniq, is_toplev)
+ = case (lookupFM b_keys orig) of
+ Just (key,_) -> (key, True)
+ Nothing -> case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
+ Nothing -> (pprPanic "newGlobalName:Qual:uniq:" (ppr PprDebug rdr), True)
+ Just xx -> (uniqueOf xx, False{-builtin!-})
exp = case maybe_exp of
- Just exp -> exp
- Nothing -> exp_fn n
+ Just flag -> flag
+ Nothing -> rec_exp_fn n
- n = mkTopLevName uniq orig locn exp (occ_fn n) -- NB: two "n"s
+ n = if is_toplev
+ then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
+ else mkWiredInName uniq orig
in
- addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
returnRn n
+
+ | otherwise
+ = addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
+ returnRn (pprPanic "newGlobalName:Qual:" (ppr PprDebug rdr))
\end{code}
*********************************************************
*********************************************************
\begin{code}
-type ImportNameInfo = (GlobalNameInfo,
- FiniteMap (Module,FAST_STRING) RnName, -- values imported so far
- FiniteMap (Module,FAST_STRING) RnName, -- tycons/classes imported so far
- Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns
-
+type ImportNameInfo
+ = (GlobalNameInfo,
+ FiniteMap OrigName RnName, -- values imported so far
+ FiniteMap OrigName RnName, -- tycons/classes imported so far
+ Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns;
+ -- NB: this last field is in a knot
+ -- and mustn't be tugged on!
+
type RnM_IInfo s r = RnMonad ImportNameInfo s r
+------------------------------------------------------------------
doImportDecls ::
IfaceCache
- -> GlobalNameInfo -- builtin and knot name info
+ -> GlobalNameInfo -- builtin and knot name info
-> UniqSupply
- -> [RdrNameImportDecl] -- import declarations
- -> IO (Bag (RdrName,RnName), -- imported values in scope
- Bag (RdrName,RnName), -- imported tycons/classes in scope
- [Module], -- directly imported modules
- Bag (Module,RnName), -- unqualified import from module
- Bag RenamedFixityDecl, -- fixity info for imported names
+ -> [RdrNameImportDecl] -- import declarations
+ -> IO (Bag (RdrName,RnName), -- imported values in scope
+ Bag (RdrName,RnName), -- imported tycons/classes in scope
+ [Module], -- directly imported modules
+ Bag (Module,RnName), -- unqualified import from module
+ Bag RenamedFixityDecl, -- fixity info for imported names
Bag Error,
Bag Warning)
imp_errs `unionBags` errs,
imp_warns `unionBags` warns)
where
- the_imps = implicit_prel ++ src_imps
+ the_imps = implicit_prel ++ src_imps
all_imps = implicit_qprel ++ the_imps
- implicit_qprel = if opt_NoImplicitPrelude
- then [{- no "import qualified Prelude" -}
- ImportDecl pRELUDE_BUILTIN True Nothing Nothing prel_loc
- ]
- else [ImportDecl pRELUDE True Nothing Nothing prel_loc]
+ implicit_qprel = ImportDecl gHC_BUILTINS True Nothing Nothing prel_loc
+ : (if opt_NoImplicitPrelude
+ then [{- no "import qualified Prelude" -}]
+ else [ImportDecl pRELUDE True Nothing Nothing prel_loc])
explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps,
mod == pRELUDE ])
- implicit_prel = if explicit_prelude_imp || opt_NoImplicitPrelude
- then [{- no "import Prelude" -}
- ImportDecl pRELUDE_BUILTIN False Nothing Nothing prel_loc
- ]
- else [ImportDecl pRELUDE False Nothing Nothing prel_loc]
+ implicit_prel = ImportDecl gHC_BUILTINS False Nothing Nothing prel_loc
+ : (if explicit_prelude_imp || opt_NoImplicitPrelude
+ then [{- no "import Prelude" -}]
+ else [ImportDecl pRELUDE False Nothing Nothing prel_loc])
prel_loc = mkBuiltinSrcLoc
cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps,
- fromPrelude mod ]
+ mod == pRELUDE ]
qual_mods = [ (qual_name mod as_mod, imp) | imp@(ImportDecl mod True as_mod _ _) <- src_imps ]
qual_name mod (Just as_mod) = as_mod
all_same_mod ((q,ImportDecl mod _ _ _ _):rest)
= all has_same_mod rest
where
- has_same_mod (q,ImportDecl mod2 _ _ _ _) = mod == mod2
-
+ has_same_mod (_,ImportDecl mod2 _ _ _ _) = mod == mod2
- imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps, mod /= pRELUDE_BUILTIN ]
+ imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps, mod /= gHC_BUILTINS ]
imp_warns = listToBag (map dupImportWarn imp_dups)
`unionBags`
imp_errs = listToBag (map dupQualImportErr bad_qual_dups)
+-----------------------
+doImports :: IfaceCache
+ -> ImportNameInfo
+ -> UniqSupply
+ -> [RdrNameImportDecl] -- import declarations
+ -> IO (Bag (RdrName,RnName), -- imported values in scope
+ Bag (RdrName,RnName), -- imported tycons/classes in scope
+ Bag (Module, RnName), -- unqualified import from module
+ Bag RenamedFixityDecl, -- fixity info for imported names
+ Bag Error,
+ Bag Warning,
+ Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
+
doImports iface_cache i_info us []
= return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
-doImports iface_cache i_info@(g_info,done_vals,done_tcs,imp_fn) us (imp:imps)
- = doImport iface_cache i_info us1 imp
+
+doImports iface_cache i_info@(g_info,done_vals,done_tcs,rec_imp_fn) us (imp:imps)
+ = let
+ (us1, us2) = splitUniqSupply us
+ in
+ doImport iface_cache i_info us1 imp
>>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) ->
let
- new_vals = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList vals1,
- not (maybeToBool (lookupFM done_vals (moduleNamePair rn))) ]
- -- moduleNamePair computed twice
- ext_vals = addListToFM done_vals new_vals
-
- new_tcs = [ (moduleNamePair rn, rn) | (_,rn) <- bagToList tcs1,
- not (maybeToBool (lookupFM done_tcs (moduleNamePair rn))) ]
- ext_tcs = addListToFM done_tcs new_tcs
+ ext_vals = foldl add_new_one done_vals (bagToList vals1)
+ ext_tcs = foldl add_new_one done_tcs (bagToList tcs1)
in
- doImports iface_cache (g_info,ext_vals,ext_tcs,imp_fn) us2 imps
+ doImports iface_cache (g_info,ext_vals,ext_tcs,rec_imp_fn) us2 imps
>>= \ (vals2, tcs2, unquals2, fixes2, errs2, warns2, imps2) ->
return (vals1 `unionBags` vals2,
tcs1 `unionBags` tcs2,
warns1 `unionBags` warns2,
imps1 `unionBags` imps2)
where
- (us1, us2) = splitUniqSupply us
+ add_new_one :: FiniteMap OrigName RnName -- ones done so far
+ -> (dont_care, RnName)
+ -> FiniteMap OrigName RnName -- extended
+ add_new_one fm (_, rn)
+ = let
+ orig = origName "add_new_one" rn
+ in
+ case (lookupFM fm orig) of
+ Just _ -> fm -- already there: no change
+ Nothing -> addToFM fm orig rn
+----------------------
doImport :: IfaceCache
-> ImportNameInfo
-> UniqSupply
= let
(b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec
in
- (if mod == pRELUDE_BUILTIN then
- return (Succeeded (panic "doImport:PreludeBuiltin"),
- \ iface -> ([], [], emptyBag))
+ (if mod == gHC_BUILTINS then
+ return (Succeeded (panic "doImport:GHC fake import!"),
+ \ iface -> ([], [], emptyBag))
else
--pprTrace "doImport:" (ppPStr mod) $
cachedIface False iface_cache mod >>= \ maybe_iface ->
final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs
final_vals_list = bagToList final_vals
in
- (if mod == pRELUDE_BUILTIN then
+ (if mod == gHC_BUILTINS then
return [ (Nothing, emptyBag) | _ <- final_vals_list ]
else
- accumulate (map (getFixityDecl iface_cache) final_vals_list)
+ accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
) >>= \ fix_maybes_errs ->
let
(chk_errs, chk_warns) = unzip chk_errs_warns
(fix_maybes, fix_errs) = unzip fix_maybes_errs
- unquals = if qual then emptyBag
+ unquals = if qual{-ified import-}
+ then emptyBag
else mapBag pair_as (ie_vals `unionBags` ie_tcs)
final_fixes = listToBag (catMaybes fix_maybes)
return (final_vals, final_tcs, unquals, final_fixes,
final_errs, final_warns, imp_stuff)
where
+ as_mod :: Module
as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this}
+
+ mk_occ :: FAST_STRING -> RdrName
mk_occ str = if qual then Qual as_mod str else Unqual str
+ fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName)
fst_occ (str, rn) = (mk_occ str, rn)
- pair_occ rn = (mk_occ (getLocalName rn), rn)
- pair_as rn = (as_mod, rn)
+ pair_occ :: RnName -> (RdrName, RnName)
+ pair_occ rn = (mk_occ (getLocalName rn), rn)
+
+ pair_as :: RnName -> (Module, RnName)
+ pair_as rn = (as_mod, rn)
-getBuiltins _ mod maybe_spec
- | not (fromPrelude mod || mod == iX || mod == rATIO)
+-----------------------------
+getBuiltins :: ImportNameInfo
+ -> Module
+ -> Maybe (Bool, [RdrNameIE])
+ -> (Bag (FAST_STRING, RnName),
+ Bag (FAST_STRING, RnName),
+ Maybe (Bool, [RdrNameIE]) -- return IEs that had no effect
+ )
+
+getBuiltins _ modname maybe_spec
+ | modname `notElem` modulesWithBuiltins
= (emptyBag, emptyBag, maybe_spec)
-getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec
+getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
= case maybe_spec of
Nothing -> (all_vals, all_tcs, Nothing)
Just (True, ies) -> -- hiding does not work for builtin names
- trace "getBuiltins: import Prelude hiding ( ... )" $
+ trace "NOTE: `import Prelude hiding ...' does not hide built-in names" $
(all_vals, all_tcs, maybe_spec)
Just (False, ies) -> let
all_vals = do_all_builtin (fmToList b_val_names)
all_tcs = do_all_builtin (fmToList b_tc_names)
- filter_mod = if fromPrelude mod then pRELUDE else mod
-
do_all_builtin [] = emptyBag
- do_all_builtin (((str,mod),rn):rest)
- | mod == filter_mod
- = (str, rn) `consBag` do_all_builtin rest
- | otherwise
- = do_all_builtin rest
+ do_all_builtin (((OrigName mod str),rn):rest)
+ = --pprTrace "do_all_builtin:" (ppCat [ppPStr modname, ppPStr mod, ppPStr str]) $
+ (if mod == modname then consBag (str, rn) else id) (do_all_builtin rest)
do_builtin [] = (emptyBag,emptyBag,[])
do_builtin (ie:ies)
- = let str = unqual_str (ie_name ie)
+ = let
+ (str, orig)
+ = case (ie_name ie) of
+ Unqual s -> (s, OrigName modname s)
+ Qual m s -> pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $
+ (s, OrigName modname s)
in
- case (lookupFM b_tc_names (str,mod)) of -- NB: we favour the tycon/class FM...
+ case (lookupFM b_tc_names orig) of -- NB: we favour the tycon/class FM...
Just rn -> case (ie,rn) of
(IEThingAbs _, WiredInTyCon tc)
-> (vals, (str, rn) `consBag` tcs, ies_left)
`unionBags` vals,
(str,rn) `consBag` tcs, ies_left)
(IEThingWith _ _, WiredInTyCon tc) -- No checking of With...
- -> (listToBag (map (\ id -> (getLocalName id, WiredInId id))
+ -> (listToBag (map (\ id -> (nameOf (origName "IEThingWith" id), WiredInId id))
(tyConDataCons tc))
`unionBags` vals,
(str,rn) `consBag` tcs, ies_left)
_ -> panic "importing builtin names (1)"
Nothing ->
- case (lookupFM b_val_names (str,mod)) of
+ case (lookupFM b_val_names orig) of
Nothing -> (vals, tcs, ie:ies_left)
Just rn -> case (ie,rn) of
(IEVar _, WiredInId _)
where
(vals, tcs, ies_left) = do_builtin ies
+-------------------------
+getOrigIEs :: ParsedIface
+ -> Maybe (Bool, [RdrNameIE]) -- "hiding" or not, blah, blah, blah
+ -> ([IE OrigName],
+ [(IE OrigName, ExportFlag)],
+ Bag (Module -> SrcLoc -> Error))
getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
= (map mkAllIE (eltsFM exps), [], emptyBag)
where
(found_ies, errs) = lookupIEs exps ies
+------------------------------------------------
+mkAllIE :: (OrigName, ExportFlag) -> IE OrigName
mkAllIE (orig,ExportAbs)
- = ASSERT(isLexCon (getLocalName orig))
+ = ASSERT(isLexCon (nameOf orig))
IEThingAbs orig
mkAllIE (orig, ExportAll)
- | isLexCon (getLocalName orig)
+ | isLexCon (nameOf orig)
= IEThingAll orig
| otherwise
= IEVar orig
+------------
+lookupIEs :: ExportsMap
+ -> [RdrNameIE]
+ -> ([(IE OrigName, ExportFlag)], -- IEs we found, orig-ified
+ Bag (Module -> SrcLoc -> Error))
-lookupIEs exps []
- = ([], emptyBag)
-lookupIEs exps (ie:ies)
- = case lookupFM exps (unqual_str (ie_name ie)) of
- Nothing ->
- (orig_ies, unknownImpSpecErr ie `consBag` errs)
- Just (orig,flag) ->
- (orig_ie orig flag ie ++ orig_ies,
- adderr_if (seen_ie orig orig_ies) (duplicateImpSpecErr ie) errs)
+lookupIEs exps ies
+ = foldr go ([], emptyBag) ies
where
- (orig_ies, errs) = lookupIEs exps ies
-
- orig_ie orig flag (IEVar n) = [(IEVar orig, flag)]
- orig_ie orig flag (IEThingAbs n) = [(IEThingAbs orig, flag)]
- orig_ie orig flag (IEThingAll n) = [(IEThingAll orig, flag)]
- orig_ie orig flag (IEThingWith n ns) = [(IEThingWith orig ns, flag)]
+ go ie (already, errs)
+ = let
+ str = case (ie_name ie) of
+ Unqual s -> s
+ Qual m s -> s
+ in
+ case (lookupFM exps str) of
+ Nothing ->
+ (already, unknownImpSpecErr ie `consBag` errs)
+ Just (orig, flag) ->
+ ((orig_ie orig ie, flag) : already,
+ adderr_if (seen_ie orig already) (duplicateImpSpecErr ie) errs)
+
+ orig_ie orig (IEVar n) = IEVar orig
+ orig_ie orig (IEThingAbs n) = IEThingAbs orig
+ orig_ie orig (IEThingAll n) = IEThingAll orig
+ orig_ie orig (IEThingWith n ns) = IEThingWith orig (map re_orig ns)
+ where
+ (OrigName mod _) = orig
+ re_orig (Unqual s) = OrigName mod s
seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies
-
+--------------------------------------------
doOrigIEs iface_cache info mod src_loc us []
= return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag)
doOrigIEs iface_cache info mod src_loc us (ie:ies)
- = doOrigIE iface_cache info mod src_loc us1 ie
+ = let
+ (us1, us2) = splitUniqSupply us
+ in
+ doOrigIE iface_cache info mod src_loc us1 ie
>>= \ (vals1, tcs1, imps1, errs1, warns1) ->
doOrigIEs iface_cache info mod src_loc us2 ies
>>= \ (vals2, tcs2, imps2, errs2, warns2) ->
imps1 `unionBags` imps2,
errs1 `unionBags` errs2,
warns1 `unionBags` warns2)
- where
- (us1, us2) = splitUniqSupply us
+
+----------------------
+doOrigIE :: IfaceCache
+ -> ImportNameInfo
+ -> Module
+ -> SrcLoc
+ -> UniqSupply
+ -> IE OrigName
+ -> IO (Bag RnName, -- values
+ Bag RnName, -- tycons/classes
+ Bag (RnName,ExportFlag), -- import flags
+ Bag Error,
+ Bag Warning)
doOrigIE iface_cache info mod src_loc us ie
= with_decl iface_cache (ie_name ie)
of
((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns))
+-------------------------
+checkOrigIE :: IfaceCache
+ -> (IE OrigName, ExportFlag)
+ -> IO (Bag (Module -> SrcLoc -> Error), Bag (Module -> SrcLoc -> Warning))
+
checkOrigIE iface_cache (IEThingAll n, ExportAbs)
= with_decl iface_cache n
(\ err -> (unitBag (\ mod locn -> err), emptyBag))
DataSig _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag)
ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag))
where
- check_with str has rdrs
- | sortLt (<) (map getLocalName has) == sortLt (<) (map unqual_str rdrs)
+ check_with str has origs
+ | sortLt (<) (map getLocalName has) == sortLt (<) (map nameOf origs)
= emptyBag
| otherwise
- = unitBag (withImpSpecErr str n has rdrs)
+ = unitBag (withImpSpecErr str n has origs)
checkOrigIE iface_cache other
= return (emptyBag, emptyBag)
+-----------------------
+with_decl :: IfaceCache
+ -> OrigName
+ -> (Error -> something) -- if an error...
+ -> (RdrIfaceDecl -> something) -- if OK...
+ -> IO something
with_decl iface_cache n do_err do_decl
- = cachedDecl iface_cache (isRdrLexCon n) n >>= \ maybe_decl ->
+ = cachedDecl iface_cache (isLexCon (nameOf n)) n >>= \ maybe_decl ->
case maybe_decl of
- Failed err -> return (do_err err)
+ Failed err -> return (do_err err)
Succeeded decl -> return (do_decl decl)
+-------------
+getFixityDecl :: IfaceCache
+ -> RnName
+ -> IO (Maybe RenamedFixityDecl, Bag Error)
-getFixityDecl iface_cache (_,rn)
+getFixityDecl iface_cache rn
= let
- (mod, str) = moduleNamePair rn
+ (OrigName mod str) = origName "getFixityDecl" rn
succeeded infx i = return (Just (infx rn i), emptyBag)
in
ie_name (IEThingAll n) = n
ie_name (IEThingWith n _) = n
-unqual_str (Unqual str) = str
-unqual_str q@(Qual _ _) = panic "unqual_str"
-
-adderr_if True err errs = err `consBag` errs
+adderr_if True err errs = err `consBag` errs
adderr_if False err errs = errs
\end{code}
*********************************************************
\begin{code}
-getIfaceDeclNames :: RdrNameIE -> RdrIfaceDecl
+getIfaceDeclNames :: IE OrigName -> RdrIfaceDecl
-> RnM_IInfo s (Bag RnName, -- values
Bag RnName, -- tycons/classes
Bag (RnName,ExportFlag)) -- import flags
-> RnM_IInfo s Name
newImportedName tycon_or_class locn maybe_exp maybe_imp rdr
- = getExtraRn `thenRn` \ ((_,b_keys,exp_fn,occ_fn),done_vals,done_tcs,imp_fn) ->
- case if tycon_or_class
- then lookupFM done_tcs (moduleNamePair rdr)
- else lookupFM done_vals (moduleNamePair rdr)
- of
- Just rn -> returnRn (getName rn)
- Nothing ->
+ = let
+ orig = qualToOrigName rdr
+ in
+ getExtraRn `thenRn` \ ((_,b_keys,rec_exp_fn,rec_occ_fn),done_vals,done_tcs,rec_imp_fn) ->
+ case ((if tycon_or_class
+ then lookupFM done_tcs
+ else lookupFM done_vals) orig) of
+
+ Just rn -> returnRn (getName rn)
+ Nothing ->
rnGetUnique `thenRn` \ u ->
let
- str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n,pRELUDE) }
-
- uniq = case lookupFM b_keys str_mod of
+ uniq = case lookupFM b_keys orig of
Nothing -> u
Just (key,_) -> key
exp = case maybe_exp of
- Just exp -> exp
- Nothing -> exp_fn n
+ Just xx -> xx
+ Nothing -> rec_exp_fn n
imp = case maybe_imp of
- Just imp -> imp
- Nothing -> imp_flag
+ Just xx -> xx
+ Nothing -> imp_flag
- (imp_flag, imp_locs) = imp_fn n
+ (imp_flag, imp_locs) = rec_imp_fn n
- n = mkImportedName uniq rdr imp locn imp_locs exp (occ_fn n) -- NB: two "n"s
+ n = mkImportedName uniq orig imp locn imp_locs exp (rec_occ_fn n) -- NB: two "n"s
in
returnRn n
\end{code}
import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
import Class ( derivableClassKeys )
+import CmdLineOpts ( opt_CompilingPrelude )
import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
import FiniteMap ( emptyFM, lookupFM, addListToFM_C )
import ListSetOps ( unionLists, minusList )
import Maybes ( maybeToBool, catMaybes )
-import Name ( Name, isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
- nameImportFlag, RdrName, pprNonSym )
+import Name ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
+ nameImportFlag, RdrName, pprNonSym, Name )
import Outputable -- ToDo:rm
import PprStyle -- ToDo:rm
import Pretty
rn_fixity_pieces mk_fixity name i fix
= getRnEnv `thenRn` \ env ->
case lookupGlobalRnEnv env name of
- Just res | isLocallyDefined res
+ Just res | isLocallyDefined res || opt_CompilingPrelude
+ -- the opt_CompilingPrelude thing is a *HACK* to get (:)'s
+ -- fixity decl to go through. It has a builtin name, which
+ -- doesn't respond to isLocallyDefined... sigh.
-> returnRn (Just (mk_fixity res i))
_ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
in
IMP_Ubiq(){-uitous-}
import Bag ( Bag, emptyBag, snocBag, unionBags )
+import CmdLineOpts ( opt_CompilingPrelude )
import ErrUtils ( addShortErrLocLine )
import FiniteMap ( FiniteMap, emptyFM, isEmptyFM,
lookupFM, addListToFM, addToFM )
* *
*********************************************************
-Seperate FiniteMaps are kept for lookup up Qual names,
+Separate FiniteMaps are kept for lookup up Qual names,
Unqual names and Local names.
\begin{code}
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
+ Qual mod str -> lookup qual (str,mod)
+ (if not opt_CompilingPrelude -- see below
+ then Nothing
+ else lookup unqual str Nothing)
where
lookup fm thing do_on_fail
= case lookupFM fm thing of
lookupGlobalRnEnv ((qual, unqual, _, _), _) rdr
= case rdr of
Unqual str -> lookupFM unqual str
- Qual mod str -> lookupFM qual (str,mod)
+ Qual mod str -> case (lookupFM qual (str,mod)) of
+ Just xx -> Just xx
+ Nothing -> if not opt_CompilingPrelude then
+ Nothing
+ else -- "[]" may have turned into "Prelude.[]" and
+ -- we are actually compiling "data [] a = ...";
+ -- maybe the right thing is to get "Prelude.[]"
+ -- into the "qual" table...
+ lookupFM unqual str
lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr
= case rdr of
Unqual str -> lookupFM tc_unqual str
- Qual mod str -> lookupFM tc_qual (str,mod)
+ Qual mod str -> case (lookupFM tc_qual (str,mod)) of -- as above
+ Just xx -> Just xx
+ Nothing -> if not opt_CompilingPrelude then
+ Nothing
+ else
+ lookupFM tc_unqual str
\end{code}
*********************************************************
-- right function to use ..
-- Now the bodies
- c_id = mkSysLocal SLIT("_fbww") c_new_uq c_ty mkUnknownSrcLoc
- n_id = mkSysLocal SLIT("_fbww") n_new_uq n_ty mkUnknownSrcLoc
+ c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty mkUnknownSrcLoc
+ n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty mkUnknownSrcLoc
worker_rhs
= mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body
) where
IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(IdLoop) -- paranoia
import BinderInfo
import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
import SimplMonad
import SimplUtils ( mkValLamTryingEta )
import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTys, eqTy )
-import TysWiredIn ( voidTy )
+import TysPrim ( voidTy )
import Unique ( Unique{-instance Eq-} )
import Usage ( GenUsage{-instance Eq-} )
import Util ( isIn, isSingleton, zipEqual, panic, assertPanic )
GenId {-instance NamedThing -}
)
import Maybes ( maybeToBool, catMaybes, firstJust )
-import Name ( isLexVarSym, isLexSpecialSym, pprNonSym, moduleNamePair )
+import Name ( origName, isLexVarSym, isLexSpecialSym, pprNonSym )
import PprStyle ( PprStyle(..) )
import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
TyCon{-ditto-}, GenType{-ditto-}, GenTyVar
)
-import PrelMods ( fromPrelude, pRELUDE )
import Pretty -- plenty of it
import TyCon ( tyConTyVars, TyCon{-instance NamedThing-} )
import Type ( splitSigmaTy, mkTyVarTy, mkForAllTys,
| isDictFunId id || maybeToBool (isConstMethodId_maybe id)
= let get_mod = getInstIdModule id
- use_mod = if fromPrelude get_mod
- then pRELUDE
- else get_mod
+ use_mod = get_mod
in (use_mod, _NIL_)
| otherwise
- = moduleNamePair id
+ = case (origName "get_id_name" id) of { OrigName m n -> (m, n) }
get_ty_data (ty, tys)
= (mod_name, [(ty_name, ty, tys)])
where
- (mod_name,ty_name) = moduleNamePair ty
+ (OrigName mod_name ty_name) = origName "get_ty_data" ty
module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
mods = map head (equivClasses _CMP_STRING_ module_names)
EQ_ -> ([_NIL_], tail mods)
other -> ([], mods)
- (prels, others) = partition fromPrelude known
- use_modules = unks ++ prels ++ others
+ use_modules = unks ++ known
pp_module_specs :: FAST_STRING -> Pretty
pp_module_specs mod
| is_const_method_id
= let
Just (cls, clsty, clsop) = const_method_maybe
- (_, cls_str) = moduleNamePair cls
+ (OrigName _ cls_str) = origName "pp_idspec" cls
clsop_str = classOpString clsop
in
ppCat [pp_mod,
| is_default_method_id
= let
Just (cls, clsop, _) = default_method_maybe
- (_, cls_str) = moduleNamePair cls
+ (OrigName _ cls_str) = origName "pp_idspec2" cls
clsop_str = classOpString clsop
in
ppCat [pp_mod,
else
[] -- Discard it
in
+ -- pprTrace "coreBindToStg:" (ppCat [ppr PprDebug binder, ppr PprDebug (isExported binder)]) $
case stg_rhs of
StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
-- Trivial RHS, so augment envt, and ditch the binding
IMP_Ubiq()
import HsSyn ( HsLit(..), HsExpr(..), HsBinds,
- InPat, OutPat, Stmt, Qual, Match,
+ InPat, OutPat, Stmt, Qualifier, Match,
ArithSeqInfo, PolyType, Fake )
import RnHsSyn ( RenamedArithSeqInfo(..), RenamedHsExpr(..) )
import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..),
import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType,
- Stmt, Qual, ArithSeqInfo, InPat, Fake )
+ Stmt, Qualifier, ArithSeqInfo, InPat, Fake )
import HsPragmas ( ClassPragmas(..) )
import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
RenamedClassOpSig(..), RenamedMonoBinds(..),
import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
idType )
import IdInfo ( noIdInfo )
-import Name ( isLocallyDefined, moduleNamePair, getLocalName )
+import Name ( isLocallyDefined, origName, getLocalName )
import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID )
import PprStyle
import Pretty
-}
where
- (clas_mod, clas_name) = moduleNamePair clas
+ (OrigName clas_mod clas_name) = origName "makeClassDeclDefaultMethodRhs" clas
method_id = method_ids !! (tag-1)
class_op = (classOps clas) !! (tag-1)
import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag )
import Class ( classKey, needsDataDeclCtxtClassKeys, GenClass )
-import CmdLineOpts ( opt_CompilingPrelude )
import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) )
import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId )
import Maybes ( maybeToBool, Maybe(..) )
-import Name ( moduleNamePair, isLocallyDefined, getSrcLoc,
+import Name ( isLocallyDefined, getSrcLoc,
mkTopLevName, origName, mkImplicitName, ExportFlag(..),
- RdrName{-instance Outputable-}, Name{--O only-}
+ RdrName(..), Name{--O only-}
)
import Outputable ( Outputable(..){-instances e.g., (,)-} )
import PprType ( GenType, GenTyVar, GenClass, TyCon )
mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
getAppDataTyCon, getAppTyCon
)
-import TysWiredIn ( voidTy )
+import TysPrim ( voidTy )
import TyVar ( GenTyVar )
import UniqFM ( emptyUFM )
import Unique -- Keys stuff
gen_tag_n_con_binds rn_env nm_alist_etc
`thenTc` \ (extra_binds, deriver_rn_env) ->
- mapTc (gen_inst_info maybe_mod fixities deriver_rn_env) new_inst_infos
+ mapTc (gen_inst_info modname fixities deriver_rn_env) new_inst_infos
`thenTc` \ really_new_inst_infos ->
let
ddump_deriv = ddump_deriving really_new_inst_infos extra_binds
extra_binds,
ddump_deriv)
where
- maybe_mod = if opt_CompilingPrelude then Nothing else Just modname
-
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
ddump_deriving inst_infos extra_binds sty
\end{itemize}
\begin{code}
-gen_inst_info :: Maybe Module -- Module name; Nothing => Prelude
+gen_inst_info :: Module -- Module name
-> [RenamedFixityDecl] -- all known fixities;
-- may be needed for Text
-> RnEnv -- lookup stuff for names we may use
from_here modname locn [])
where
clas_key = classKey clas
- clas_Name = RnImplicitClass (mkImplicitName clas_key (origName clas))
+ clas_Name = RnImplicitClass (mkImplicitName clas_key (origName "gen_inst_info" clas))
\end{code}
%************************************************************************
in
tcGetUniques (length names_to_add) `thenNF_Tc` \ uniqs ->
let
- pairs_to_add = [ (pn, mkRnName (mkTopLevName u pn mkGeneratedSrcLoc ExportAll []))
+ pairs_to_add = [ case pn of { Qual pnm pnn ->
+ (pn, mkRnName (mkTopLevName u (OrigName pnm pnn) mkGeneratedSrcLoc ExportAll [])) }
| (pn,u) <- zipEqual "gen_tag..." names_to_add uniqs ]
deriver_rn_env
IMP_Ubiq()
-import HsSyn ( HsExpr(..), Qual(..), Stmt(..),
+import HsSyn ( HsExpr(..), Qualifier(..), Stmt(..),
HsBinds(..), Bind(..), MonoBinds(..),
ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
Match, Fake, InPat, OutPat, PolyType,
IMP_Ubiq()
import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
- GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qual(..), Stmt,
+ GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qualifier(..), Stmt,
ArithSeqInfo, Sig, PolyType, FixityDecl, Fake )
import RdrHsSyn ( RdrNameMonoBinds(..), RdrNameHsExpr(..), RdrNamePat(..) )
import RnHsSyn ( RenamedFixityDecl(..) )
isDataCon, DataCon(..), ConTag(..) )
import IdUtils ( primOpId )
import Maybes ( maybeToBool )
-import Name ( moduleNamePair, origName, RdrName(..) )
-import PrelMods ( fromPrelude, pRELUDE, pRELUDE_BUILTIN, pRELUDE_LIST, pRELUDE_TEXT )
+import Name ( origName, preludeQual, nameOf, RdrName(..), OrigName(..) )
+import PrelMods ( pRELUDE, gHC__, iX )
import PrelVals ( eRROR_ID )
import PrimOp ( PrimOp(..) )
con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
- data_con_PN = origName data_con
+ data_con_PN = qual_orig_name data_con
con_arity = dataConArity data_con
as_needed = take con_arity as_PNs
bs_needed = take con_arity bs_PNs
con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
- data_con_PN = origName data_con
+ data_con_PN = qual_orig_name data_con
con_arity = dataConArity data_con
as_needed = take con_arity as_PNs
bs_needed = take con_arity bs_PNs
data_con_1 = head data_cons
data_con_N = last data_cons
- data_con_1_PN = origName data_con_1
- data_con_N_PN = origName data_con_N
+ data_con_1_PN = qual_orig_name data_con_1
+ data_con_N_PN = qual_orig_name data_con_N
----- single-constructor-flavored: -------------
arity = dataConArity data_con_1
then enum_ixes
else single_con_ixes
where
- tycon_str = _UNPK_ (snd (moduleNamePair tycon))
+ tycon_str = _UNPK_ (nameOf (origName "gen_Ix_binds" tycon))
--------------------------------------------------------------
enum_ixes = enum_range `AndMonoBinds`
dc
con_arity = dataConArity data_con
- data_con_PN = origName data_con
+ data_con_PN = qual_orig_name data_con
con_pat xs = ConPatIn data_con_PN (map VarPatIn xs)
con_expr xs = mk_easy_App data_con_PN xs
where
read_con data_con -- note: "b" is the string being "read"
= let
- data_con_PN = origName data_con
- data_con_str= snd (moduleNamePair data_con)
+ data_con_PN = qual_orig_name data_con
+ data_con_str= nameOf (origName "gen_Read_binds" data_con)
con_arity = dataConArity data_con
as_needed = take con_arity as_PNs
bs_needed = take con_arity bs_PNs
where
pats_etc data_con
= let
- data_con_PN = origName data_con
+ data_con_PN = qual_orig_name data_con
con_arity = dataConArity data_con
bs_needed = take con_arity bs_PNs
con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
nullary_con = isNullaryDataCon data_con
show_con
- = let (mod, nm) = moduleNamePair data_con
+ = let (OrigName mod nm) = origName "gen_Show_binds" data_con
space_maybe = if nullary_con then _NIL_ else SLIT(" ")
in
HsApp (HsVar showString_PN) (HsLit (HsString (nm _APPEND_ space_maybe)))
([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
where
pat = ConPatIn var_PN (nOfThem (dataConArity var) WildPatIn)
- var_PN = origName var
+ var_PN = qual_orig_name var
gen_tag_n_con_monobind (pn, tycon, GenTag2Con)
= mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
([lit_pat], HsVar var_PN)
where
lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
- var_PN = origName var
+ var_PN = qual_orig_name var
gen_tag_n_con_monobind (pn, tycon, GenMaxTag)
= mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
\end{code}
\begin{code}
+qual_orig_name n = case (origName "qual_orig_name" n) of { OrigName m n -> Qual m n }
+
a_PN = Unqual SLIT("a")
b_PN = Unqual SLIT("b")
c_PN = Unqual SLIT("c")
ch_PN = Unqual SLIT("c#")
dh_PN = Unqual SLIT("d#")
cmp_eq_PN = Unqual SLIT("cmp_eq")
-rangeSize_PN = Unqual SLIT("rangeSize")
+rangeSize_PN = Qual iX SLIT("rangeSize")
as_PNs = [ Unqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
bs_PNs = [ Unqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
cs_PNs = [ Unqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
-eq_PN = prelude_method SLIT("Eq") SLIT("==")
-ne_PN = prelude_method SLIT("Eq") SLIT("/=")
-le_PN = prelude_method SLIT("Ord") SLIT("<=")
-lt_PN = prelude_method SLIT("Ord") SLIT("<")
-ge_PN = prelude_method SLIT("Ord") SLIT(">=")
-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")
-minBound_PN = prelude_method SLIT("Bounded") SLIT("minBound")
-maxBound_PN = prelude_method SLIT("Bounded") SLIT("maxBound")
-ltTag_PN = Unqual SLIT("LT")
-eqTag_PN = Unqual SLIT("EQ")
-gtTag_PN = Unqual SLIT("GT")
-enumFrom_PN = prelude_method SLIT("Enum") SLIT("enumFrom")
-enumFromTo_PN = prelude_method SLIT("Enum") SLIT("enumFromTo")
-enumFromThen_PN = prelude_method SLIT("Enum") SLIT("enumFromThen")
-enumFromThenTo_PN= prelude_method SLIT("Enum") SLIT("enumFromThenTo")
-range_PN = prelude_method SLIT("Ix") SLIT("range")
-index_PN = prelude_method SLIT("Ix") SLIT("index")
-inRange_PN = prelude_method SLIT("Ix") SLIT("inRange")
-readsPrec_PN = prelude_method SLIT("Read") SLIT("readsPrec")
-readList_PN = prelude_method SLIT("Read") SLIT("readList")
-showsPrec_PN = prelude_method SLIT("Show") SLIT("showsPrec")
-showList_PN = prelude_method SLIT("Show") SLIT("showList")
-plus_PN = prelude_method SLIT("Num") SLIT("+")
-times_PN = prelude_method SLIT("Num") SLIT("*")
-
-false_PN = prelude_val pRELUDE SLIT("False")
-true_PN = prelude_val pRELUDE SLIT("True")
+eq_PN = preludeQual {-SLIT("Eq")-} SLIT("==")
+ne_PN = preludeQual {-SLIT("Eq")-} SLIT("/=")
+le_PN = preludeQual {-SLIT("Ord")-} SLIT("<=")
+lt_PN = preludeQual {-SLIT("Ord")-} SLIT("<")
+ge_PN = preludeQual {-SLIT("Ord")-} SLIT(">=")
+gt_PN = preludeQual {-SLIT("Ord")-} SLIT(">")
+max_PN = preludeQual {-SLIT("Ord")-} SLIT("max")
+min_PN = preludeQual {-SLIT("Ord")-} SLIT("min")
+compare_PN = preludeQual {-SLIT("Ord")-} SLIT("compare")
+minBound_PN = preludeQual {-SLIT("Bounded")-} SLIT("minBound")
+maxBound_PN = preludeQual {-SLIT("Bounded")-} SLIT("maxBound")
+enumFrom_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFrom")
+enumFromTo_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFromTo")
+enumFromThen_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFromThen")
+enumFromThenTo_PN= preludeQual {-SLIT("Enum")-} SLIT("enumFromThenTo")
+range_PN = Qual iX SLIT("range")
+index_PN = Qual iX SLIT("index")
+inRange_PN = Qual iX SLIT("inRange")
+readsPrec_PN = preludeQual {-SLIT("Read")-} SLIT("readsPrec")
+readList_PN = preludeQual {-SLIT("Read")-} SLIT("readList")
+showsPrec_PN = preludeQual {-SLIT("Show")-} SLIT("showsPrec")
+showList_PN = preludeQual {-SLIT("Show")-} SLIT("showList")
+plus_PN = preludeQual {-SLIT("Num")-} SLIT("+")
+times_PN = preludeQual {-SLIT("Num")-} SLIT("*")
+ltTag_PN = preludeQual SLIT("LT")
+eqTag_PN = preludeQual SLIT("EQ")
+gtTag_PN = preludeQual SLIT("GT")
+
eqH_Char_PN = prelude_primop CharEqOp
ltH_Char_PN = prelude_primop CharLtOp
eqH_Word_PN = prelude_primop WordEqOp
geH_PN = prelude_primop IntGeOp
leH_PN = prelude_primop IntLeOp
minusH_PN = prelude_primop 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 = prelude_val pRELUDE_BUILTIN SLIT("I#")
-error_PN = prelude_val pRELUDE SLIT("error")
-showString_PN = prelude_val pRELUDE_TEXT SLIT("showString")
-showParen_PN = prelude_val pRELUDE_TEXT SLIT("showParen")
-readParen_PN = prelude_val pRELUDE_TEXT SLIT("readParen")
-lex_PN = prelude_val pRELUDE_TEXT SLIT("lex")
-showSpace_PN = prelude_val pRELUDE_TEXT SLIT("__showSpace")
-_showList_PN = prelude_val pRELUDE SLIT("__showList")
-_readList_PN = prelude_val pRELUDE SLIT("__readList")
-
-prelude_val m s = Unqual s
-prelude_method c o = Unqual o
-prelude_primop o = origName (primOpId o)
+
+prelude_primop o = case (origName "prelude_primop" (primOpId o)) of { OrigName m n -> Qual m n }
+
+false_PN = preludeQual SLIT("False")
+true_PN = preludeQual SLIT("True")
+and_PN = preludeQual SLIT("&&")
+not_PN = preludeQual SLIT("not")
+append_PN = preludeQual SLIT("++")
+map_PN = preludeQual SLIT("map")
+compose_PN = preludeQual SLIT(".")
+mkInt_PN = preludeQual SLIT("I#")
+error_PN = preludeQual SLIT("error")
+showString_PN = preludeQual SLIT("showString")
+showParen_PN = preludeQual SLIT("showParen")
+readParen_PN = preludeQual SLIT("readParen")
+lex_PN = preludeQual SLIT("lex")
+showSpace_PN = Qual gHC__ SLIT("showSpace")
+_showList_PN = Qual gHC__ SLIT("showList__")
+_readList_PN = Qual gHC__ SLIT("readList__")
a_Expr = HsVar a_PN
b_Expr = HsVar b_PN
con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName
con2tag_PN tycon
- = let (mod, nm) = moduleNamePair tycon
+ = let (OrigName mod nm) = origName "con2tag_PN" tycon
con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
in
- (if fromPrelude mod then Unqual else Qual mod) con2tag
+ Qual mod con2tag
tag2con_PN tycon
- = let (mod, nm) = moduleNamePair tycon
+ = let (OrigName mod nm) = origName "tag2con_PN" tycon
tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
in
- (if fromPrelude mod then Unqual else Qual mod) tag2con
+ Qual mod tag2con
maxtag_PN tycon
- = let (mod, nm) = moduleNamePair tycon
+ = let (OrigName mod nm) = origName "maxtag_PN" tycon
maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
in
- (if fromPrelude mod then Unqual else Qual mod) maxtag
+ Qual mod maxtag
\end{code}
import Type ( mkTyVarTy, tyVarsOfType )
import TyVar ( GenTyVar {- instances -},
TyVarEnv(..), growTyVarEnvList, emptyTyVarSet )
-import TysWiredIn ( voidTy )
+import TysPrim ( voidTy )
import Unique ( Unique ) -- instances
import UniqFM
import PprStyle
type TcGRHSsAndBinds s = GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcGRHS s = GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
-type TcQual s = Qual (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcQual s = Qualifier (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TypecheckedBind = Bind TyVar UVar Id TypecheckedPat
type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat
type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat
-type TypecheckedQual = Qual TyVar UVar Id TypecheckedPat
+type TypecheckedQual = Qualifier TyVar UVar Id TypecheckedPat
type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat
type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat
type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat
SpecInstSig(..), HsBinds(..), Bind(..),
MonoBinds(..), GRHSsAndBinds, Match,
InPat(..), OutPat(..), HsExpr(..), HsLit(..),
- Stmt, Qual, ArithSeqInfo, Fake,
+ Stmt, Qualifier, ArithSeqInfo, Fake,
PolyType(..), MonoType )
import RnHsSyn ( RenamedHsBinds(..), RenamedMonoBinds(..),
RenamedInstDecl(..), RenamedFixityDecl(..),
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
concatBag, foldBag, bagToList )
-import CmdLineOpts ( opt_GlasgowExts, opt_CompilingPrelude,
+import CmdLineOpts ( opt_GlasgowExts,
opt_OmitDefaultInstanceMethods,
- opt_SpecialiseOverloaded )
+ opt_SpecialiseOverloaded
+ )
import Class ( GenClass, GenClassOp,
isCcallishClass, classBigSig,
classOps, classOpLocalType,
if (not from_here && (clas `derivedFor` inst_tycon)
&& all isTyVarTy arg_tys)
then
- if not opt_CompilingPrelude && maybeToBool inst_mod &&
- mod_name == expectJust "inst_mod" inst_mod
+ if mod_name == inst_mod
then
-- Imported instance came from this module;
-- discard and derive fresh instance
-> [Id]
-> TcType s
-> Class
- -> Maybe Module
+ -> Module
-> Int
-> NF_TcM s (TcExpr s)
Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
- mod_str = case inst_mod of { Nothing -> pRELUDE; Just m -> m }
-
- error_msg = _UNPK_ mod_str ++ "." ++ _UNPK_ clas_name ++ "."
+ error_msg = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "."
++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
- clas_name = nameOf (origName clas)
+ clas_name = nameOf (origName "makeInstanceDeclNoDefaultExpr" clas)
\end{code}
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
isCcallishClass clas
--- && not opt_CompilingPrelude -- which allows anything
&& not (maybeToBool (maybeBoxedPrimType inst_tau))
= failTc (nonBoxedPrimCCallErr clas inst_tau)
= ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
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 "'"]
+ pp_mod = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"]
nonBoxedPrimCCallErr clas inst_ty sty
= ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
[Id] -- Constant methods (either all or none)
RenamedMonoBinds -- Bindings, b
Bool -- True <=> local instance decl
- (Maybe Module) -- Name of module where this instance defined; Nothing => Prelude
+ Module -- Name of module where this instance defined
SrcLoc -- Source location assoc'd with this instance's defn
[RenamedSig] -- User pragmas recorded for generating specialised instances
\end{code}
\begin{code}
mkInstanceRelatedIds :: Bool
-> SrcLoc
- -> Maybe Module
+ -> Module
-> RenamedInstancePragmas
-> Class
-> [TyVar]
IMP_Ubiq(){-uitous-}
import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
- Match, HsBinds, Qual, PolyType,
+ Match, HsBinds, Qualifier, PolyType,
ArithSeqInfo, Stmt, Fake )
import RnHsSyn ( RenamedPat(..) )
import TcHsSyn ( TcPat(..), TcIdOcc(..) )
IMP_Ubiq()
import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
- Match, HsBinds, Qual, PolyType, ArithSeqInfo,
+ Match, HsBinds, Qualifier, PolyType, ArithSeqInfo,
GRHSsAndBinds, Stmt, Fake )
import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) )
import Inst ( InstanceMapper(..) )
import TcClassDcl ( tcClassDecl1 )
import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
- tcExtendGlobalValEnv,
tcTyVarScope, tcGetEnv )
import TcKind ( TcKind, newKindVars )
import TcTyDecls ( tcTyDecl, mkDataBinds )
import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..),
Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..),
- HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo,
+ HsBinds(..), HsLit, Stmt, Qualifier, ArithSeqInfo,
PolyType, Fake, InPat,
Bind(..), MonoBinds(..), Sig,
MonoType )
import TcMonad hiding ( rnMtoTcM )
import Usage ( Usage(..), GenUsage, UVar(..), duffUsage )
-import TysWiredIn ( voidTy )
+import TysPrim ( voidTy )
IMP_Ubiq()
import Unique ( Unique )
import CStrings ( identToC )
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( maybeToBool )
-import Name ( isLexVarSym, isLexSpecialSym, isPreludeDefined, origName, moduleOf,
- nameOrigName, nameOf, Name{-instance Outputable-}
+import Name ( isLexVarSym, isLexSpecialSym, origName, moduleOf,
+ getLocalName, Name{-instance Outputable-}
)
import Outputable ( ifPprShowAll, interpp'SP )
import PprEnv
import Pretty
import TysWiredIn ( listTyCon )
import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList{-ToDo:rm-} )
-import Unique ( pprUnique10, pprUnique, incrUnique )
+import Unique ( pprUnique10, pprUnique, incrUnique, listTyConKey )
import Usage ( UVar(..), pprUVar )
import Util
\end{code}
where
(theta, body_ty) = splitRhoTy ty
- ppr_theta [ct] = ppr_dict sty env tOP_PREC ct
- ppr_theta cts = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts))
+ ppr_theta = case sty of { PprInterface -> ppr_theta_2 ; _ -> ppr_theta_1 }
+
+ ppr_theta_1 [ct] = ppr_dict sty env tOP_PREC ct
+ ppr_theta_1 cts = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts))
+
+ ppr_theta_2 cts = ppBesides [ppStr "{{", ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts), ppStr "}}"]
ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
-- We fiddle the precedences passed to left/right branches,
where
(fun_ty, arg_tys) = splitAppTy ty
+{- OLD:
ppr_ty PprInterface env ctxt_prec (SynTy tycon tys expansion)
-- always expand types in an interface
= ppr_ty PprInterface env ctxt_prec expansion
+-}
ppr_ty sty env ctxt_prec (SynTy tycon tys expansion)
= ppBeside
where
pp_u = pprUnique uniq
pp_name = case name of
- Just n -> ppPStr (nameOf (nameOrigName n))
+ Just n -> ppPStr (getLocalName n)
Nothing -> case kind of
TypeKind -> ppChar 'o'
BoxedTypeKind -> ppChar 't'
showTyCon :: PprStyle -> TyCon -> String
showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
+maybe_code sty = if codeStyle sty then identToC else ppPStr
+
pprTyCon :: PprStyle -> TyCon -> Pretty
-pprTyCon sty FunTyCon = ppStr "(->)"
-pprTyCon sty (TupleTyCon _ name _) = ppr sty name
pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name
+pprTyCon sty FunTyCon = maybe_code sty SLIT("(->)")
+pprTyCon sty (TupleTyCon _ _ arity) = case arity of
+ 0 -> maybe_code sty SLIT("()")
+ 2 -> maybe_code sty SLIT("(,)")
+ 3 -> maybe_code sty SLIT("(,,)")
+ 4 -> maybe_code sty SLIT("(,,,)")
+ 5 -> maybe_code sty SLIT("(,,,,)")
+ n -> maybe_code sty (_PK_ ( "(" ++ nOfThem (n-1) ',' ++ ")"))
+
pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
+ | uniq == listTyConKey
+ = maybe_code sty SLIT("[]")
+ | otherwise
= ppr sty name
pprTyCon sty (SpecTyCon tc ty_maybes)
-- vaguely close to what can be used in C identifier.
-- Don't forget to include the module name!!!
getTypeString :: Type -> [FAST_STRING]
-getTypeString ty
- | is_prelude_ty = [string]
- | otherwise = [mod, string]
+getTypeString ty = [mod, string]
where
string = _PK_ (tidy (ppShow 1000 ppr_t))
ppr_t = pprGenType PprForC ty
-- PprForC expands type synonyms as it goes
- (is_prelude_ty, mod)
+ mod
= case (maybeAppTyCon ty) of
- Nothing -> true_bottom
- Just (tycon,_) ->
- if isPreludeDefined tycon
- then true_bottom
- else (False, moduleOf (origName tycon))
-
- true_bottom = (True, panic "getTypeString")
+ Nothing -> panic "getTypeString"
+ Just (tycon,_) -> moduleOf (origName "getTypeString" tycon)
--------------------------------------------------
-- tidy: very ad-hoc
getName tc = panic "TyCon.getName"
{- LATER:
- getName (SpecTyCon tc tys) = let (m,n) = moduleNamePair tc in
+ getName (SpecTyCon tc tys) = let (OrigName m n) = origName "????" tc in
(m, n _APPEND_ specMaybeTysSuffix tys)
getName other_tc = moduleNamePair (expectJust "tycon1" (getName other_tc))
getName other = Nothing
import Type ( GenType, Type )
import Usage ( GenUsage )
import Class ( Class, GenClass )
-import TysWiredIn ( voidTy )
+import TysPrim ( voidTy )
data GenId ty
data GenType tyvar uvar
Bag, -- abstract type
emptyBag, unitBag, unionBags, unionManyBags,
- elemBag, mapBag,
+ mapBag, -- UNUSED: elemBag,
filterBag, partitionBag, concatBag, foldBag,
isEmptyBag, consBag, snocBag,
- listToBag, bagToList, bagToList_append
+ listToBag, bagToList
) where
#ifdef COMPILING_GHC
emptyBag = EmptyBag
unitBag = UnitBag
+{- UNUSED:
elemBag :: Eq a => a -> Bag a -> Bool
elemBag x EmptyBag = False
elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2
elemBag x (ListBag ys) = any (x ==) ys
elemBag x (ListOfBags bs) = any (x `elemBag`) bs
+-}
unionManyBags [] = EmptyBag
unionManyBags xs = ListOfBags xs
bagToList b = bagToList_append b []
-- (bagToList_append b xs) flattens b and puts xs on the end.
+ -- (not exported)
bagToList_append EmptyBag xs = xs
bagToList_append (UnitBag x) xs = x:xs
bagToList_append (TwoBags b1 b2) xs = bagToList_append b1 (bagToList_append b2 xs)
import MachRegs ( Reg )
import Maybes ( MaybeErr )
import MatchEnv ( MatchEnv )
-import Name ( Module(..), RdrName, Name, ExportFlag, NamedThing(..) )
+import Name ( Module(..), OrigName, RdrName, Name, ExportFlag, NamedThing(..) )
import Outputable ( Outputable(..) )
import PprStyle ( PprStyle )
import PragmaInfo ( PragmaInfo )
data MaybeErr a b
data MatchEnv a b
data Name
+data OrigName = OrigName _PackedString _PackedString
data RdrName = Unqual _PackedString | Qual _PackedString _PackedString
data Reg
data OutPat a b c
startsWith [] str = Just str
startsWith (c:cs) (s:ss)
= if c /= s then Nothing else startsWith cs ss
+startWith _ [] = Nothing
endsWith cs ss
= case (startsWith (reverse cs) (reverse ss)) of
projects / ghc-hetmet.git / commitdiff