compiler/typecheck/TcClassDcl.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Typechecking class declarations
   7
   8 \begin{code}
   9 module TcClassDcl ( tcClassSigs, tcClassDecl2,
  10                     findMethodBind, instantiateMethod, tcInstanceMethodBody,
  11                     mkGenericDefMethBind,
  12                     tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
  13                   ) where
  14
  15 #include "HsVersions.h"
  16
  17 import HsSyn
  18 import TcEnv
  19 import TcPat( addInlinePrags )
  20 import TcBinds
  21 import TcUnify
  22 import TcHsType
  23 import TcMType
  24 import TcType
  25 import TcRnMonad
  26 import BuildTyCl( TcMethInfo )
  27 import Class
  28 import Id
  29 import Name
  30 import Var
  31 import Outputable
  32 import DynFlags
  33 import ErrUtils
  34 import SrcLoc
  35 import Maybes
  36 import BasicTypes
  37 import Bag
  38 import FastString
  39
  40 import Control.Monad
  41 \end{code}
  42
  43
  44 Dictionary handling
  45 ~~~~~~~~~~~~~~~~~~~
  46 Every class implicitly declares a new data type, corresponding to dictionaries
  47 of that class. So, for example:
  48
  49         class (D a) => C a where
  50           op1 :: a -> a
  51           op2 :: forall b. Ord b => a -> b -> b
  52
  53 would implicitly declare
  54
  55         data CDict a = CDict (D a)
  56                              (a -> a)
  57                              (forall b. Ord b => a -> b -> b)
  58
  59 (We could use a record decl, but that means changing more of the existing apparatus.
  60 One step at at time!)
  61
  62 For classes with just one superclass+method, we use a newtype decl instead:
  63
  64         class C a where
  65           op :: forallb. a -> b -> b
  66
  67 generates
  68
  69         newtype CDict a = CDict (forall b. a -> b -> b)
  70
  71 Now DictTy in Type is just a form of type synomym:
  72         DictTy c t = TyConTy CDict `AppTy` t
  73
  74 Death to "ExpandingDicts".
  75
  76
  77 %************************************************************************
  78 %*                                                                      *
  79                 Type-checking the class op signatures
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 tcClassSigs :: Name                     -- Name of the class
  85             -> [LSig Name]
  86             -> LHsBinds Name
  87             -> TcM [TcMethInfo]    -- One for each method
  88
  89 tcClassSigs clas sigs def_methods
  90   = do { -- Check that all def_methods are in the class
  91        ; op_info <- mapM (addLocM tc_sig) [sig | sig@(L _ (TypeSig _ _)) <- sigs]
  92        ; let op_names = [ n | (n,_,_) <- op_info ]
  93
  94        ; sequence_ [ failWithTc (badMethodErr clas n)
  95                    | n <- dm_bind_names, not (n `elem` op_names) ]
  96                    -- Value binding for non class-method (ie no TypeSig)
  97
  98        ; sequence_ [ failWithTc (badGenericMethod clas n)
  99                    | n <- genop_names, not (n `elem` dm_bind_names) ]
 100                    -- Generic signature without value binding
 101
 102        ; return op_info }
 103   where
 104     dm_bind_names :: [Name]     -- These ones have a value binding in the class decl
 105     dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
 106
 107     genop_names :: [Name]   -- These ones have a generic signature
 108     genop_names = [n | L _ (GenericSig (L _ n) _) <- sigs]
 109
 110     tc_sig (TypeSig (L _ op_name) op_hs_ty)
 111       = do { op_ty <- tcHsKindedType op_hs_ty   -- Class tyvars already in scope
 112            ; let dm | op_name `elem` genop_names   = GenericDM
 113                     | op_name `elem` dm_bind_names = VanillaDM
 114                     | otherwise                    = NoDM
 115            ; return (op_name, dm, op_ty) }
 116     tc_sig sig = pprPanic "tc_cls_sig" (ppr sig)
 117 \end{code}
 118
 119
 120 %************************************************************************
 121 %*                                                                      *
 122                 Class Declarations
 123 %*                                                                      *
 124 %************************************************************************
 125
 126 \begin{code}
 127 tcClassDecl2 :: LTyClDecl Name          -- The class declaration
 128              -> TcM (LHsBinds Id)
 129
 130 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 131                                 tcdMeths = default_binds}))
 132   = recoverM (return emptyLHsBinds)     $
 133     setSrcSpan loc                      $
 134     do  { clas <- tcLookupLocatedClass class_name
 135
 136         -- We make a separate binding for each default method.
 137         -- At one time I used a single AbsBinds for all of them, thus
 138         -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
 139         -- But that desugars into
 140         --      ds = \d -> (..., ..., ...)
 141         --      dm1 = \d -> case ds d of (a,b,c) -> a
 142         -- And since ds is big, it doesn't get inlined, so we don't get good
 143         -- default methods.  Better to make separate AbsBinds for each
 144         ; let
 145               (tyvars, _, _, op_items) = classBigSig clas
 146               prag_fn     = mkPragFun sigs default_binds
 147               sig_fn      = mkSigFun sigs
 148               clas_tyvars = tcSuperSkolTyVars tyvars
 149               pred        = mkClassPred clas (mkTyVarTys clas_tyvars)
 150         ; this_dict <- newEvVar pred
 151
 152         ; traceTc "TIM2" (ppr sigs)
 153         ; let tc_dm = tcDefMeth clas clas_tyvars
 154                                 this_dict default_binds sigs
 155                                 sig_fn prag_fn
 156
 157         ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
 158                       mapM tc_dm op_items
 159
 160         ; return (unionManyBags dm_binds) }
 161
 162 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
 163
 164 tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name]
 165           -> SigFun -> PragFun -> ClassOpItem
 166           -> TcM (LHsBinds TcId)
 167 -- Generate code for polymorphic default methods only (hence DefMeth)
 168 -- (Generic default methods have turned into instance decls by now.)
 169 -- This is incompatible with Hugs, which expects a polymorphic
 170 -- default method for every class op, regardless of whether or not
 171 -- the programmer supplied an explicit default decl for the class.
 172 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 173 tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
 174   = case dm_info of
 175       NoDefMeth          -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
 176                                ; return emptyBag }
 177       DefMeth dm_name    -> tc_dm dm_name (instantiateMethod clas sel_id (mkTyVarTys tyvars))
 178       GenDefMeth dm_name -> do { tau <- tc_genop_ty (findGenericSig sigs sel_name)
 179                                ; tc_dm dm_name tau }
 180            -- In the case of a generic default, we have to get the type from the signature
 181            -- Otherwise we can get it by instantiating the method selector
 182   where
 183     sel_name      = idName sel_id
 184     prags         = prag_fn sel_name
 185     dm_sig_fn  _  = sig_fn sel_name
 186     dm_bind       = findMethodBind sel_name binds_in
 187                     `orElse` pprPanic "tcDefMeth" (ppr sel_id)
 188
 189     -- Eg.   class C a where
 190     --          op :: forall b. Eq b => a -> [b] -> a
 191     --          gen_op :: a -> a
 192     --          generic gen_op :: D a => a -> a
 193     -- The "local_dm_ty" is precisely the type in the above
 194     -- type signatures, ie with no "forall a. C a =>" prefix
 195
 196     tc_dm dm_name local_dm_ty
 197       = do { local_dm_name <- newLocalName sel_name
 198              -- Base the local_dm_name on the selector name, because
 199              -- type errors from tcInstanceMethodBody come from here
 200
 201            ; let dm_ty = mkSigmaTy tyvars [mkClassPred clas (mkTyVarTys tyvars)] local_dm_ty
 202                  dm_id = mkExportedLocalId dm_name dm_ty
 203                  local_dm_id = mkLocalId local_dm_name local_dm_ty
 204
 205            ; dm_id_w_inline <- addInlinePrags dm_id prags
 206            ; spec_prags     <- tcSpecPrags dm_id prags
 207
 208            ; warnTc (not (null spec_prags))
 209                     (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
 210                      <+> quotes (ppr sel_name))
 211
 212            ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
 213                                              dm_id_w_inline local_dm_id dm_sig_fn
 214                                              IsDefaultMethod dm_bind
 215
 216            ; return (unitBag tc_bind) }
 217
 218     tc_genop_ty :: LHsType Name -> TcM Type
 219     tc_genop_ty hs_ty
 220        = setSrcSpan (getLoc hs_ty) $
 221          do { tau <- tcHsKindedType hs_ty
 222             ; checkValidType (FunSigCtxt sel_name) tau
 223             ; return tau }
 224
 225 findGenericSig :: [LSig Name] -> Name -> LHsType Name
 226 -- Find the 'generic op :: ty' signature among the sigs
 227 -- If dm_info is GenDefMeth, the corresponding signature
 228 -- should jolly well exist!  Hence the panic
 229 findGenericSig sigs sel_name
 230   = case [lty | L _ (GenericSig (L _ n) lty) <- sigs
 231          , n == sel_name ] of
 232       [lty] -> lty
 233       _     -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs)
 234
 235 ---------------
 236 tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
 237                      -> Id -> Id
 238                      -> SigFun -> TcSpecPrags -> LHsBind Name
 239                      -> TcM (LHsBind Id)
 240 tcInstanceMethodBody skol_info tyvars dfun_ev_vars
 241                      meth_id local_meth_id
 242                      meth_sig_fn specs
 243                      (L loc bind)
 244   = do  {       -- Typecheck the binding, first extending the envt
 245                 -- so that when tcInstSig looks up the local_meth_id to find
 246                 -- its signature, we'll find it in the environment
 247           let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
 248                              -- Substitute the local_meth_name for the binder
 249                              -- NB: the binding is always a FunBind
 250         ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id)))
 251         ; (ev_binds, (tc_bind, _))
 252                <- checkConstraints skol_info tyvars dfun_ev_vars $
 253                   tcExtendIdEnv [local_meth_id] $
 254                   tcPolyBinds TopLevel meth_sig_fn no_prag_fn
 255                              NonRecursive NonRecursive
 256                              [lm_bind]
 257
 258         ; let full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
 259                                    , abs_exports = [(tyvars, meth_id, local_meth_id, specs)]
 260                                    , abs_ev_binds = ev_binds
 261                                    , abs_binds = tc_bind }
 262
 263         ; return (L loc full_bind) }
 264   where
 265     no_prag_fn  _ = []          -- No pragmas for local_meth_id;
 266                                 -- they are all for meth_id
 267 \end{code}
 268
 269 \begin{code}
 270 instantiateMethod :: Class -> Id -> [TcType] -> TcType
 271 -- Take a class operation, say
 272 --      op :: forall ab. C a => forall c. Ix c => (b,c) -> a
 273 -- Instantiate it at [ty1,ty2]
 274 -- Return the "local method type":
 275 --      forall c. Ix x => (ty2,c) -> ty1
 276 instantiateMethod clas sel_id inst_tys
 277   = ASSERT( ok_first_pred ) local_meth_ty
 278   where
 279     (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
 280     rho_ty = ASSERT( length sel_tyvars == length inst_tys )
 281              substTyWith sel_tyvars inst_tys sel_rho
 282
 283     (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
 284                 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
 285
 286     ok_first_pred = case getClassPredTys_maybe first_pred of
 287                       Just (clas1, _tys) -> clas == clas1
 288                       Nothing -> False
 289               -- The first predicate should be of form (C a b)
 290               -- where C is the class in question
 291
 292
 293 ---------------------------
 294 findMethodBind  :: Name                 -- Selector name
 295                 -> LHsBinds Name        -- A group of bindings
 296                 -> Maybe (LHsBind Name) -- The binding
 297 findMethodBind sel_name binds
 298   = foldlBag mplus Nothing (mapBag f binds)
 299   where
 300     f bind@(L _ (FunBind { fun_id = L _ op_name }))
 301              | op_name == sel_name
 302              = Just bind
 303     f _other = Nothing
 304 \end{code}
 305
 306 Note [Polymorphic methods]
 307 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 308 Consider
 309     class Foo a where
 310         op :: forall b. Ord b => a -> b -> b -> b
 311     instance Foo c => Foo [c] where
 312         op = e
 313
 314 When typechecking the binding 'op = e', we'll have a meth_id for op
 315 whose type is
 316       op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
 317
 318 So tcPolyBinds must be capable of dealing with nested polytypes;
 319 and so it is. See TcBinds.tcMonoBinds (with type-sig case).
 320
 321 Note [Silly default-method bind]
 322 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 323 When we pass the default method binding to the type checker, it must
 324 look like    op2 = e
 325 not          $dmop2 = e
 326 otherwise the "$dm" stuff comes out error messages.  But we want the
 327 "$dm" to come out in the interface file.  So we typecheck the former,
 328 and wrap it in a let, thus
 329           $dmop2 = let op2 = e in op2
 330 This makes the error messages right.
 331
 332
 333 %************************************************************************
 334 %*                                                                      *
 335         Extracting generic instance declaration from class declarations
 336 %*                                                                      *
 337 %************************************************************************
 338
 339 @getGenericInstances@ extracts the generic instance declarations from a class
 340 declaration.  For exmaple
 341
 342         class C a where
 343           op :: a -> a
 344
 345           op{ x+y } (Inl v)   = ...
 346           op{ x+y } (Inr v)   = ...
 347           op{ x*y } (v :*: w) = ...
 348           op{ 1   } Unit      = ...
 349
 350 gives rise to the instance declarations
 351
 352         instance C (x+y) where
 353           op (Inl v)   = ...
 354           op (Inr v)   = ...
 355
 356         instance C (x*y) where
 357           op (v :*: w) = ...
 358
 359         instance C 1 where
 360           op Unit      = ...
 361
 362 \begin{code}
 363 mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
 364 mkGenericDefMethBind clas inst_tys sel_id dm_name
 365   =     -- A generic default method
 366         -- If the method is defined generically, we only have to call the
 367         -- dm_name.
 368     do  { dflags <- getDOpts
 369         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
 370                    (vcat [ppr clas <+> ppr inst_tys,
 371                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 372
 373         ; return (noLoc $ mkFunBind (noLoc (idName sel_id))
 374                                     [mkSimpleMatch [] rhs]) }
 375   where
 376     rhs = nlHsVar dm_name
 377 \end{code}
 378
 379 %************************************************************************
 380 %*                                                                      *
 381                 Error messages
 382 %*                                                                      *
 383 %************************************************************************
 384
 385 \begin{code}
 386 tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
 387 tcAddDeclCtxt decl thing_inside
 388   = addErrCtxt ctxt thing_inside
 389   where
 390      thing | isClassDecl decl  = "class"
 391            | isTypeDecl decl   = "type synonym" ++ maybeInst
 392            | isDataDecl decl   = if tcdND decl == NewType
 393                                  then "newtype" ++ maybeInst
 394                                  else "data type" ++ maybeInst
 395            | isFamilyDecl decl = "family"
 396            | otherwise         = panic "tcAddDeclCtxt/thing"
 397
 398      maybeInst | isFamInstDecl decl = " instance"
 399                | otherwise          = ""
 400
 401      ctxt = hsep [ptext (sLit "In the"), text thing,
 402                   ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
 403
 404 badMethodErr :: Outputable a => a -> Name -> SDoc
 405 badMethodErr clas op
 406   = hsep [ptext (sLit "Class"), quotes (ppr clas),
 407           ptext (sLit "does not have a method"), quotes (ppr op)]
 408
 409 badGenericMethod :: Outputable a => a -> Name -> SDoc
 410 badGenericMethod clas op
 411   = hsep [ptext (sLit "Class"), quotes (ppr clas),
 412           ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
 413
 414 badATErr :: Class -> Name -> SDoc
 415 badATErr clas at
 416   = hsep [ptext (sLit "Class"), quotes (ppr clas),
 417           ptext (sLit "does not have an associated type"), quotes (ppr at)]
 418
 419 omittedATWarn :: Name -> SDoc
 420 omittedATWarn at
 421   = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
 422 {-
 423 badGenericInstanceType :: LHsBinds Name -> SDoc
 424 badGenericInstanceType binds
 425   = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
 426           nest 2 (ppr binds)]
 427
 428 missingGenericInstances :: [Name] -> SDoc
 429 missingGenericInstances missing
 430   = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
 431
 432 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
 433 dupGenericInsts tc_inst_infos
 434   = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
 435           nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
 436           ptext (sLit "All the type patterns for a generic type constructor must be identical")
 437     ]
 438   where
 439     ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
 440 -}
 441 badDmPrag :: Id -> Sig Name -> TcM ()
 442 badDmPrag sel_id prag
 443   = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method")
 444               <+> quotes (ppr sel_id)
 445               <+> ptext (sLit "lacks an accompanying binding"))
 446 \end{code}