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