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