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