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