#include "HsVersions.h"
module PrelInfo (
+ -- finite maps for built-in things (for the renamer and typechecker):
+ builtinNames, derivingOccurrences,
+ SYN_IE(BuiltinNames),
+
+ maybeCharLikeTyCon, maybeIntLikeTyCon,
+
+ eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR, compare_RDR,
+ minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR,
+ enumFromThenTo_RDR, fromEnum_RDR, toEnum_RDR,
+ range_RDR, index_RDR, inRange_RDR, readsPrec_RDR, readList_RDR,
+ showsPrec_RDR, showList_RDR, plus_RDR, times_RDR, ltTag_RDR, eqTag_RDR, gtTag_RDR,
+ eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR,
+ eqH_Float_RDR, ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, ltH_Int_RDR,
+ geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR, and_RDR, not_RDR, append_RDR,
+ map_RDR, compose_RDR, mkInt_RDR, error_RDR, showString_RDR, showParen_RDR, readParen_RDR,
+ lex_RDR, showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
+
+ numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR,
+ monadZeroClass_RDR, enumClass_RDR, evalClass_RDR, ordClass_RDR,
+
+ main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME,
+
+ needsDataDeclCtxtClassKeys, cCallishClassKeys, isNoDictClass,
+ isNumericClass, isStandardClass, isCcallishClass
+ ) where
- pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO,
- pRELUDE_LIST, pRELUDE_TEXT,
- pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
- gLASGOW_ST, gLASGOW_MISC,
+IMP_Ubiq()
+IMPORT_DELOOPER(PrelLoop) ( primOpName )
+-- IMPORT_DELOOPER(IdLoop) ( SpecEnv )
- -- lookup functions for built-in names, for the renamer:
- builtinNameInfo,
+-- friends:
+import PrelMods -- Prelude module names
+import PrelVals -- VALUES
+import PrimOp ( PrimOp(..), allThePrimOps )
+import PrimRep ( PrimRep(..) )
+import TysPrim -- TYPES
+import TysWiredIn
- -- *odd* values that need to be reached out and grabbed:
- eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
- packStringForCId,
- unpackCStringId, unpackCString2Id,
- unpackCStringAppendId, unpackCStringFoldrId,
- integerZeroId, integerPlusOneId,
- integerPlusTwoId, integerMinusOneId,
+-- others:
+import SpecEnv ( SpecEnv )
+import RdrHsSyn ( RdrName(..), varQual, tcQual, qual )
+import Id ( GenId, SYN_IE(Id) )
+import Name ( Name, OccName(..), DefnInfo(..), Provenance(..),
+ getName, mkGlobalName, modAndOcc )
+import Class ( Class(..), GenClass, classKey )
+import TyCon ( tyConDataCons, mkFunTyCon, TyCon )
+import Type
+import Bag
+import Unique -- *Key stuff
+import UniqFM ( UniqFM, listToUFM )
+import Util ( isIn )
+\end{code}
- -----------------------------------------------------
- -- the rest of the export list is organised by *type*
- -----------------------------------------------------
+%************************************************************************
+%* *
+\subsection[builtinNameInfo]{Lookup built-in names}
+%* *
+%************************************************************************
- -- type: Bool
- boolTyCon, boolTy, falseDataCon, trueDataCon,
+We have two ``builtin name funs,'' one to look up @TyCons@ and
+@Classes@, the other to look up values.
- -- types: Char#, Char, String (= [Char])
- charPrimTy, charTy, stringTy,
- charPrimTyCon, charTyCon, charDataCon,
+\begin{code}
+type BuiltinNames = Bag Name
- -- type: Ordering (used in deriving)
- orderingTy, ltDataCon, eqDataCon, gtDataCon,
+builtinNames :: BuiltinNames
+builtinNames
+ = -- Wired in TyCons
+ unionManyBags (map getTyConNames wired_in_tycons) `unionBags`
- -- types: Double#, Double
- doublePrimTy, doubleTy,
- doublePrimTyCon, doubleTyCon, doubleDataCon,
+ -- Wired in Ids
+ listToBag (map getName wired_in_ids) `unionBags`
- -- types: Float#, Float
- floatPrimTy, floatTy,
- floatPrimTyCon, floatTyCon, floatDataCon,
+ -- PrimOps
+ listToBag (map (getName.primOpName) allThePrimOps) `unionBags`
- -- types: Glasgow *primitive* arrays, sequencing and I/O
- mkPrimIoTy, -- to typecheck "mainPrimIO" & for _ccall_s
- realWorldStatePrimTy, realWorldStateTy{-boxed-},
- realWorldTy, realWorldTyCon, realWorldPrimId,
- statePrimTyCon, stateDataCon, getStatePairingConInfo,
+ -- Other names with magic keys
+ listToBag knownKeyNames
+\end{code}
- byteArrayPrimTy,
- -- types: Void# (only used within the compiler)
- voidPrimTy, voidPrimId,
+\begin{code}
+getTyConNames :: TyCon -> Bag Name
+getTyConNames tycon
+ = getName tycon `consBag` listToBag (map getName (tyConDataCons tycon))
+ -- Synonyms return empty list of constructors
+\end{code}
- -- types: Addr#, Int#, Word#, Int
- intPrimTy, intTy, intPrimTyCon, intTyCon, intDataCon,
- wordPrimTyCon, wordPrimTy, wordTy, wordTyCon, wordDataCon,
- addrPrimTyCon, addrPrimTy, addrTy, addrTyCon, addrDataCon,
- -- types: Integer, Rational (= Ratio Integer)
- integerTy, rationalTy,
- integerTyCon, integerDataCon,
- rationalTyCon, ratioDataCon,
+We let a lot of "non-standard" values be visible, so that we can make
+sense of them in interface pragmas. It's cool, though they all have
+"non-standard" names, so they won't get past the parser in user code.
- -- type: Lift
- liftTyCon, liftDataCon, mkLiftTy,
+%************************************************************************
+%* *
+\subsection{Wired in TyCons}
+%* *
+%************************************************************************
- -- type: List
- listTyCon, mkListTy, nilDataCon, consDataCon,
- -- type: tuples
- mkTupleTy, unitTy,
+\begin{code}
+wired_in_tycons = [mkFunTyCon] ++
+ prim_tycons ++
+ tuple_tycons ++
+ data_tycons
- -- for compilation of List Comprehensions and foldr
- foldlId, foldrId,
- mkBuild, buildId, augmentId, appendId
+prim_tycons
+ = [ addrPrimTyCon
+ , arrayPrimTyCon
+ , byteArrayPrimTyCon
+ , charPrimTyCon
+ , doublePrimTyCon
+ , floatPrimTyCon
+ , intPrimTyCon
+ , foreignObjPrimTyCon
+ , mutableArrayPrimTyCon
+ , mutableByteArrayPrimTyCon
+ , synchVarPrimTyCon
+ , realWorldTyCon
+ , stablePtrPrimTyCon
+ , statePrimTyCon
+ , wordPrimTyCon
+ ]
- -- and, finally, we must put in some (abstract) data types,
- -- to make the interface self-sufficient
- ) where
+tuple_tycons = unitTyCon : [tupleTyCon i | i <- [2..37] ]
-import Ubiq
-import PrelLoop ( primOpNameInfo )
--- friends:
-import PrelMods -- Prelude module names
-import PrelVals -- VALUES
-import PrimOp ( PrimOp(..), allThePrimOps )
-import PrimRep ( PrimRep(..) )
-import TysPrim -- TYPES
-import TysWiredIn
+data_tycons
+ = [ listTyCon
+ , addrTyCon
+ , boolTyCon
+ , charTyCon
+ , doubleTyCon
+ , floatTyCon
+ , foreignObjTyCon
+ , intTyCon
+ , integerTyCon
+ , liftTyCon
+ , primIoTyCon
+ , return2GMPsTyCon
+ , returnIntAndGMPTyCon
+ , stTyCon
+ , stablePtrTyCon
+ , stateAndAddrPrimTyCon
+ , stateAndArrayPrimTyCon
+ , stateAndByteArrayPrimTyCon
+ , stateAndCharPrimTyCon
+ , stateAndDoublePrimTyCon
+ , stateAndFloatPrimTyCon
+ , stateAndForeignObjPrimTyCon
+ , stateAndIntPrimTyCon
+ , stateAndMutableArrayPrimTyCon
+ , stateAndMutableByteArrayPrimTyCon
+ , stateAndPtrPrimTyCon
+ , stateAndStablePtrPrimTyCon
+ , stateAndSynchVarPrimTyCon
+ , stateAndWordPrimTyCon
+ , stateTyCon
+ , voidTyCon
+ , wordTyCon
+ ]
--- others:
-import CmdLineOpts
-import FiniteMap
-import Id ( mkTupleCon, GenId{-instances-} )
-import Name ( Name(..) )
-import NameTypes ( mkPreludeCoreName, FullName, ShortName )
-import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon{-instances-} )
-import Type
-import Unique -- *Key stuff
-import Util ( nOfThem, panic )
+min_nonprim_tycon_list -- used w/ HideMostBuiltinNames
+ = [ boolTyCon
+ , charTyCon
+ , intTyCon
+ , floatTyCon
+ , doubleTyCon
+ , integerTyCon
+ , liftTyCon
+ , return2GMPsTyCon -- ADR asked for these last two (WDP 94/11)
+ , returnIntAndGMPTyCon
+ ]
\end{code}
%************************************************************************
%* *
-\subsection[builtinNameInfo]{Lookup built-in names}
+\subsection{Wired in Ids}
%* *
%************************************************************************
-We have two ``builtin name funs,'' one to look up @TyCons@ and
-@Classes@, the other to look up values.
+The WiredIn Ids ...
+ToDo: Some of these should be moved to id_keys_infos!
\begin{code}
-builtinNameInfo :: (FAST_STRING -> Maybe Name, -- name lookup fn for values
- FAST_STRING -> Maybe Name) -- name lookup fn for tycons/classes
+wired_in_ids
+ = [ aBSENT_ERROR_ID
+ , augmentId
+ , buildId
+ , eRROR_ID
+ , foldlId
+ , foldrId
+ , iRREFUT_PAT_ERROR_ID
+ , integerMinusOneId
+ , integerPlusOneId
+ , integerPlusTwoId
+ , integerZeroId
+ , nON_EXHAUSTIVE_GUARDS_ERROR_ID
+ , nO_DEFAULT_METHOD_ERROR_ID
+ , nO_EXPLICIT_METHOD_ERROR_ID
+ , pAR_ERROR_ID
+ , pAT_ERROR_ID
+ , packStringForCId
+ , rEC_CON_ERROR_ID
+ , rEC_UPD_ERROR_ID
+ , realWorldPrimId
+ , runSTId
+ , tRACE_ID
+ , unpackCString2Id
+ , unpackCStringAppendId
+ , unpackCStringFoldrId
+ , unpackCStringId
+ , voidId
+
+-- , copyableId
+-- , forkId
+-- , noFollowId
+-- , parAtAbsId
+-- , parAtForNowId
+-- , parAtId
+-- , parAtRelId
+-- , parGlobalId
+-- , parId
+-- , parLocalId
+-- , seqId
+ ]
+\end{code}
-builtinNameInfo
- = (init_val_lookup_fn, init_tc_lookup_fn)
- where
- --
- -- values (including data constructors)
- --
- init_val_lookup_fn
- = if opt_HideBuiltinNames then
- (\ x -> Nothing)
- else if opt_HideMostBuiltinNames then
- lookupFM (listToFM (concat min_val_assoc_lists))
- else
- lookupFM (listToFM (concat val_assoc_lists))
-
- min_val_assoc_lists -- min needed when compiling bits of Prelude
- = [
- concat (map pcDataConNameInfo g_con_tycons),
- concat (map pcDataConNameInfo min_nonprim_tycon_list),
- totally_wired_in_Ids,
- unboxed_ops
- ]
-
- val_assoc_lists
- = [
- concat (map pcDataConNameInfo g_con_tycons),
- concat (map pcDataConNameInfo data_tycons),
- totally_wired_in_Ids,
- unboxed_ops,
- special_class_ops,
- if opt_ForConcurrent then parallel_vals else []
- ]
- --
- -- type constructors and classes
- --
- init_tc_lookup_fn
- = if opt_HideBuiltinNames then
- (\ x -> Nothing)
- else if opt_HideMostBuiltinNames then
- lookupFM (listToFM (concat min_tc_assoc_lists))
- else
- lookupFM (listToFM (concat tc_assoc_lists))
-
- min_tc_assoc_lists -- again, pretty ad-hoc
- = [
- map pcTyConNameInfo prim_tycons,
- map pcTyConNameInfo g_tycons,
- map pcTyConNameInfo min_nonprim_tycon_list
- ]
-
- tc_assoc_lists
- = [
- map pcTyConNameInfo prim_tycons,
- map pcTyConNameInfo g_tycons,
- map pcTyConNameInfo data_tycons,
- map pcTyConNameInfo synonym_tycons,
- std_tycon_list,
- std_class_list
- ]
-
- -- We let a lot of "non-standard" values be visible, so that we
- -- can make sense of them in interface pragmas. It's cool, though
- -- they all have "non-standard" names, so they won't get past
- -- the parser in user code.
+%************************************************************************
+%* *
+\subsection{Built-in keys}
+%* *
+%************************************************************************
+Ids, Synonyms, Classes and ClassOps with builtin keys.
-prim_tycons
- = [addrPrimTyCon,
- arrayPrimTyCon,
- byteArrayPrimTyCon,
- charPrimTyCon,
- doublePrimTyCon,
- floatPrimTyCon,
- intPrimTyCon,
- mallocPtrPrimTyCon,
- mutableArrayPrimTyCon,
- mutableByteArrayPrimTyCon,
- synchVarPrimTyCon,
- realWorldTyCon,
- stablePtrPrimTyCon,
- statePrimTyCon,
- wordPrimTyCon
+\begin{code}
+mkKnownKeyGlobal :: (RdrName, Unique) -> Name
+mkKnownKeyGlobal (Qual mod occ, uniq) = mkGlobalName uniq mod occ VanillaDefn Implicit
+
+main_NAME = mkKnownKeyGlobal (main_RDR, mainKey)
+mainPrimIO_NAME = mkKnownKeyGlobal (mainPrimIO_RDR, mainPrimIoKey)
+ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, iOTyConKey)
+primIoTyCon_NAME = getName primIoTyCon
+
+knownKeyNames :: [Name]
+knownKeyNames
+ = [main_NAME, mainPrimIO_NAME, ioTyCon_NAME]
+ ++
+ map mkKnownKeyGlobal
+ [
+ -- Type constructors (synonyms especially)
+ (orderingTyCon_RDR, orderingTyConKey)
+ , (rationalTyCon_RDR, rationalTyConKey)
+ , (ratioTyCon_RDR, ratioTyConKey)
+
+ -- Classes. *Must* include:
+ -- classes that are grabbed by key (e.g., eqClassKey)
+ -- classes in "Class.standardClassKeys" (quite a few)
+ , (eqClass_RDR, eqClassKey) -- mentioned, derivable
+ , (ordClass_RDR, ordClassKey) -- derivable
+ , (evalClass_RDR, evalClassKey) -- mentioned
+ , (boundedClass_RDR, boundedClassKey) -- derivable
+ , (numClass_RDR, numClassKey) -- mentioned, numeric
+ , (enumClass_RDR, enumClassKey) -- derivable
+ , (monadClass_RDR, monadClassKey)
+ , (monadZeroClass_RDR, monadZeroClassKey)
+ , (monadPlusClass_RDR, monadPlusClassKey)
+ , (functorClass_RDR, functorClassKey)
+ , (showClass_RDR, showClassKey) -- derivable
+ , (realClass_RDR, realClassKey) -- numeric
+ , (integralClass_RDR, integralClassKey) -- numeric
+ , (fractionalClass_RDR, fractionalClassKey) -- numeric
+ , (floatingClass_RDR, floatingClassKey) -- numeric
+ , (realFracClass_RDR, realFracClassKey) -- numeric
+ , (realFloatClass_RDR, realFloatClassKey) -- numeric
+ , (readClass_RDR, readClassKey) -- derivable
+ , (ixClass_RDR, ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm)
+ , (ccallableClass_RDR, cCallableClassKey) -- mentioned, ccallish
+ , (creturnableClass_RDR, cReturnableClassKey) -- mentioned, ccallish
+
+ -- ClassOps
+ , (fromInt_RDR, fromIntClassOpKey)
+ , (fromInteger_RDR, fromIntegerClassOpKey)
+ , (ge_RDR, geClassOpKey)
+ , (minus_RDR, minusClassOpKey)
+ , (enumFrom_RDR, enumFromClassOpKey)
+ , (enumFromThen_RDR, enumFromThenClassOpKey)
+ , (enumFromTo_RDR, enumFromToClassOpKey)
+ , (enumFromThenTo_RDR, enumFromThenToClassOpKey)
+ , (fromEnum_RDR, fromEnumClassOpKey)
+ , (toEnum_RDR, toEnumClassOpKey)
+ , (eq_RDR, eqClassOpKey)
+ , (thenM_RDR, thenMClassOpKey)
+ , (returnM_RDR, returnMClassOpKey)
+ , (zeroM_RDR, zeroClassOpKey)
+ , (fromRational_RDR, fromRationalClassOpKey)
+
+ -- Others
+ , (otherwiseId_RDR, otherwiseIdKey)
]
+\end{code}
-g_tycons
- = mkFunTyCon : g_con_tycons
+ToDo: make it do the ``like'' part properly (as in 0.26 and before).
-g_con_tycons
- = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..32] ]
+\begin{code}
+maybeCharLikeTyCon tc = if (uniqueOf tc == charDataConKey) then Just charDataCon else Nothing
+maybeIntLikeTyCon tc = if (uniqueOf tc == intDataConKey) then Just intDataCon else Nothing
+\end{code}
-min_nonprim_tycon_list -- used w/ HideMostBuiltinNames
- = [ boolTyCon,
- orderingTyCon,
- charTyCon,
- intTyCon,
- floatTyCon,
- doubleTyCon,
- integerTyCon,
- ratioTyCon,
- liftTyCon,
- return2GMPsTyCon, -- ADR asked for these last two (WDP 94/11)
- returnIntAndGMPTyCon ]
+%************************************************************************
+%* *
+\subsection{Commonly-used RdrNames}
+%* *
+%************************************************************************
-data_tycons
- = [addrTyCon,
- boolTyCon,
--- byteArrayTyCon,
- charTyCon,
- orderingTyCon,
- doubleTyCon,
- floatTyCon,
- intTyCon,
- integerTyCon,
- liftTyCon,
- mallocPtrTyCon,
--- mutableArrayTyCon,
--- mutableByteArrayTyCon,
- ratioTyCon,
- return2GMPsTyCon,
- returnIntAndGMPTyCon,
- stablePtrTyCon,
- stateAndAddrPrimTyCon,
- stateAndArrayPrimTyCon,
- stateAndByteArrayPrimTyCon,
- stateAndCharPrimTyCon,
- stateAndDoublePrimTyCon,
- stateAndFloatPrimTyCon,
- stateAndIntPrimTyCon,
- stateAndMallocPtrPrimTyCon,
- stateAndMutableArrayPrimTyCon,
- stateAndMutableByteArrayPrimTyCon,
- stateAndSynchVarPrimTyCon,
- stateAndPtrPrimTyCon,
- stateAndStablePtrPrimTyCon,
- stateAndWordPrimTyCon,
- stateTyCon,
- wordTyCon
- ]
+These RdrNames are not really "built in", but some parts of the compiler
+(notably the deriving mechanism) need to mention their names, and it's convenient
+to write them all down in one place.
-synonym_tycons
- = [primIoTyCon,
- rationalTyCon,
- stTyCon,
- stringTyCon]
-
-
-totally_wired_in_Ids
- = [(SLIT("error"), WiredInVal eRROR_ID),
- (SLIT("patError#"), WiredInVal pAT_ERROR_ID), -- occurs in i/faces
- (SLIT("parError#"), WiredInVal pAR_ERROR_ID), -- ditto
- (SLIT("_trace"), WiredInVal tRACE_ID),
-
- -- now the foldr/build Ids, which need to be built in
- -- because they have magic unfoldings
- (SLIT("_build"), WiredInVal buildId),
- (SLIT("_augment"), WiredInVal augmentId),
- (SLIT("foldl"), WiredInVal foldlId),
- (SLIT("foldr"), WiredInVal foldrId),
- (SLIT("unpackAppendPS#"), WiredInVal unpackCStringAppendId),
- (SLIT("unpackFoldrPS#"), WiredInVal unpackCStringFoldrId),
-
- (SLIT("_runST"), WiredInVal runSTId),
- (SLIT("_seq_"), WiredInVal seqId), -- yes, used in sequential-land, too
- -- WDP 95/11
- (SLIT("realWorld#"), WiredInVal realWorldPrimId)
- ]
+\begin{code}
+prelude_primop op = qual (modAndOcc (primOpName op))
+
+intTyCon_RDR = qual (modAndOcc intTyCon)
+ioTyCon_RDR = tcQual (iO_BASE, SLIT("IO"))
+orderingTyCon_RDR = tcQual (pREL_BASE, SLIT("Ordering"))
+rationalTyCon_RDR = tcQual (pREL_NUM, SLIT("Rational"))
+ratioTyCon_RDR = tcQual (pREL_NUM, SLIT("Ratio"))
+
+eqClass_RDR = tcQual (pREL_BASE, SLIT("Eq"))
+ordClass_RDR = tcQual (pREL_BASE, SLIT("Ord"))
+evalClass_RDR = tcQual (pREL_BASE, SLIT("Eval"))
+boundedClass_RDR = tcQual (pREL_BASE, SLIT("Bounded"))
+numClass_RDR = tcQual (pREL_BASE, SLIT("Num"))
+enumClass_RDR = tcQual (pREL_BASE, SLIT("Enum"))
+monadClass_RDR = tcQual (pREL_BASE, SLIT("Monad"))
+monadZeroClass_RDR = tcQual (pREL_BASE, SLIT("MonadZero"))
+monadPlusClass_RDR = tcQual (pREL_BASE, SLIT("MonadPlus"))
+functorClass_RDR = tcQual (pREL_BASE, SLIT("Functor"))
+showClass_RDR = tcQual (pREL_BASE, SLIT("Show"))
+realClass_RDR = tcQual (pREL_NUM, SLIT("Real"))
+integralClass_RDR = tcQual (pREL_NUM, SLIT("Integral"))
+fractionalClass_RDR = tcQual (pREL_NUM, SLIT("Fractional"))
+floatingClass_RDR = tcQual (pREL_NUM, SLIT("Floating"))
+realFracClass_RDR = tcQual (pREL_NUM, SLIT("RealFrac"))
+realFloatClass_RDR = tcQual (pREL_NUM, SLIT("RealFloat"))
+readClass_RDR = tcQual (pREL_READ, SLIT("Read"))
+ixClass_RDR = tcQual (iX, SLIT("Ix"))
+ccallableClass_RDR = tcQual (fOREIGN, SLIT("CCallable"))
+creturnableClass_RDR = tcQual (fOREIGN, SLIT("CReturnable"))
+
+fromInt_RDR = varQual (pREL_BASE, SLIT("fromInt"))
+fromInteger_RDR = varQual (pREL_BASE, SLIT("fromInteger"))
+minus_RDR = varQual (pREL_BASE, SLIT("-"))
+toEnum_RDR = varQual (pREL_BASE, SLIT("toEnum"))
+fromEnum_RDR = varQual (pREL_BASE, SLIT("fromEnum"))
+enumFrom_RDR = varQual (pREL_BASE, SLIT("enumFrom"))
+enumFromTo_RDR = varQual (pREL_BASE, SLIT("enumFromTo"))
+enumFromThen_RDR = varQual (pREL_BASE, SLIT("enumFromThen"))
+enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo"))
+
+thenM_RDR = varQual (pREL_BASE, SLIT(">>="))
+returnM_RDR = varQual (pREL_BASE, SLIT("return"))
+zeroM_RDR = varQual (pREL_BASE, SLIT("zero"))
+fromRational_RDR = varQual (pREL_NUM, SLIT("fromRational"))
+
+negate_RDR = varQual (pREL_BASE, SLIT("negate"))
+eq_RDR = varQual (pREL_BASE, SLIT("=="))
+ne_RDR = varQual (pREL_BASE, SLIT("/="))
+le_RDR = varQual (pREL_BASE, SLIT("<="))
+lt_RDR = varQual (pREL_BASE, SLIT("<"))
+ge_RDR = varQual (pREL_BASE, SLIT(">="))
+gt_RDR = varQual (pREL_BASE, SLIT(">"))
+ltTag_RDR = varQual (pREL_BASE, SLIT("LT"))
+eqTag_RDR = varQual (pREL_BASE, SLIT("EQ"))
+gtTag_RDR = varQual (pREL_BASE, SLIT("GT"))
+max_RDR = varQual (pREL_BASE, SLIT("max"))
+min_RDR = varQual (pREL_BASE, SLIT("min"))
+compare_RDR = varQual (pREL_BASE, SLIT("compare"))
+minBound_RDR = varQual (pREL_BASE, SLIT("minBound"))
+maxBound_RDR = varQual (pREL_BASE, SLIT("maxBound"))
+false_RDR = varQual (pREL_BASE, SLIT("False"))
+true_RDR = varQual (pREL_BASE, SLIT("True"))
+and_RDR = varQual (pREL_BASE, SLIT("&&"))
+not_RDR = varQual (pREL_BASE, SLIT("not"))
+compose_RDR = varQual (pREL_BASE, SLIT("."))
+append_RDR = varQual (pREL_BASE, SLIT("++"))
+map_RDR = varQual (pREL_BASE, SLIT("map"))
+
+showList___RDR = varQual (pREL_BASE, SLIT("showList__"))
+showsPrec_RDR = varQual (pREL_BASE, SLIT("showsPrec"))
+showList_RDR = varQual (pREL_BASE, SLIT("showList"))
+showSpace_RDR = varQual (pREL_BASE, SLIT("showSpace"))
+showString_RDR = varQual (pREL_BASE, SLIT("showString"))
+showParen_RDR = varQual (pREL_BASE, SLIT("showParen"))
+
+range_RDR = varQual (iX, SLIT("range"))
+index_RDR = varQual (iX, SLIT("index"))
+inRange_RDR = varQual (iX, SLIT("inRange"))
+
+readsPrec_RDR = varQual (pREL_READ, SLIT("readsPrec"))
+readList_RDR = varQual (pREL_READ, SLIT("readList"))
+readParen_RDR = varQual (pREL_READ, SLIT("readParen"))
+lex_RDR = varQual (pREL_READ, SLIT("lex"))
+readList___RDR = varQual (pREL_READ, SLIT("readList__"))
+
+plus_RDR = varQual (pREL_BASE, SLIT("+"))
+times_RDR = varQual (pREL_BASE, SLIT("*"))
+mkInt_RDR = varQual (pREL_BASE, SLIT("I#"))
+
+error_RDR = varQual (iO_BASE, SLIT("error"))
+
+eqH_Char_RDR = prelude_primop CharEqOp
+ltH_Char_RDR = prelude_primop CharLtOp
+eqH_Word_RDR = prelude_primop WordEqOp
+ltH_Word_RDR = prelude_primop WordLtOp
+eqH_Addr_RDR = prelude_primop AddrEqOp
+ltH_Addr_RDR = prelude_primop AddrLtOp
+eqH_Float_RDR = prelude_primop FloatEqOp
+ltH_Float_RDR = prelude_primop FloatLtOp
+eqH_Double_RDR = prelude_primop DoubleEqOp
+ltH_Double_RDR = prelude_primop DoubleLtOp
+eqH_Int_RDR = prelude_primop IntEqOp
+ltH_Int_RDR = prelude_primop IntLtOp
+geH_RDR = prelude_primop IntGeOp
+leH_RDR = prelude_primop IntLeOp
+minusH_RDR = prelude_primop IntSubOp
+
+main_RDR = varQual (mAIN, SLIT("main"))
+mainPrimIO_RDR = varQual (gHC_MAIN, SLIT("mainPrimIO"))
+
+otherwiseId_RDR = varQual (pREL_BASE, SLIT("otherwise"))
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Class-std-groups]{Standard groups of Prelude classes}
+%* *
+%************************************************************************
+
+@derivableClassKeys@ is also used in checking \tr{deriving} constructs
+(@TcDeriv@).
+
+@derivingOccurrences@ maps a class name to a list of the (qualified) occurrences
+that will be mentioned by the derived code for the class when it is later generated.
+We don't need to put in things that are WiredIn (because they are already mapped to their
+correct name by the @NameSupply@. The class itself, and all its class ops, is
+already flagged as an occurrence so we don't need to mention that either.
-parallel_vals
- =[(SLIT("_par_"), WiredInVal parId),
- (SLIT("_fork_"), WiredInVal forkId)
-#ifdef GRAN
- ,
- (SLIT("_parLocal_"), WiredInVal parLocalId),
- (SLIT("_parGlobal_"), WiredInVal parGlobalId)
- -- Add later:
- -- (SLIT("_parAt_"), WiredInVal parAtId)
- -- (SLIT("_parAtForNow_"), WiredInVal parAtForNowId)
- -- (SLIT("_copyable_"), WiredInVal copyableId)
- -- (SLIT("_noFollow_"), WiredInVal noFollowId)
-#endif {-GRAN-}
- ]
-
-special_class_ops
- = let
- swizzle_over (str, key)
- = (str, ClassOpName key bottom1 str bottom2)
-
- bottom1 = panic "PrelInfo.special_class_ops:class"
- bottom2 = panic "PrelInfo.special_class_ops:tag"
- in
- map swizzle_over
- [ (SLIT("fromInt"), fromIntClassOpKey),
- (SLIT("fromInteger"), fromIntegerClassOpKey),
- (SLIT("fromRational"), fromRationalClassOpKey),
- (SLIT("enumFrom"), enumFromClassOpKey),
- (SLIT("enumFromThen"), enumFromThenClassOpKey),
- (SLIT("enumFromTo"), enumFromToClassOpKey),
- (SLIT("enumFromThenTo"),enumFromThenToClassOpKey),
- (SLIT("=="), eqClassOpKey),
- (SLIT(">="), geClassOpKey),
- (SLIT("-"), negateClassOpKey)
- ]
-
-unboxed_ops
- = map primOpNameInfo allThePrimOps
- -- plus some of the same ones but w/ different names ...
- ++ map fn funny_name_primops
- where
- fn (op,s) = case (primOpNameInfo op) of (_,n) -> (s,n)
-
-funny_name_primops
- = [(IntAddOp, SLIT("+#")),
- (IntSubOp, SLIT("-#")),
- (IntMulOp, SLIT("*#")),
- (IntGtOp, SLIT(">#")),
- (IntGeOp, SLIT(">=#")),
- (IntEqOp, SLIT("==#")),
- (IntNeOp, SLIT("/=#")),
- (IntLtOp, SLIT("<#")),
- (IntLeOp, SLIT("<=#")),
- (DoubleAddOp, SLIT("+##")),
- (DoubleSubOp, SLIT("-##")),
- (DoubleMulOp, SLIT("*##")),
- (DoubleDivOp, SLIT("/##")),
- (DoublePowerOp, SLIT("**##")),
- (DoubleGtOp, SLIT(">##")),
- (DoubleGeOp, SLIT(">=##")),
- (DoubleEqOp, SLIT("==##")),
- (DoubleNeOp, SLIT("/=##")),
- (DoubleLtOp, SLIT("<##")),
- (DoubleLeOp, SLIT("<=##"))]
-
-
-std_tycon_list
- = let
- swizzle_over (mod, nm, key, arity, is_data)
- = let
- fname = mkPreludeCoreName mod nm
- in
- (nm, TyConName key fname arity is_data (panic "std_tycon_list:data_cons"))
- in
- map swizzle_over
- [(SLIT("PreludeMonadicIO"), SLIT("IO"), iOTyConKey, 1, False)
- ]
-
-std_class_list
- = let
- swizzle_over (str, key)
- = (str, ClassName key (mkPreludeCoreName pRELUDE_CORE str) (panic "std_class_list:ops"))
- in
- map swizzle_over
- [(SLIT("Eq"), eqClassKey),
- (SLIT("Ord"), ordClassKey),
- (SLIT("Num"), numClassKey),
- (SLIT("Real"), realClassKey),
- (SLIT("Integral"), integralClassKey),
- (SLIT("Fractional"), fractionalClassKey),
- (SLIT("Floating"), floatingClassKey),
- (SLIT("RealFrac"), realFracClassKey),
- (SLIT("RealFloat"), realFloatClassKey),
- (SLIT("Ix"), ixClassKey),
- (SLIT("Enum"), enumClassKey),
- (SLIT("Show"), showClassKey),
- (SLIT("Read"), readClassKey),
- (SLIT("Monad"), monadClassKey),
- (SLIT("MonadZero"), monadZeroClassKey),
- (SLIT("Binary"), binaryClassKey),
- (SLIT("_CCallable"), cCallableClassKey),
- (SLIT("_CReturnable"), cReturnableClassKey)
- ]
+@derivingOccurrences@ has an item for every derivable class, even if that item is empty,
+because we treat lookup failure as indicating that the class is illegal in a deriving clause.
+\begin{code}
+derivingOccurrences :: UniqFM [RdrName]
+derivingOccurrences = listToUFM deriving_occ_info
+
+derivableClassKeys = map fst deriving_occ_info
+
+deriving_occ_info
+ = [ (eqClassKey, [intTyCon_RDR, and_RDR, not_RDR])
+ , (ordClassKey, [intTyCon_RDR, compose_RDR])
+ , (enumClassKey, [intTyCon_RDR, map_RDR])
+ , (evalClassKey, [intTyCon_RDR])
+ , (boundedClassKey, [intTyCon_RDR])
+ , (showClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR,
+ showParen_RDR, showSpace_RDR, showList___RDR])
+ , (readClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, append_RDR,
+ lex_RDR, readParen_RDR, readList___RDR])
+ , (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR, enumFromTo_RDR])
+ ]
+ -- intTyCon: Practically any deriving needs Int, either for index calculations,
+ -- or for taggery.
+ -- ordClass: really it's the methods that are actually used.
+ -- numClass: for Int literals
\end{code}
-Make table entries for various things:
+
+NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
+even though every numeric class has these two as a superclass,
+because the list of ambiguous dictionaries hasn't been simplified.
+
\begin{code}
-pcTyConNameInfo :: TyCon -> (FAST_STRING, Name)
-pcTyConNameInfo tc = (getOccurrenceName tc, WiredInTyCon tc)
+isCcallishClass, isNoDictClass, isNumericClass, isStandardClass :: Class -> Bool
+
+isNumericClass clas = classKey clas `is_elem` numericClassKeys
+isStandardClass clas = classKey clas `is_elem` standardClassKeys
+isCcallishClass clas = classKey clas `is_elem` cCallishClassKeys
+isNoDictClass clas = classKey clas `is_elem` noDictClassKeys
+is_elem = isIn "is_X_Class"
+
+numericClassKeys
+ = [ numClassKey
+ , realClassKey
+ , integralClassKey
+ , fractionalClassKey
+ , floatingClassKey
+ , realFracClassKey
+ , realFloatClassKey
+ ]
-pcDataConNameInfo :: TyCon -> [(FAST_STRING, Name)]
-pcDataConNameInfo tycon
- = -- slurp out its data constructors...
- [ (getOccurrenceName con, WiredInVal con) | con <- tyConDataCons tycon ]
+needsDataDeclCtxtClassKeys -- see comments in TcDeriv
+ = [ readClassKey
+ ]
+
+cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
+
+standardClassKeys
+ = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
+ --
+ -- We have to have "CCallable" and "CReturnable" in the standard
+ -- classes, so that if you go...
+ --
+ -- _ccall_ foo ... 93{-numeric literal-} ...
+ --
+ -- ... it can do The Right Thing on the 93.
+
+noDictClassKeys -- These classes are used only for type annotations;
+ -- they are not implemented by dictionaries, ever.
+ = cCallishClassKeys
+ -- I used to think that class Eval belonged in here, but
+ -- we really want functions with type (Eval a => ...) and that
+ -- means that we really want to pass a placeholder for an Eval
+ -- dictionary. The unit tuple is what we'll get if we leave things
+ -- alone, and that'll do for now. Could arrange to drop that parameter
+ -- in the end.
\end{code}
projects / ghc-hetmet.git / blobdiff