Class.hs 10.1 KB
Newer Older
1 2 3 4
-- (c) The University of Glasgow 2006
-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
--
-- The @Class@ datatype
5

6
{-# LANGUAGE CPP, DeriveDataTypeable #-}
Ian Lynagh's avatar
Ian Lynagh committed
7

8
module Class (
9
        Class,
10
        ClassOpItem, DefMeth (..),
11
        ClassATItem(..),
12
        ClassMinimalDef,
13
        defMethSpecOfDefMeth,
14

15
        FunDep, pprFundeps, pprFunDep,
16

17 18 19
        mkClass, classTyVars, classArity,
        classKey, className, classATs, classATItems, classTyCon, classMethods,
        classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
20
        classAllSelIds, classSCSelId, classMinimalDef, classHasFds
21 22
    ) where

23
#include "HsVersions.h"
24

25 26
import {-# SOURCE #-} TyCon     ( TyCon, tyConName, tyConUnique )
import {-# SOURCE #-} TypeRep   ( Type, PredType )
27 28 29 30
import Var
import Name
import BasicTypes
import Unique
31
import Util
32
import SrcLoc
sof's avatar
sof committed
33
import Outputable
34
import FastString
35
import BooleanFormula (BooleanFormula)
36

37
import Data.Typeable (Typeable)
38
import qualified Data.Data as Data
39

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

50
data Class
51
  = Class {
52 53
        classTyCon :: TyCon,    -- The data type constructor for
                                -- dictionaries of this class
dreixel's avatar
dreixel committed
54
                                -- See Note [ATyCon for classes] in TypeRep
Simon Peyton Jones's avatar
Simon Peyton Jones committed
55

56 57
        className :: Name,              -- Just the cached name of the TyCon
        classKey  :: Unique,            -- Cached unique of TyCon
dreixel's avatar
dreixel committed
58

59 60
        classTyVars  :: [TyVar],        -- The class kind and type variables;
                                        -- identical to those of the TyCon
61

62 63 64 65 66 67 68 69 70 71 72
        classFunDeps :: [FunDep TyVar], -- The functional dependencies

        -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)
        -- We need value-level selectors for both the dictionary
        -- superclasses and the equality superclasses
        classSCTheta :: [PredType],     -- Immediate superclasses,
        classSCSels  :: [Id],           -- Selector functions to extract the
                                        --   superclasses from a
                                        --   dictionary of this class
        -- Associated types
        classATStuff :: [ClassATItem],  -- Associated type families
73

74
        -- Class operations (methods, not superclasses)
75
        classOpStuff :: [ClassOpItem],  -- Ordered by tag
76

77 78
        -- Minimal complete definition
        classMinimalDef :: ClassMinimalDef
79
     }
80
  deriving Typeable
81

Alan Zimmerman's avatar
Alan Zimmerman committed
82 83 84 85 86 87 88
--  | e.g.
--
-- >  class C a b c | a b -> c, a c -> b where...
--
--  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
--
--  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'',
89 90

-- For details on above see note [Api annotations] in ApiAnnotation
Alan Zimmerman's avatar
Alan Zimmerman committed
91
type FunDep a = ([a],[a])
92

93
type ClassOpItem = (Id, DefMeth)
94
        -- Selector function; contains unfolding
95
        -- Default-method info
96

97 98 99
data DefMeth = NoDefMeth                -- No default method
             | DefMeth Name             -- A polymorphic default method
             | GenDefMeth Name          -- A generic default method
100 101
             deriving Eq

102 103
data ClassATItem
  = ATI TyCon         -- See Note [Associated type tyvar names]
104 105
        (Maybe (Type, SrcSpan))
                      -- Default associated type (if any) from this template
106
                      -- Note [Associated type defaults]
dreixel's avatar
dreixel committed
107

108 109
type ClassMinimalDef = BooleanFormula Name -- Required methods

110 111 112 113 114
-- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
--   the `DefMeth` constructor of the `DefMeth`.
defMethSpecOfDefMeth :: DefMeth -> DefMethSpec
defMethSpecOfDefMeth meth
 = case meth of
115 116 117
        NoDefMeth       -> NoDM
        DefMeth _       -> VanillaDM
        GenDefMeth _    -> GenericDM
118

119
{-
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150
Note [Associated type defaults]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The following is an example of associated type defaults:
   class C a where
     data D a r

     type F x a b :: *
     type F p q r = (p,q)->r    -- Default

Note that

 * The TyCons for the associated types *share type variables* with the
   class, so that we can tell which argument positions should be
   instantiated in an instance decl.  (The first for 'D', the second
   for 'F'.)

 * We can have default definitions only for *type* families,
   not data families

 * In the default decl, the "patterns" should all be type variables,
   but (in the source language) they don't need to be the same as in
   the 'type' decl signature or the class.  It's more like a
   free-standing 'type instance' declaration.

 * HOWEVER, in the internal ClassATItem we rename the RHS to match the
   tyConTyVars of the family TyCon.  So in the example above we'd get
   a ClassATItem of
        ATI F ((x,a) -> b)
   So the tyConTyVars of the family TyCon bind the free vars of
   the default Type rhs

151
The @mkClass@ function fills in the indirect superclasses.
152 153

The SrcSpan is for the entire original declaration.
154
-}
155

batterseapower's avatar
batterseapower committed
156
mkClass :: [TyVar]
157 158 159 160 161 162 163
        -> [([TyVar], [TyVar])]
        -> [PredType] -> [Id]
        -> [ClassATItem]
        -> [ClassOpItem]
        -> ClassMinimalDef
        -> TyCon
        -> Class
164

batterseapower's avatar
batterseapower committed
165
mkClass tyvars fds super_classes superdict_sels at_stuff
166 167 168 169 170 171 172 173 174 175 176
        op_stuff mindef tycon
  = Class { classKey     = tyConUnique tycon,
            className    = tyConName tycon,
            classTyVars  = tyvars,
            classFunDeps = fds,
            classSCTheta = super_classes,
            classSCSels  = superdict_sels,
            classATStuff = at_stuff,
            classOpStuff = op_stuff,
            classMinimalDef = mindef,
            classTyCon   = tycon }
177

178
{-
179 180 181 182 183 184 185 186
Note [Associated type tyvar names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The TyCon of an associated type should use the same variable names as its
parent class. Thus
    class C a b where
      type F b x a :: *
We make F use the same Name for 'a' as C does, and similary 'b'.

187
The reason for this is when checking instances it's easier to match
188 189 190 191 192 193
them up, to ensure they match.  Eg
    instance C Int [d] where
      type F [d] x Int = ....
we should make sure that the first and third args match the instance
header.

194 195
Having the same variables for class and tycon is also used in checkValidRoles
(in TcTyClsDecls) when checking a class's roles.
196 197


198 199
************************************************************************
*                                                                      *
200
\subsection[Class-selectors]{@Class@: simple selectors}
201 202
*                                                                      *
************************************************************************
203 204

The rest of these functions are just simple selectors.
205
-}
206

207 208
classArity :: Class -> Arity
classArity clas = length (classTyVars clas)
209
        -- Could memoise this
210

211 212 213
classAllSelIds :: Class -> [Id]
-- Both superclass-dictionary and method selectors
classAllSelIds c@(Class {classSCSels = sc_sels})
214 215
  = sc_sels ++ classMethods c

216 217
classSCSelId :: Class -> Int -> Id
-- Get the n'th superclass selector Id
218
-- where n is 0-indexed, and counts
219
--    *all* superclasses including equalities
220 221 222
classSCSelId (Class { classSCSels = sc_sels }) n
  = ASSERT( n >= 0 && n < length sc_sels )
    sc_sels !! n
223

224 225 226
classMethods :: Class -> [Id]
classMethods (Class {classOpStuff = op_stuff})
  = [op_sel | (op_sel, _) <- op_stuff]
227

228
classOpItems :: Class -> [ClassOpItem]
229 230 231 232
classOpItems = classOpStuff

classATs :: Class -> [TyCon]
classATs (Class { classATStuff = at_stuff })
233
  = [tc | ATI tc _ <- at_stuff]
234 235 236

classATItems :: Class -> [ClassATItem]
classATItems = classATStuff
237

twanvl's avatar
twanvl committed
238
classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
239 240 241
classTvsFds c
  = (classTyVars c, classFunDeps c)

242 243 244
classHasFds :: Class -> Bool
classHasFds (Class { classFunDeps = fds }) = not (null fds)

twanvl's avatar
twanvl committed
245
classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
246 247
classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
                    classSCSels = sc_sels, classOpStuff = op_stuff})
248
  = (tyvars, sc_theta, sc_sels, op_stuff)
twanvl's avatar
twanvl committed
249

250
classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem])
251
classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
252 253
                         classSCTheta = sc_theta, classSCSels = sc_sels,
                         classATStuff = ats, classOpStuff = op_stuff})
254
  = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
255

256 257 258
{-
************************************************************************
*                                                                      *
259
\subsection[Class-instances]{Instance declarations for @Class@}
260 261
*                                                                      *
************************************************************************
262 263

We compare @Classes@ by their keys (which include @Uniques@).
264
-}
265

266 267 268 269 270 271 272 273 274 275
instance Eq Class where
    c1 == c2 = classKey c1 == classKey c2
    c1 /= c2 = classKey c1 /= classKey c2

instance Ord Class where
    c1 <= c2 = classKey c1 <= classKey c2
    c1 <  c2 = classKey c1 <  classKey c2
    c1 >= c2 = classKey c1 >= classKey c2
    c1 >  c2 = classKey c1 >  classKey c2
    compare c1 c2 = classKey c1 `compare` classKey c2
276

277
instance Uniquable Class where
278
    getUnique c = classKey c
279

280
instance NamedThing Class where
281
    getName clas = className clas
282 283 284 285

instance Outputable Class where
    ppr c = ppr (getName c)

286
instance Outputable DefMeth where
287 288 289
    ppr (DefMeth n)    =  ptext (sLit "Default method") <+> ppr n
    ppr (GenDefMeth n) =  ptext (sLit "Generic default method") <+> ppr n
    ppr NoDefMeth      =  empty   -- No default method
290

291 292
pprFundeps :: Outputable a => [FunDep a] -> SDoc
pprFundeps []  = empty
293
pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))
294 295 296

pprFunDep :: Outputable a => FunDep a -> SDoc
pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs]
297 298 299 300 301 302

instance Data.Data Class where
    -- don't traverse?
    toConstr _   = abstractConstr "Class"
    gunfold _ _  = error "gunfold"
    dataTypeOf _ = mkNoRepType "Class"