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         tcClassDecls1, tcClassDecls2,
  11         ClassInfo   -- abstract
  12     ) where
  13
  14 IMPORT_Trace            -- ToDo: rm (debugging)
  15 import Pretty   -- add proper one below
  16
  17 import TcMonad          -- typechecking monad machinery
  18 import TcMonadFns       ( newDicts, newClassOpLocals, copyTyVars )
  19 import AbsSyn           -- the stuff being typechecked
  20
  21 import AbsPrel          ( pAT_ERROR_ID )
  22 import AbsUniType       ( mkClass, getClassKey, getClassBigSig,
  23                           getClassOpString, getClassOps, splitType,
  24                           mkSuperDictSelType, InstTyEnv(..),
  25                           instantiateTy, instantiateThetaTy, UniType
  26                         )
  27 import BackSubst        ( applyTcSubstToBinds )
  28 import CE               -- ( nullCE, unitCE, plusCE, CE(..), UniqFM )
  29 import E                ( mkE, getE_TCE, getE_CE, tvOfE, nullGVE, plusGVE, E, TCE(..), UniqFM, GVE(..) )
  30 import Errors           ( confusedNameErr, Error(..) )
  31 import HsPragmas        -- ****** NEED TO SEE CONSTRUCTORS ******
  32 import Id               ( mkSuperDictSelId, mkInstId, getIdUniType,
  33                           Id, DictFun(..)
  34                         )
  35 import IdInfo
  36 import Inst             ( InstOrigin(..), Inst )
  37 import InstEnv
  38 import LIE              ( nullLIE, mkLIE, plusLIE, LIE )
  39 import Maybes           ( Maybe(..) )
  40 import Name             ( Name(..) )
  41 import PlainCore        ( escErrorMsg )
  42 import Spec             ( specTy )
  43 import TVE              ( mkTVE, TVE(..)
  44                           IF_ATTACK_PRAGMAS(COMMA u2i)
  45                         )
  46 import TcClassSig       ( tcClassSigs )
  47 import TcContext        ( tcContext )
  48 import TcInstDcls       ( processInstBinds )
  49 import TcPragmas        ( tcGenPragmas )
  50 import Util
  51 \end{code}
  52
  53 @ClassInfo@ communicates the essential information about
  54 locally-defined classes between passes 1 and 2.
  55
  56 \begin{code}
  57 data ClassInfo
  58   = ClassInfo   Class
  59                 RenamedMonoBinds
  60 \end{code}
  61
  62
  63 %************************************************************************
  64 %*                                                                      *
  65 \subsection[TcClassDcl]{Does the real work (apart from default methods)}
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 \begin{code}
  70 tcClassDecls1
  71     :: E                        -- Consult the CE/TCE args only to build knots
  72     -> InstanceMapper           -- Maps class name to its instances,
  73                                 -- ...and its ops to their instances,
  74     -> [RenamedClassDecl]
  75     -> TcM ([ClassInfo],        -- boiled-down info related to classes
  76             CE,                 -- env so we can look up classes elsewhere
  77             GVE)                -- env so we can look up class ops elsewhere
  78
  79 tcClassDecls1 e rec_inst_mapper []
  80   = returnTc ([], nullCE, nullGVE)
  81
  82 tcClassDecls1 e rec_inst_mapper (cd:cds)
  83   = tc_clas1                        cd  `thenTc` \ (cinfo1_maybe, ce1, gve1) ->
  84     tcClassDecls1 e rec_inst_mapper cds `thenTc` \ (cinfo2, ce2, gve2) ->
  85     let
  86         glued_cinfos
  87           = case cinfo1_maybe of
  88               Nothing -> cinfo2
  89               Just xx -> xx : cinfo2
  90     in
  91     returnTc (glued_cinfos, ce1 `plusCE` ce2, gve1 `plusGVE` gve2)
  92   where
  93     rec_ce  = getE_CE  e
  94     rec_tce = getE_TCE e
  95 --FAKE:    fake_E  = mkE rec_tce rec_ce
  96
  97     tc_clas1 (ClassDecl context class_name
  98                         tyvar_name class_sigs def_methods pragmas src_loc)
  99
 100       = addSrcLocTc src_loc     (
 101
 102             -- The knot is needed so that the signatures etc can point
 103             -- back to the class itself
 104         fixTc (\ ~(rec_clas, _) ->
 105           let
 106              (rec_clas_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_clas
 107           in
 108             -- Get new (template) type variables for the class
 109           let  (tve, [clas_tyvar], [alpha]) = mkTVE [tyvar_name]  in
 110
 111             -- Typecheck the class context; since there is only one type
 112             -- variable in scope, we are assured that the it will be of
 113             -- the form (C1 a, C2 a...)
 114           babyTcMtoTcM (tcContext rec_ce rec_tce tve context) `thenTc` \ theta ->
 115
 116             -- Make the superclass selector ids; the "class" pragmas
 117             -- may have info about the superclass dict selectors;
 118             -- so it is only tcClassPragmas that gives back the
 119             -- final Ids.
 120           getUniquesTc (length theta)           `thenNF_Tc` \ uniqs ->
 121           let
 122               super_classes = [ supers | (supers, _) <- theta ]
 123               super_tys
 124                 = [ mkSuperDictSelType rec_clas super | super <- super_classes ]
 125               super_info = zip3 super_classes uniqs super_tys
 126           in
 127           (case pragmas of
 128             NoClassPragmas ->
 129               returnNF_Tc [ mk_super_id rec_clas info noIdInfo | info <- super_info ]
 130
 131             SuperDictPragmas prags ->
 132 --            pprTrace "SuperDictPragmas:" (ppAboves (ppr PprDebug prags : map pp super_info)) (
 133               mapNF_Tc (mk_super_id_w_info rec_clas) (super_info `zipEqual` prags)
 134 --            )
 135 --            where
 136 --              pp (sc, u, ty) = ppCat [ppr PprDebug sc, ppr PprDebug ty]
 137
 138           ) `thenNF_Tc` \ super_class_sel_ids ->
 139
 140             -- Typecheck the class signatures, checking that each mentions
 141             -- the class type variable somewhere, and manufacturing
 142             -- suitable Ids for selectors and default methods.
 143           babyTcMtoTcM
 144             (tcClassSigs e tve rec_clas rec_class_op_inst_fn
 145                                clas_tyvar class_sigs)
 146                    `thenTc` \ (ops, ops_gve, op_sel_ids, defm_ids) ->
 147
 148              -- Make the class object itself, producing clas::Class
 149           let
 150              clas
 151                 = mkClass class_name clas_tyvar
 152                           super_classes super_class_sel_ids
 153                           ops op_sel_ids defm_ids
 154                           rec_clas_inst_env
 155           in
 156           returnTc (clas, ops_gve)
 157         )                               `thenTc` \ (clas, ops_gve) ->
 158
 159              -- Return the class decl for further work if it is
 160              -- local, otherwise just return the CE
 161         returnTc (if (isLocallyDefined class_name) then
 162                      Just (ClassInfo clas def_methods)
 163                   else
 164                      Nothing,
 165                   unitCE (getClassKey clas) clas,
 166                   ops_gve
 167         ))
 168       where
 169         -----------
 170         mk_super_id clas (super_clas, uniq, ty) id_info
 171           = mkSuperDictSelId uniq clas super_clas ty id_info
 172
 173         -----------
 174         mk_super_id_w_info clas ((super_clas, uniq, ty), gen_prags)
 175           = fixNF_Tc ( \ rec_super_id ->
 176                 babyTcMtoNF_TcM
 177                     (tcGenPragmas e{-fake_E-} Nothing{-ty unknown-} rec_super_id gen_prags)
 178                         `thenNF_Tc` \ id_info ->
 179
 180                 returnNF_Tc(mkSuperDictSelId uniq clas super_clas ty id_info)
 181             )
 182
 183 {- SOMETHING LIKE THIS NEEDED? ToDo [WDP]
 184     tc_clas1 (ClassDecl _ bad_name _ _ _ _ src_loc)
 185       = failTc (confusedNameErr
 186                     "Bad name for a class (a type constructor, or Prelude name?)"
 187                     bad_name src_loc)
 188 -}
 189 \end{code}
 190
 191
 192 %************************************************************************
 193 %*                                                                      *
 194 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 195 %*                                                                      *
 196 %************************************************************************
 197
 198 The purpose of pass 2 is
 199 \begin{enumerate}
 200 \item
 201 to beat on the explicitly-provided default-method decls (if any),
 202 using them to produce a complete set of default-method decls.
 203 (Omitted ones elicit an error message.)
 204 \item
 205 to produce a definition for the selector function for each method
 206 \end{enumerate}
 207
 208 Pass~2 only applies to locally-defined class declarations.
 209
 210 The function @tcClassDecls2@ just arranges to apply
 211 @tcClassDecls2_help@ to each local class decl.
 212
 213 \begin{code}
 214 tcClassDecls2 e class_info
 215   = let
 216         -- Get type variables free in environment. Sadly, there may be
 217         -- some, because of the dreaded monomorphism restriction
 218         free_tyvars = tvOfE e
 219     in
 220     tcClassDecls2_help e free_tyvars class_info
 221
 222 tcClassDecls2_help
 223         :: E
 224         -> [TyVar]
 225         -> [ClassInfo]
 226         -> NF_TcM (LIE, TypecheckedBinds)
 227
 228 tcClassDecls2_help e free_tyvars [] = returnNF_Tc (nullLIE, EmptyBinds)
 229
 230 tcClassDecls2_help e free_tyvars ((ClassInfo clas default_binds) : rest)
 231   = tcClassDecl2 e free_tyvars clas default_binds `thenNF_Tc` \ (lie1, binds1) ->
 232     tcClassDecls2_help e free_tyvars rest         `thenNF_Tc` \ (lie2, binds2) ->
 233     returnNF_Tc (lie1 `plusLIE` lie2, binds1 `ThenBinds` binds2)
 234 \end{code}
 235
 236 @tcClassDecl2@ is the business end of things.
 237
 238 \begin{code}
 239 tcClassDecl2 :: E
 240              -> [TyVar]                 -- Free in the envt
 241              -> Class
 242              -> RenamedMonoBinds        -- The default decls
 243              -> NF_TcM (LIE, TypecheckedBinds)
 244
 245 tcClassDecl2 e free_tyvars clas default_binds
 246   = let
 247         src_loc = getSrcLoc clas
 248         origin  = ClassDeclOrigin src_loc
 249         (clas_tyvar_tmpl, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
 250           = getClassBigSig clas
 251     in
 252          -- Prune the substitution when we are finished, and arrange error recovery
 253     recoverTc (nullLIE, EmptyBinds) (
 254     addSrcLocTc src_loc             (
 255     pruneSubstTc free_tyvars        (
 256
 257          -- Generate bindings for the selector functions
 258     buildSelectors origin clas clas_tyvar_tmpl scs sc_sel_ids ops op_sel_ids
 259                                                 `thenNF_Tc` \ sel_binds ->
 260          -- Ditto for the methods
 261     buildDefaultMethodBinds e free_tyvars origin clas clas_tyvar_tmpl
 262                 defm_ids default_binds          `thenTc` \ (const_insts, meth_binds) ->
 263
 264          -- Back-substitute through the definitions
 265     applyTcSubstToInsts const_insts                        `thenNF_Tc` \ final_const_insts ->
 266     applyTcSubstToBinds (sel_binds `ThenBinds` meth_binds) `thenNF_Tc` \ final_binds ->
 267     returnTc (mkLIE final_const_insts, final_binds)
 268     )))
 269 \end{code}
 270
 271 %************************************************************************
 272 %*                                                                      *
 273 \subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses}
 274 %*                                                                      *
 275 %************************************************************************
 276
 277 \begin{code}
 278 buildSelectors :: InstOrigin
 279                -> Class                 -- The class object
 280                -> TyVarTemplate         -- Class type variable
 281                -> [Class] -> [Id]       -- Superclasses and selectors
 282                -> [ClassOp] -> [Id]     -- Class ops and selectors
 283                -> NF_TcM TypecheckedBinds
 284
 285 buildSelectors origin clas clas_tyvar_tmpl
 286         scs sc_sel_ids
 287         ops op_sel_ids
 288   =
 289          -- Instantiate the class variable
 290     copyTyVars [clas_tyvar_tmpl] `thenNF_Tc` \ (inst_env, [clas_tyvar], [clas_tyvar_ty]) ->
 291          -- Make an Inst for each class op, and
 292          -- dicts for the superclasses.  These are used to
 293          -- construct the selector functions
 294     newClassOpLocals inst_env ops                       `thenNF_Tc` \ method_ids ->
 295     newDicts origin [ (super_clas, clas_tyvar_ty)
 296                     | super_clas <- scs
 297                     ]                                   `thenNF_Tc` \ dicts ->
 298     let dict_ids = map mkInstId dicts  in
 299
 300          -- Make suitable bindings for the selectors
 301     let mk_op_sel op sel_id method_id
 302           = mkSelExpr origin clas_tyvar dict_ids method_ids method_id   `thenNF_Tc` \ rhs ->
 303             returnNF_Tc (VarMonoBind sel_id rhs)
 304         mk_sc_sel sc sel_id dict_id
 305          = mkSelExpr origin clas_tyvar dict_ids method_ids dict_id      `thenNF_Tc` \ rhs ->
 306            returnNF_Tc (VarMonoBind sel_id rhs)
 307     in
 308     listNF_Tc (zipWith3 mk_op_sel ops op_sel_ids method_ids)    `thenNF_Tc` \ op_sel_binds ->
 309     listNF_Tc (zipWith3 mk_sc_sel scs sc_sel_ids dict_ids)      `thenNF_Tc` \ sc_sel_binds ->
 310
 311     returnNF_Tc (SingleBind (
 312                  NonRecBind (
 313                  foldr AndMonoBinds EmptyMonoBinds (
 314                  op_sel_binds ++ sc_sel_binds))))
 315 \end{code}
 316
 317 %************************************************************************
 318 %*                                                                      *
 319 \subsection[ClassDcl-misc]{Miscellaneous}
 320 %*                                                                      *
 321 %************************************************************************
 322
 323 Make a selector expression for @local@ from a dictionary consisting of
 324 @dicts@ and @op_locals@.
 325
 326 We have to do a bit of jiggery pokery to get the type variables right.
 327 Suppose we have the class decl:
 328 \begin{verbatim}
 329         class Foo a where
 330                 op1 :: Ord b => a -> b -> a
 331                 op2 :: ...
 332 \end{verbatim}
 333 Then the method selector for \tr{op1} is like this:
 334 \begin{verbatim}
 335         op1_sel = /\ab -> \dFoo -> case dFoo of
 336                                         (op1_method,op2_method) -> op1_method b
 337 \end{verbatim}
 338 Note that the type variable for \tr{b} is lifted to the top big lambda, and
 339 \tr{op1_method} is applied to it.  This is preferable to the alternative:
 340 \begin{verbatim}
 341         op1_sel' = /\a -> \dFoo -> case dFoo of
 342                                         (op1_method,op2_method) -> op1_method
 343 \end{verbatim}
 344 because \tr{op1_sel'} then has the rather strange type
 345 \begin{verbatim}
 346         op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
 347 \end{verbatim}
 348 whereas \tr{op1_sel} (the one we use) has the decent type
 349 \begin{verbatim}
 350         op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
 351 \end{verbatim}
 352
 353 {\em NOTE:}
 354 We could do the same thing for the dictionaries, giving
 355 \begin{verbatim}
 356         op1_sel = /\ab -> \dFoo -> \dOrd -> case dFoo of
 357                                                 (m1,m2) -> m1 b dOrd
 358 \end{verbatim}
 359 but WE ASSUME THAT DICTIONARY APPLICATION IS CURRIED, so the two are
 360 precisely equivalent, and have the same type, namely
 361 \begin{verbatim}
 362         op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
 363 \end{verbatim}
 364
 365 WDP 95/03: Quite false (``DICTIONARY APPLICATION IS CURRIED'').
 366 Specialisation now wants to see all type- and dictionary-applications
 367 absolutely explicitly.
 368
 369 \begin{code}
 370 mkSelExpr :: InstOrigin -> TyVar -> [Id] -> [Id] -> Id -> NF_TcM TypecheckedExpr
 371
 372 mkSelExpr origin clas_tyvar dicts op_locals local
 373   = let
 374         (op_tyvar_tmpls,local_theta,_) = splitType (getIdUniType local)
 375     in
 376     copyTyVars op_tyvar_tmpls   `thenNF_Tc` \ (inst_env, op_tyvars, tys) ->
 377     let
 378         inst_theta = instantiateThetaTy inst_env local_theta
 379     in
 380     newDicts origin inst_theta  `thenNF_Tc` \ local_dict_insts ->
 381     let
 382         local_dicts = map mkInstId local_dict_insts
 383     in
 384     returnNF_Tc (TyLam (clas_tyvar:op_tyvars)
 385                    (ClassDictLam
 386                       dicts
 387                       op_locals
 388                       (mkDictLam local_dicts
 389                         (mkDictApp (mkTyApp (Var local) tys) local_dicts))))
 390 \end{code}
 391
 392
 393 %************************************************************************
 394 %*                                                                      *
 395 \subsection[Default methods]{Default methods}
 396 %*                                                                      *
 397 %************************************************************************
 398
 399 The default methods for a class are each passed a dictionary for the
 400 class, so that they get access to the other methods at the same type.
 401 So, given the class decl
 402 \begin{verbatim}
 403 class Foo a where
 404         op1 :: a -> Bool
 405         op2 :: Ord b => a -> b -> b -> b
 406
 407         op1 x = True
 408         op2 x y z = if (op1 x) && (y < z) then y else z
 409 \end{verbatim}
 410 we get the default methods:
 411 \begin{verbatim}
 412 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 413 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 414
 415 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 416 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 417                   if (op1 a dfoo x) && (< b dord y z) then y else z
 418 \end{verbatim}
 419 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 420
 421 When we come across an instance decl, we may need to use the default
 422 methods:
 423 \begin{verbatim}
 424 instance Foo Int where {}
 425 \end{verbatim}
 426 gives
 427 \begin{verbatim}
 428 const.Foo.Int.op1 :: Int -> Bool
 429 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 430
 431 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 432 const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int
 433
 434 dfun.Foo.Int :: Foo Int
 435 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 436 \end{verbatim}
 437 Notice that, as with method selectors above, we assume that dictionary
 438 application is curried, so there's no need to mention the Ord dictionary
 439 in const.Foo.Int.op2
 440 \begin{verbatim}
 441 instance Foo a => Foo [a] where {}
 442
 443 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 444 dfun.Foo.List
 445   = /\ a -> \ dfoo_a ->
 446     let rec
 447         op1 = defm.Foo.op1 [a] dfoo_list
 448         op2 = /\b -> defm.Foo.op2 [a] b dfoo_list
 449         dfoo_list = (op1, op2)
 450     in
 451         dfoo_list
 452 \end{verbatim}
 453
 454 \begin{code}
 455 buildDefaultMethodBinds
 456         :: E
 457         -> [TyVar]
 458         -> InstOrigin
 459         -> Class
 460         -> TyVarTemplate
 461         -> [Id]
 462         -> RenamedMonoBinds
 463         -> TcM ([Inst], TypecheckedBinds)
 464
 465 buildDefaultMethodBinds e free_tyvars origin clas clas_tyvar_tmpl
 466                         default_method_ids default_binds
 467   =     -- Deal with the method declarations themselves
 468     processInstBinds e
 469          free_tyvars
 470          (makeClassDeclDefaultMethodRhs clas origin default_method_ids)
 471          []     -- No tyvars in scope for "this inst decl"
 472          []     -- No insts available
 473          default_method_ids
 474          default_binds          `thenTc` \ (dicts_needed, default_binds') ->
 475
 476     returnTc (dicts_needed, SingleBind (NonRecBind default_binds'))
 477 \end{code}
 478
 479 @makeClassDeclDefaultMethodRhs@ builds the default method for a
 480 class declaration when no explicit default method is given.
 481
 482 \begin{code}
 483 makeClassDeclDefaultMethodRhs
 484         :: Class
 485         -> InstOrigin
 486         -> [Id]
 487         -> Int
 488         -> NF_TcM TypecheckedExpr
 489
 490 makeClassDeclDefaultMethodRhs clas origin method_ids tag
 491   = specTy origin (getIdUniType method_id) `thenNF_Tc` \ (tyvars, dicts, tau) ->
 492
 493     returnNF_Tc (mkTyLam tyvars (
 494                  mkDictLam (map mkInstId dicts) (
 495                  App (mkTyApp (Var pAT_ERROR_ID) [tau])
 496                      (Lit (StringLit (_PK_ error_msg))))))
 497   where
 498     method_id = method_ids  !! (tag-1)
 499     class_op = (getClassOps clas) !! (tag-1)
 500
 501     error_msg = "%D" -- => No default method for \"
 502              ++ unencoded_part_of_msg
 503
 504     unencoded_part_of_msg = escErrorMsg (
 505         _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
 506              ++ (ppShow 80 (ppr PprForUser class_op))
 507              ++ "\"" )
 508
 509     (clas_mod, clas_name) = getOrigName clas
 510 \end{code}