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