#include "HsVersions.h"
module Class (
- GenClass(..), Class(..),
+ GenClass(..), SYN_IE(Class),
mkClass,
- getClassKey, getClassOps, getClassSelIds,
- getSuperDictSelId, getClassOpId, getDefaultMethodId,
- getClassSig, getClassBigSig, getClassInstEnv,
+ classKey, classOps, classSelIds,
+ classSuperDictSelId, classOpId, classDefaultMethodId,
+ classSig, classBigSig, classInstEnv,
isSuperClassOf,
+ classOpTagByString, classOpTagByString_maybe,
- derivableClassKeys, cCallishClassKeys,
+ derivableClassKeys, needsDataDeclCtxtClassKeys,
+ cCallishClassKeys, isNoDictClass,
isNumericClass, isStandardClass, isCcallishClass,
- GenClassOp(..), ClassOp(..),
+ GenClassOp(..), SYN_IE(ClassOp),
mkClassOp,
- getClassOpTag, getClassOpString,
- getClassOpLocalType,
+ classOpTag, classOpString,
+ classOpLocalType,
- ClassInstEnv(..)
-
- -- and to make the interface self-sufficient...
+ SYN_IE(ClassInstEnv)
) where
CHK_Ubiq() -- debugging consistency check
-import TyLoop
+IMPORT_DELOOPER(TyLoop)
import TyCon ( TyCon )
-import TyVar ( TyVar(..), GenTyVar )
-import Usage ( GenUsage, Usage(..), UVar(..) )
+import TyVar ( SYN_IE(TyVar), GenTyVar )
+import Usage ( GenUsage, SYN_IE(Usage), SYN_IE(UVar) )
-import Maybes ( assocMaybe, Maybe )
---import Name ( Name )
+import MatchEnv ( MatchEnv )
+import Maybes ( assocMaybe )
+import Name ( changeUnique, Name )
import Unique -- Keys for built-in classes
---import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
-import Pretty ( Pretty(..), PrettyRep )
-import PprStyle ( PprStyle )
+import Pretty ( SYN_IE(Pretty), ppCat, ppPStr )
+--import PprStyle ( PprStyle )
import SrcLoc ( SrcLoc )
import Util
\end{code}
mkClass uniq full_name tyvar super_classes superdict_sels
class_ops dict_sels defms class_insts
- = Class uniq full_name tyvar
+ = Class uniq (changeUnique full_name uniq) tyvar
super_classes superdict_sels
class_ops dict_sels defms
class_insts
The rest of these functions are just simple selectors.
\begin{code}
-getClassKey (Class key _ _ _ _ _ _ _ _ _) = key
-getClassOps (Class _ _ _ _ _ ops _ _ _ _) = ops
-getClassSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels
-
-getClassOpId (Class _ _ _ _ _ ops op_ids _ _ _) op
- = op_ids !! (getClassOpTag op - 1)
-getDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) op
- = defm_ids !! (getClassOpTag op - 1)
-getSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas
- = assoc "getSuperDictSelId" (scs `zip` scsel_ids) super_clas
-
-getClassSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)])
-getClassSig (Class _ _ tyvar super_classes _ ops _ _ _ _)
+classKey (Class key _ _ _ _ _ _ _ _ _) = key
+classOps (Class _ _ _ _ _ ops _ _ _ _) = ops
+classSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels
+
+classOpId (Class _ _ _ _ _ ops op_ids _ _ _) op
+ = op_ids !! (classOpTag op - 1)
+classDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) op
+ = defm_ids !! (classOpTag op - 1)
+classSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas
+ = assoc "classSuperDictSelId" (scs `zip` scsel_ids) super_clas
+
+classSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)])
+classSig (Class _ _ tyvar super_classes _ ops _ _ _ _)
= (tyvar, super_classes, ops)
-getClassBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
+classBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
= (tyvar, super_classes, sdsels, ops, sels, defms)
-getClassInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
+classInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
\end{code}
@a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of
\begin{code}
isNumericClass, isStandardClass :: Class -> Bool
-isNumericClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` numericClassKeys
+isNumericClass (Class key _ _ _ _ _ _ _ _ _) = --pprTrace "isNum:" (ppCat (map pprUnique (key : numericClassKeys ))) $
+ key `is_elem` numericClassKeys
isStandardClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
isCcallishClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys
+isNoDictClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` noDictClassKeys
is_elem = isIn "is_X_Class"
numericClassKeys
- = [ numClassKey,
- realClassKey,
- integralClassKey,
- fractionalClassKey,
- floatingClassKey,
- realFracClassKey,
- realFloatClassKey ]
+ = [ numClassKey
+ , realClassKey
+ , integralClassKey
+ , fractionalClassKey
+ , floatingClassKey
+ , realFracClassKey
+ , realFloatClassKey
+ ]
derivableClassKeys
- = [ eqClassKey,
- showClassKey,
- ordClassKey,
- enumClassKey,
- ixClassKey,
- readClassKey ]
+ = [ eqClassKey
+ , ordClassKey
+ , enumClassKey
+ , evalClassKey
+ , boundedClassKey
+ , showClassKey
+ , readClassKey
+ , ixClassKey
+ ]
+
+needsDataDeclCtxtClassKeys -- see comments in TcDeriv
+ = [ readClassKey
+ ]
cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
standardClassKeys
= derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
--
- -- We have to have "_CCallable" and "_CReturnable" in the standard
+ -- 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}
%************************************************************************
\begin{code}
instance Ord3 (GenClass tyvar uvar) where
- cmp (Class k1 _ _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _ _)
- = cmp k1 k2
+ cmp (Class k1 _ _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _ _) = cmp k1 k2
instance Eq (GenClass tyvar uvar) where
(Class k1 _ _ _ _ _ _ _ _ _) == (Class k2 _ _ _ _ _ _ _ _ _) = k1 == k2
mkClassOp :: FAST_STRING -> Int -> ty -> GenClassOp ty
mkClassOp name tag ty = ClassOp name tag ty
-getClassOpTag :: GenClassOp ty -> Int
-getClassOpTag (ClassOp _ tag _) = tag
+classOpTag :: GenClassOp ty -> Int
+classOpTag (ClassOp _ tag _) = tag
+
+classOpString :: GenClassOp ty -> FAST_STRING
+classOpString (ClassOp str _ _) = str
-getClassOpString :: GenClassOp ty -> FAST_STRING
-getClassOpString (ClassOp str _ _) = str
+classOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
+classOpLocalType (ClassOp _ _ ty) = ty
+\end{code}
-getClassOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
-getClassOpLocalType (ClassOp _ _ ty) = ty
+Rather unsavoury ways of getting ClassOp tags:
+\begin{code}
+classOpTagByString_maybe :: Class -> FAST_STRING -> Maybe Int
+classOpTagByString :: Class -> FAST_STRING -> Int
+
+classOpTagByString clas op
+ = case (classOpTagByString_maybe clas op) of
+ Just tag -> tag
+#ifdef DEBUG
+ Nothing -> pprPanic "classOpTagByString:" (ppCat (ppPStr op : map (ppPStr . classOpString) (classOps clas)))
+#endif
+
+classOpTagByString_maybe clas op
+ = go (map classOpString (classOps clas)) 1
+ where
+ go [] _ = Nothing
+ go (n:ns) tag = if n == op
+ then Just tag
+ else go ns (tag+1)
\end{code}
%************************************************************************
projects / ghc-hetmet.git / blobdiff