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