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