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, sigThetaCtxt, 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     mapTc mk_super_id sc_theta          `thenTc` \ sc_sel_ids ->
 185
 186         -- Done
 187     returnTc (sc_theta, sc_tys, sc_sel_ids)
 188
 189   where
 190     rec_tyvar_tys = mkTyVarTys rec_tyvars
 191
 192     mk_super_id (super_class, tys)
 193         = tcGetUnique                   `thenNF_Tc` \ uniq ->
 194           let
 195                 ty = mkForAllTys rec_tyvars $
 196                      mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys)
 197           in
 198           returnTc (mkSuperDictSelId uniq rec_class super_class ty)
 199
 200
 201 tcClassSig :: TcEnv s                   -- Knot tying only!
 202            -> Class                     -- ...ditto...
 203            -> [TyVar]                   -- The class type variable, used for error check only
 204            -> RenamedClassOpSig
 205            -> TcM s (Type,              -- Type of the method
 206                      Id,                -- selector id
 207                      Maybe Id)          -- default-method ids
 208
 209 tcClassSig rec_env rec_clas rec_clas_tyvars
 210            (ClassOpSig op_name maybe_dm_name
 211                        op_ty
 212                        src_loc)
 213   = tcAddSrcLoc src_loc $
 214
 215         -- Check the type signature.  NB that the envt *already has*
 216         -- bindings for the type variables; see comments in TcTyAndClassDcls.
 217
 218     -- NB: Renamer checks that the class type variable is mentioned in local_ty,
 219     -- and that it is not constrained by theta
 220     tcHsType op_ty                              `thenTc` \ local_ty ->
 221     let
 222         global_ty   = mkSigmaTy rec_clas_tyvars
 223                                 [(rec_clas, mkTyVarTys rec_clas_tyvars)]
 224                                 local_ty
 225     in
 226
 227         -- Build the selector id and default method id
 228     let
 229         sel_id      = mkMethodSelId op_name rec_clas global_ty
 230         maybe_dm_id = case maybe_dm_name of
 231                            Nothing      -> Nothing
 232                            Just dm_name -> let
 233                                              dm_id = mkDefaultMethodId dm_name rec_clas global_ty
 234                                            in
 235                                            Just (tcAddImportedIdInfo rec_env dm_id)
 236     in
 237     returnTc (local_ty, sel_id, maybe_dm_id)
 238 \end{code}
 239
 240
 241 %************************************************************************
 242 %*                                                                      *
 243 \subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
 244 %*                                                                      *
 245 %************************************************************************
 246
 247 The purpose of pass 2 is
 248 \begin{enumerate}
 249 \item
 250 to beat on the explicitly-provided default-method decls (if any),
 251 using them to produce a complete set of default-method decls.
 252 (Omitted ones elicit an error message.)
 253 \item
 254 to produce a definition for the selector function for each method
 255 and superclass dictionary.
 256 \end{enumerate}
 257
 258 Pass~2 only applies to locally-defined class declarations.
 259
 260 The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 261 each local class decl.
 262
 263 \begin{code}
 264 tcClassDecls2 :: [RenamedHsDecl]
 265               -> NF_TcM s (LIE s, TcMonoBinds s)
 266
 267 tcClassDecls2 decls
 268   = foldr combine
 269           (returnNF_Tc (emptyLIE, EmptyMonoBinds))
 270           [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
 271   where
 272     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
 273                       tc2 `thenNF_Tc` \ (lie2, binds2) ->
 274                       returnNF_Tc (lie1 `plusLIE` lie2,
 275                                    binds1 `AndMonoBinds` binds2)
 276 \end{code}
 277
 278 @tcClassDecl2@ is the business end of things.
 279
 280 \begin{code}
 281 tcClassDecl2 :: RenamedClassDecl        -- The class declaration
 282              -> NF_TcM s (LIE s, TcMonoBinds s)
 283
 284 tcClassDecl2 (ClassDecl context class_name
 285                         tyvar_names class_sigs default_binds pragmas _ _ src_loc)
 286
 287   | not (isLocallyDefined class_name)
 288   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
 289
 290   | otherwise   -- It is locally defined
 291   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
 292     tcAddSrcLoc src_loc                                   $
 293
 294         -- Get the relevant class
 295     tcLookupClass class_name            `thenTc` \ (_, clas) ->
 296     let
 297         (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 298
 299         -- The selector binds are already in the selector Id's unfoldings
 300         sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
 301                     | sel_id <- sc_sel_ids ++ op_sel_ids,
 302                       isLocallyDefined sel_id
 303                     ]
 304
 305         final_sel_binds = andMonoBinds sel_binds
 306     in
 307         -- Generate bindings for the default methods
 308     tcDefaultMethodBinds clas default_binds             `thenTc` \ (const_insts, meth_binds) ->
 309
 310     returnTc (const_insts,
 311               final_sel_binds `AndMonoBinds` meth_binds)
 312 \end{code}
 313
 314 %************************************************************************
 315 %*                                                                      *
 316 \subsection[Default methods]{Default methods}
 317 %*                                                                      *
 318 %************************************************************************
 319
 320 The default methods for a class are each passed a dictionary for the
 321 class, so that they get access to the other methods at the same type.
 322 So, given the class decl
 323 \begin{verbatim}
 324 class Foo a where
 325         op1 :: a -> Bool
 326         op2 :: Ord b => a -> b -> b -> b
 327
 328         op1 x = True
 329         op2 x y z = if (op1 x) && (y < z) then y else z
 330 \end{verbatim}
 331 we get the default methods:
 332 \begin{verbatim}
 333 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 334 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 335
 336 ====================== OLD ==================
 337 \begin{verbatim}
 338 defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
 339 defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
 340                   if (op1 a dfoo x) && (< b dord y z) then y else z
 341 \end{verbatim}
 342 Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
 343 ====================== END OF OLD ===================
 344
 345 NEW:
 346 \begin{verbatim}
 347 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 348 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 349                   if (op1 a dfoo x) && (< b dord y z) then y else z
 350 \end{verbatim}
 351
 352
 353 When we come across an instance decl, we may need to use the default
 354 methods:
 355 \begin{verbatim}
 356 instance Foo Int where {}
 357 \end{verbatim}
 358 gives
 359 \begin{verbatim}
 360 const.Foo.Int.op1 :: Int -> Bool
 361 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 362
 363 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 364 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 365
 366 dfun.Foo.Int :: Foo Int
 367 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 368 \end{verbatim}
 369 Notice that, as with method selectors above, we assume that dictionary
 370 application is curried, so there's no need to mention the Ord dictionary
 371 in const.Foo.Int.op2 (or the type variable).
 372
 373 \begin{verbatim}
 374 instance Foo a => Foo [a] where {}
 375
 376 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 377 dfun.Foo.List
 378   = /\ a -> \ dfoo_a ->
 379     let rec
 380         op1 = defm.Foo.op1 [a] dfoo_list
 381         op2 = defm.Foo.op2 [a] dfoo_list
 382         dfoo_list = (op1, op2)
 383     in
 384         dfoo_list
 385 \end{verbatim}
 386
 387 \begin{code}
 388 tcDefaultMethodBinds
 389         :: Class
 390         -> RenamedMonoBinds
 391         -> TcM s (LIE s, TcMonoBinds s)
 392
 393 tcDefaultMethodBinds clas default_binds
 394   =     -- Construct suitable signatures
 395     tcInstSigTyVars tyvars              `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
 396
 397         -- Typecheck the default bindings
 398     let
 399         tc_dm meth_bind
 400           | not (maybeToBool maybe_stuff)
 401           =     -- Binding for something that isn't in the class signature
 402             failWithTc (badMethodErr bndr_name clas)
 403
 404           | otherwise
 405           =     -- Normal case
 406             tcMethodBind clas origin inst_tys clas_tyvars sel_id meth_bind
 407                                                 `thenTc` \ (bind, insts, (_, local_dm_id)) ->
 408             returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
 409           where
 410             bndr_name  = case meth_bind of
 411                                 FunMonoBind name _ _ _          -> name
 412                                 PatMonoBind (VarPatIn name) _ _ -> name
 413
 414             maybe_stuff = assocMaybe assoc_list (nameOccName bndr_name)
 415             assoc_list  = [ (getOccName sel_id, pair)
 416                           | pair@(sel_id, dm_ie) <- op_sel_ids `zip` defm_ids
 417                           ]
 418             Just (sel_id, Just dm_id) = maybe_stuff
 419                  -- We're looking at a default-method binding, so the dm_id
 420                  -- is sure to be there!  Hence the inner "Just".
 421     in
 422     mapAndUnzip3Tc tc_dm
 423         (flatten default_binds [])              `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
 424
 425         -- Check the context
 426     newDicts origin [(clas,inst_tys)]           `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
 427     let
 428         avail_insts = this_dict
 429     in
 430     tcAddErrCtxt (classDeclCtxt clas) $
 431     tcAddErrCtxtM (sigThetaCtxt avail_insts) $
 432     mapNF_Tc zonkSigTyVar clas_tyvars           `thenNF_Tc` \ clas_tyvars' ->
 433     tcSimplifyAndCheck (text "classDecl")
 434         (mkTyVarSet clas_tyvars')
 435         avail_insts
 436         (unionManyBags insts_needed)            `thenTc` \ (const_lie, dict_binds) ->
 437
 438     let
 439         full_binds = AbsBinds
 440                         clas_tyvars'
 441                         [this_dict_id]
 442                         abs_bind_stuff
 443                         (dict_binds `AndMonoBinds` andMonoBinds defm_binds)
 444     in
 445     returnTc (const_lie, full_binds)
 446
 447   where
 448     (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 449     origin = ClassDeclOrigin
 450
 451     flatten EmptyMonoBinds rest       = rest
 452     flatten (AndMonoBinds b1 b2) rest = flatten b1 (flatten b2 rest)
 453     flatten a_bind rest               = a_bind : rest
 454 \end{code}
 455
 456 @tcMethodBind@ is used to type-check both default-method and
 457 instance-decl method declarations.  We must type-check methods one at a
 458 time, because their signatures may have different contexts and
 459 tyvar sets.
 460
 461 \begin{code}
 462 tcMethodBind
 463         :: Class
 464         -> InstOrigin s
 465         -> [TcType s]                                   -- Instance types
 466         -> [TcTyVar s]                                  -- Free variables of those instance types
 467                                                         --  they'll be signature tyvars, and we
 468                                                         --  want to check that they don't bound
 469         -> Id                                           -- The method selector
 470         -> RenamedMonoBinds                             -- Method binding (just one)
 471         -> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
 472
 473 tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind
 474  = tcAddSrcLoc src_loc                          $
 475    newMethod origin (RealId sel_id) inst_tys    `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
 476    tcInstSigTcType (idType local_meth_id)       `thenNF_Tc` \ (tyvars', rho_ty') ->
 477    let
 478         (theta', tau')  = splitRhoTy rho_ty'
 479         sig_info        = TySigInfo bndr_name local_meth_id tyvars' theta' tau' src_loc
 480    in
 481    tcExtendGlobalTyVars inst_tyvars (
 482      tcAddErrCtxt (methodCtxt sel_id)           $
 483      tcBindWithSigs NotTopLevel [bndr_name] meth_bind [sig_info]
 484                     NonRecursive (\_ -> NoPragmaInfo)
 485    )                                                    `thenTc` \ (binds, insts, _) ->
 486
 487         -- Now check that the instance type variables
 488         -- (or, in the case of a class decl, the class tyvars)
 489         -- have not been unified with anything in the environment
 490    tcAddErrCtxt (monoCtxt sel_id) (
 491      tcAddErrCtxt (sigCtxt sel_id) $
 492      checkSigTyVars inst_tyvars (idType local_meth_id)
 493    )                                                    `thenTc_`
 494
 495    returnTc (binds, insts, meth)
 496  where
 497    (bndr_name, src_loc) = case meth_bind of
 498                                 FunMonoBind name _ _ loc          -> (name, loc)
 499                                 PatMonoBind (VarPatIn name) _ loc -> (name, loc)
 500 \end{code}
 501
 502 Contexts and errors
 503 ~~~~~~~~~~~~~~~~~~~
 504 \begin{code}
 505 classArityErr class_name
 506   = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
 507
 508 classDeclCtxt class_name
 509   = ptext SLIT("In the class declaration for") <+> quotes (ppr class_name)
 510
 511 methodCtxt sel_id
 512   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 513
 514 monoCtxt sel_id
 515   = sep [ptext SLIT("Probable cause: the right hand side of") <+> quotes (ppr sel_id),
 516          nest 4 (ptext SLIT("mentions a top-level variable subject to the dreaded monomorphism restriction"))
 517     ]
 518
 519 badMethodErr bndr clas
 520   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 521           ptext SLIT("does not have a method"), quotes (ppr bndr)]
 522 \end{code}