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 (
  10         tcClassDecl1, tcClassDecls2
  11     ) where
  12
  13 import Ubiq
  14
  15 import HsSyn            ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
  16                           Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
  17                           HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType,
  18                           Stmt, Qual, ArithSeqInfo, InPat, Fake )
  19 import HsPragmas        ( ClassPragmas(..) )
  20 import RnHsSyn          ( RenamedClassDecl(..), RenamedClassPragmas(..),
  21                           RenamedClassOpSig(..), RenamedMonoBinds(..),
  22                           RenamedGenPragmas(..), RenamedContext(..) )
  23 import TcHsSyn          ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
  24                           mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, unZonkId )
  25
  26 import TcMonad
  27 import GenSpecEtc       ( specTy )
  28 import Inst             ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts )
  29 import TcEnv            ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds)
  30 import TcInstDcls       ( processInstBinds )
  31 import TcKind           ( unifyKind )
  32 import TcMonoType       ( tcMonoType, tcContext )
  33 import TcType           ( TcTyVar(..), tcInstType, tcInstTyVar )
  34 import TcKind           ( TcKind )
  35
  36 import Bag              ( foldBag )
  37 import Class            ( GenClass, mkClass, mkClassOp, getClassBigSig,
  38                           getClassOps, getClassOpString, getClassOpLocalType )
  39 import CoreUtils        ( escErrorMsg )
  40 import Id               ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
  41                           idType )
  42 import IdInfo           ( noIdInfo )
  43 import Name             ( Name, getNameFullName, getTagFromClassOpName )
  44 import PrelVals         ( pAT_ERROR_ID )
  45 import PprStyle
  46 import Pretty
  47 import PprType          ( GenType, GenTyVar, GenClassOp )
  48 import SpecEnv          ( SpecEnv(..) )
  49 import SrcLoc           ( mkGeneratedSrcLoc )
  50 import Type             ( mkFunTy, mkTyVarTy, mkDictTy,
  51                           mkForAllTy, mkSigmaTy, splitSigmaTy)
  52 import TysWiredIn       ( stringTy )
  53 import TyVar            ( GenTyVar )
  54 import Unique           ( Unique )
  55 import Util
  56
  57 -- import TcPragmas     ( tcGenPragmas, tcClassOpPragmas )
  58 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
  59 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo, noIdInfo)
  60
  61 \end{code}
  62
  63 \begin{code}
  64 tcClassDecl1 rec_inst_mapper
  65              (ClassDecl context class_name
  66                         tyvar_name class_sigs def_methods pragmas src_loc)
  67   = tcAddSrcLoc src_loc $
  68     tcAddErrCtxt (classDeclCtxt class_name) $
  69
  70         -- LOOK THINGS UP IN THE ENVIRONMENT
  71     tcLookupClass class_name    `thenNF_Tc` \ (class_kind, rec_class) ->
  72     tcLookupTyVar tyvar_name    `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
  73     let
  74         (rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class
  75     in
  76
  77         -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
  78     unifyKind class_kind tyvar_kind     `thenTc_`
  79
  80         -- CHECK THE CONTEXT
  81     tcClassContext rec_class rec_tyvar context pragmas
  82                                 `thenTc` \ (scs, sc_sel_ids) ->
  83
  84         -- CHECK THE CLASS SIGNATURES,
  85     mapTc (tcClassSig rec_class rec_tyvar rec_class_op_inst_fn) class_sigs
  86                                 `thenTc` \ sig_stuff ->
  87
  88         -- MAKE THE CLASS OBJECT ITSELF
  89     tcGetUnique                 `thenNF_Tc` \ uniq ->
  90     let
  91         (ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
  92         clas = mkClass uniq (getNameFullName class_name) rec_tyvar
  93                        scs sc_sel_ids ops op_sel_ids defm_ids
  94                        rec_class_inst_env
  95     in
  96     returnTc clas
  97 \end{code}
  98
  99
 100 \begin{code}
 101 tcClassContext :: Class -> TyVar
 102                -> RenamedContext        -- class context
 103                -> RenamedClassPragmas   -- pragmas for superclasses
 104                -> TcM s ([Class],       -- the superclasses
 105                          [Id])          -- superclass selector Ids
 106
 107 tcClassContext rec_class rec_tyvar context pragmas
 108   =     -- Check the context.
 109         -- The renamer has already checked that the context mentions
 110         -- only the type variable of the class decl.
 111     tcContext context                   `thenTc` \ theta ->
 112     let
 113       super_classes = [ supers | (supers, _) <- theta ]
 114     in
 115
 116         -- Make super-class selector ids
 117     mapTc (mk_super_id rec_class)
 118           (super_classes `zip` maybe_pragmas)   `thenTc` \ sc_sel_ids ->
 119
 120         -- Done
 121     returnTc (super_classes, sc_sel_ids)
 122
 123   where
 124     mk_super_id rec_class (super_class, maybe_pragma)
 125         = fixTc ( \ rec_super_id ->
 126             tcGetUnique                 `thenNF_Tc` \ uniq ->
 127
 128                 -- GET THE PRAGMA INFO FOR THE SUPERCLASS
 129             (case maybe_pragma of
 130                 Nothing   -> returnNF_Tc noIdInfo
 131                 Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag
 132             )                           `thenNF_Tc` \ id_info ->
 133             let
 134               ty = mkForAllTy rec_tyvar (
 135                    mkFunTy (mkDictTy rec_class   (mkTyVarTy rec_tyvar))
 136                            (mkDictTy super_class (mkTyVarTy rec_tyvar))
 137                    )
 138             in
 139                 -- BUILD THE SUPERCLASS ID
 140             returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info)
 141           )
 142
 143     maybe_pragmas :: [Maybe RenamedGenPragmas]
 144     maybe_pragmas = case pragmas of
 145                         NoClassPragmas         -> repeat Nothing
 146                         SuperDictPragmas prags -> ASSERT(length prags == length context)
 147                                                   map Just prags
 148                         -- If there are any pragmas there should
 149                         -- be one for each superclass
 150
 151
 152
 153 tcClassSig :: Class                     -- Knot tying only!
 154            -> TyVar                     -- The class type variable, used for error check only
 155            -> (ClassOp -> SpecEnv)      -- Ditto; the spec info for the class ops
 156            -> RenamedClassOpSig
 157            -> TcM s (ClassOp,           -- class op
 158                      Id,                -- selector id
 159                      Id)                -- default-method ids
 160
 161 tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
 162            (ClassOpSig op_name
 163                        (HsForAllTy tyvar_names context monotype)
 164                        pragmas src_loc)
 165   = tcAddSrcLoc src_loc $
 166     fixTc ( \ ~(_, rec_sel_id, rec_defm_id) ->  -- Knot for pragmas
 167
 168         -- Check the type signature.  NB that the envt *already has*
 169         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 170     tcContext context                           `thenTc`    \ theta ->
 171     tcMonoType monotype                         `thenTc`    \ tau ->
 172     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (_,tyvars) ->
 173     let
 174         full_tyvars = rec_clas_tyvar : tyvars
 175         full_theta  = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta
 176         global_ty   = mkSigmaTy full_tyvars full_theta tau
 177         local_ty    = mkSigmaTy tyvars theta tau
 178         class_op    = mkClassOp (getOccurrenceName op_name)
 179                                 (getTagFromClassOpName op_name)
 180                                 local_ty
 181     in
 182
 183         -- Munch the pragmas
 184     tcClassOpPragmas
 185                 global_ty
 186                 rec_sel_id rec_defm_id
 187                 (rec_classop_spec_fn class_op)
 188                 pragmas                         `thenNF_Tc` \ (op_info, defm_info) ->
 189
 190         -- Build the selector id and default method id
 191     tcGetUnique                                 `thenNF_Tc` \ d_uniq ->
 192     let
 193         op_uniq = getItsUnique op_name
 194         sel_id  = mkMethodSelId     op_uniq rec_clas class_op global_ty op_info
 195         defm_id = mkDefaultMethodId d_uniq  rec_clas class_op False global_ty defm_info
 196                         -- ToDo: improve the "False"
 197     in
 198     returnTc (class_op, sel_id, defm_id)
 199     )
 200 \end{code}
 201
 202
 203 %************************************************************************
 204 %*                                                                      *
 205 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 206 %*                                                                      *
 207 %************************************************************************
 208
 209 The purpose of pass 2 is
 210 \begin{enumerate}
 211 \item
 212 to beat on the explicitly-provided default-method decls (if any),
 213 using them to produce a complete set of default-method decls.
 214 (Omitted ones elicit an error message.)
 215 \item
 216 to produce a definition for the selector function for each method
 217 and superclass dictionary.
 218 \end{enumerate}
 219
 220 Pass~2 only applies to locally-defined class declarations.
 221
 222 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 223 each local class decl.
 224
 225 \begin{code}
 226 tcClassDecls2 :: Bag RenamedClassDecl
 227               -> NF_TcM s (LIE s, TcHsBinds s)
 228
 229 tcClassDecls2 decls
 230   = foldBag combine
 231             tcClassDecl2
 232             (returnNF_Tc (emptyLIE, EmptyBinds))
 233             decls
 234   where
 235     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 236                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 237                       returnNF_Tc (lie1 `plusLIE` lie2,
 238                                    binds1 `ThenBinds` binds2)
 239 \end{code}
 240
 241 @tcClassDecl2@ is the business end of things.
 242
 243 \begin{code}
 244 tcClassDecl2 :: RenamedClassDecl        -- The class declaration
 245              -> NF_TcM s (LIE s, TcHsBinds s)
 246
 247 tcClassDecl2 (ClassDecl context class_name
 248                         tyvar_name class_sigs default_binds pragmas src_loc)
 249   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
 250     tcAddSrcLoc src_loc                               $
 251
 252         -- Get the relevant class
 253     tcLookupClass class_name            `thenNF_Tc` \ (_, clas) ->
 254     let
 255         (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
 256           = getClassBigSig clas
 257     in
 258     tcInstTyVar tyvar                   `thenNF_Tc` \ clas_tyvar ->
 259
 260         -- Generate bindings for the selector functions
 261     buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids
 262                                                 `thenNF_Tc` \ sel_binds ->
 263         -- Ditto for the methods
 264     buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
 265                                                 `thenTc` \ (const_insts, meth_binds) ->
 266
 267     returnTc (const_insts, sel_binds `ThenBinds` meth_binds)
 268 \end{code}
 269
 270 %************************************************************************
 271 %*                                                                      *
 272 \subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses}
 273 %*                                                                      *
 274 %************************************************************************
 275
 276 \begin{code}
 277 buildSelectors :: Class                 -- The class object
 278                -> TcTyVar s             -- Class type variable
 279                -> [Class] -> [Id]       -- Superclasses and selectors
 280                -> [ClassOp] -> [Id]     -- Class ops and selectors
 281                -> NF_TcM s (TcHsBinds s)
 282
 283 buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids
 284   =
 285         -- Make new Ids for the components of the dictionary
 286     mapNF_Tc (tcInstType [] . getClassOpLocalType) ops  `thenNF_Tc` \ op_tys ->
 287
 288     newLocalIds (map getClassOpString ops) op_tys       `thenNF_Tc` \ method_ids ->
 289
 290     newDicts ClassDeclOrigin
 291              [ (super_clas, mkTyVarTy clas_tyvar)
 292              | super_clas <- scs ]                      `thenNF_Tc` \ (_,dict_ids) ->
 293
 294     newDicts ClassDeclOrigin
 295              [ (clas, mkTyVarTy clas_tyvar) ]           `thenNF_Tc` \ (_,[clas_dict]) ->
 296
 297          -- Make suitable bindings for the selectors
 298     let
 299         tc_method_ids = map TcId method_ids
 300
 301         mk_sel sel_id method_or_dict
 302           = mkSelBind sel_id clas_tyvar clas_dict dict_ids tc_method_ids method_or_dict
 303     in
 304     listNF_Tc (zipWithEqual mk_sel op_sel_ids tc_method_ids) `thenNF_Tc` \ op_sel_binds ->
 305     listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids)      `thenNF_Tc` \ sc_sel_binds ->
 306
 307     returnNF_Tc (SingleBind (
 308                  NonRecBind (
 309                  foldr AndMonoBinds
 310                        (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
 311                        sc_sel_binds
 312                  )))
 313 \end{code}
 314
 315 %************************************************************************
 316 %*                                                                      *
 317 \subsection[ClassDcl-misc]{Miscellaneous}
 318 %*                                                                      *
 319 %************************************************************************
 320
 321 Make a selector expression for @sel_id@ from a dictionary @clas_dict@
 322 consisting of @dicts@ and @methods@.
 323
 324 We have to do a bit of jiggery pokery to get the type variables right.
 325 Suppose we have the class decl:
 326 \begin{verbatim}
 327         class Foo a where
 328                 op1 :: Ord b => a -> b -> a
 329                 op2 :: ...
 330 \end{verbatim}
 331 Then the method selector for \tr{op1} is like this:
 332 \begin{verbatim}
 333         op1_sel = /\a b -> \dFoo dOrd -> case dFoo of
 334                                          (op1_method,op2_method) -> op1_method b dOrd
 335 \end{verbatim}
 336 Note that the type variable for \tr{b} and the (Ord b) dictionary
 337 are lifted to the top lambda, and
 338 \tr{op1_method} is applied to them.  This is preferable to the alternative:
 339 \begin{verbatim}
 340         op1_sel' = /\a -> \dFoo -> case dFoo of
 341                                         (op1_method,op2_method) -> op1_method
 342 \end{verbatim}
 343 because \tr{op1_sel'} then has the rather strange type
 344 \begin{verbatim}
 345         op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
 346 \end{verbatim}
 347 whereas \tr{op1_sel} (the one we use) has the decent type
 348 \begin{verbatim}
 349         op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
 350 \end{verbatim}
 351
 352 NOTE that we return a TcMonoBinds (which is later zonked) even though
 353 there's no real back-substitution to do. It's just simpler this way!
 354
 355 NOTE ALSO that the selector has no free type variables, so we
 356 don't bother to instantiate the class-op's local type; instead
 357 we just use the variables inside it.
 358
 359 \begin{code}
 360 mkSelBind :: Id                         -- the selector id
 361           -> TcTyVar s -> TcIdOcc s     -- class tyvar and dict
 362           -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict
 363           -> TcIdOcc s                  -- the superclass/method being slected
 364           -> NF_TcM s (TcMonoBinds s)
 365
 366 mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
 367   = let
 368         (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op)
 369         op_tys = map mkTyVarTy op_tyvars
 370     in
 371     newDicts ClassDeclOrigin op_theta   `thenNF_Tc` \ (_, op_dicts) ->
 372
 373         -- sel_id = /\ clas_tyvar op_tyvars -> \ clas_dict op_dicts ->
 374         --          case clas_dict of
 375         --               <dicts..methods> -> method_or_dict op_tyvars op_dicts
 376
 377     returnNF_Tc (VarMonoBind (RealId sel_id)  (
 378                  TyLam (clas_tyvar:op_tyvars) (
 379                  DictLam (clas_dict:op_dicts) (
 380                  HsCase
 381                    (HsVar clas_dict)
 382                    ([PatMatch  (DictPat dicts methods) (
 383                      GRHSMatch (GRHSsAndBindsOut
 384                         [OtherwiseGRHS
 385                            (mkHsDictApp (mkHsTyApp (HsVar method_or_dict) op_tys) op_dicts)
 386                            mkGeneratedSrcLoc]
 387                         EmptyBinds
 388                         op_tau))])
 389                     mkGeneratedSrcLoc
 390                  ))))
 391 \end{code}
 392
 393
 394 %************************************************************************
 395 %*                                                                      *
 396 \subsection[Default methods]{Default methods}
 397 %*                                                                      *
 398 %************************************************************************
 399
 400 The default methods for a class are each passed a dictionary for the
 401 class, so that they get access to the other methods at the same type.
 402 So, given the class decl
 403 \begin{verbatim}
 404 class Foo a where
 405         op1 :: a -> Bool
 406         op2 :: Ord b => a -> b -> b -> b
 407
 408         op1 x = True
 409         op2 x y z = if (op1 x) && (y < z) then y else z
 410 \end{verbatim}
 411 we get the default methods:
 412 \begin{verbatim}
 413 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 414 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 415
 416 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 417 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 418                   if (op1 a dfoo x) && (< b dord y z) then y else z
 419 \end{verbatim}
 420 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 421
 422 When we come across an instance decl, we may need to use the default
 423 methods:
 424 \begin{verbatim}
 425 instance Foo Int where {}
 426 \end{verbatim}
 427 gives
 428 \begin{verbatim}
 429 const.Foo.Int.op1 :: Int -> Bool
 430 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 431
 432 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 433 const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int
 434
 435 dfun.Foo.Int :: Foo Int
 436 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 437 \end{verbatim}
 438 Notice that, as with method selectors above, we assume that dictionary
 439 application is curried, so there's no need to mention the Ord dictionary
 440 in const.Foo.Int.op2
 441 \begin{verbatim}
 442 instance Foo a => Foo [a] where {}
 443
 444 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 445 dfun.Foo.List
 446   = /\ a -> \ dfoo_a ->
 447     let rec
 448         op1 = defm.Foo.op1 [a] dfoo_list
 449         op2 = /\b -> defm.Foo.op2 [a] b dfoo_list
 450         dfoo_list = (op1, op2)
 451     in
 452         dfoo_list
 453 \end{verbatim}
 454
 455 \begin{code}
 456 buildDefaultMethodBinds
 457         :: Class
 458         -> TcTyVar s
 459         -> [Id]
 460         -> RenamedMonoBinds
 461         -> TcM s (LIE s, TcHsBinds s)
 462
 463 buildDefaultMethodBinds clas clas_tyvar
 464                         default_method_ids default_binds
 465   =     -- Deal with the method declarations themselves
 466     mapNF_Tc unZonkId default_method_ids        `thenNF_Tc` \ tc_defm_ids ->
 467     processInstBinds
 468          (makeClassDeclDefaultMethodRhs clas default_method_ids)
 469          []             -- No tyvars in scope for "this inst decl"
 470          emptyLIE       -- No insts available
 471          (map TcId tc_defm_ids)
 472          default_binds          `thenTc` \ (dicts_needed, default_binds') ->
 473
 474     returnTc (dicts_needed, SingleBind (NonRecBind default_binds'))
 475 \end{code}
 476
 477 @makeClassDeclDefaultMethodRhs@ builds the default method for a
 478 class declaration when no explicit default method is given.
 479
 480 \begin{code}
 481 makeClassDeclDefaultMethodRhs
 482         :: Class
 483         -> [Id]
 484         -> Int
 485         -> NF_TcM s (TcExpr s)
 486
 487 makeClassDeclDefaultMethodRhs clas method_ids tag
 488   = specTy ClassDeclOrigin (idType method_id) `thenNF_Tc` \ (tyvars, dicts, tau, dict_ids) ->
 489
 490     returnNF_Tc (mkHsTyLam tyvars (
 491                  mkHsDictLam dict_ids (
 492                  HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [tau])
 493                      (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
 494   where
 495     (clas_mod, clas_name) = getOrigName clas
 496
 497     method_id = method_ids  !! (tag-1)
 498     class_op = (getClassOps clas) !! (tag-1)
 499
 500     error_msg = "%D" -- => No default method for \"
 501              ++ unencoded_part_of_msg
 502
 503     unencoded_part_of_msg = escErrorMsg (
 504         _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
 505              ++ (ppShow 80 (ppr PprForUser class_op))
 506              ++ "\"" )
 507 \end{code}
 508
 509
 510 Contexts
 511 ~~~~~~~~
 512 \begin{code}
 513 classDeclCtxt class_name sty
 514   = ppCat [ppStr "In the class declaration for", ppr sty class_name]
 515 \end{code}