ghc/compiler/typecheck/TcClassDcl.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcClassDcl]{Typechecking class declarations}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where
  10
  11 IMP_Ubiq()
  12
  13 import HsSyn            ( HsDecl(..), ClassDecl(..), HsBinds(..), MonoBinds(..),
  14                           Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
  15                           DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity,
  16                           HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar,
  17                           SYN_IE(RecFlag), nonRecursive, andMonoBinds,
  18                           Stmt, DoOrListComp, ArithSeqInfo, InPat, Fake )
  19 import HsTypes          ( getTyVarName )
  20 import HsPragmas        ( ClassPragmas(..) )
  21 import RnHsSyn          ( RenamedClassDecl(..), RenamedClassPragmas(..),
  22                           RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds),
  23                           RenamedGenPragmas(..), RenamedContext(..), SYN_IE(RenamedHsDecl)
  24                         )
  25 import TcHsSyn          ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr),
  26                           mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
  27
  28 import Inst             ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
  29 import TcEnv            ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcAddImportedIdInfo,
  30                           tcExtendGlobalTyVars )
  31 import TcInstDcls       ( tcMethodBind )
  32 import TcKind           ( unifyKind, TcKind )
  33 import TcMonad
  34 import TcMonoType       ( tcHsType, tcContext )
  35 import TcSimplify       ( tcSimplifyAndCheck )
  36 import TcType           ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType )
  37 import PragmaInfo       ( PragmaInfo(..) )
  38
  39 import Bag              ( foldBag, unionManyBags )
  40 import Class            ( GenClass, GenClassOp, mkClass, mkClassOp, classBigSig,
  41                           classOps, classOpString, classOpLocalType, classDefaultMethodId,
  42                           classOpTagByOccName, SYN_IE(ClassOp), SYN_IE(Class)
  43                         )
  44 import CmdLineOpts      ( opt_PprUserLength )
  45 import Id               ( GenId, mkSuperDictSelId, mkMethodSelId,
  46                           mkDefaultMethodId, getIdUnfolding,
  47                           idType, SYN_IE(Id)
  48                         )
  49 import CoreUnfold       ( getUnfoldingTemplate )
  50 import IdInfo
  51 import Name             ( Name, isLocallyDefined, moduleString,
  52                           nameString, NamedThing(..) )
  53 import Outputable
  54 import PrelVals         ( nO_DEFAULT_METHOD_ERROR_ID )
  55 import Pretty
  56 import PprType          ( GenClass, GenType, GenTyVar, GenClassOp )
  57 import SpecEnv          ( SpecEnv )
  58 import SrcLoc           ( mkGeneratedSrcLoc )
  59 import Type             ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
  60                           mkForAllTy, mkSigmaTy, splitSigmaTy, SYN_IE(Type)
  61                         )
  62 import TysWiredIn       ( stringTy )
  63 import TyVar            ( unitTyVarSet, GenTyVar, SYN_IE(TyVar) )
  64 import Unique           ( Unique, Uniquable(..) )
  65 import Util
  66
  67
  68 -- import TcPragmas     ( tcGenPragmas, tcClassOpPragmas )
  69 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
  70 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec,
  71                                                    noIdInfo)
  72 \end{code}
  73
  74
  75
  76 Dictionary handling
  77 ~~~~~~~~~~~~~~~~~~~
  78 Every class implicitly declares a new data type, corresponding to dictionaries
  79 of that class. So, for example:
  80
  81         class (D a) => C a where
  82           op1 :: a -> a
  83           op2 :: forall b. Ord b => a -> b -> b
  84
  85 would implicitly declare
  86
  87         data CDict a = CDict (D a)
  88                              (a -> a)
  89                              (forall b. Ord b => a -> b -> b)
  90
  91 (We could use a record decl, but that means changing more of the existing apparatus.
  92 One step at at time!)
  93
  94 For classes with just one superclass+method, we use a newtype decl instead:
  95
  96         class C a where
  97           op :: forallb. a -> b -> b
  98
  99 generates
 100
 101         newtype CDict a = CDict (forall b. a -> b -> b)
 102
 103 Now DictTy in Type is just a form of type synomym:
 104         DictTy c t = TyConTy CDict `AppTy` t
 105
 106 Death to "ExpandingDicts".
 107
 108
 109 \begin{code}
 110 tcClassDecl1 rec_inst_mapper
 111              (ClassDecl context class_name
 112                         tyvar_name class_sigs def_methods pragmas src_loc)
 113   = tcAddSrcLoc src_loc $
 114     tcAddErrCtxt (classDeclCtxt class_name) $
 115
 116         -- LOOK THINGS UP IN THE ENVIRONMENT
 117     tcLookupClass class_name                    `thenTc` \ (class_kind, rec_class) ->
 118     tcLookupTyVar (getTyVarName tyvar_name)     `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
 119     let
 120         (rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class
 121     in
 122
 123         -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
 124     unifyKind class_kind tyvar_kind     `thenTc_`
 125
 126         -- CHECK THE CONTEXT
 127     tcClassContext rec_class rec_tyvar context pragmas
 128                                 `thenTc` \ (scs, sc_sel_ids) ->
 129
 130         -- CHECK THE CLASS SIGNATURES,
 131     mapTc (tcClassSig rec_class rec_tyvar rec_class_op_inst_fn) class_sigs
 132                                 `thenTc` \ sig_stuff ->
 133
 134         -- MAKE THE CLASS OBJECT ITSELF
 135     let
 136         (ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
 137         clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
 138                        scs sc_sel_ids ops op_sel_ids defm_ids
 139                        rec_class_inst_env
 140     in
 141     returnTc clas
 142 \end{code}
 143
 144
 145     let
 146         clas_ty = mkTyVarTy clas_tyvar
 147         dict_component_tys = [mkDictTy sc clas_ty | sc <- scs] ++
 148                              [classOpLocalType op | op <- ops])
 149         new_or_data = case dict_component_tys of
 150                         [_]   -> NewType
 151                         other -> DataType
 152
 153         dict_con_id = mkDataCon class_name
 154                            [NotMarkedStrict]
 155                            [{- No labelled fields -}]
 156                            [clas_tyvar]
 157                            [{-No context-}]
 158                            dict_component_tys
 159                            tycon
 160
 161         tycon = mkDataTyCon class_name
 162                             (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind)
 163                             [rec_tyvar]
 164                             [{- Empty context -}]
 165                             [dict_con_id]
 166                             [{- No derived classes -}]
 167                             new_or_data
 168     in
 169
 170
 171 \begin{code}
 172 tcClassContext :: Class -> TyVar
 173                -> RenamedContext        -- class context
 174                -> RenamedClassPragmas   -- pragmas for superclasses
 175                -> TcM s ([Class],       -- the superclasses
 176                          [Id])          -- superclass selector Ids
 177
 178 tcClassContext rec_class rec_tyvar context pragmas
 179   =     -- Check the context.
 180         -- The renamer has already checked that the context mentions
 181         -- only the type variable of the class decl.
 182     tcContext context                   `thenTc` \ theta ->
 183     let
 184       super_classes = [ supers | (supers, _) <- theta ]
 185     in
 186
 187         -- Make super-class selector ids
 188     mapTc (mk_super_id rec_class) super_classes `thenTc` \ sc_sel_ids ->
 189
 190         -- Done
 191     returnTc (super_classes, sc_sel_ids)
 192
 193   where
 194     rec_tyvar_ty = mkTyVarTy rec_tyvar
 195
 196     mk_super_id rec_class super_class
 197         = tcGetUnique                   `thenNF_Tc` \ uniq ->
 198           let
 199                 ty = mkForAllTy rec_tyvar $
 200                      mkFunTy (mkDictTy rec_class   rec_tyvar_ty)
 201                              (mkDictTy super_class rec_tyvar_ty)
 202           in
 203           returnTc (mkSuperDictSelId uniq rec_class super_class ty)
 204
 205
 206 tcClassSig :: Class                     -- Knot tying only!
 207            -> TyVar                     -- The class type variable, used for error check only
 208            -> (ClassOp -> SpecEnv)      -- Ditto; the spec info for the class ops
 209            -> RenamedClassOpSig
 210            -> TcM s (ClassOp,           -- class op
 211                      Id,                -- selector id
 212                      Id)                -- default-method ids
 213
 214 tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
 215            (ClassOpSig op_name dm_name
 216                        op_ty
 217                        src_loc)
 218   = tcAddSrcLoc src_loc $
 219     fixTc ( \ ~(_, rec_sel_id, rec_defm_id) ->  -- Knot for pragmas
 220
 221         -- Check the type signature.  NB that the envt *already has*
 222         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 223
 224     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
 225     -- and that it is not constrained by theta
 226     tcHsType op_ty                              `thenTc` \ local_ty ->
 227     let
 228         global_ty   = mkSigmaTy [rec_clas_tyvar]
 229                                 [(rec_clas, mkTyVarTy rec_clas_tyvar)]
 230                                 local_ty
 231         class_op_nm = getOccName op_name
 232         class_op    = mkClassOp class_op_nm
 233                                 (classOpTagByOccName rec_clas{-yeeps!-} class_op_nm)
 234                                 local_ty
 235     in
 236
 237         -- Build the selector id and default method id
 238     let
 239         sel_id  = mkMethodSelId     op_name rec_clas class_op       global_ty
 240         defm_id = mkDefaultMethodId dm_name rec_clas class_op False global_ty
 241                         -- ToDo: improve the "False"
 242     in
 243     tcAddImportedIdInfo defm_id                 `thenNF_Tc` \ final_defm_id ->
 244     returnTc (class_op, sel_id, final_defm_id)
 245     )
 246 \end{code}
 247
 248
 249 %************************************************************************
 250 %*                                                                      *
 251 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 252 %*                                                                      *
 253 %************************************************************************
 254
 255 The purpose of pass 2 is
 256 \begin{enumerate}
 257 \item
 258 to beat on the explicitly-provided default-method decls (if any),
 259 using them to produce a complete set of default-method decls.
 260 (Omitted ones elicit an error message.)
 261 \item
 262 to produce a definition for the selector function for each method
 263 and superclass dictionary.
 264 \end{enumerate}
 265
 266 Pass~2 only applies to locally-defined class declarations.
 267
 268 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 269 each local class decl.
 270
 271 \begin{code}
 272 tcClassDecls2 :: [RenamedHsDecl]
 273               -> NF_TcM s (LIE s, TcHsBinds s)
 274
 275 tcClassDecls2 decls
 276   = foldr combine
 277           (returnNF_Tc (emptyLIE, EmptyBinds))
 278           [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
 279   where
 280     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 281                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 282                       returnNF_Tc (lie1 `plusLIE` lie2,
 283                                    binds1 `ThenBinds` binds2)
 284 \end{code}
 285
 286 @tcClassDecl2@ is the business end of things.
 287
 288 \begin{code}
 289 tcClassDecl2 :: RenamedClassDecl        -- The class declaration
 290              -> NF_TcM s (LIE s, TcHsBinds s)
 291
 292 tcClassDecl2 (ClassDecl context class_name
 293                         tyvar_name class_sigs default_binds pragmas src_loc)
 294
 295   | not (isLocallyDefined class_name)
 296   = returnNF_Tc (emptyLIE, EmptyBinds)
 297
 298   | otherwise   -- It is locally defined
 299   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
 300     tcAddSrcLoc src_loc                               $
 301
 302         -- Get the relevant class
 303     tcLookupClass class_name            `thenTc` \ (_, clas) ->
 304     let
 305         (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
 306           = classBigSig clas
 307
 308         -- The selector binds are already in the selector Id's unfoldings
 309         sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
 310                     | sel_id <- sc_sel_ids ++ op_sel_ids,
 311                       isLocallyDefined sel_id
 312                     ]
 313
 314         final_sel_binds = MonoBind (andMonoBinds sel_binds) [] nonRecursive
 315     in
 316         -- Generate bindings for the default methods
 317     tcInstSigTyVars [tyvar]             `thenNF_Tc` \ ([clas_tyvar], _, _) ->
 318     mapAndUnzipTc (buildDefaultMethodBind clas clas_tyvar default_binds)
 319                   (op_sel_ids `zip` [0..])
 320                                         `thenTc` \ (const_insts_s, meth_binds) ->
 321
 322     returnTc (unionManyBags const_insts_s,
 323               final_sel_binds `ThenBinds`
 324               MonoBind (andMonoBinds meth_binds) [] nonRecursive)
 325 \end{code}
 326
 327 %************************************************************************
 328 %*                                                                      *
 329 \subsection[Default methods]{Default methods}
 330 %*                                                                      *
 331 %************************************************************************
 332
 333 The default methods for a class are each passed a dictionary for the
 334 class, so that they get access to the other methods at the same type.
 335 So, given the class decl
 336 \begin{verbatim}
 337 class Foo a where
 338         op1 :: a -> Bool
 339         op2 :: Ord b => a -> b -> b -> b
 340
 341         op1 x = True
 342         op2 x y z = if (op1 x) && (y < z) then y else z
 343 \end{verbatim}
 344 we get the default methods:
 345 \begin{verbatim}
 346 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 347 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 348
 349 ====================== OLD ==================
 350 \begin{verbatim}
 351 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 352 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 353                   if (op1 a dfoo x) && (< b dord y z) then y else z
 354 \end{verbatim}
 355 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 356 ====================== END OF OLD ===================
 357
 358 NEW:
 359 \begin{verbatim}
 360 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 361 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 362                   if (op1 a dfoo x) && (< b dord y z) then y else z
 363 \end{verbatim}
 364
 365
 366 When we come across an instance decl, we may need to use the default
 367 methods:
 368 \begin{verbatim}
 369 instance Foo Int where {}
 370 \end{verbatim}
 371 gives
 372 \begin{verbatim}
 373 const.Foo.Int.op1 :: Int -> Bool
 374 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 375
 376 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 377 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 378
 379 dfun.Foo.Int :: Foo Int
 380 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 381 \end{verbatim}
 382 Notice that, as with method selectors above, we assume that dictionary
 383 application is curried, so there's no need to mention the Ord dictionary
 384 in const.Foo.Int.op2 (or the type variable).
 385
 386 \begin{verbatim}
 387 instance Foo a => Foo [a] where {}
 388
 389 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 390 dfun.Foo.List
 391   = /\ a -> \ dfoo_a ->
 392     let rec
 393         op1 = defm.Foo.op1 [a] dfoo_list
 394         op2 = defm.Foo.op2 [a] dfoo_list
 395         dfoo_list = (op1, op2)
 396     in
 397         dfoo_list
 398 \end{verbatim}
 399
 400 \begin{code}
 401 buildDefaultMethodBind
 402         :: Class
 403         -> TcTyVar s
 404         -> RenamedMonoBinds
 405         -> (Id, Int)
 406         -> TcM s (LIE s, TcMonoBinds s)
 407
 408 buildDefaultMethodBind clas clas_tyvar default_binds (sel_id, idx)
 409   = newDicts origin [(clas,inst_ty)]                    `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 410     let
 411         avail_insts   = this_dict
 412         defm_id       = classDefaultMethodId clas idx
 413         no_prags name = NoPragmaInfo            -- No pragmas yet for default methods
 414     in
 415     tcExtendGlobalTyVars clas_tyvar_set (
 416         tcMethodBind noDefmExpr inst_ty no_prags default_binds (sel_id, idx)
 417     )                                           `thenTc` \ (defm_bind, insts_needed, (_, local_defm_id)) ->
 418
 419         -- CHECK THE CONTEXT OF THE DEFAULT-METHOD BINDS
 420     tcSimplifyAndCheck
 421         clas_tyvar_set
 422         avail_insts
 423         insts_needed                    `thenTc` \ (const_lie, dict_binds) ->
 424
 425     let
 426         defm_binds = AbsBinds
 427                         [clas_tyvar]
 428                         [this_dict_id]
 429                         [([clas_tyvar], RealId defm_id, local_defm_id)]
 430                         (dict_binds `AndMonoBinds` defm_bind)
 431     in
 432     returnTc (const_lie, defm_binds)
 433
 434   where
 435     clas_tyvar_set    = unitTyVarSet clas_tyvar
 436     inst_ty           = mkTyVarTy clas_tyvar
 437     origin            = ClassDeclOrigin
 438     noDefmExpr _      = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID))
 439                               (HsLit (HsString (_PK_ error_msg)))
 440
 441     error_msg = show (sep [text "Class",  ppr (PprForUser opt_PprUserLength) clas,
 442                                   text "Method", ppr (PprForUser opt_PprUserLength) sel_id])
 443 \end{code}
 444
 445
 446
 447 Contexts
 448 ~~~~~~~~
 449 \begin{code}
 450 classDeclCtxt class_name sty
 451   = hsep [ptext SLIT("In the class declaration for"), ppr sty class_name]
 452 \end{code}