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