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 )
  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           -- NB: we worry about matching list lengths below
 123
 124         -- Done
 125     returnTc (super_classes, sc_sel_ids)
 126
 127   where
 128     mk_super_id rec_class (super_class, maybe_pragma)
 129         = fixTc ( \ rec_super_id ->
 130             tcGetUnique                 `thenNF_Tc` \ uniq ->
 131
 132                 -- GET THE PRAGMA INFO FOR THE SUPERCLASS
 133             (case maybe_pragma of
 134                 Nothing   -> returnNF_Tc noIdInfo
 135                 Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag
 136             )                           `thenNF_Tc` \ id_info ->
 137             let
 138               ty = mkForAllTy rec_tyvar (
 139                    mkFunTy (mkDictTy rec_class   (mkTyVarTy rec_tyvar))
 140                            (mkDictTy super_class (mkTyVarTy rec_tyvar))
 141                    )
 142             in
 143                 -- BUILD THE SUPERCLASS ID
 144             returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info)
 145           )
 146
 147     maybe_pragmas :: [Maybe RenamedGenPragmas]
 148     maybe_pragmas = case pragmas of
 149                         NoClassPragmas         -> repeat Nothing
 150                         SuperDictPragmas prags -> ASSERT(length prags == length context)
 151                                                   map Just prags
 152                         -- If there are any pragmas there should
 153                         -- be one for each superclass
 154
 155
 156
 157 tcClassSig :: Class                     -- Knot tying only!
 158            -> TyVar                     -- The class type variable, used for error check only
 159            -> (ClassOp -> SpecEnv)      -- Ditto; the spec info for the class ops
 160            -> RenamedClassOpSig
 161            -> TcM s (ClassOp,           -- class op
 162                      Id,                -- selector id
 163                      Id)                -- default-method ids
 164
 165 tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
 166            (ClassOpSig op_name
 167                        (HsForAllTy tyvar_names context monotype)
 168                        pragmas src_loc)
 169   = tcAddSrcLoc src_loc $
 170     fixTc ( \ ~(_, rec_sel_id, rec_defm_id) ->  -- Knot for pragmas
 171
 172         -- Check the type signature.  NB that the envt *already has*
 173         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 174     tcContext context                           `thenTc`    \ theta ->
 175     tcMonoType monotype                         `thenTc`    \ tau ->
 176     mapAndUnzipNF_Tc tcLookupTyVar tyvar_names  `thenNF_Tc` \ (_,tyvars) ->
 177     let
 178         full_tyvars = rec_clas_tyvar : tyvars
 179         full_theta  = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta
 180         global_ty   = mkSigmaTy full_tyvars full_theta tau
 181         local_ty    = mkSigmaTy tyvars theta tau
 182         class_op_nm = getLocalName op_name
 183         class_op    = mkClassOp class_op_nm
 184                                 (classOpTagByString rec_clas{-yeeps!-} class_op_nm)
 185                                 local_ty
 186     in
 187
 188         -- Munch the pragmas
 189     tcClassOpPragmas
 190                 global_ty
 191                 rec_sel_id rec_defm_id
 192                 (rec_classop_spec_fn class_op)
 193                 pragmas                         `thenNF_Tc` \ (op_info, defm_info) ->
 194
 195         -- Build the selector id and default method id
 196     tcGetUnique                                 `thenNF_Tc` \ d_uniq ->
 197     let
 198         op_uniq = uniqueOf op_name
 199         sel_id  = mkMethodSelId     op_uniq rec_clas class_op global_ty op_info
 200         defm_id = mkDefaultMethodId d_uniq  rec_clas class_op False global_ty defm_info
 201                         -- ToDo: improve the "False"
 202     in
 203     returnTc (class_op, sel_id, defm_id)
 204     )
 205 \end{code}
 206
 207
 208 %************************************************************************
 209 %*                                                                      *
 210 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 211 %*                                                                      *
 212 %************************************************************************
 213
 214 The purpose of pass 2 is
 215 \begin{enumerate}
 216 \item
 217 to beat on the explicitly-provided default-method decls (if any),
 218 using them to produce a complete set of default-method decls.
 219 (Omitted ones elicit an error message.)
 220 \item
 221 to produce a definition for the selector function for each method
 222 and superclass dictionary.
 223 \end{enumerate}
 224
 225 Pass~2 only applies to locally-defined class declarations.
 226
 227 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 228 each local class decl.
 229
 230 \begin{code}
 231 tcClassDecls2 :: Bag RenamedClassDecl
 232               -> NF_TcM s (LIE s, TcHsBinds s)
 233
 234 tcClassDecls2 decls
 235   = foldBag combine
 236             tcClassDecl2
 237             (returnNF_Tc (emptyLIE, EmptyBinds))
 238             decls
 239   where
 240     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 241                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 242                       returnNF_Tc (lie1 `plusLIE` lie2,
 243                                    binds1 `ThenBinds` binds2)
 244 \end{code}
 245
 246 @tcClassDecl2@ is the business end of things.
 247
 248 \begin{code}
 249 tcClassDecl2 :: RenamedClassDecl        -- The class declaration
 250              -> NF_TcM s (LIE s, TcHsBinds s)
 251
 252 tcClassDecl2 (ClassDecl context class_name
 253                         tyvar_name class_sigs default_binds pragmas src_loc)
 254
 255   | not (isLocallyDefined class_name)
 256   = returnNF_Tc (emptyLIE, EmptyBinds)
 257
 258   | otherwise   -- It is locally defined
 259   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
 260     tcAddSrcLoc src_loc                               $
 261
 262         -- Get the relevant class
 263     tcLookupClass class_name            `thenNF_Tc` \ (_, clas) ->
 264     let
 265         (tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
 266           = classBigSig clas
 267     in
 268     tcInstSigTyVars [tyvar]             `thenNF_Tc` \ ([clas_tyvar], _, _) ->
 269
 270         -- Generate bindings for the selector functions
 271     buildSelectors clas tyvar clas_tyvar scs sc_sel_ids ops op_sel_ids
 272                                         `thenNF_Tc` \ sel_binds ->
 273         -- Ditto for the methods
 274     buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
 275                                         `thenTc` \ (const_insts, meth_binds) ->
 276
 277     returnTc (const_insts, sel_binds `ThenBinds` meth_binds)
 278 \end{code}
 279
 280 %************************************************************************
 281 %*                                                                      *
 282 \subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses}
 283 %*                                                                      *
 284 %************************************************************************
 285
 286 \begin{code}
 287 buildSelectors :: Class                 -- The class object
 288                -> TyVar                 -- Class type variable
 289                -> TcTyVar s             -- Instantiated class type variable (TyVarTy)
 290                -> [Class] -> [Id]       -- Superclasses and selectors
 291                -> [ClassOp] -> [Id]     -- Class ops and selectors
 292                -> NF_TcM s (TcHsBinds s)
 293
 294 buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids
 295   =
 296         -- Make new Ids for the components of the dictionary
 297     let
 298         clas_tyvar_ty = mkTyVarTy clas_tc_tyvar
 299         mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . classOpLocalType
 300     in
 301     mapNF_Tc mk_op_ty ops                               `thenNF_Tc` \ op_tys ->
 302     newLocalIds (map classOpString ops) op_tys  `thenNF_Tc` \ method_ids ->
 303
 304     newDicts ClassDeclOrigin
 305              [ (super_clas, clas_tyvar_ty)
 306              | super_clas <- scs ]                      `thenNF_Tc` \ (_,dict_ids) ->
 307
 308     newDicts ClassDeclOrigin
 309              [ (clas, clas_tyvar_ty) ]                  `thenNF_Tc` \ (_,[clas_dict]) ->
 310
 311          -- Make suitable bindings for the selectors
 312     let
 313         mk_sel sel_id method_or_dict
 314           = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict
 315     in
 316     listNF_Tc (zipWithEqual "mk_sel1" mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
 317     listNF_Tc (zipWithEqual "mk_sel2" mk_sel sc_sel_ids dict_ids)   `thenNF_Tc` \ sc_sel_binds ->
 318
 319     returnNF_Tc (SingleBind (
 320                  NonRecBind (
 321                  foldr AndMonoBinds
 322                        (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
 323                        sc_sel_binds
 324                  )))
 325 \end{code}
 326
 327 %************************************************************************
 328 %*                                                                      *
 329 \subsection[ClassDcl-misc]{Miscellaneous}
 330 %*                                                                      *
 331 %************************************************************************
 332
 333 Make a selector expression for @sel_id@ from a dictionary @clas_dict@
 334 consisting of @dicts@ and @methods@.
 335
 336 We have to do a bit of jiggery pokery to get the type variables right.
 337 Suppose we have the class decl:
 338 \begin{verbatim}
 339         class Foo a where
 340                 op1 :: Ord b => a -> b -> a
 341                 op2 :: ...
 342 \end{verbatim}
 343 Then the method selector for \tr{op1} is like this:
 344 \begin{verbatim}
 345         op1_sel = /\a b -> \dFoo dOrd -> case dFoo of
 346                                          (op1_method,op2_method) -> op1_method b dOrd
 347 \end{verbatim}
 348 Note that the type variable for \tr{b} and the (Ord b) dictionary
 349 are lifted to the top lambda, and
 350 \tr{op1_method} is applied to them.  This is preferable to the alternative:
 351 \begin{verbatim}
 352         op1_sel' = /\a -> \dFoo -> case dFoo of
 353                                         (op1_method,op2_method) -> op1_method
 354 \end{verbatim}
 355 because \tr{op1_sel'} then has the rather strange type
 356 \begin{verbatim}
 357         op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
 358 \end{verbatim}
 359 whereas \tr{op1_sel} (the one we use) has the decent type
 360 \begin{verbatim}
 361         op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
 362 \end{verbatim}
 363
 364 NOTE that we return a TcMonoBinds (which is later zonked) even though
 365 there's no real back-substitution to do. It's just simpler this way!
 366
 367 NOTE ALSO that the selector has no free type variables, so we
 368 don't bother to instantiate the class-op's local type; instead
 369 we just use the variables inside it.
 370
 371 \begin{code}
 372 mkSelBind :: Id                         -- the selector id
 373           -> TcTyVar s -> TcIdOcc s     -- class tyvar and dict
 374           -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict
 375           -> TcIdOcc s                  -- the superclass/method being slected
 376           -> NF_TcM s (TcMonoBinds s)
 377
 378 mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
 379   = let
 380         (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op)
 381         op_tys = mkTyVarTys op_tyvars
 382     in
 383     newDicts ClassDeclOrigin op_theta   `thenNF_Tc` \ (_, op_dicts) ->
 384
 385         -- sel_id = /\ clas_tyvar op_tyvars -> \ clas_dict op_dicts ->
 386         --          case clas_dict of
 387         --               <dicts..methods> -> method_or_dict op_tyvars op_dicts
 388
 389     returnNF_Tc (VarMonoBind (RealId sel_id)  (
 390                  TyLam (clas_tyvar:op_tyvars) (
 391                  DictLam (clas_dict:op_dicts) (
 392                  HsCase
 393                    (HsVar clas_dict)
 394                    ([PatMatch  (DictPat dicts methods) (
 395                      GRHSMatch (GRHSsAndBindsOut
 396                         [OtherwiseGRHS
 397                            (mkHsDictApp (mkHsTyApp (HsVar method_or_dict) op_tys) op_dicts)
 398                            mkGeneratedSrcLoc]
 399                         EmptyBinds
 400                         op_tau))])
 401                     mkGeneratedSrcLoc
 402                  ))))
 403 \end{code}
 404
 405
 406 %************************************************************************
 407 %*                                                                      *
 408 \subsection[Default methods]{Default methods}
 409 %*                                                                      *
 410 %************************************************************************
 411
 412 The default methods for a class are each passed a dictionary for the
 413 class, so that they get access to the other methods at the same type.
 414 So, given the class decl
 415 \begin{verbatim}
 416 class Foo a where
 417         op1 :: a -> Bool
 418         op2 :: Ord b => a -> b -> b -> b
 419
 420         op1 x = True
 421         op2 x y z = if (op1 x) && (y < z) then y else z
 422 \end{verbatim}
 423 we get the default methods:
 424 \begin{verbatim}
 425 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 426 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 427
 428 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 429 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 430                   if (op1 a dfoo x) && (< b dord y z) then y else z
 431 \end{verbatim}
 432 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 433
 434 When we come across an instance decl, we may need to use the default
 435 methods:
 436 \begin{verbatim}
 437 instance Foo Int where {}
 438 \end{verbatim}
 439 gives
 440 \begin{verbatim}
 441 const.Foo.Int.op1 :: Int -> Bool
 442 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 443
 444 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 445 const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int
 446
 447 dfun.Foo.Int :: Foo Int
 448 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 449 \end{verbatim}
 450 Notice that, as with method selectors above, we assume that dictionary
 451 application is curried, so there's no need to mention the Ord dictionary
 452 in const.Foo.Int.op2
 453 \begin{verbatim}
 454 instance Foo a => Foo [a] where {}
 455
 456 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 457 dfun.Foo.List
 458   = /\ a -> \ dfoo_a ->
 459     let rec
 460         op1 = defm.Foo.op1 [a] dfoo_list
 461         op2 = /\b -> \dord -> defm.Foo.op2 [a] b dfoo_list dord
 462         dfoo_list = (op1, op2)
 463     in
 464         dfoo_list
 465 \end{verbatim}
 466
 467 \begin{code}
 468 buildDefaultMethodBinds
 469         :: Class
 470         -> TcTyVar s
 471         -> [Id]
 472         -> RenamedMonoBinds
 473         -> TcM s (LIE s, TcHsBinds s)
 474
 475 buildDefaultMethodBinds clas clas_tyvar
 476                         default_method_ids default_binds
 477   =     -- Deal with the method declarations themselves
 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 RealId default_method_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}