TcClassDcl.hs 19 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Simon Marlow's avatar
Simon Marlow committed
5 6

Typechecking class declarations
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9
{-# LANGUAGE CPP #-}
10 11

module TcClassDcl ( tcClassSigs, tcClassDecl2,
12
                    findMethodBind, instantiateMethod,
13
                    tcClassMinimalDef,
14
                    HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
15 16
                    tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr,
                    tcATDefault
17
                  ) where
18

19
#include "HsVersions.h"
20

21
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
22
import TcEnv
23
import TcPat( addInlinePrags, lookupPragEnv, emptyPragEnv )
24
import TcEvidence( idHsWrapper )
Simon Marlow's avatar
Simon Marlow committed
25
import TcBinds
26
import TcUnify
Simon Marlow's avatar
Simon Marlow committed
27 28
import TcHsType
import TcMType
29
import Type     ( getClassPredTys_maybe, varSetElemsWellScoped )
Simon Marlow's avatar
Simon Marlow committed
30
import TcType
31
import TcRnMonad
32
import BuildTyCl( TcMethInfo )
Simon Marlow's avatar
Simon Marlow committed
33
import Class
34 35 36 37
import Coercion ( pprCoAxiom )
import DynFlags
import FamInst
import FamInstEnv
Simon Marlow's avatar
Simon Marlow committed
38 39
import Id
import Name
40 41
import NameEnv
import NameSet
Ian Lynagh's avatar
Ian Lynagh committed
42
import Var
43 44
import VarEnv
import VarSet
sof's avatar
sof committed
45
import Outputable
Simon Marlow's avatar
Simon Marlow committed
46
import SrcLoc
47
import TyCon
Simon Marlow's avatar
Simon Marlow committed
48 49
import Maybes
import BasicTypes
50
import Bag
51
import FastString
52
import BooleanFormula
53
import Util
54 55

import Control.Monad
56
import Data.List ( mapAccumL )
57

Austin Seipp's avatar
Austin Seipp committed
58
{-
59 60 61 62 63
Dictionary handling
~~~~~~~~~~~~~~~~~~~
Every class implicitly declares a new data type, corresponding to dictionaries
of that class. So, for example:

64 65 66
        class (D a) => C a where
          op1 :: a -> a
          op2 :: forall b. Ord b => a -> b -> b
67 68 69

would implicitly declare

70 71 72
        data CDict a = CDict (D a)
                             (a -> a)
                             (forall b. Ord b => a -> b -> b)
73 74 75 76 77 78

(We could use a record decl, but that means changing more of the existing apparatus.
One step at at time!)

For classes with just one superclass+method, we use a newtype decl instead:

79 80
        class C a where
          op :: forallb. a -> b -> b
81 82 83

generates

84
        newtype CDict a = CDict (forall b. a -> b -> b)
85

86 87
Now DictTy in Type is just a form of type synomym:
        DictTy c t = TyConTy CDict `AppTy` t
88 89 90 91

Death to "ExpandingDicts".


Austin Seipp's avatar
Austin Seipp committed
92 93
************************************************************************
*                                                                      *
94
                Type-checking the class op signatures
Austin Seipp's avatar
Austin Seipp committed
95 96 97
*                                                                      *
************************************************************************
-}
98

99
tcClassSigs :: Name                -- Name of the class
100 101
            -> [LSig Name]
            -> LHsBinds Name
102
            -> TcM [TcMethInfo]    -- Exactly one for each method
103
tcClassSigs clas sigs def_methods
104 105 106
  = do { traceTc "tcClassSigs 1" (ppr clas)

       ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
107 108
       ; let gen_dm_env :: NameEnv Type
             gen_dm_env = mkNameEnv gen_dm_prs
109

110
       ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
111

112
       ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
113
       ; sequence_ [ failWithTc (badMethodErr clas n)
114
                   | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
115
                   -- Value binding for non class-method (ie no TypeSig)
116

117
       ; sequence_ [ failWithTc (badGenericMethod clas n)
118
                   | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
119
                   -- Generic signature without value binding
120

121
       ; traceTc "tcClassSigs 2" (ppr clas)
122
       ; return op_info }
123
  where
124 125
    vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig False nm ty) <- sigs]
    gen_sigs     = [L loc (nm,ty) | L loc (ClassOpSig True  nm ty) <- sigs]
126
    dm_bind_names :: [Name]     -- These ones have a value binding in the class decl
127
    dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
128

129 130
    tc_sig :: NameEnv Type -> ([Located Name], LHsSigType Name)
           -> TcM [TcMethInfo]
131
    tc_sig gen_dm_env (op_names, op_hs_ty)
132
      = do { traceTc "ClsSig 1" (ppr op_names)
133
           ; op_ty <- tcClassSigType op_names op_hs_ty   -- Class tyvars already in scope
134
           ; traceTc "ClsSig 2" (ppr op_names)
135
           ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
136
           where
137 138 139
             f nm | Just ty <- lookupNameEnv gen_dm_env nm = Just (GenericDM ty)
                  | nm `elem` dm_bind_names                = Just VanillaDM
                  | otherwise                              = Nothing
140

141
    tc_gen_sig (op_names, gen_hs_ty)
142
      = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty
143
           ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }
144

Austin Seipp's avatar
Austin Seipp committed
145 146 147
{-
************************************************************************
*                                                                      *
148
                Class Declarations
Austin Seipp's avatar
Austin Seipp committed
149 150 151
*                                                                      *
************************************************************************
-}
152

153 154
tcClassDecl2 :: LTyClDecl Name          -- The class declaration
             -> TcM (LHsBinds Id)
155

156 157 158 159
tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
                                tcdMeths = default_binds}))
  = recoverM (return emptyLHsBinds)     $
    setSrcSpan loc                      $
160
    do  { clas <- tcLookupLocatedClass class_name
161

162 163 164 165 166 167 168 169
        -- We make a separate binding for each default method.
        -- At one time I used a single AbsBinds for all of them, thus
        -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
        -- But that desugars into
        --      ds = \d -> (..., ..., ...)
        --      dm1 = \d -> case ds d of (a,b,c) -> a
        -- And since ds is big, it doesn't get inlined, so we don't get good
        -- default methods.  Better to make separate AbsBinds for each
170
        ; let (tyvars, _, _, op_items) = classBigSig clas
171
              prag_fn     = mkPragEnv sigs default_binds
172
              sig_fn      = mkHsSigFun sigs
173
              clas_tyvars = snd (tcSuperSkolTyVars tyvars)
174 175
              pred        = mkClassPred clas (mkTyVarTys clas_tyvars)
        ; this_dict <- newEvVar pred
176

177 178
        ; let tc_item = tcDefMeth clas clas_tyvars this_dict
                                  default_binds sig_fn prag_fn
179
        ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
180
                      mapM tc_item op_items
181

182
        ; return (unionManyBags dm_binds) }
183

Ian Lynagh's avatar
Ian Lynagh committed
184
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
185

186
tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
187
          -> HsSigFun -> TcPragEnv -> ClassOpItem
188
          -> TcM (LHsBinds TcId)
189
-- Generate code for default methods
190 191 192
-- This is incompatible with Hugs, which expects a polymorphic
-- default method for every class op, regardless of whether or not
-- the programmer supplied an explicit default decl for the class.
193
-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
194 195 196 197 198 199 200 201 202

tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
  = do { -- No default method
         mapM_ (addLocM (badDmPrag sel_id))
               (lookupPragEnv prag_fn (idName sel_id))
       ; return emptyBag }

tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
          (sel_id, Just (dm_name, dm_spec))
203
  | Just (L bind_loc dm_bind, bndr_loc) <- findMethodBind sel_name binds_in
204 205
  = do { -- First look up the default method -- It should be there!
         global_dm_id  <- tcLookupId dm_name
206 207 208 209 210
       ; global_dm_id  <- addInlinePrags global_dm_id prags
       ; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name)
            -- Base the local_dm_name on the selector name, because
            -- type errors from tcInstanceMethodBody come from here

211 212
       ; spec_prags <- discardConstraints $
                       tcSpecPrags global_dm_id prags
213
       ; warnTc (not (null spec_prags))
214
                (text "Ignoring SPECIALISE pragmas on default method"
215 216
                 <+> quotes (ppr sel_name))

217 218
       ; let hs_ty = lookupHsSig hs_sig_fn sel_name
                     `orElse` pprPanic "tc_dm" (ppr sel_name)
219 220 221 222 223 224 225 226 227 228 229 230 231
             -- We need the HsType so that we can bring the right
             -- type variables into scope
             --
             -- Eg.   class C a where
             --          op :: forall b. Eq b => a -> [b] -> a
             --          gen_op :: a -> a
             --          generic gen_op :: D a => a -> a
             -- The "local_dm_ty" is precisely the type in the above
             -- type signatures, ie with no "forall a. C a =>" prefix

             local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)

             lm_bind     = dm_bind { fun_id = L bind_loc local_dm_name }
232
                             -- Substitute the local_meth_name for the binder
233
                             -- NB: the binding is always a FunBind
234

235 236 237 238 239 240 241
             warn_redundant = case dm_spec of
                                GenericDM {} -> True
                                VanillaDM    -> False
                -- For GenericDM, warn if the user specifies a signature
                -- with redundant constraints; but not for VanillaDM, where
                -- the default method may well be 'error' or something

242 243
             ctxt = FunSigCtxt sel_name warn_redundant

244
       ; local_dm_sig <- instTcTySig ctxt hs_ty local_dm_ty local_dm_name
245
        ; (ev_binds, (tc_bind, _))
246
               <- checkConstraints (ClsSkol clas) tyvars [this_dict] $
247
                  tcPolyCheck NonRecursive no_prag_fn local_dm_sig
248 249
                              (L bind_loc lm_bind)

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
250
        ; let export = ABE { abe_poly      = global_dm_id
thomasw's avatar
thomasw committed
251 252 253
                           -- We have created a complete type signature in
                           -- instTcTySig, hence it is safe to call
                           -- completeSigPolyId
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
254 255 256 257
                           , abe_mono      = completeIdSigPolyId local_dm_sig
                           , abe_wrap      = idHsWrapper
                           , abe_inst_wrap = idHsWrapper
                           , abe_prags     = IsDefaultMethod }
258
              full_bind = AbsBinds { abs_tvs      = tyvars
259
                                   , abs_ev_vars  = [this_dict]
260
                                   , abs_exports  = [export]
261
                                   , abs_ev_binds = [ev_binds]
262
                                   , abs_binds    = tc_bind }
263

264 265 266
        ; return (unitBag (L bind_loc full_bind)) }

  | otherwise = pprPanic "tcDefMeth" (ppr sel_id)
267
  where
268
    sel_name = idName sel_id
269 270
    prags    = lookupPragEnv prag_fn sel_name
    no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;
271
                                -- they are all for meth_id
272 273 274 275 276 277 278

---------------
tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef
tcClassMinimalDef _clas sigs op_info
  = case findMinimalDef sigs of
      Nothing -> return defMindef
      Just mindef -> do
279 280 281 282
        -- Warn if the given mindef does not imply the default one
        -- That is, the given mindef should at least ensure that the
        -- class ops without default methods are required, since we
        -- have no way to fill them in otherwise
283
        whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
284
                   (\bf -> addWarnTc (warningMinimalDefIncomplete bf))
285 286
        return mindef
  where
287
    -- By default require all methods without a default
288 289
    -- implementation whose names don't start with '_'
    defMindef :: ClassMinimalDef
290
    defMindef = mkAnd [ noLoc (mkVar name)
291
                      | (name, _, Nothing) <- op_info
292
                      , not (startsWithUnderscore (getOccName name)) ]
293

294
instantiateMethod :: Class -> Id -> [TcType] -> TcType
295 296
-- Take a class operation, say
--      op :: forall ab. C a => forall c. Ix c => (b,c) -> a
297
-- Instantiate it at [ty1,ty2]
298 299
-- Return the "local method type":
--      forall c. Ix x => (ty2,c) -> ty1
300 301 302
instantiateMethod clas sel_id inst_tys
  = ASSERT( ok_first_pred ) local_meth_ty
  where
303
    rho_ty = applyTys (idType sel_id) inst_tys
304
    (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
305
                `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
306 307

    ok_first_pred = case getClassPredTys_maybe first_pred of
308
                      Just (clas1, _tys) -> clas == clas1
309
                      Nothing -> False
310 311
              -- The first predicate should be of form (C a b)
              -- where C is the class in question
312 313


314
---------------------------
315
type HsSigFun = NameEnv (LHsSigType Name)
316 317 318 319 320

emptyHsSigs :: HsSigFun
emptyHsSigs = emptyNameEnv

mkHsSigFun :: [LSig Name] -> HsSigFun
321
mkHsSigFun sigs = mkNameEnv [(n, hs_ty)
322
                            | L _ (ClassOpSig False ns hs_ty) <- sigs
323 324
                            , L _ n <- ns ]

325
lookupHsSig :: HsSigFun -> Name -> Maybe (LHsSigType Name)
326 327
lookupHsSig = lookupNameEnv

328
---------------------------
329 330 331 332
findMethodBind  :: Name                 -- Selector name
                -> LHsBinds Name        -- A group of bindings
                -> Maybe (LHsBind Name, SrcSpan)
                -- Returns the binding, and the binding
333
                -- site of the method binder
334
findMethodBind sel_name binds
335
  = foldlBag mplus Nothing (mapBag f binds)
336 337 338
  where
    f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
      | op_name == sel_name
339
             = Just (bind, bndr_loc)
340
    f _other = Nothing
341 342 343 344 345

---------------------------
findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef
findMinimalDef = firstJusts . map toMinimalDef
  where
Icelandjack's avatar
Icelandjack committed
346
    toMinimalDef :: LSig Name -> Maybe ClassMinimalDef
347 348
    toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf)
    toMinimalDef _                             = Nothing
349

Austin Seipp's avatar
Austin Seipp committed
350
{-
351 352 353 354
Note [Polymorphic methods]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
    class Foo a where
355
        op :: forall b. Ord b => a -> b -> b -> b
356 357
    instance Foo c => Foo [c] where
        op = e
358

359 360 361
When typechecking the binding 'op = e', we'll have a meth_id for op
whose type is
      op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
362

363
So tcPolyBinds must be capable of dealing with nested polytypes;
364
and so it is. See TcBinds.tcMonoBinds (with type-sig case).
365

366 367 368 369
Note [Silly default-method bind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we pass the default method binding to the type checker, it must
look like    op2 = e
370
not          $dmop2 = e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
371 372 373
otherwise the "$dm" stuff comes out error messages.  But we want the
"$dm" to come out in the interface file.  So we typecheck the former,
and wrap it in a let, thus
374
          $dmop2 = let op2 = e in op2
375
This makes the error messages right.
376 377


Austin Seipp's avatar
Austin Seipp committed
378 379
************************************************************************
*                                                                      *
380
                Error messages
Austin Seipp's avatar
Austin Seipp committed
381 382 383
*                                                                      *
************************************************************************
-}
384

385
tcMkDeclCtxt :: TyClDecl Name -> SDoc
386 387
tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,
                      text "declaration for", quotes (ppr (tcdName decl))]
388

Ian Lynagh's avatar
Ian Lynagh committed
389
tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
390
tcAddDeclCtxt decl thing_inside
391
  = addErrCtxt (tcMkDeclCtxt decl) thing_inside
392

Ian Lynagh's avatar
Ian Lynagh committed
393
badMethodErr :: Outputable a => a -> Name -> SDoc
394
badMethodErr clas op
395 396
  = hsep [text "Class", quotes (ppr clas),
          text "does not have a method", quotes (ppr op)]
397

398 399
badGenericMethod :: Outputable a => a -> Name -> SDoc
badGenericMethod clas op
400 401
  = hsep [text "Class", quotes (ppr clas),
          text "has a generic-default signature without a binding", quotes (ppr op)]
402

403
{-
Ian Lynagh's avatar
Ian Lynagh committed
404
badGenericInstanceType :: LHsBinds Name -> SDoc
405
badGenericInstanceType binds
406
  = vcat [text "Illegal type pattern in the generic bindings",
407
          nest 2 (ppr binds)]
408

Ian Lynagh's avatar
Ian Lynagh committed
409
missingGenericInstances :: [Name] -> SDoc
410
missingGenericInstances missing
411
  = text "Missing type patterns for" <+> pprQuotedList missing
412

413
dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
414
dupGenericInsts tc_inst_infos
415
  = vcat [text "More than one type pattern for a single generic type constructor:",
416
          nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
417
          text "All the type patterns for a generic type constructor must be identical"
418
    ]
419
  where
420
    ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
421
-}
Simon Peyton Jones's avatar
Simon Peyton Jones committed
422 423
badDmPrag :: Id -> Sig Name -> TcM ()
badDmPrag sel_id prag
424
  = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method")
425
              <+> quotes (ppr sel_id)
426
              <+> text "lacks an accompanying binding")
427 428 429

warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
warningMinimalDefIncomplete mindef
430
  = vcat [ text "The MINIMAL pragma does not require:"
431
         , nest 2 (pprBooleanFormulaNice mindef)
432
         , text "but there is no default implementation." ]
433 434 435 436

tcATDefault :: Bool -- If a warning should be emitted when a default instance
                    -- definition is not provided by the user
            -> SrcSpan
437
            -> TCvSubst
438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455
            -> NameSet
            -> ClassATItem
            -> TcM [FamInst]
-- ^ Construct default instances for any associated types that
-- aren't given a user definition
-- Returns [] or singleton
tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs)
  -- User supplied instances ==> everything is OK
  | tyConName fam_tc `elemNameSet` defined_ats
  = return []

  -- No user instance, have defaults ==> instatiate them
   -- Example:   class C a where { type F a b :: *; type F a b = () }
   --            instance C [x]
   -- Then we want to generate the decl:   type F [x] b = ()
  | Just (rhs_ty, _loc) <- defs
  = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
                                            (tyConTyVars fam_tc)
456
             rhs'     = substTyUnchecked subst' rhs_ty
457 458 459 460
             tcv_set' = tyCoVarsOfTypes pat_tys'
             (tv_set', cv_set') = partitionVarSet isTyVar tcv_set'
             tvs'     = varSetElemsWellScoped tv_set'
             cvs'     = varSetElemsWellScoped cv_set'
461
       ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys'
462
       ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' cvs'
463 464 465 466 467 468 469 470
                                     fam_tc pat_tys' rhs'
           -- NB: no validity check. We check validity of default instances
           -- in the class definition. Because type instance arguments cannot
           -- be type family applications and cannot be polytypes, the
           -- validity check is redundant.

       ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
                                              , pprCoAxiom axiom ])
471
       ; fam_inst <- ASSERT( tyCoVarsOfType rhs' `subVarSet` tv_set' )
472 473 474 475 476 477 478 479 480 481 482 483
                     newFamInst SynFamilyInst axiom
       ; return [fam_inst] }

   -- No defaults ==> generate a warning
  | otherwise  -- defs = Nothing
  = do { when emit_warn $ warnMissingAT (tyConName fam_tc)
       ; return [] }
  where
    subst_tv subst tc_tv
      | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
      = (subst, ty)
      | otherwise
484
      = (extendTCvSubst subst tc_tv ty', ty')
485
      where
486
        ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)
487 488 489 490 491

warnMissingAT :: Name -> TcM ()
warnMissingAT name
  = do { warn <- woptM Opt_WarnMissingMethods
       ; traceTc "warn" (ppr name <+> ppr warn)
492
       ; warnTc warn  -- Warn only if -Wmissing-methods
493 494
                (text "No explicit" <+> text "associated type"
                    <+> text "or default declaration for     "
495
                    <+> quotes (ppr name)) }