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