Move exprIsConApp_maybe to CoreSubst so we can use it in VSO. Fix VSO bug with unlift...
[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, ClassOpItem, 
11         DefMeth (..),
12         defMethSpecOfDefMeth,
13
14         FunDep, pprFundeps, pprFunDep,
15
16         mkClass, classTyVars, classArity, 
17         classKey, className, classATs, classTyCon, classMethods,
18         classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
19         classAllSelIds, classSCSelId
20     ) where
21
22 #include "Typeable.h"
23 #include "HsVersions.h"
24
25 import {-# SOURCE #-} TyCon     ( TyCon, tyConName, tyConUnique )
26 import {-# SOURCE #-} TypeRep   ( PredType )
27
28 import Var
29 import Name
30 import BasicTypes
31 import Unique
32 import Util
33 import Outputable
34 import FastString
35
36 import Data.Typeable hiding (TyCon)
37 import qualified Data.Data as Data
38 \end{code}
39
40 %************************************************************************
41 %*                                                                      *
42 \subsection[Class-basic]{@Class@: basic definition}
43 %*                                                                      *
44 %************************************************************************
45
46 A @Class@ corresponds to a Greek kappa in the static semantics:
47
48 \begin{code}
49 data Class
50   = Class {
51         classTyCon :: TyCon,            -- The data type constructor for
52                                         -- dictionaries of this class
53
54         className :: Name,              -- Just the cached name of the TyCon
55         classKey  :: Unique,            -- Cached unique of TyCon
56         
57         classTyVars  :: [TyVar],        -- The class type variables;
58                                         -- identical to those of the TyCon
59         classFunDeps :: [FunDep TyVar], -- The functional dependencies
60
61         -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)
62         -- We need value-level selectors for both the dictionary 
63         -- superclasses and the equality superclasses
64         classSCTheta :: [PredType],     -- Immediate superclasses, 
65         classSCSels  :: [Id],           -- Selector functions to extract the
66                                         --   superclasses from a 
67                                         --   dictionary of this class
68         -- Associated types
69         classATs     :: [TyCon],        -- Associated type families
70
71         -- Class operations (methods, not superclasses)
72         classOpStuff :: [ClassOpItem]   -- Ordered by tag
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 -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
89 --   the `DefMeth` constructor of the `DefMeth`.
90 defMethSpecOfDefMeth :: DefMeth -> DefMethSpec
91 defMethSpecOfDefMeth meth
92  = case meth of
93         NoDefMeth       -> NoDM
94         DefMeth _       -> VanillaDM
95         GenDefMeth _    -> GenericDM
96
97 \end{code}
98
99 The @mkClass@ function fills in the indirect superclasses.
100
101 \begin{code}
102 mkClass :: [TyVar]
103         -> [([TyVar], [TyVar])]
104         -> [PredType] -> [Id]
105         -> [TyCon]
106         -> [ClassOpItem]
107         -> TyCon
108         -> Class
109
110 mkClass tyvars fds super_classes superdict_sels ats 
111         op_stuff tycon
112   = Class {     classKey     = tyConUnique tycon, 
113                 className    = tyConName tycon,
114                 classTyVars  = tyvars,
115                 classFunDeps = fds,
116                 classSCTheta = super_classes,
117                 classSCSels  = superdict_sels,
118                 classATs     = ats,
119                 classOpStuff = op_stuff,
120                 classTyCon   = tycon }
121 \end{code}
122
123 %************************************************************************
124 %*                                                                      *
125 \subsection[Class-selectors]{@Class@: simple selectors}
126 %*                                                                      *
127 %************************************************************************
128
129 The rest of these functions are just simple selectors.
130
131 \begin{code}
132 classArity :: Class -> Arity
133 classArity clas = length (classTyVars clas)
134         -- Could memoise this
135
136 classAllSelIds :: Class -> [Id]
137 -- Both superclass-dictionary and method selectors
138 classAllSelIds c@(Class {classSCSels = sc_sels})
139   = sc_sels ++ classMethods c
140
141 classSCSelId :: Class -> Int -> Id
142 -- Get the n'th superclass selector Id
143 -- where n is 0-indexed, and counts 
144 --    *all* superclasses including equalities
145 classSCSelId (Class { classSCSels = sc_sels }) n
146   = ASSERT( n >= 0 && n < length sc_sels )
147     sc_sels !! n
148
149 classMethods :: Class -> [Id]
150 classMethods (Class {classOpStuff = op_stuff})
151   = [op_sel | (op_sel, _) <- op_stuff]
152
153 classOpItems :: Class -> [ClassOpItem]
154 classOpItems (Class { classOpStuff = op_stuff})
155   = op_stuff
156
157 classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
158 classTvsFds c
159   = (classTyVars c, classFunDeps c)
160
161 classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
162 classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta, 
163                     classSCSels = sc_sels, classOpStuff = op_stuff})
164   = (tyvars, sc_theta, sc_sels, op_stuff)
165
166 classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [TyCon], [ClassOpItem])
167 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
168                          classSCTheta = sc_theta, classSCSels = sc_sels,
169                          classATs = ats, classOpStuff = op_stuff})
170   = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
171 \end{code}
172
173
174 %************************************************************************
175 %*                                                                      *
176 \subsection[Class-instances]{Instance declarations for @Class@}
177 %*                                                                      *
178 %************************************************************************
179
180 We compare @Classes@ by their keys (which include @Uniques@).
181
182 \begin{code}
183 instance Eq Class where
184     c1 == c2 = classKey c1 == classKey c2
185     c1 /= c2 = classKey c1 /= classKey c2
186
187 instance Ord Class where
188     c1 <= c2 = classKey c1 <= classKey c2
189     c1 <  c2 = classKey c1 <  classKey c2
190     c1 >= c2 = classKey c1 >= classKey c2
191     c1 >  c2 = classKey c1 >  classKey c2
192     compare c1 c2 = classKey c1 `compare` classKey c2
193 \end{code}
194
195 \begin{code}
196 instance Uniquable Class where
197     getUnique c = classKey c
198
199 instance NamedThing Class where
200     getName clas = className clas
201
202 instance Outputable Class where
203     ppr c = ppr (getName c)
204
205 instance Show Class where
206     showsPrec p c = showsPrecSDoc p (ppr c)
207
208 instance Outputable DefMeth where
209     ppr (DefMeth n)    =  ptext (sLit "Default method") <+> ppr n
210     ppr (GenDefMeth n) =  ptext (sLit "Generic default method") <+> ppr n
211     ppr NoDefMeth      =  empty   -- No default method
212
213 pprFundeps :: Outputable a => [FunDep a] -> SDoc
214 pprFundeps []  = empty
215 pprFundeps fds = hsep (ptext (sLit "|") : punctuate comma (map pprFunDep fds))
216
217 pprFunDep :: Outputable a => FunDep a -> SDoc
218 pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs]
219
220 instance Data.Data Class where
221     -- don't traverse?
222     toConstr _   = abstractConstr "Class"
223     gunfold _ _  = error "gunfold"
224     dataTypeOf _ = mkNoRepType "Class"
225 \end{code}