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