GenClass(..), SYN_IE(Class),
mkClass,
- classKey, classOps, classGlobalIds,
- classSuperDictSelId, classOpId, classDefaultMethodId,
- classSig, classBigSig, classInstEnv,
+ classKey, classSelIds, classDictArgTys,
+ classSuperDictSelId, classDefaultMethodId,
+ classBigSig, classInstEnv,
isSuperClassOf,
- classOpTagByOccName, classOpTagByOccName_maybe,
-
- GenClassOp(..), SYN_IE(ClassOp),
- mkClassOp,
- classOpTag, classOpString,
- classOpLocalType,
+ classOpTagByOccName,
SYN_IE(ClassInstEnv)
) where
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(TyLoop)
+IMPORT_DELOOPER(IdLoop)
#else
-import {-# SOURCE #-} Id
+import {-# SOURCE #-} Id ( Id, idType, idName )
import {-# SOURCE #-} Type
import {-# SOURCE #-} TysWiredIn
import {-# SOURCE #-} TysPrim
import MatchEnv ( MatchEnv )
import Maybes ( assocMaybe )
import Name ( changeUnique, Name, OccName, occNameString )
-import Outputable
import Unique -- Keys for built-in classes
import Pretty ( Doc, hsep, ptext )
import SrcLoc ( SrcLoc )
+import Outputable
import Util
\end{code}
get appropriately general instances of Ord3 for GenType.
\begin{code}
-data GenClassOp ty
- = ClassOp OccName -- The operation name
-
- Int -- Unique within a class; starts at 1
-
- ty -- Type; the class tyvar is free (you can find
- -- it from the class). This means that a
- -- ClassOp doesn't make much sense outside the
- -- context of its parent class.
-
data GenClass tyvar uvar
= Class
Unique -- Key for fast comparison
-- extract them from a dictionary of this
-- class
- [GenClassOp (GenType tyvar uvar)] -- The * class operations
[Id] -- * selector functions
- [Id] -- * default methods
+ [Maybe Id] -- * default methods
-- They are all ordered by tag. The
-- selector ids are less innocent than they
-- look, because their IdInfos contains
-- the superclass information above.)
type Class = GenClass TyVar UVar
-type ClassOp = GenClassOp Type
type ClassInstEnv = MatchEnv Type Id -- The Ids are dfuns
\end{code}
\begin{code}
mkClass :: Unique -> Name -> TyVar
-> [Class] -> [Id]
- -> [ClassOp] -> [Id] -> [Id]
+ -> [Id] -> [Maybe Id]
-> ClassInstEnv
-> Class
mkClass uniq full_name tyvar super_classes superdict_sels
- class_ops dict_sels defms class_insts
+ dict_sels defms class_insts
= Class uniq (changeUnique full_name uniq) tyvar
super_classes superdict_sels
- class_ops dict_sels defms
+ dict_sels defms
class_insts
trans_clos
where
trans_clos :: [(Class,[Class])]
trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ]
- succ (clas@(Class _ _ _ super_classes _ _ _ _ _ _), links)
+ succ (clas@(Class _ _ _ super_classes _ _ _ _ _), links)
= [(super, (clas:links)) | super <- super_classes]
\end{code}
The rest of these functions are just simple selectors.
\begin{code}
-classKey (Class key _ _ _ _ _ _ _ _ _) = key
-classOps (Class _ _ _ _ _ ops _ _ _ _) = ops
-classGlobalIds (Class _ _ _ _ _ _ sels defm_ids _ _) = sels ++ defm_ids
-
-classOpId (Class _ _ _ _ _ ops op_ids _ _ _) op
- = op_ids !! (classOpTag op - 1)
+classKey (Class key _ _ _ _ _ _ _ _) = key
+classSelIds (Class _ _ _ _ _ sels _ _ _) = sels
-classDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) idx
+classDefaultMethodId (Class _ _ _ _ _ _ defm_ids _ _) idx
= defm_ids !! idx
-classSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas
+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)
+classBigSig (Class _ _ tyvar super_classes sdsels sels defms _ _)
+ = (tyvar, super_classes, sdsels, sels, defms)
-classBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
- = (tyvar, super_classes, sdsels, ops, sels, defms)
+classInstEnv (Class _ _ _ _ _ _ _ inst_env _) = inst_env
-classInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
+classDictArgTys :: Class -> Type -> [Type] -- Types of components of the dictionary (C ty)
+classDictArgTys (Class _ _ _ _ sc_sel_ids meth_sel_ids _ _ _) ty
+ = map mk_arg_ty (sc_sel_ids ++ meth_sel_ids)
+ where
+ mk_arg_ty id = case splitRhoTy (applyTy (idType id) ty) of
+ (sel_theta, meth_ty) -> ASSERT( length sel_theta == 1 )
+ meth_ty
+
+classOpTagByOccName clas occ
+ = go (classSelIds clas) 1
+ where
+ go (sel_id : sel_ids) tag
+ | getOccName (idName sel_id) == occ = tag
+ | otherwise = go sel_ids (tag+1)
+ go [] _ = pprPanic "classOpTagByOccName"
+ (hsep [ppr PprDebug (getName clas), ppr PprDebug occ])
\end{code}
@a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of
\begin{code}
isSuperClassOf :: Class -> Class -> Maybe [Class]
-clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas
+clas `isSuperClassOf` (Class _ _ _ _ _ _ _ _ links) = assocMaybe links clas
\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
- (Class k1 _ _ _ _ _ _ _ _ _) /= (Class k2 _ _ _ _ _ _ _ _ _) = k1 /= k2
+ (Class k1 _ _ _ _ _ _ _ _) == (Class k2 _ _ _ _ _ _ _ _) = k1 == k2
+ (Class k1 _ _ _ _ _ _ _ _) /= (Class k2 _ _ _ _ _ _ _ _) = k1 /= k2
instance Ord (GenClass tyvar uvar) where
- (Class k1 _ _ _ _ _ _ _ _ _) <= (Class k2 _ _ _ _ _ _ _ _ _) = k1 <= k2
- (Class k1 _ _ _ _ _ _ _ _ _) < (Class k2 _ _ _ _ _ _ _ _ _) = k1 < k2
- (Class k1 _ _ _ _ _ _ _ _ _) >= (Class k2 _ _ _ _ _ _ _ _ _) = k1 >= k2
- (Class k1 _ _ _ _ _ _ _ _ _) > (Class k2 _ _ _ _ _ _ _ _ _) = k1 > k2
+ (Class k1 _ _ _ _ _ _ _ _) <= (Class k2 _ _ _ _ _ _ _ _) = k1 <= k2
+ (Class k1 _ _ _ _ _ _ _ _) < (Class k2 _ _ _ _ _ _ _ _) = k1 < k2
+ (Class k1 _ _ _ _ _ _ _ _) >= (Class k2 _ _ _ _ _ _ _ _) = k1 >= k2
+ (Class k1 _ _ _ _ _ _ _ _) > (Class k2 _ _ _ _ _ _ _ _) = k1 > k2
_tagCmp a b = case cmp a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
\end{code}
\begin{code}
instance Uniquable (GenClass tyvar uvar) where
- uniqueOf (Class u _ _ _ _ _ _ _ _ _) = u
+ uniqueOf (Class u _ _ _ _ _ _ _ _) = u
instance NamedThing (GenClass tyvar uvar) where
- getName (Class _ n _ _ _ _ _ _ _ _) = n
-
-instance NamedThing (GenClassOp ty) where
- getOccName (ClassOp occ _ _) = occ
+ getName (Class _ n _ _ _ _ _ _ _) = n
\end{code}
-%************************************************************************
-%* *
-\subsection[ClassOp-basic]{@ClassOp@: type and basic functions}
-%* *
-%************************************************************************
-
-A @ClassOp@ represents a a class operation. From it and its parent
-class we can construct the dictionary-selector @Id@ for the
-operation/superclass dictionary, and the @Id@ for its default method.
-It appears in a list inside the @Class@ object.
-
-The type of a method in a @ClassOp@ object is its local type; that is,
-without the overloading of the class itself. For example, in the
-declaration
-\begin{pseudocode}
- class Foo a where
- op :: Ord b => a -> b -> a
-\end{pseudocode}
-the type recorded for @op@ in the @ClassOp@ list of the @Class@ object is
-just
- $\forall \beta.~
- @Ord@~\beta \Rightarrow
- \alpha \rightarrow \beta \rightarrow alpha$
-
-(where $\alpha$ is the class type variable recorded in the @Class@
-object). Of course, the type of @op@ recorded in the GVE will be its
-``full'' type
-
- $\forall \alpha \forall \beta.~
- @Foo@~\alpha \Rightarrow
- ~@Ord@~\beta \Rightarrow \alpha
- \rightarrow \beta \rightarrow alpha$
-
-******************************************************************
-**** That is, the type variables of a class op selector
-*** are all at the outer level.
-******************************************************************
-
-\begin{code}
-mkClassOp :: OccName -> Int -> ty -> GenClassOp ty
-mkClassOp name tag ty = ClassOp name tag ty
-
-classOpTag :: GenClassOp ty -> Int
-classOpTag (ClassOp _ tag _) = tag
-
-classOpString :: GenClassOp ty -> FAST_STRING
-classOpString (ClassOp occ _ _) = occNameString occ
-
-classOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
-classOpLocalType (ClassOp _ _ ty) = ty
-\end{code}
-
-Rather unsavoury ways of getting ClassOp tags:
-\begin{code}
-classOpTagByOccName_maybe :: Class -> OccName -> Maybe Int
-classOpTagByOccName :: Class -> OccName -> Int
-
-classOpTagByOccName clas op
- = case (classOpTagByOccName_maybe clas op) of
- Just tag -> tag
-#ifdef DEBUG
- Nothing -> pprPanic "classOpTagByOccName:" (hsep (ppr PprDebug op : map (ptext . classOpString) (classOps clas)))
-#endif
-
-classOpTagByOccName_maybe clas op
- = go (classOps clas) 1
- where
- go [] _ = Nothing
- go (ClassOp occ _ _ : ns) tag = if occ == op
- then Just tag
- else go ns (tag+1)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ClassOp-instances]{Instance declarations for @ClassOp@}
-%* *
-%************************************************************************
-
-@ClassOps@ are compared by their tags.
-
-\begin{code}
-instance Eq (GenClassOp ty) where
- (ClassOp _ i1 _) == (ClassOp _ i2 _) = i1 == i2
- (ClassOp _ i1 _) /= (ClassOp _ i2 _) = i1 == i2
-
-instance Ord (GenClassOp ty) where
- (ClassOp _ i1 _) <= (ClassOp _ i2 _) = i1 <= i2
- (ClassOp _ i1 _) < (ClassOp _ i2 _) = i1 < i2
- (ClassOp _ i1 _) >= (ClassOp _ i2 _) = i1 >= i2
- (ClassOp _ i1 _) > (ClassOp _ i2 _) = i1 > i2
- -- ToDo: something for _tagCmp? (WDP 94/10)
-\end{code}
projects / ghc-hetmet.git / commitdiff