[project @ 1996-07-25 20:43:49 by partain]

[ghc-hetmet.git] / ghc / compiler / types / Class.lhs

diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs
index e5db71f..e7630b0 100644 (file)
--- a/ghc/compiler/types/Class.lhs
+++ b/ghc/compiler/types/Class.lhs
@@ -7,38 +7,41 @@
 #include "HsVersions.h"
 
 module Class (
-       GenClass(..), Class(..),
+       GenClass(..), SYN_IE(Class),
 
        mkClass,
        classKey, classOps, classSelIds,
        classSuperDictSelId, classOpId, classDefaultMethodId,
        classSig, classBigSig, classInstEnv,
        isSuperClassOf,
-       classOpTagByString,
+       classOpTagByString, classOpTagByString_maybe,
 
-       derivableClassKeys, cCallishClassKeys,
+       derivableClassKeys, needsDataDeclCtxtClassKeys,
+       cCallishClassKeys, isNoDictClass,
        isNumericClass, isStandardClass, isCcallishClass,
 
-       GenClassOp(..), ClassOp(..),
+       GenClassOp(..), SYN_IE(ClassOp),
        mkClassOp,
        classOpTag, classOpString,
        classOpLocalType,
 
-       ClassInstEnv(..)
+       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 MatchEnv                ( MatchEnv )
+import Maybes          ( assocMaybe )
+import Name            ( changeUnique, Name )
 import Unique          -- Keys for built-in classes
-import Pretty          ( Pretty(..), ppCat{-ToDo:rm-}, ppPStr{-ditto-} )
-import PprStyle                ( PprStyle )
+import Pretty          ( SYN_IE(Pretty), ppCat, ppPStr )
+--import PprStyle              ( PprStyle )
 import SrcLoc          ( SrcLoc )
 import Util
 \end{code}
@@ -117,7 +120,7 @@ mkClass :: Unique -> Name -> TyVar
 
 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
@@ -190,25 +193,33 @@ isNumericClass   (Class key _ _ _ _ _ _ _ _ _) = --pprTrace "isNum:" (ppCat (map
                                                 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,
-      boundedClassKey,
-      enumClassKey,
-      ixClassKey,
-      readClassKey ]
+  = [ eqClassKey
+    , ordClassKey
+    , enumClassKey
+    , evalClassKey
+    , boundedClassKey
+    , showClassKey
+    , readClassKey
+    , ixClassKey
+    ]
+
+needsDataDeclCtxtClassKeys -- see comments in TcDeriv
+  = [ readClassKey
+    ]
 
 cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
 
@@ -221,6 +232,16 @@ standardClassKeys
     --     _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}
 
 %************************************************************************
@@ -233,8 +254,7 @@ We compare @Classes@ by their keys (which include @Uniques@).
 
 \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
@@ -311,17 +331,23 @@ classOpLocalType (ClassOp _ _ ty) = ty
 
 Rather unsavoury ways of getting ClassOp tags:
 \begin{code}
-classOpTagByString :: Class -> FAST_STRING -> Int
+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 tag
+                   then Just tag
                    else go ns (tag+1)
-#ifdef DEBUG
-    go []     tag = pprPanic "classOpTagByString:" (ppCat (ppPStr op : map (ppPStr . classOpString) (classOps clas)))
-#endif
 \end{code}
 
 %************************************************************************