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, tcMethodBind ) 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, InPat(..),
  17                           SYN_IE(RecFlag), nonRecursive, andMonoBinds, collectMonoBinders,
  18                           Stmt, DoOrListComp, ArithSeqInfo, 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          ( 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           ( TcIdOcc(..), SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars,
  37                           tcInstSigType, tcInstSigTcType )
  38 import PragmaInfo       ( PragmaInfo(..) )
  39
  40 import Bag              ( bagToList, unionManyBags )
  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, nameOccName,
  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     tcDefaultMethodBinds 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 tcDefaultMethodBinds
 392         :: Class
 393         -> RenamedMonoBinds
 394         -> TcM s (LIE s, TcMonoBinds s)
 395
 396 tcDefaultMethodBinds clas default_binds
 397   =     -- Construct suitable signatures
 398     tcInstSigTyVars [tyvar]             `thenNF_Tc` \ ([clas_tyvar], [inst_ty], inst_env) ->
 399
 400         -- Typecheck the default bindings
 401     let
 402         clas_tyvar_set = unitTyVarSet clas_tyvar
 403
 404         tc_dm meth_bind
 405           = let
 406                 bndr_name  = case meth_bind of
 407                                 FunMonoBind name _ _ _          -> name
 408                                 PatMonoBind (VarPatIn name) _ _ -> name
 409
 410                 idx        = classOpTagByOccName clas (nameOccName bndr_name) - 1
 411                 sel_id     = op_sel_ids !! idx
 412                 Just dm_id = defm_ids !! idx
 413             in
 414             tcMethodBind clas origin inst_ty sel_id meth_bind
 415                                                 `thenTc` \ (bind, insts, (_, local_dm_id)) ->
 416             returnTc (bind, insts, ([clas_tyvar], RealId dm_id, local_dm_id))
 417     in
 418     tcExtendGlobalTyVars clas_tyvar_set (
 419         mapAndUnzip3Tc tc_dm (flatten default_binds [])
 420     )                                           `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
 421
 422         -- Check the context
 423     newDicts origin [(clas,inst_ty)]            `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 424     let
 425         avail_insts   = this_dict
 426     in
 427     tcSimplifyAndCheck
 428         clas_tyvar_set
 429         avail_insts
 430         (unionManyBags insts_needed)            `thenTc` \ (const_lie, dict_binds) ->
 431
 432     let
 433         full_binds = AbsBinds
 434                         [clas_tyvar]
 435                         [this_dict_id]
 436                         abs_bind_stuff
 437                         (dict_binds `AndMonoBinds` andMonoBinds defm_binds)
 438     in
 439     returnTc (const_lie, full_binds)
 440
 441   where
 442     (tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 443     origin = ClassDeclOrigin
 444
 445     flatten EmptyMonoBinds rest       = rest
 446     flatten (AndMonoBinds b1 b2) rest = flatten b1 (flatten b2 rest)
 447     flatten a_bind rest               = a_bind : rest
 448 \end{code}
 449
 450 @tcMethodBind@ is used to type-check both default-method and
 451 instance-decl method declarations.  We must type-check methods one at a
 452 time, because their signatures may have different contexts and
 453 tyvar sets.
 454
 455 \begin{code}
 456 tcMethodBind
 457         :: Class
 458         -> InstOrigin s
 459         -> TcType s                                     -- Instance type
 460         -> Id                                           -- The method selector
 461         -> RenamedMonoBinds                             -- Method binding (just one)
 462         -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
 463
 464 tcMethodBind clas origin inst_ty sel_id meth_bind
 465  = tcAddSrcLoc src_loc                          $
 466    newMethod origin (RealId sel_id) [inst_ty]   `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
 467    tcInstSigTcType (idType local_meth_id)       `thenNF_Tc` \ (tyvars', rho_ty') ->
 468    let
 469         (theta', tau')  = splitRhoTy rho_ty'
 470         sig_info        = TySigInfo bndr_name local_meth_id tyvars' theta' tau' src_loc
 471    in
 472    tcBindWithSigs [bndr_name] meth_bind [sig_info]
 473                   nonRecursive (\_ -> NoPragmaInfo)     `thenTc` \ (binds, insts, _) ->
 474
 475    returnTc (binds, insts, meth)
 476   where
 477    (bndr_name, src_loc) = case meth_bind of
 478                                 FunMonoBind name _ _ loc          -> (name, loc)
 479                                 PatMonoBind (VarPatIn name) _ loc -> (name, loc)
 480 \end{code}
 481
 482 Contexts
 483 ~~~~~~~~
 484 \begin{code}
 485 classDeclCtxt class_name sty
 486   = hsep [ptext SLIT("In the class declaration for"), ppr sty class_name]
 487 \end{code}