2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
22 mkClass, classTyVars, classArity,
23 classKey, className, classATs, classSelIds, classTyCon, classMethods,
24 classBigSig, classExtraBigSig, classTvsFds, classSCTheta
27 #include "HsVersions.h"
29 import {-# SOURCE #-} TyCon ( TyCon )
30 import {-# SOURCE #-} TypeRep ( PredType )
39 %************************************************************************
41 \subsection[Class-basic]{@Class@: basic definition}
43 %************************************************************************
45 A @Class@ corresponds to a Greek kappa in the static semantics:
50 classKey :: Unique, -- Key for fast comparison
53 classTyVars :: [TyVar], -- The class type variables
54 classFunDeps :: [FunDep TyVar], -- The functional dependencies
56 classSCTheta :: [PredType], -- Immediate superclasses, and the
57 classSCSels :: [Id], -- corresponding selector functions
58 -- to extract them from a dictionary
61 classATs :: [TyCon], -- Associated type families
63 classOpStuff :: [ClassOpItem], -- Ordered by tag
65 classTyCon :: TyCon -- The data type constructor for
66 -- dictionaries of this class
69 type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where...
70 -- Here fun-deps are [([a,b],[c]), ([a,c],[b])]
72 type ClassOpItem = (Id, DefMeth)
73 -- Selector function; contains unfolding
74 -- Default-method info
76 data DefMeth = NoDefMeth -- No default method
77 | DefMeth -- A polymorphic default method
78 | GenDefMeth -- A generic default method
82 The @mkClass@ function fills in the indirect superclasses.
85 mkClass :: Name -> [TyVar]
86 -> [([TyVar], [TyVar])]
93 mkClass name tyvars fds super_classes superdict_sels ats
95 = Class { classKey = getUnique name,
99 classSCTheta = super_classes,
100 classSCSels = superdict_sels,
102 classOpStuff = op_stuff,
106 %************************************************************************
108 \subsection[Class-selectors]{@Class@: simple selectors}
110 %************************************************************************
112 The rest of these functions are just simple selectors.
115 classArity :: Class -> Arity
116 classArity clas = length (classTyVars clas)
117 -- Could memoise this
119 classSelIds :: Class -> [Id]
120 classSelIds c@(Class {classSCSels = sc_sels})
121 = sc_sels ++ classMethods c
123 classMethods :: Class -> [Id]
124 classMethods (Class {classOpStuff = op_stuff})
125 = [op_sel | (op_sel, _) <- op_stuff]
128 = (classTyVars c, classFunDeps c)
130 classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
131 classSCSels = sc_sels, classOpStuff = op_stuff})
132 = (tyvars, sc_theta, sc_sels, op_stuff)
133 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
134 classSCTheta = sc_theta, classSCSels = sc_sels,
135 classATs = ats, classOpStuff = op_stuff})
136 = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
140 %************************************************************************
142 \subsection[Class-instances]{Instance declarations for @Class@}
144 %************************************************************************
146 We compare @Classes@ by their keys (which include @Uniques@).
149 instance Eq Class where
150 c1 == c2 = classKey c1 == classKey c2
151 c1 /= c2 = classKey c1 /= classKey c2
153 instance Ord Class where
154 c1 <= c2 = classKey c1 <= classKey c2
155 c1 < c2 = classKey c1 < classKey c2
156 c1 >= c2 = classKey c1 >= classKey c2
157 c1 > c2 = classKey c1 > classKey c2
158 compare c1 c2 = classKey c1 `compare` classKey c2
162 instance Uniquable Class where
163 getUnique c = classKey c
165 instance NamedThing Class where
166 getName clas = className clas
168 instance Outputable Class where
169 ppr c = ppr (getName c)
171 instance Show Class where
172 showsPrec p c = showsPrecSDoc p (ppr c)
174 instance Outputable DefMeth where
175 ppr DefMeth = text "{- has default method -}"
176 ppr GenDefMeth = text "{- has generic method -}"
177 ppr NoDefMeth = empty -- No default method
179 pprFundeps :: Outputable a => [FunDep a] -> SDoc
180 pprFundeps [] = empty
181 pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
183 ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"),