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, collectMonoBinders,
  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 TcBinds          ( tcBindWithSigs, TcSigInfo(..) )
  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,
  37                           tcInstSigType, tcInstSigTcType )
  38 import PragmaInfo       ( PragmaInfo(..) )
  39
  40 import Bag              ( bagToList )
  41 import Class            ( GenClass, mkClass, classBigSig,
  42                           classDefaultMethodId,
  43                           classOpTagByOccName, SYN_IE(Class)
  44                         )
  45 import CmdLineOpts      ( opt_PprUserLength )
  46 import Id               ( GenId, mkSuperDictSelId, mkMethodSelId,
  47                           mkDefaultMethodId, getIdUnfolding,
  48                           idType, SYN_IE(Id)
  49                         )
  50 import CoreUnfold       ( getUnfoldingTemplate )
  51 import IdInfo
  52 import Name             ( Name, isLocallyDefined, moduleString, getSrcLoc,
  53                           nameString, NamedThing(..) )
  54 import Outputable
  55 import Pretty
  56 import PprType          ( GenClass, GenType, GenTyVar )
  57 import SpecEnv          ( SpecEnv )
  58 import SrcLoc           ( mkGeneratedSrcLoc )
  59 import Type             ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, splitRhoTy,
  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_env 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_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_env rec_class rec_tyvar) class_sigs
 132                                 `thenTc` \ sig_stuff ->
 133
 134         -- MAKE THE CLASS OBJECT ITSELF
 135     let
 136         (op_sel_ids, defm_ids) = unzip sig_stuff
 137         clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
 138                        scs sc_sel_ids 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 = classDictArgTys clas_ty
 148         new_or_data = case dict_component_tys of
 149                         [_]   -> NewType
 150                         other -> DataType
 151
 152         dict_con_id = mkDataCon class_name
 153                            [NotMarkedStrict]
 154                            [{- No labelled fields -}]
 155                            [clas_tyvar]
 156                            [{-No context-}]
 157                            dict_component_tys
 158                            tycon
 159
 160         tycon = mkDataTyCon class_name
 161                             (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind)
 162                             [rec_tyvar]
 163                             [{- Empty context -}]
 164                             [dict_con_id]
 165                             [{- No derived classes -}]
 166                             new_or_data
 167     in
 168
 169
 170 \begin{code}
 171 tcClassContext :: Class -> TyVar
 172                -> RenamedContext        -- class context
 173                -> RenamedClassPragmas   -- pragmas for superclasses
 174                -> TcM s ([Class],       -- the superclasses
 175                          [Id])          -- superclass selector Ids
 176
 177 tcClassContext rec_class rec_tyvar context pragmas
 178   =     -- Check the context.
 179         -- The renamer has already checked that the context mentions
 180         -- only the type variable of the class decl.
 181     tcContext context                   `thenTc` \ theta ->
 182     let
 183       super_classes = [ supers | (supers, _) <- theta ]
 184     in
 185
 186         -- Make super-class selector ids
 187     mapTc (mk_super_id rec_class) super_classes `thenTc` \ sc_sel_ids ->
 188
 189         -- Done
 190     returnTc (super_classes, sc_sel_ids)
 191
 192   where
 193     rec_tyvar_ty = mkTyVarTy rec_tyvar
 194
 195     mk_super_id rec_class super_class
 196         = tcGetUnique                   `thenNF_Tc` \ uniq ->
 197           let
 198                 ty = mkForAllTy rec_tyvar $
 199                      mkFunTy (mkDictTy rec_class   rec_tyvar_ty)
 200                              (mkDictTy super_class rec_tyvar_ty)
 201           in
 202           returnTc (mkSuperDictSelId uniq rec_class super_class ty)
 203
 204
 205 tcClassSig :: TcEnv s                   -- Knot tying only!
 206            -> Class                     -- ...ditto...
 207            -> TyVar                     -- The class type variable, used for error check only
 208            -> RenamedClassOpSig
 209            -> TcM s (Id,                -- selector id
 210                      Maybe Id)          -- default-method ids
 211
 212 tcClassSig rec_env rec_clas rec_clas_tyvar
 213            (ClassOpSig op_name maybe_dm_name
 214                        op_ty
 215                        src_loc)
 216   = tcAddSrcLoc src_loc $
 217
 218         -- Check the type signature.  NB that the envt *already has*
 219         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 220
 221     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
 222     -- and that it is not constrained by theta
 223     tcHsType op_ty                              `thenTc` \ local_ty ->
 224     let
 225         global_ty   = mkSigmaTy [rec_clas_tyvar]
 226                                 [(rec_clas, mkTyVarTy rec_clas_tyvar)]
 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 global_ty
 233         maybe_dm_id = case maybe_dm_name of
 234                            Nothing      -> Nothing
 235                            Just dm_name -> let
 236                                              dm_id = mkDefaultMethodId dm_name rec_clas global_ty
 237                                            in
 238                                            Just (tcAddImportedIdInfo rec_env dm_id)
 239     in
 240     returnTc (sel_id, maybe_dm_id)
 241 \end{code}
 242
 243
 244 %************************************************************************
 245 %*                                                                      *
 246 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 247 %*                                                                      *
 248 %************************************************************************
 249
 250 The purpose of pass 2 is
 251 \begin{enumerate}
 252 \item
 253 to beat on the explicitly-provided default-method decls (if any),
 254 using them to produce a complete set of default-method decls.
 255 (Omitted ones elicit an error message.)
 256 \item
 257 to produce a definition for the selector function for each method
 258 and superclass dictionary.
 259 \end{enumerate}
 260
 261 Pass~2 only applies to locally-defined class declarations.
 262
 263 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 264 each local class decl.
 265
 266 \begin{code}
 267 tcClassDecls2 :: [RenamedHsDecl]
 268               -> NF_TcM s (LIE s, TcMonoBinds s)
 269
 270 tcClassDecls2 decls
 271   = foldr combine
 272           (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 273           [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
 274   where
 275     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 276                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 277                       returnNF_Tc (lie1 `plusLIE` lie2,
 278                                    binds1 `AndMonoBinds` binds2)
 279 \end{code}
 280
 281 @tcClassDecl2@ is the business end of things.
 282
 283 \begin{code}
 284 tcClassDecl2 :: RenamedClassDecl        -- The class declaration
 285              -> NF_TcM s (LIE s, TcMonoBinds s)
 286
 287 tcClassDecl2 (ClassDecl context class_name
 288                         tyvar_name class_sigs default_binds pragmas src_loc)
 289
 290   | not (isLocallyDefined class_name)
 291   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 292
 293   | otherwise   -- It is locally defined
 294   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
 295     tcAddSrcLoc src_loc                                   $
 296
 297         -- Get the relevant class
 298     tcLookupClass class_name            `thenTc` \ (_, clas) ->
 299     let
 300         (tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 301
 302         -- The selector binds are already in the selector Id's unfoldings
 303         sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
 304                     | sel_id <- sc_sel_ids ++ op_sel_ids,
 305                       isLocallyDefined sel_id
 306                     ]
 307
 308         final_sel_binds = andMonoBinds sel_binds
 309     in
 310         -- Generate bindings for the default methods
 311     buildDefaultMethodBinds clas default_binds          `thenTc` \ (const_insts, meth_binds) ->
 312
 313     returnTc (const_insts,
 314               final_sel_binds `AndMonoBinds` meth_binds)
 315 \end{code}
 316
 317 %************************************************************************
 318 %*                                                                      *
 319 \subsection[Default methods]{Default methods}
 320 %*                                                                      *
 321 %************************************************************************
 322
 323 The default methods for a class are each passed a dictionary for the
 324 class, so that they get access to the other methods at the same type.
 325 So, given the class decl
 326 \begin{verbatim}
 327 class Foo a where
 328         op1 :: a -> Bool
 329         op2 :: Ord b => a -> b -> b -> b
 330
 331         op1 x = True
 332         op2 x y z = if (op1 x) && (y < z) then y else z
 333 \end{verbatim}
 334 we get the default methods:
 335 \begin{verbatim}
 336 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 337 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 338
 339 ====================== OLD ==================
 340 \begin{verbatim}
 341 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 342 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 343                   if (op1 a dfoo x) && (< b dord y z) then y else z
 344 \end{verbatim}
 345 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 346 ====================== END OF OLD ===================
 347
 348 NEW:
 349 \begin{verbatim}
 350 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 351 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 352                   if (op1 a dfoo x) && (< b dord y z) then y else z
 353 \end{verbatim}
 354
 355
 356 When we come across an instance decl, we may need to use the default
 357 methods:
 358 \begin{verbatim}
 359 instance Foo Int where {}
 360 \end{verbatim}
 361 gives
 362 \begin{verbatim}
 363 const.Foo.Int.op1 :: Int -> Bool
 364 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 365
 366 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 367 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 368
 369 dfun.Foo.Int :: Foo Int
 370 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 371 \end{verbatim}
 372 Notice that, as with method selectors above, we assume that dictionary
 373 application is curried, so there's no need to mention the Ord dictionary
 374 in const.Foo.Int.op2 (or the type variable).
 375
 376 \begin{verbatim}
 377 instance Foo a => Foo [a] where {}
 378
 379 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 380 dfun.Foo.List
 381   = /\ a -> \ dfoo_a ->
 382     let rec
 383         op1 = defm.Foo.op1 [a] dfoo_list
 384         op2 = defm.Foo.op2 [a] dfoo_list
 385         dfoo_list = (op1, op2)
 386     in
 387         dfoo_list
 388 \end{verbatim}
 389
 390 \begin{code}
 391 buildDefaultMethodBinds
 392         :: Class
 393         -> RenamedMonoBinds
 394         -> TcM s (LIE s, TcMonoBinds s)
 395
 396 buildDefaultMethodBinds clas default_binds
 397   =     -- Construct suitable signatures
 398     tcInstSigTyVars [tyvar]             `thenNF_Tc` \ ([clas_tyvar], [inst_ty], inst_env) ->
 399     let
 400         mk_sig (bndr_name, locn)
 401           = let
 402                 idx        = classOpTagByOccName clas (getOccName bndr_name) - 1
 403                 sel_id     = op_sel_ids !! idx
 404                 Just dm_id = defm_ids !! idx
 405             in
 406             newMethod origin (RealId sel_id) [inst_ty]  `thenNF_Tc` \ meth@(_, TcId local_dm_id) ->
 407             tcInstSigTcType (idType local_dm_id)        `thenNF_Tc` \ (tyvars', rho_ty') ->
 408             let
 409                 (theta', tau') = splitRhoTy rho_ty'
 410                 sig_info       = TySigInfo bndr_name local_dm_id tyvars' theta' tau' locn
 411             in
 412             returnNF_Tc (sig_info, ([clas_tyvar], RealId dm_id, TcId local_dm_id))
 413     in
 414     mapAndUnzipNF_Tc mk_sig bndrs       `thenNF_Tc` \ (sigs, abs_bind_stuff) ->
 415
 416         -- Typecheck the default bindings
 417     let
 418         clas_tyvar_set    = unitTyVarSet clas_tyvar
 419     in
 420     tcExtendGlobalTyVars clas_tyvar_set (
 421         tcBindWithSigs (map fst bndrs) default_binds sigs nonRecursive (\_ -> NoPragmaInfo)
 422     )                                           `thenTc` \ (defm_binds, insts_needed, _) ->
 423
 424         -- Check the context
 425     newDicts origin [(clas,inst_ty)]            `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 426     let
 427         avail_insts   = this_dict
 428     in
 429     tcSimplifyAndCheck
 430         clas_tyvar_set
 431         avail_insts
 432         insts_needed                    `thenTc` \ (const_lie, dict_binds) ->
 433
 434     let
 435         full_binds = AbsBinds
 436                         [clas_tyvar]
 437                         [this_dict_id]
 438                         abs_bind_stuff
 439                         (dict_binds `AndMonoBinds` defm_binds)
 440     in
 441     returnTc (const_lie, full_binds)
 442
 443   where
 444     (tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 445     origin = ClassDeclOrigin
 446     bndrs  = bagToList (collectMonoBinders default_binds)
 447 \end{code}
 448
 449
 450
 451 Contexts
 452 ~~~~~~~~
 453 \begin{code}
 454 classDeclCtxt class_name sty
 455   = hsep [ptext SLIT("In the class declaration for"), ppr sty class_name]
 456 \end{code}