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 module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsDecl(..), ClassDecl(..), Sig(..), MonoBinds(..),
  12                           InPat(..), andMonoBinds, getTyVarName
  13                         )
  14 import HsPragmas        ( ClassPragmas(..) )
  15 import BasicTypes       ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
  16 import RnHsSyn          ( RenamedClassDecl(..), RenamedClassPragmas(..),
  17                           RenamedClassOpSig(..), RenamedMonoBinds,
  18                           RenamedContext(..), RenamedHsDecl
  19                         )
  20 import TcHsSyn          ( TcMonoBinds )
  21
  22 import Inst             ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
  23 import TcEnv            ( TcIdOcc(..), tcAddImportedIdInfo,
  24                           tcLookupClass, tcLookupTyVar,
  25                           tcExtendGlobalTyVars )
  26 import TcBinds          ( tcBindWithSigs, checkSigTyVars, sigCtxt, TcSigInfo(..) )
  27 import TcKind           ( unifyKinds, TcKind )
  28 import TcMonad
  29 import TcMonoType       ( tcHsType, tcContext )
  30 import TcSimplify       ( tcSimplifyAndCheck )
  31 import TcType           ( TcType, TcTyVar, TcTyVarSet, tcInstSigTyVars,
  32                           zonkSigTyVar, tcInstSigTcType
  33                         )
  34 import PragmaInfo       ( PragmaInfo(..) )
  35
  36 import Bag              ( unionManyBags )
  37 import Class            ( mkClass, classBigSig, Class )
  38 import CmdLineOpts      ( opt_GlasgowExts )
  39 import Id               ( Id, StrictnessMark(..),
  40                           mkSuperDictSelId, mkMethodSelId,
  41                           mkDefaultMethodId, getIdUnfolding, mkDataCon,
  42                           idType
  43                         )
  44 import CoreUnfold       ( getUnfoldingTemplate )
  45 import IdInfo
  46 import Name             ( Name, isLocallyDefined, OccName, nameOccName,
  47                           NamedThing(..) )
  48 import Outputable
  49 import Type             ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, splitRhoTy,
  50                           mkSigmaTy, mkForAllTys, Type, ThetaType
  51                         )
  52 import TyVar            ( mkTyVarSet, tyVarKind, TyVar )
  53 import TyCon            ( mkDataTyCon )
  54 import Kind             ( mkBoxedTypeKind, mkArrowKind )
  55 import Unique           ( Unique, Uniquable(..) )
  56 import Util
  57 import Maybes           ( assocMaybe, maybeToBool )
  58
  59
  60 -- import TcPragmas     ( tcGenPragmas, tcClassOpPragmas )
  61 tcGenPragmas ty id ps = returnNF_Tc noIdInfo
  62 tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec,
  63                                                    noIdInfo)
  64 \end{code}
  65
  66
  67
  68 Dictionary handling
  69 ~~~~~~~~~~~~~~~~~~~
  70 Every class implicitly declares a new data type, corresponding to dictionaries
  71 of that class. So, for example:
  72
  73         class (D a) => C a where
  74           op1 :: a -> a
  75           op2 :: forall b. Ord b => a -> b -> b
  76
  77 would implicitly declare
  78
  79         data CDict a = CDict (D a)
  80                              (a -> a)
  81                              (forall b. Ord b => a -> b -> b)
  82
  83 (We could use a record decl, but that means changing more of the existing apparatus.
  84 One step at at time!)
  85
  86 For classes with just one superclass+method, we use a newtype decl instead:
  87
  88         class C a where
  89           op :: forallb. a -> b -> b
  90
  91 generates
  92
  93         newtype CDict a = CDict (forall b. a -> b -> b)
  94
  95 Now DictTy in Type is just a form of type synomym:
  96         DictTy c t = TyConTy CDict `AppTy` t
  97
  98 Death to "ExpandingDicts".
  99
 100
 101 \begin{code}
 102 tcClassDecl1 rec_env rec_inst_mapper
 103              (ClassDecl context class_name
 104                         tyvar_names class_sigs def_methods pragmas
 105                         tycon_name datacon_name src_loc)
 106   = tcAddSrcLoc src_loc $
 107     tcAddErrCtxt (classDeclCtxt class_name) $
 108
 109         -- CHECK ARITY 1 FOR HASKELL 1.4
 110     checkTc (opt_GlasgowExts || length tyvar_names == 1)
 111             (classArityErr class_name)          `thenTc_`
 112
 113         -- LOOK THINGS UP IN THE ENVIRONMENT
 114     tcLookupClass class_name                    `thenTc` \ (class_kinds, rec_class) ->
 115     mapAndUnzipNF_Tc (tcLookupTyVar . getTyVarName) tyvar_names
 116                                                 `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
 117
 118         -- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
 119     unifyKinds class_kinds tyvar_kinds  `thenTc_`
 120
 121         -- CHECK THE CONTEXT
 122     tcClassContext rec_class rec_tyvars context pragmas
 123                                                 `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
 124
 125         -- CHECK THE CLASS SIGNATURES,
 126     mapTc (tcClassSig rec_env rec_class rec_tyvars) class_sigs
 127                                                 `thenTc` \ sig_stuff ->
 128
 129         -- MAKE THE CLASS OBJECT ITSELF
 130     let
 131         (op_tys, op_sel_ids, defm_ids) = unzip3 sig_stuff
 132         rec_class_inst_env = rec_inst_mapper rec_class
 133         clas = mkClass (getName class_name) rec_tyvars
 134                        sc_theta sc_sel_ids op_sel_ids defm_ids
 135                        tycon
 136                        rec_class_inst_env
 137
 138         dict_component_tys = sc_tys ++ op_tys
 139         new_or_data = case dict_component_tys of
 140                         [_]   -> NewType
 141                         other -> DataType
 142
 143         dict_con_id = mkDataCon datacon_name
 144                            [NotMarkedStrict | _ <- dict_component_tys]
 145                            [{- No labelled fields -}]
 146                            rec_tyvars
 147                            [{-No context-}]
 148                            [{-No existential tyvars-}] [{-Or context-}]
 149                            dict_component_tys
 150                            tycon
 151
 152         tycon = mkDataTyCon tycon_name
 153                             (foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars)
 154                             rec_tyvars
 155                             []                  -- No context
 156                             [dict_con_id]       -- Constructors
 157                             []                  -- No derivings
 158                             (Just clas)         -- Yes!  It's a dictionary
 159                             new_or_data
 160                             NonRecursive
 161     in
 162     returnTc clas
 163 \end{code}
 164
 165
 166 \begin{code}
 167 tcClassContext :: Class -> [TyVar]
 168                -> RenamedContext        -- class context
 169                -> RenamedClassPragmas   -- pragmas for superclasses
 170                -> TcM s (ThetaType,     -- the superclass context
 171                          [Type],        -- types of the superclass dictionaries
 172                          [Id])          -- superclass selector Ids
 173
 174 tcClassContext rec_class rec_tyvars context pragmas
 175   =     -- Check the context.
 176         -- The renamer has already checked that the context mentions
 177         -- only the type variable of the class decl.
 178     tcContext context                   `thenTc` \ sc_theta ->
 179     let
 180        sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
 181     in
 182
 183         -- Make super-class selector ids
 184         -- We number them off, 1, 2, 3 etc so that we can construct
 185         -- names for the selectors.  Thus
 186         --      class (C a, C b) => D a b where ...
 187         -- gives superclass selectors
 188         --      D_sc1, D_sc2
 189         -- (We used to call them D_C, but now we can have two different
 190         --  superclasses both called C!)
 191     mapTc mk_super_id (sc_theta `zip` [1..])    `thenTc` \ sc_sel_ids ->
 192
 193         -- Done
 194     returnTc (sc_theta, sc_tys, sc_sel_ids)
 195
 196   where
 197     rec_tyvar_tys = mkTyVarTys rec_tyvars
 198
 199     mk_super_id ((super_class, tys), index)
 200         = tcGetUnique                   `thenNF_Tc` \ uniq ->
 201           let
 202                 ty = mkForAllTys rec_tyvars $
 203                      mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys)
 204           in
 205           returnTc (mkSuperDictSelId uniq rec_class index ty)
 206
 207
 208 tcClassSig :: TcEnv s                   -- Knot tying only!
 209            -> Class                     -- ...ditto...
 210            -> [TyVar]                   -- The class type variable, used for error check only
 211            -> RenamedClassOpSig
 212            -> TcM s (Type,              -- Type of the method
 213                      Id,                -- selector id
 214                      Maybe Id)          -- default-method ids
 215
 216 tcClassSig rec_env rec_clas rec_clas_tyvars
 217            (ClassOpSig op_name maybe_dm_name
 218                        op_ty
 219                        src_loc)
 220   = tcAddSrcLoc src_loc $
 221
 222         -- Check the type signature.  NB that the envt *already has*
 223         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 224
 225     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
 226     -- and that it is not constrained by theta
 227     tcHsType op_ty                              `thenTc` \ local_ty ->
 228     let
 229         global_ty   = mkSigmaTy rec_clas_tyvars
 230                                 [(rec_clas, mkTyVarTys rec_clas_tyvars)]
 231                                 local_ty
 232     in
 233
 234         -- Build the selector id and default method id
 235     let
 236         sel_id      = mkMethodSelId op_name rec_clas global_ty
 237         maybe_dm_id = case maybe_dm_name of
 238                            Nothing      -> Nothing
 239                            Just dm_name -> let
 240                                              dm_id = mkDefaultMethodId dm_name rec_clas global_ty
 241                                            in
 242                                            Just (tcAddImportedIdInfo rec_env dm_id)
 243     in
 244     returnTc (local_ty, sel_id, maybe_dm_id)
 245 \end{code}
 246
 247
 248 %************************************************************************
 249 %*                                                                      *
 250 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 251 %*                                                                      *
 252 %************************************************************************
 253
 254 The purpose of pass 2 is
 255 \begin{enumerate}
 256 \item
 257 to beat on the explicitly-provided default-method decls (if any),
 258 using them to produce a complete set of default-method decls.
 259 (Omitted ones elicit an error message.)
 260 \item
 261 to produce a definition for the selector function for each method
 262 and superclass dictionary.
 263 \end{enumerate}
 264
 265 Pass~2 only applies to locally-defined class declarations.
 266
 267 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 268 each local class decl.
 269
 270 \begin{code}
 271 tcClassDecls2 :: [RenamedHsDecl]
 272               -> NF_TcM s (LIE s, TcMonoBinds s)
 273
 274 tcClassDecls2 decls
 275   = foldr combine
 276           (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 277           [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
 278   where
 279     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 280                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 281                       returnNF_Tc (lie1 `plusLIE` lie2,
 282                                    binds1 `AndMonoBinds` binds2)
 283 \end{code}
 284
 285 @tcClassDecl2@ is the business end of things.
 286
 287 \begin{code}
 288 tcClassDecl2 :: RenamedClassDecl        -- The class declaration
 289              -> NF_TcM s (LIE s, TcMonoBinds s)
 290
 291 tcClassDecl2 (ClassDecl context class_name
 292                         tyvar_names class_sigs default_binds pragmas _ _ src_loc)
 293
 294   | not (isLocallyDefined class_name)
 295   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 296
 297   | otherwise   -- It is locally defined
 298   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
 299     tcAddSrcLoc src_loc                                   $
 300
 301         -- Get the relevant class
 302     tcLookupClass class_name            `thenTc` \ (_, clas) ->
 303     let
 304         (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 305
 306         -- The selector binds are already in the selector Id's unfoldings
 307         sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
 308                     | sel_id <- sc_sel_ids ++ op_sel_ids,
 309                       isLocallyDefined sel_id
 310                     ]
 311
 312         final_sel_binds = andMonoBinds sel_binds
 313     in
 314         -- Generate bindings for the default methods
 315     tcDefaultMethodBinds clas default_binds             `thenTc` \ (const_insts, meth_binds) ->
 316
 317     returnTc (const_insts,
 318               final_sel_binds `AndMonoBinds` meth_binds)
 319 \end{code}
 320
 321 %************************************************************************
 322 %*                                                                      *
 323 \subsection[Default methods]{Default methods}
 324 %*                                                                      *
 325 %************************************************************************
 326
 327 The default methods for a class are each passed a dictionary for the
 328 class, so that they get access to the other methods at the same type.
 329 So, given the class decl
 330 \begin{verbatim}
 331 class Foo a where
 332         op1 :: a -> Bool
 333         op2 :: Ord b => a -> b -> b -> b
 334
 335         op1 x = True
 336         op2 x y z = if (op1 x) && (y < z) then y else z
 337 \end{verbatim}
 338 we get the default methods:
 339 \begin{verbatim}
 340 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 341 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 342
 343 ====================== OLD ==================
 344 \begin{verbatim}
 345 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 346 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 347                   if (op1 a dfoo x) && (< b dord y z) then y else z
 348 \end{verbatim}
 349 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 350 ====================== END OF OLD ===================
 351
 352 NEW:
 353 \begin{verbatim}
 354 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 355 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 356                   if (op1 a dfoo x) && (< b dord y z) then y else z
 357 \end{verbatim}
 358
 359
 360 When we come across an instance decl, we may need to use the default
 361 methods:
 362 \begin{verbatim}
 363 instance Foo Int where {}
 364 \end{verbatim}
 365 gives
 366 \begin{verbatim}
 367 const.Foo.Int.op1 :: Int -> Bool
 368 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 369
 370 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 371 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 372
 373 dfun.Foo.Int :: Foo Int
 374 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 375 \end{verbatim}
 376 Notice that, as with method selectors above, we assume that dictionary
 377 application is curried, so there's no need to mention the Ord dictionary
 378 in const.Foo.Int.op2 (or the type variable).
 379
 380 \begin{verbatim}
 381 instance Foo a => Foo [a] where {}
 382
 383 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 384 dfun.Foo.List
 385   = /\ a -> \ dfoo_a ->
 386     let rec
 387         op1 = defm.Foo.op1 [a] dfoo_list
 388         op2 = defm.Foo.op2 [a] dfoo_list
 389         dfoo_list = (op1, op2)
 390     in
 391         dfoo_list
 392 \end{verbatim}
 393
 394 \begin{code}
 395 tcDefaultMethodBinds
 396         :: Class
 397         -> RenamedMonoBinds
 398         -> TcM s (LIE s, TcMonoBinds s)
 399
 400 tcDefaultMethodBinds clas default_binds
 401   =     -- Construct suitable signatures
 402     tcInstSigTyVars tyvars              `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
 403
 404         -- Typecheck the default bindings
 405     let
 406         tc_dm meth_bind
 407           | not (maybeToBool maybe_stuff)
 408           =     -- Binding for something that isn't in the class signature
 409             failWithTc (badMethodErr bndr_name clas)
 410
 411           | otherwise
 412           =     -- Normal case
 413             tcMethodBind clas origin inst_tys clas_tyvars sel_id meth_bind
 414                                                 `thenTc` \ (bind, insts, (_, local_dm_id)) ->
 415             returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
 416           where
 417             bndr_name  = case meth_bind of
 418                                 FunMonoBind name _ _ _          -> name
 419                                 PatMonoBind (VarPatIn name) _ _ -> name
 420
 421             maybe_stuff = assocMaybe assoc_list (nameOccName bndr_name)
 422             assoc_list  = [ (getOccName sel_id, pair)
 423                           | pair@(sel_id, dm_ie) <- op_sel_ids `zip` defm_ids
 424                           ]
 425             Just (sel_id, Just dm_id) = maybe_stuff
 426                  -- We're looking at a default-method binding, so the dm_id
 427                  -- is sure to be there!  Hence the inner "Just".
 428     in
 429     mapAndUnzip3Tc tc_dm
 430         (flatten default_binds [])              `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
 431
 432         -- Check the context
 433     newDicts origin [(clas,inst_tys)]           `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 434     let
 435         avail_insts = this_dict
 436     in
 437     tcAddErrCtxt (classDeclCtxt clas) $
 438     mapNF_Tc zonkSigTyVar clas_tyvars           `thenNF_Tc` \ clas_tyvars' ->
 439     tcSimplifyAndCheck
 440         (ptext SLIT("class") <+> ppr clas)
 441         (mkTyVarSet clas_tyvars')
 442         avail_insts
 443         (unionManyBags insts_needed)            `thenTc` \ (const_lie, dict_binds) ->
 444
 445     let
 446         full_binds = AbsBinds
 447                         clas_tyvars'
 448                         [this_dict_id]
 449                         abs_bind_stuff
 450                         (dict_binds `AndMonoBinds` andMonoBinds defm_binds)
 451     in
 452     returnTc (const_lie, full_binds)
 453
 454   where
 455     (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 456     origin = ClassDeclOrigin
 457
 458     flatten EmptyMonoBinds rest       = rest
 459     flatten (AndMonoBinds b1 b2) rest = flatten b1 (flatten b2 rest)
 460     flatten a_bind rest               = a_bind : rest
 461 \end{code}
 462
 463 @tcMethodBind@ is used to type-check both default-method and
 464 instance-decl method declarations.  We must type-check methods one at a
 465 time, because their signatures may have different contexts and
 466 tyvar sets.
 467
 468 \begin{code}
 469 tcMethodBind
 470         :: Class
 471         -> InstOrigin s
 472         -> [TcType s]                                   -- Instance types
 473         -> [TcTyVar s]                                  -- Free variables of those instance types
 474                                                         --  they'll be signature tyvars, and we
 475                                                         --  want to check that they don't bound
 476         -> Id                                           -- The method selector
 477         -> RenamedMonoBinds                             -- Method binding (just one)
 478         -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
 479
 480 tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind
 481  = tcAddSrcLoc src_loc                          $
 482    newMethod origin (RealId sel_id) inst_tys    `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
 483    tcInstSigTcType (idType local_meth_id)       `thenNF_Tc` \ (tyvars', rho_ty') ->
 484    let
 485         (theta', tau')  = splitRhoTy rho_ty'
 486         sig_info        = TySigInfo bndr_name local_meth_id tyvars' theta' tau' src_loc
 487    in
 488    tcExtendGlobalTyVars inst_tyvars (
 489      tcAddErrCtxt (methodCtxt sel_id)           $
 490      tcBindWithSigs NotTopLevel [bndr_name] meth_bind [sig_info]
 491                     NonRecursive (\_ -> NoPragmaInfo)
 492    )                                                    `thenTc` \ (binds, insts, _) ->
 493
 494         -- Now check that the instance type variables
 495         -- (or, in the case of a class decl, the class tyvars)
 496         -- have not been unified with anything in the environment
 497    tcAddErrCtxt (monoCtxt sel_id) (
 498      tcAddErrCtxt (sigCtxt sel_id) $
 499      checkSigTyVars inst_tyvars (idType local_meth_id)
 500    )                                                    `thenTc_`
 501
 502    returnTc (binds, insts, meth)
 503  where
 504    (bndr_name, src_loc) = case meth_bind of
 505                                 FunMonoBind name _ _ loc          -> (name, loc)
 506                                 PatMonoBind (VarPatIn name) _ loc -> (name, loc)
 507 \end{code}
 508
 509 Contexts and errors
 510 ~~~~~~~~~~~~~~~~~~~
 511 \begin{code}
 512 classArityErr class_name
 513   = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
 514
 515 classDeclCtxt class_name
 516   = ptext SLIT("In the class declaration for") <+> quotes (ppr class_name)
 517
 518 methodCtxt sel_id
 519   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 520
 521 monoCtxt sel_id
 522   = sep [ptext SLIT("Probable cause: the right hand side of") <+> quotes (ppr sel_id),
 523          nest 4 (ptext SLIT("mentions a top-level variable subject to the dreaded monomorphism restriction"))
 524     ]
 525
 526 badMethodErr bndr clas
 527   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 528           ptext SLIT("does not have a method"), quotes (ppr bndr)]
 529 \end{code}