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