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,
  10                     badMethodErr, tcMethodBind
  11                   ) where
  12
  13 IMP_Ubiq()
  14
  15 import HsSyn            ( HsDecl(..), ClassDecl(..), HsBinds(..), MonoBinds(..),
  16                           Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
  17                           DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity,
  18                           HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar, InPat(..),
  19                           SYN_IE(RecFlag), nonRecursive, andMonoBinds, collectMonoBinders,
  20                           Stmt, DoOrListComp, ArithSeqInfo, Fake )
  21 import HsTypes          ( getTyVarName )
  22 import HsPragmas        ( ClassPragmas(..) )
  23 import RnHsSyn          ( RenamedClassDecl(..), RenamedClassPragmas(..),
  24                           RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds),
  25                           RenamedGenPragmas(..), RenamedContext(..), SYN_IE(RenamedHsDecl)
  26                         )
  27 import TcHsSyn          ( SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr),
  28                           mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
  29
  30 import Inst             ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
  31 import TcEnv            ( tcLookupClass, tcLookupTyVar, newLocalIds, tcAddImportedIdInfo,
  32                           tcExtendGlobalTyVars )
  33 import TcBinds          ( tcBindWithSigs, TcSigInfo(..) )
  34 import TcKind           ( unifyKind, TcKind )
  35 import TcMonad
  36 import TcMonoType       ( tcHsType, tcContext )
  37 import TcSimplify       ( tcSimplifyAndCheck )
  38 import TcType           ( TcIdOcc(..), SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars,
  39                           tcInstSigType, tcInstSigTcType )
  40 import PragmaInfo       ( PragmaInfo(..) )
  41
  42 import Bag              ( bagToList, unionManyBags )
  43 import Class            ( GenClass, mkClass, classBigSig,
  44                           classDefaultMethodId,
  45                           SYN_IE(Class)
  46                         )
  47 import CmdLineOpts      ( opt_PprUserLength )
  48 import Id               ( GenId, mkSuperDictSelId, mkMethodSelId,
  49                           mkDefaultMethodId, getIdUnfolding,
  50                           idType, SYN_IE(Id)
  51                         )
  52 import CoreUnfold       ( getUnfoldingTemplate )
  53 import IdInfo
  54 import Name             ( Name, isLocallyDefined, moduleString, getSrcLoc,
  55                           OccName, nameOccName,
  56                           nameString, NamedThing(..) )
  57 import Outputable
  58 import Pretty
  59 import PprType          ( GenClass, GenType, GenTyVar )
  60 import SpecEnv          ( SpecEnv )
  61 import SrcLoc           ( mkGeneratedSrcLoc )
  62 import Type             ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, splitRhoTy,
  63                           mkForAllTy, mkSigmaTy, splitSigmaTy, SYN_IE(Type)
  64                         )
  65 import TysWiredIn       ( stringTy )
  66 import TyVar            ( unitTyVarSet, GenTyVar, SYN_IE(TyVar) )
  67 import Unique           ( Unique, Uniquable(..) )
  68 import Util
  69 import Maybes           ( assocMaybe, maybeToBool )
  70
  71
  72 -- import TcPragmas     ( tcGenPragmas, tcClassOpPragmas )
  73 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
  74 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec,
  75                                                    noIdInfo)
  76 \end{code}
  77
  78
  79
  80 Dictionary handling
  81 ~~~~~~~~~~~~~~~~~~~
  82 Every class implicitly declares a new data type, corresponding to dictionaries
  83 of that class. So, for example:
  84
  85         class (D a) => C a where
  86           op1 :: a -> a
  87           op2 :: forall b. Ord b => a -> b -> b
  88
  89 would implicitly declare
  90
  91         data CDict a = CDict (D a)
  92                              (a -> a)
  93                              (forall b. Ord b => a -> b -> b)
  94
  95 (We could use a record decl, but that means changing more of the existing apparatus.
  96 One step at at time!)
  97
  98 For classes with just one superclass+method, we use a newtype decl instead:
  99
 100         class C a where
 101           op :: forallb. a -> b -> b
 102
 103 generates
 104
 105         newtype CDict a = CDict (forall b. a -> b -> b)
 106
 107 Now DictTy in Type is just a form of type synomym:
 108         DictTy c t = TyConTy CDict `AppTy` t
 109
 110 Death to "ExpandingDicts".
 111
 112
 113 \begin{code}
 114 tcClassDecl1 rec_env rec_inst_mapper
 115              (ClassDecl context class_name
 116                         tyvar_name class_sigs def_methods pragmas src_loc)
 117   = tcAddSrcLoc src_loc $
 118     tcAddErrCtxt (classDeclCtxt class_name) $
 119
 120         -- LOOK THINGS UP IN THE ENVIRONMENT
 121     tcLookupClass class_name                    `thenTc` \ (class_kind, rec_class) ->
 122     tcLookupTyVar (getTyVarName tyvar_name)     `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
 123     let
 124         rec_class_inst_env = rec_inst_mapper rec_class
 125     in
 126
 127         -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
 128     unifyKind class_kind tyvar_kind     `thenTc_`
 129
 130         -- CHECK THE CONTEXT
 131     tcClassContext rec_class rec_tyvar context pragmas
 132                                 `thenTc` \ (scs, sc_sel_ids) ->
 133
 134         -- CHECK THE CLASS SIGNATURES,
 135     mapTc (tcClassSig rec_env rec_class rec_tyvar) class_sigs
 136                                 `thenTc` \ sig_stuff ->
 137
 138         -- MAKE THE CLASS OBJECT ITSELF
 139     let
 140         (op_sel_ids, defm_ids) = unzip sig_stuff
 141         clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
 142                        scs sc_sel_ids op_sel_ids defm_ids
 143                        rec_class_inst_env
 144     in
 145     returnTc clas
 146 \end{code}
 147
 148
 149     let
 150         clas_ty = mkTyVarTy clas_tyvar
 151         dict_component_tys = classDictArgTys clas_ty
 152         new_or_data = case dict_component_tys of
 153                         [_]   -> NewType
 154                         other -> DataType
 155
 156         dict_con_id = mkDataCon class_name
 157                            [NotMarkedStrict]
 158                            [{- No labelled fields -}]
 159                            [clas_tyvar]
 160                            [{-No context-}]
 161                            dict_component_tys
 162                            tycon
 163
 164         tycon = mkDataTyCon class_name
 165                             (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind)
 166                             [rec_tyvar]
 167                             [{- Empty context -}]
 168                             [dict_con_id]
 169                             [{- No derived classes -}]
 170                             new_or_data
 171     in
 172
 173
 174 \begin{code}
 175 tcClassContext :: Class -> TyVar
 176                -> RenamedContext        -- class context
 177                -> RenamedClassPragmas   -- pragmas for superclasses
 178                -> TcM s ([Class],       -- the superclasses
 179                          [Id])          -- superclass selector Ids
 180
 181 tcClassContext rec_class rec_tyvar context pragmas
 182   =     -- Check the context.
 183         -- The renamer has already checked that the context mentions
 184         -- only the type variable of the class decl.
 185     tcContext context                   `thenTc` \ theta ->
 186     let
 187       super_classes = [ supers | (supers, _) <- theta ]
 188     in
 189
 190         -- Make super-class selector ids
 191     mapTc (mk_super_id rec_class) super_classes `thenTc` \ sc_sel_ids ->
 192
 193         -- Done
 194     returnTc (super_classes, sc_sel_ids)
 195
 196   where
 197     rec_tyvar_ty = mkTyVarTy rec_tyvar
 198
 199     mk_super_id rec_class super_class
 200         = tcGetUnique                   `thenNF_Tc` \ uniq ->
 201           let
 202                 ty = mkForAllTy rec_tyvar $
 203                      mkFunTy (mkDictTy rec_class   rec_tyvar_ty)
 204                              (mkDictTy super_class rec_tyvar_ty)
 205           in
 206           returnTc (mkSuperDictSelId uniq rec_class super_class ty)
 207
 208
 209 tcClassSig :: TcEnv s                   -- Knot tying only!
 210            -> Class                     -- ...ditto...
 211            -> TyVar                     -- The class type variable, used for error check only
 212            -> RenamedClassOpSig
 213            -> TcM s (Id,                -- selector id
 214                      Maybe Id)          -- default-method ids
 215
 216 tcClassSig rec_env rec_clas rec_clas_tyvar
 217            (ClassOpSig op_name maybe_dm_name
 218                        op_ty
 219                        src_loc)
 220   = tcAddSrcLoc src_loc $
 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     in
 233
 234         -- Build the selector id and default method id
 235     let
 236         sel_id      = mkMethodSelId op_name rec_clas global_ty
 237         maybe_dm_id = case maybe_dm_name of
 238                            Nothing      -> Nothing
 239                            Just dm_name -> let
 240                                              dm_id = mkDefaultMethodId dm_name rec_clas global_ty
 241                                            in
 242                                            Just (tcAddImportedIdInfo rec_env dm_id)
 243     in
 244     returnTc (sel_id, maybe_dm_id)
 245 \end{code}
 246
 247
 248 %************************************************************************
 249 %*                                                                      *
 250 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 251 %*                                                                      *
 252 %************************************************************************
 253
 254 The purpose of pass 2 is
 255 \begin{enumerate}
 256 \item
 257 to beat on the explicitly-provided default-method decls (if any),
 258 using them to produce a complete set of default-method decls.
 259 (Omitted ones elicit an error message.)
 260 \item
 261 to produce a definition for the selector function for each method
 262 and superclass dictionary.
 263 \end{enumerate}
 264
 265 Pass~2 only applies to locally-defined class declarations.
 266
 267 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 268 each local class decl.
 269
 270 \begin{code}
 271 tcClassDecls2 :: [RenamedHsDecl]
 272               -> NF_TcM s (LIE s, TcMonoBinds s)
 273
 274 tcClassDecls2 decls
 275   = foldr combine
 276           (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 277           [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
 278   where
 279     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 280                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 281                       returnNF_Tc (lie1 `plusLIE` lie2,
 282                                    binds1 `AndMonoBinds` binds2)
 283 \end{code}
 284
 285 @tcClassDecl2@ is the business end of things.
 286
 287 \begin{code}
 288 tcClassDecl2 :: RenamedClassDecl        -- The class declaration
 289              -> NF_TcM s (LIE s, TcMonoBinds s)
 290
 291 tcClassDecl2 (ClassDecl context class_name
 292                         tyvar_name class_sigs default_binds pragmas src_loc)
 293
 294   | not (isLocallyDefined class_name)
 295   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 296
 297   | otherwise   -- It is locally defined
 298   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
 299     tcAddSrcLoc src_loc                                   $
 300
 301         -- Get the relevant class
 302     tcLookupClass class_name            `thenTc` \ (_, clas) ->
 303     let
 304         (tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 305
 306         -- The selector binds are already in the selector Id's unfoldings
 307         sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
 308                     | sel_id <- sc_sel_ids ++ op_sel_ids,
 309                       isLocallyDefined sel_id
 310                     ]
 311
 312         final_sel_binds = andMonoBinds sel_binds
 313     in
 314         -- Generate bindings for the default methods
 315     tcDefaultMethodBinds clas default_binds             `thenTc` \ (const_insts, meth_binds) ->
 316
 317     returnTc (const_insts,
 318               final_sel_binds `AndMonoBinds` meth_binds)
 319 \end{code}
 320
 321 %************************************************************************
 322 %*                                                                      *
 323 \subsection[Default methods]{Default methods}
 324 %*                                                                      *
 325 %************************************************************************
 326
 327 The default methods for a class are each passed a dictionary for the
 328 class, so that they get access to the other methods at the same type.
 329 So, given the class decl
 330 \begin{verbatim}
 331 class Foo a where
 332         op1 :: a -> Bool
 333         op2 :: Ord b => a -> b -> b -> b
 334
 335         op1 x = True
 336         op2 x y z = if (op1 x) && (y < z) then y else z
 337 \end{verbatim}
 338 we get the default methods:
 339 \begin{verbatim}
 340 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 341 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 342
 343 ====================== OLD ==================
 344 \begin{verbatim}
 345 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 346 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 347                   if (op1 a dfoo x) && (< b dord y z) then y else z
 348 \end{verbatim}
 349 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 350 ====================== END OF OLD ===================
 351
 352 NEW:
 353 \begin{verbatim}
 354 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 355 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 356                   if (op1 a dfoo x) && (< b dord y z) then y else z
 357 \end{verbatim}
 358
 359
 360 When we come across an instance decl, we may need to use the default
 361 methods:
 362 \begin{verbatim}
 363 instance Foo Int where {}
 364 \end{verbatim}
 365 gives
 366 \begin{verbatim}
 367 const.Foo.Int.op1 :: Int -> Bool
 368 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 369
 370 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 371 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 372
 373 dfun.Foo.Int :: Foo Int
 374 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 375 \end{verbatim}
 376 Notice that, as with method selectors above, we assume that dictionary
 377 application is curried, so there's no need to mention the Ord dictionary
 378 in const.Foo.Int.op2 (or the type variable).
 379
 380 \begin{verbatim}
 381 instance Foo a => Foo [a] where {}
 382
 383 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 384 dfun.Foo.List
 385   = /\ a -> \ dfoo_a ->
 386     let rec
 387         op1 = defm.Foo.op1 [a] dfoo_list
 388         op2 = defm.Foo.op2 [a] dfoo_list
 389         dfoo_list = (op1, op2)
 390     in
 391         dfoo_list
 392 \end{verbatim}
 393
 394 \begin{code}
 395 tcDefaultMethodBinds
 396         :: Class
 397         -> RenamedMonoBinds
 398         -> TcM s (LIE s, TcMonoBinds s)
 399
 400 tcDefaultMethodBinds clas default_binds
 401   =     -- Construct suitable signatures
 402     tcInstSigTyVars [tyvar]             `thenNF_Tc` \ ([clas_tyvar], [inst_ty], inst_env) ->
 403
 404         -- Typecheck the default bindings
 405     let
 406         clas_tyvar_set = unitTyVarSet clas_tyvar
 407
 408         tc_dm meth_bind
 409           | not (maybeToBool maybe_stuff)
 410           =     -- Binding for something that isn't in the class signature
 411             failTc (badMethodErr bndr_name clas)
 412
 413           | otherwise
 414           =     -- Normal case
 415             tcMethodBind clas origin inst_ty sel_id meth_bind
 416                                                 `thenTc` \ (bind, insts, (_, local_dm_id)) ->
 417             returnTc (bind, insts, ([clas_tyvar], RealId dm_id, local_dm_id))
 418           where
 419             bndr_name  = case meth_bind of
 420                                 FunMonoBind name _ _ _          -> name
 421                                 PatMonoBind (VarPatIn name) _ _ -> name
 422
 423             maybe_stuff = assocMaybe assoc_list (nameOccName bndr_name)
 424             assoc_list  = [ (getOccName sel_id, pair)
 425                           | pair@(sel_id, dm_ie) <- op_sel_ids `zip` defm_ids
 426                           ]
 427             Just (sel_id, Just dm_id) = maybe_stuff
 428                  -- We're looking at a default-method binding, so the dm_id
 429                  -- is sure to be there!  Hence the inner "Just".
 430     in
 431     tcExtendGlobalTyVars clas_tyvar_set (
 432         mapAndUnzip3Tc tc_dm (flatten default_binds [])
 433     )                                           `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
 434
 435         -- Check the context
 436     newDicts origin [(clas,inst_ty)]            `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 437     let
 438         avail_insts   = this_dict
 439     in
 440     tcSimplifyAndCheck
 441         clas_tyvar_set
 442         avail_insts
 443         (unionManyBags insts_needed)            `thenTc` \ (const_lie, dict_binds) ->
 444
 445     let
 446         full_binds = AbsBinds
 447                         [clas_tyvar]
 448                         [this_dict_id]
 449                         abs_bind_stuff
 450                         (dict_binds `AndMonoBinds` andMonoBinds defm_binds)
 451     in
 452     returnTc (const_lie, full_binds)
 453
 454   where
 455     (tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 456     origin = ClassDeclOrigin
 457
 458     flatten EmptyMonoBinds rest       = rest
 459     flatten (AndMonoBinds b1 b2) rest = flatten b1 (flatten b2 rest)
 460     flatten a_bind rest               = a_bind : rest
 461 \end{code}
 462
 463 @tcMethodBind@ is used to type-check both default-method and
 464 instance-decl method declarations.  We must type-check methods one at a
 465 time, because their signatures may have different contexts and
 466 tyvar sets.
 467
 468 \begin{code}
 469 tcMethodBind
 470         :: Class
 471         -> InstOrigin s
 472         -> TcType s                                     -- Instance type
 473         -> Id                                           -- The method selector
 474         -> RenamedMonoBinds                             -- Method binding (just one)
 475         -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
 476
 477 tcMethodBind clas origin inst_ty sel_id meth_bind
 478  = tcAddSrcLoc src_loc                          $
 479    newMethod origin (RealId sel_id) [inst_ty]   `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
 480    tcInstSigTcType (idType local_meth_id)       `thenNF_Tc` \ (tyvars', rho_ty') ->
 481    let
 482         (theta', tau')  = splitRhoTy rho_ty'
 483         sig_info        = TySigInfo bndr_name local_meth_id tyvars' theta' tau' src_loc
 484    in
 485    tcBindWithSigs [bndr_name] meth_bind [sig_info]
 486                   nonRecursive (\_ -> NoPragmaInfo)     `thenTc` \ (binds, insts, _) ->
 487
 488    returnTc (binds, insts, meth)
 489   where
 490    (bndr_name, src_loc) = case meth_bind of
 491                                 FunMonoBind name _ _ loc          -> (name, loc)
 492                                 PatMonoBind (VarPatIn name) _ loc -> (name, loc)
 493 \end{code}
 494
 495 Contexts and errors
 496 ~~~~~~~~~~~~~~~~~~~
 497 \begin{code}
 498 badMethodErr bndr clas sty
 499   = hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr]
 500
 501 classDeclCtxt class_name sty
 502   = hsep [ptext SLIT("In the class declaration for"), ppr sty class_name]
 503 \end{code}