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, mkTyVarTys, 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         mk_sel sel_id method_or_dict
 300           = mkSelBind sel_id clas_tyvar clas_dict dict_ids method_ids method_or_dict
 301     in
 302     listNF_Tc (zipWithEqual mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
 303     listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids)   `thenNF_Tc` \ sc_sel_binds ->
 304
 305     returnNF_Tc (SingleBind (
 306                  NonRecBind (
 307                  foldr AndMonoBinds
 308                        (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
 309                        sc_sel_binds
 310                  )))
 311 \end{code}
 312
 313 %************************************************************************
 314 %*                                                                      *
 315 \subsection[ClassDcl-misc]{Miscellaneous}
 316 %*                                                                      *
 317 %************************************************************************
 318
 319 Make a selector expression for @sel_id@ from a dictionary @clas_dict@
 320 consisting of @dicts@ and @methods@.
 321
 322 We have to do a bit of jiggery pokery to get the type variables right.
 323 Suppose we have the class decl:
 324 \begin{verbatim}
 325         class Foo a where
 326                 op1 :: Ord b => a -> b -> a
 327                 op2 :: ...
 328 \end{verbatim}
 329 Then the method selector for \tr{op1} is like this:
 330 \begin{verbatim}
 331         op1_sel = /\a b -> \dFoo dOrd -> case dFoo of
 332                                          (op1_method,op2_method) -> op1_method b dOrd
 333 \end{verbatim}
 334 Note that the type variable for \tr{b} and the (Ord b) dictionary
 335 are lifted to the top lambda, and
 336 \tr{op1_method} is applied to them.  This is preferable to the alternative:
 337 \begin{verbatim}
 338         op1_sel' = /\a -> \dFoo -> case dFoo of
 339                                         (op1_method,op2_method) -> op1_method
 340 \end{verbatim}
 341 because \tr{op1_sel'} then has the rather strange type
 342 \begin{verbatim}
 343         op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
 344 \end{verbatim}
 345 whereas \tr{op1_sel} (the one we use) has the decent type
 346 \begin{verbatim}
 347         op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
 348 \end{verbatim}
 349
 350 NOTE that we return a TcMonoBinds (which is later zonked) even though
 351 there's no real back-substitution to do. It's just simpler this way!
 352
 353 NOTE ALSO that the selector has no free type variables, so we
 354 don't bother to instantiate the class-op's local type; instead
 355 we just use the variables inside it.
 356
 357 \begin{code}
 358 mkSelBind :: Id                         -- the selector id
 359           -> TcTyVar s -> TcIdOcc s     -- class tyvar and dict
 360           -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict
 361           -> TcIdOcc s                  -- the superclass/method being slected
 362           -> NF_TcM s (TcMonoBinds s)
 363
 364 mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
 365   = let
 366         (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op)
 367         op_tys = mkTyVarTys op_tyvars
 368     in
 369     newDicts ClassDeclOrigin op_theta   `thenNF_Tc` \ (_, op_dicts) ->
 370
 371         -- sel_id = /\ clas_tyvar op_tyvars -> \ clas_dict op_dicts ->
 372         --          case clas_dict of
 373         --               <dicts..methods> -> method_or_dict op_tyvars op_dicts
 374
 375     returnNF_Tc (VarMonoBind (RealId sel_id)  (
 376                  TyLam (clas_tyvar:op_tyvars) (
 377                  DictLam (clas_dict:op_dicts) (
 378                  HsCase
 379                    (HsVar clas_dict)
 380                    ([PatMatch  (DictPat dicts methods) (
 381                      GRHSMatch (GRHSsAndBindsOut
 382                         [OtherwiseGRHS
 383                            (mkHsDictApp (mkHsTyApp (HsVar method_or_dict) op_tys) op_dicts)
 384                            mkGeneratedSrcLoc]
 385                         EmptyBinds
 386                         op_tau))])
 387                     mkGeneratedSrcLoc
 388                  ))))
 389 \end{code}
 390
 391
 392 %************************************************************************
 393 %*                                                                      *
 394 \subsection[Default methods]{Default methods}
 395 %*                                                                      *
 396 %************************************************************************
 397
 398 The default methods for a class are each passed a dictionary for the
 399 class, so that they get access to the other methods at the same type.
 400 So, given the class decl
 401 \begin{verbatim}
 402 class Foo a where
 403         op1 :: a -> Bool
 404         op2 :: Ord b => a -> b -> b -> b
 405
 406         op1 x = True
 407         op2 x y z = if (op1 x) && (y < z) then y else z
 408 \end{verbatim}
 409 we get the default methods:
 410 \begin{verbatim}
 411 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 412 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 413
 414 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 415 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 416                   if (op1 a dfoo x) && (< b dord y z) then y else z
 417 \end{verbatim}
 418 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 419
 420 When we come across an instance decl, we may need to use the default
 421 methods:
 422 \begin{verbatim}
 423 instance Foo Int where {}
 424 \end{verbatim}
 425 gives
 426 \begin{verbatim}
 427 const.Foo.Int.op1 :: Int -> Bool
 428 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 429
 430 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 431 const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int
 432
 433 dfun.Foo.Int :: Foo Int
 434 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 435 \end{verbatim}
 436 Notice that, as with method selectors above, we assume that dictionary
 437 application is curried, so there's no need to mention the Ord dictionary
 438 in const.Foo.Int.op2
 439 \begin{verbatim}
 440 instance Foo a => Foo [a] where {}
 441
 442 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 443 dfun.Foo.List
 444   = /\ a -> \ dfoo_a ->
 445     let rec
 446         op1 = defm.Foo.op1 [a] dfoo_list
 447         op2 = /\b -> defm.Foo.op2 [a] b dfoo_list
 448         dfoo_list = (op1, op2)
 449     in
 450         dfoo_list
 451 \end{verbatim}
 452
 453 \begin{code}
 454 buildDefaultMethodBinds
 455         :: Class
 456         -> TcTyVar s
 457         -> [Id]
 458         -> RenamedMonoBinds
 459         -> TcM s (LIE s, TcHsBinds s)
 460
 461 buildDefaultMethodBinds clas clas_tyvar
 462                         default_method_ids default_binds
 463   =     -- Deal with the method declarations themselves
 464     mapNF_Tc unZonkId default_method_ids        `thenNF_Tc` \ tc_defm_ids ->
 465     processInstBinds
 466          (makeClassDeclDefaultMethodRhs clas default_method_ids)
 467          []             -- No tyvars in scope for "this inst decl"
 468          emptyLIE       -- No insts available
 469          (map TcId tc_defm_ids)
 470          default_binds          `thenTc` \ (dicts_needed, default_binds') ->
 471
 472     returnTc (dicts_needed, SingleBind (NonRecBind default_binds'))
 473 \end{code}
 474
 475 @makeClassDeclDefaultMethodRhs@ builds the default method for a
 476 class declaration when no explicit default method is given.
 477
 478 \begin{code}
 479 makeClassDeclDefaultMethodRhs
 480         :: Class
 481         -> [Id]
 482         -> Int
 483         -> NF_TcM s (TcExpr s)
 484
 485 makeClassDeclDefaultMethodRhs clas method_ids tag
 486   = specTy ClassDeclOrigin (idType method_id) `thenNF_Tc` \ (tyvars, dicts, tau, dict_ids) ->
 487
 488     returnNF_Tc (mkHsTyLam tyvars (
 489                  mkHsDictLam dict_ids (
 490                  HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [tau])
 491                      (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
 492   where
 493     (clas_mod, clas_name) = getOrigName clas
 494
 495     method_id = method_ids  !! (tag-1)
 496     class_op = (getClassOps clas) !! (tag-1)
 497
 498     error_msg = "%D" -- => No default method for \"
 499              ++ unencoded_part_of_msg
 500
 501     unencoded_part_of_msg = escErrorMsg (
 502         _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
 503              ++ (ppShow 80 (ppr PprForUser class_op))
 504              ++ "\"" )
 505 \end{code}
 506
 507
 508 Contexts
 509 ~~~~~~~~
 510 \begin{code}
 511 classDeclCtxt class_name sty
 512   = ppCat [ppStr "In the class declaration for", ppr sty class_name]
 513 \end{code}