Refactoring and code moving-around, following Max's AT-default patch
[ghc.git] / compiler / types / Class.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 The @Class@ datatype
7
8 \begin{code}
9 module Class (
10         Class,
11         ClassOpItem, DefMeth (..),
12         ClassATItem, ATDefault (..),
13         defMethSpecOfDefMeth,
14
15         FunDep, pprFundeps, pprFunDep,
16
17         mkClass, classTyVars, classArity, 
18         classKey, className, classATs, classATItems, classTyCon, classMethods,
19         classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
20         classAllSelIds, classSCSelId
21     ) where
22
23 #include "Typeable.h"
24 #include "HsVersions.h"
25
26 import {-# SOURCE #-} TyCon     ( TyCon )
27 import {-# SOURCE #-} TypeRep   ( Type, PredType )
28
29 import Var
30 import Name
31 import BasicTypes
32 import Unique
33 import Util
34 import Outputable
35 import FastString
36
37 import Data.Typeable hiding (TyCon)
38 import qualified Data.Data as Data
39 \end{code}
40
41 %************************************************************************
42 %*                                                                      *
43 \subsection[Class-basic]{@Class@: basic definition}
44 %*                                                                      *
45 %************************************************************************
46
47 A @Class@ corresponds to a Greek kappa in the static semantics:
48
49 \begin{code}
50 data Class
51   = Class {
52         classKey  :: Unique,            -- Key for fast comparison
53         className :: Name,
54         
55         classTyVars  :: [TyVar],        -- The class type variables
56         classFunDeps :: [FunDep TyVar], -- The functional dependencies
57
58         -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)
59         -- We need value-level selectors for the dictionary 
60         -- superclasses, but not for the equality superclasses
61         classSCTheta :: [PredType],     -- Immediate superclasses, 
62         classSCSels  :: [Id],           -- Selector functions to extract the
63                                         --   superclasses from a 
64                                         --   dictionary of this class
65         -- Associated types
66         classATStuff :: [ClassATItem],  -- Associated type families
67
68         -- Class operations (methods, not superclasses)
69         classOpStuff :: [ClassOpItem],  -- Ordered by tag
70
71         classTyCon :: TyCon             -- The data type constructor for
72                                         -- dictionaries of this class
73      }
74   deriving Typeable
75
76 type FunDep a = ([a],[a])  --  e.g. class C a b c | a b -> c, a c -> b where...
77                            --  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
78
79 type ClassOpItem = (Id, DefMeth)
80         -- Selector function; contains unfolding
81         -- Default-method info
82
83 data DefMeth = NoDefMeth                -- No default method
84              | DefMeth Name             -- A polymorphic default method
85              | GenDefMeth Name          -- A generic default method
86              deriving Eq
87
88 type ClassATItem = (TyCon, [ATDefault])
89   -- Default associated types from these templates. If the template list is empty,
90   -- we assume that there is no default -- not that the default is to generate no
91   -- instances (this only makes a difference for warnings).
92
93 data ATDefault = ATD [TyVar] [Type] Type
94   -- Each associated type default template is a triple of:
95   --   1. TyVars of the RHS and family arguments (including the class TVs)
96   --   3. The instantiated family arguments
97   --   2. The RHS of the synonym
98
99 -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
100 --   the `DefMeth` constructor of the `DefMeth`.
101 defMethSpecOfDefMeth :: DefMeth -> DefMethSpec
102 defMethSpecOfDefMeth meth
103  = case meth of
104         NoDefMeth       -> NoDM
105         DefMeth _       -> VanillaDM
106         GenDefMeth _    -> GenericDM
107
108 \end{code}
109
110 The @mkClass@ function fills in the indirect superclasses.
111
112 \begin{code}
113 mkClass :: Name -> [TyVar]
114         -> [([TyVar], [TyVar])]
115         -> [PredType] -> [Id]
116         -> [ClassATItem]
117         -> [ClassOpItem]
118         -> TyCon
119         -> Class
120
121 mkClass name tyvars fds super_classes superdict_sels at_stuff
122         op_stuff tycon
123   = Class {     classKey     = getUnique name, 
124                 className    = name,
125                 classTyVars  = tyvars,
126                 classFunDeps = fds,
127                 classSCTheta = super_classes,
128                 classSCSels  = superdict_sels,
129                 classATStuff = at_stuff,
130                 classOpStuff = op_stuff,
131                 classTyCon   = tycon }
132 \end{code}
133
134 %************************************************************************
135 %*                                                                      *
136 \subsection[Class-selectors]{@Class@: simple selectors}
137 %*                                                                      *
138 %************************************************************************
139
140 The rest of these functions are just simple selectors.
141
142 \begin{code}
143 classArity :: Class -> Arity
144 classArity clas = length (classTyVars clas)
145         -- Could memoise this
146
147 classAllSelIds :: Class -> [Id]
148 -- Both superclass-dictionary and method selectors
149 classAllSelIds c@(Class {classSCSels = sc_sels})
150   = sc_sels ++ classMethods c
151
152 classSCSelId :: Class -> Int -> Id
153 -- Get the n'th superclass selector Id
154 -- where n is 0-indexed, and counts 
155 --    *all* superclasses including equalities
156 classSCSelId (Class { classSCSels = sc_sels }) n
157   = ASSERT( n >= 0 && n < length sc_sels )
158     sc_sels !! n
159
160 classMethods :: Class -> [Id]
161 classMethods (Class {classOpStuff = op_stuff})
162   = [op_sel | (op_sel, _) <- op_stuff]
163
164 classOpItems :: Class -> [ClassOpItem]
165 classOpItems = classOpStuff
166
167 classATs :: Class -> [TyCon]
168 classATs (Class { classATStuff = at_stuff })
169   = [tc | (tc, _) <- at_stuff]
170
171 classATItems :: Class -> [ClassATItem]
172 classATItems = classATStuff
173
174 classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
175 classTvsFds c
176   = (classTyVars c, classFunDeps c)
177
178 classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
179 classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta, 
180                     classSCSels = sc_sels, classOpStuff = op_stuff})
181   = (tyvars, sc_theta, sc_sels, op_stuff)
182
183 classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem])
184 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
185                          classSCTheta = sc_theta, classSCSels = sc_sels,
186                          classATStuff = ats, classOpStuff = op_stuff})
187   = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
188 \end{code}
189
190
191 %************************************************************************
192 %*                                                                      *
193 \subsection[Class-instances]{Instance declarations for @Class@}
194 %*                                                                      *
195 %************************************************************************
196
197 We compare @Classes@ by their keys (which include @Uniques@).
198
199 \begin{code}
200 instance Eq Class where
201     c1 == c2 = classKey c1 == classKey c2
202     c1 /= c2 = classKey c1 /= classKey c2
203
204 instance Ord Class where
205     c1 <= c2 = classKey c1 <= classKey c2
206     c1 <  c2 = classKey c1 <  classKey c2
207     c1 >= c2 = classKey c1 >= classKey c2
208     c1 >  c2 = classKey c1 >  classKey c2
209     compare c1 c2 = classKey c1 `compare` classKey c2
210 \end{code}
211
212 \begin{code}
213 instance Uniquable Class where
214     getUnique c = classKey c
215
216 instance NamedThing Class where
217     getName clas = className clas
218
219 instance Outputable Class where
220     ppr c = ppr (getName c)
221
222 instance Show Class where
223     showsPrec p c = showsPrecSDoc p (ppr c)
224
225 instance Outputable DefMeth where
226     ppr (DefMeth n)    =  ptext (sLit "Default method") <+> ppr n
227     ppr (GenDefMeth n) =  ptext (sLit "Generic default method") <+> ppr n
228     ppr NoDefMeth      =  empty   -- No default method
229
230 pprFundeps :: Outputable a => [FunDep a] -> SDoc
231 pprFundeps []  = empty
232 pprFundeps fds = hsep (ptext (sLit "|") : punctuate comma (map pprFunDep fds))
233
234 pprFunDep :: Outputable a => FunDep a -> SDoc
235 pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs]
236
237 instance Data.Data Class where
238     -- don't traverse?
239     toConstr _   = abstractConstr "Class"
240     gunfold _ _  = error "gunfold"
241     dataTypeOf _ = mkNoRepType "Class"
242 \end{code}
243