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                     getGenericInstances,
  11                     MethodSpec, tcMethodBind, mkMethodBind,
  12                     tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
  13                   ) where
  14
  15 #include "HsVersions.h"
  16
  17 import HsSyn
  18 import RnHsSyn
  19 import RnExpr
  20 import RnEnv
  21 import Inst
  22 import InstEnv
  23 import TcEnv
  24 import TcBinds
  25 import TcHsType
  26 import TcSimplify
  27 import TcUnify
  28 import TcMType
  29 import TcType
  30 import TcRnMonad
  31 import Generics
  32 import PrelInfo
  33 import Class
  34 import TyCon
  35 import Type
  36 import MkId
  37 import Id
  38 import Name
  39 import NameEnv
  40 import NameSet
  41 import OccName
  42 import RdrName
  43 import Outputable
  44 import PrelNames
  45 import DynFlags
  46 import ErrUtils
  47 import Util
  48 import Unique
  49 import ListSetOps
  50 import SrcLoc
  51 import Maybes
  52 import List
  53 import BasicTypes
  54 import Bag
  55 import FastString
  56 \end{code}
  57
  58
  59 Dictionary handling
  60 ~~~~~~~~~~~~~~~~~~~
  61 Every class implicitly declares a new data type, corresponding to dictionaries
  62 of that class. So, for example:
  63
  64         class (D a) => C a where
  65           op1 :: a -> a
  66           op2 :: forall b. Ord b => a -> b -> b
  67
  68 would implicitly declare
  69
  70         data CDict a = CDict (D a)
  71                              (a -> a)
  72                              (forall b. Ord b => a -> b -> b)
  73
  74 (We could use a record decl, but that means changing more of the existing apparatus.
  75 One step at at time!)
  76
  77 For classes with just one superclass+method, we use a newtype decl instead:
  78
  79         class C a where
  80           op :: forallb. a -> b -> b
  81
  82 generates
  83
  84         newtype CDict a = CDict (forall b. a -> b -> b)
  85
  86 Now DictTy in Type is just a form of type synomym:
  87         DictTy c t = TyConTy CDict `AppTy` t
  88
  89 Death to "ExpandingDicts".
  90
  91
  92 %************************************************************************
  93 %*                                                                      *
  94                 Type-checking the class op signatures
  95 %*                                                                      *
  96 %************************************************************************
  97
  98 \begin{code}
  99 tcClassSigs :: Name                     -- Name of the class
 100             -> [LSig Name]
 101             -> LHsBinds Name
 102             -> TcM [TcMethInfo]
 103
 104 type TcMethInfo = (Name, DefMeth, Type) -- A temporary intermediate, to communicate
 105                                         -- between tcClassSigs and buildClass
 106 tcClassSigs clas sigs def_methods
 107   = do { dm_env <- checkDefaultBinds clas op_names def_methods
 108        ; mappM (tcClassSig dm_env) op_sigs }
 109   where
 110     op_sigs  = [sig | sig@(L _ (TypeSig _ _))       <- sigs]
 111     op_names = [n   | sig@(L _ (TypeSig (L _ n) _)) <- op_sigs]
 112
 113
 114 checkDefaultBinds :: Name -> [Name] -> LHsBinds Name -> TcM (NameEnv Bool)
 115   -- Check default bindings
 116   --    a) must be for a class op for this class
 117   --    b) must be all generic or all non-generic
 118   -- and return a mapping from class-op to Bool
 119   --    where True <=> it's a generic default method
 120 checkDefaultBinds clas ops binds
 121   = do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds)
 122        return (mkNameEnv dm_infos)
 123
 124 checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
 125   = do {        -- Check that the op is from this class
 126         checkTc (op `elem` ops) (badMethodErr clas op)
 127
 128         -- Check that all the defns ar generic, or none are
 129     ;   checkTc (all_generic || none_generic) (mixedGenericErr op)
 130
 131     ;   returnM (op, all_generic)
 132     }
 133   where
 134     n_generic    = count (isJust . maybeGenericMatch) matches
 135     none_generic = n_generic == 0
 136     all_generic  = matches `lengthIs` n_generic
 137
 138
 139 tcClassSig :: NameEnv Bool              -- Info about default methods;
 140            -> LSig Name
 141            -> TcM TcMethInfo
 142
 143 tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
 144   = setSrcSpan loc $ do
 145     { op_ty <- tcHsKindedType op_hs_ty  -- Class tyvars already in scope
 146     ; let dm = case lookupNameEnv dm_env op_name of
 147                 Nothing    -> NoDefMeth
 148                 Just False -> DefMeth
 149                 Just True  -> GenDefMeth
 150     ; returnM (op_name, dm, op_ty) }
 151 \end{code}
 152
 153
 154 %************************************************************************
 155 %*                                                                      *
 156 \subsection[Default methods]{Default methods}
 157 %*                                                                      *
 158 %************************************************************************
 159
 160 The default methods for a class are each passed a dictionary for the
 161 class, so that they get access to the other methods at the same type.
 162 So, given the class decl
 163 \begin{verbatim}
 164 class Foo a where
 165         op1 :: a -> Bool
 166         op2 :: Ord b => a -> b -> b -> b
 167
 168         op1 x = True
 169         op2 x y z = if (op1 x) && (y < z) then y else z
 170 \end{verbatim}
 171 we get the default methods:
 172 \begin{verbatim}
 173 defm.Foo.op1 :: forall a. Foo a => a -> Bool
 174 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
 175
 176 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
 177 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
 178                   if (op1 a dfoo x) && (< b dord y z) then y else z
 179 \end{verbatim}
 180
 181 When we come across an instance decl, we may need to use the default
 182 methods:
 183 \begin{verbatim}
 184 instance Foo Int where {}
 185 \end{verbatim}
 186 gives
 187 \begin{verbatim}
 188 const.Foo.Int.op1 :: Int -> Bool
 189 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
 190
 191 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
 192 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
 193
 194 dfun.Foo.Int :: Foo Int
 195 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
 196 \end{verbatim}
 197 Notice that, as with method selectors above, we assume that dictionary
 198 application is curried, so there's no need to mention the Ord dictionary
 199 in const.Foo.Int.op2 (or the type variable).
 200
 201 \begin{verbatim}
 202 instance Foo a => Foo [a] where {}
 203
 204 dfun.Foo.List :: forall a. Foo a -> Foo [a]
 205 dfun.Foo.List
 206   = /\ a -> \ dfoo_a ->
 207     let rec
 208         op1 = defm.Foo.op1 [a] dfoo_list
 209         op2 = defm.Foo.op2 [a] dfoo_list
 210         dfoo_list = (op1, op2)
 211     in
 212         dfoo_list
 213 \end{verbatim}
 214
 215 @tcClassDecls2@ generates bindings for polymorphic default methods
 216 (generic default methods have by now turned into instance declarations)
 217
 218 \begin{code}
 219 tcClassDecl2 :: LTyClDecl Name          -- The class declaration
 220              -> TcM (LHsBinds Id, [Id])
 221
 222 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 223                                 tcdMeths = default_binds}))
 224   = recoverM (returnM (emptyLHsBinds, []))      $
 225     setSrcSpan loc                                      $
 226     tcLookupLocatedClass class_name                     `thenM` \ clas ->
 227
 228         -- We make a separate binding for each default method.
 229         -- At one time I used a single AbsBinds for all of them, thus
 230         -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
 231         -- But that desugars into
 232         --      ds = \d -> (..., ..., ...)
 233         --      dm1 = \d -> case ds d of (a,b,c) -> a
 234         -- And since ds is big, it doesn't get inlined, so we don't get good
 235         -- default methods.  Better to make separate AbsBinds for each
 236     let
 237         (tyvars, _, _, op_items) = classBigSig clas
 238         rigid_info               = ClsSkol clas
 239         origin                   = SigOrigin rigid_info
 240         prag_fn                  = mkPragFun sigs
 241         sig_fn                   = mkTcSigFun sigs
 242         clas_tyvars              = tcSkolSigTyVars rigid_info tyvars
 243         tc_dm                    = tcDefMeth origin clas clas_tyvars
 244                                              default_binds sig_fn prag_fn
 245
 246         dm_sel_ids               = [sel_id | (sel_id, DefMeth) <- op_items]
 247         -- Generate code for polymorphic default methods only
 248         -- (Generic default methods have turned into instance decls by now.)
 249         -- This is incompatible with Hugs, which expects a polymorphic
 250         -- default method for every class op, regardless of whether or not
 251         -- the programmer supplied an explicit default decl for the class.
 252         -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 253     in
 254     mapAndUnzipM tc_dm dm_sel_ids       `thenM` \ (defm_binds, dm_ids_s) ->
 255     returnM (listToBag defm_binds, concat dm_ids_s)
 256
 257 tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
 258   = do  { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
 259         ; let   inst_tys    = mkTyVarTys tyvars
 260                 dm_ty       = idType sel_id     -- Same as dict selector!
 261                 cls_pred    = mkClassPred clas inst_tys
 262                 local_dm_id = mkDefaultMethodId dm_name dm_ty
 263
 264         ; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
 265         ; loc <- getInstLoc origin
 266         ; this_dict <- newDictBndr loc cls_pred
 267         ; (defm_bind, insts_needed) <- getLIE (tcMethodBind tyvars [cls_pred] [this_dict]
 268                                                             sig_fn prag_fn meth_info)
 269
 270         ; addErrCtxt (defltMethCtxt clas) $ do
 271
 272         -- Check the context
 273         { dict_binds <- tcSimplifyCheck
 274                                 loc
 275                                 tyvars
 276                                 [this_dict]
 277                                 insts_needed
 278
 279         -- Simplification can do unification
 280         ; checkSigTyVars tyvars
 281
 282         -- Inline pragmas
 283         -- We'll have an inline pragma on the local binding, made by tcMethodBind
 284         -- but that's not enough; we want one on the global default method too
 285         -- Specialisations, on the other hand, belong on the thing inside only, I think
 286         ; let (_,dm_inst_id,_) = meth_info
 287               sel_name         = idName sel_id
 288               inline_prags     = filter isInlineLSig (prag_fn sel_name)
 289         ; prags <- tcPrags dm_inst_id inline_prags
 290
 291         ; let full_bind = AbsBinds  tyvars
 292                                     [instToId this_dict]
 293                                     [(tyvars, local_dm_id, dm_inst_id, prags)]
 294                                     (dict_binds `unionBags` defm_bind)
 295         ; returnM (noLoc full_bind, [local_dm_id]) }}
 296
 297 mkDefMethRdrName :: Id -> RdrName
 298 mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
 299 \end{code}
 300
 301
 302 %************************************************************************
 303 %*                                                                      *
 304 \subsection{Typechecking a method}
 305 %*                                                                      *
 306 %************************************************************************
 307
 308 @tcMethodBind@ is used to type-check both default-method and
 309 instance-decl method declarations.  We must type-check methods one at a
 310 time, because their signatures may have different contexts and
 311 tyvar sets.
 312
 313 \begin{code}
 314 type MethodSpec = (Id,                  -- Global selector Id
 315                    Id,                  -- Local Id (class tyvars instantiated)
 316                    LHsBind Name)        -- Binding for the method
 317
 318 tcMethodBind
 319         :: [TcTyVar]            -- Skolemised type variables for the
 320                                 --      enclosing class/instance decl.
 321                                 --      They'll be signature tyvars, and we
 322                                 --      want to check that they don't get bound
 323                                 -- Also they are scoped, so we bring them into scope
 324                                 -- Always equal the range of the type envt
 325         -> TcThetaType          -- Available theta; it's just used for the error message
 326         -> [Inst]               -- Available from context, used to simplify constraints
 327                                 --      from the method body
 328         -> TcSigFun             -- For scoped tyvars, indexed by sel_name
 329         -> TcPragFun            -- Pragmas (e.g. inline pragmas), indexed by sel_name
 330         -> MethodSpec           -- Details of this method
 331         -> TcM (LHsBinds Id)
 332
 333 tcMethodBind inst_tyvars inst_theta avail_insts sig_fn prag_fn
 334              (sel_id, meth_id, meth_bind)
 335   = recoverM (returnM emptyLHsBinds) $
 336         -- If anything fails, recover returning no bindings.
 337         -- This is particularly useful when checking the default-method binding of
 338         -- a class decl. If we don't recover, we don't add the default method to
 339         -- the type enviroment, and we get a tcLookup failure on $dmeth later.
 340
 341         -- Check the bindings; first adding inst_tyvars to the envt
 342         -- so that we don't quantify over them in nested places
 343
 344     let sel_name = idName sel_id
 345         meth_sig_fn meth_name = ASSERT( meth_name == idName meth_id ) sig_fn sel_name
 346         -- The meth_bind metions the meth_name, but sig_fn is indexed by sel_name
 347     in
 348     tcExtendTyVarEnv inst_tyvars (
 349         tcExtendIdEnv [meth_id]         $       -- In scope for tcInstSig
 350         addErrCtxt (methodCtxt sel_id)  $
 351         getLIE                          $
 352         tcMonoBinds [meth_bind] meth_sig_fn Recursive
 353     )                                   `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
 354
 355         -- Now do context reduction.   We simplify wrt both the local tyvars
 356         -- and the ones of the class/instance decl, so that there is
 357         -- no problem with
 358         --      class C a where
 359         --        op :: Eq a => a -> b -> a
 360         --
 361         -- We do this for each method independently to localise error messages
 362
 363     let
 364         [(_, Just sig, local_meth_id)] = mono_bind_infos
 365         loc = sig_loc sig
 366     in
 367
 368     addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id))        $
 369     newDictBndrs loc (sig_theta sig)            `thenM` \ meth_dicts ->
 370     let
 371         meth_tvs   = sig_tvs sig
 372         all_tyvars = meth_tvs ++ inst_tyvars
 373         all_insts  = avail_insts ++ meth_dicts
 374     in
 375     tcSimplifyCheck
 376          loc all_tyvars all_insts meth_lie      `thenM` \ lie_binds ->
 377
 378     checkSigTyVars all_tyvars                   `thenM_`
 379
 380     tcPrags meth_id (prag_fn sel_name)          `thenM` \ prags ->
 381     let
 382         poly_meth_bind = noLoc $ AbsBinds meth_tvs
 383                                   (map instToId meth_dicts)
 384                                   [(meth_tvs, meth_id, local_meth_id, prags)]
 385                                   (lie_binds `unionBags` meth_bind)
 386     in
 387     returnM (unitBag poly_meth_bind)
 388
 389
 390 mkMethodBind :: InstOrigin
 391              -> Class -> [TcType]       -- Class and instance types
 392              -> LHsBinds Name   -- Method binding (pick the right one from in here)
 393              -> ClassOpItem
 394              -> TcM (Maybe Inst,                -- Method inst
 395                      MethodSpec)
 396 -- Find the binding for the specified method, or make
 397 -- up a suitable default method if it isn't there
 398
 399 mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
 400   = mkMethId origin clas sel_id inst_tys                `thenM` \ (mb_inst, meth_id) ->
 401     let
 402         meth_name  = idName meth_id
 403     in
 404         -- Figure out what method binding to use
 405         -- If the user suppplied one, use it, else construct a default one
 406     getSrcSpanM                                 `thenM` \ loc ->
 407     (case find_bind (idName sel_id) meth_name meth_binds of
 408         Just user_bind -> returnM user_bind
 409         Nothing        ->
 410            mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
 411                 -- Not infix decl
 412            returnM (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rhs])
 413     )                                           `thenM` \ meth_bind ->
 414
 415     returnM (mb_inst, (sel_id, meth_id, meth_bind))
 416
 417 mkMethId :: InstOrigin -> Class
 418          -> Id -> [TcType]      -- Selector, and instance types
 419          -> TcM (Maybe Inst, Id)
 420
 421 -- mkMethId instantiates the selector Id at the specified types
 422 mkMethId origin clas sel_id inst_tys
 423   = let
 424         (tyvars,rho) = tcSplitForAllTys (idType sel_id)
 425         rho_ty       = ASSERT( length tyvars == length inst_tys )
 426                        substTyWith tyvars inst_tys rho
 427         (preds,tau)  = tcSplitPhiTy rho_ty
 428         first_pred   = head preds
 429     in
 430         -- The first predicate should be of form (C a b)
 431         -- where C is the class in question
 432     ASSERT( not (null preds) &&
 433             case getClassPredTys_maybe first_pred of
 434                 { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
 435     )
 436     if isSingleton preds then
 437         -- If it's the only one, make a 'method'
 438         getInstLoc origin                       `thenM` \ inst_loc ->
 439         newMethod inst_loc sel_id inst_tys      `thenM` \ meth_inst ->
 440         returnM (Just meth_inst, instToId meth_inst)
 441     else
 442         -- If it's not the only one we need to be careful
 443         -- For example, given 'op' defined thus:
 444         --      class Foo a where
 445         --        op :: (?x :: String) => a -> a
 446         -- (mkMethId op T) should return an Inst with type
 447         --      (?x :: String) => T -> T
 448         -- That is, the class-op's context is still there.
 449         -- BUT: it can't be a Method any more, because it breaks
 450         --      INVARIANT 2 of methods.  (See the data decl for Inst.)
 451         newUnique                       `thenM` \ uniq ->
 452         getSrcSpanM                     `thenM` \ loc ->
 453         let
 454             real_tau = mkPhiTy (tail preds) tau
 455             meth_id  = mkUserLocal (getOccName sel_id) uniq real_tau
 456                         (srcSpanStart loc) --TODO
 457         in
 458         returnM (Nothing, meth_id)
 459
 460      -- The user didn't supply a method binding,
 461      -- so we have to make up a default binding
 462      -- The RHS of a default method depends on the default-method info
 463 mkDefMethRhs origin clas inst_tys sel_id loc DefMeth
 464   =  -- An polymorphic default method
 465     lookupImportedName (mkDefMethRdrName sel_id)        `thenM` \ dm_name ->
 466         -- Might not be imported, but will be an OrigName
 467     traceRn (text "mkDefMeth" <+> ppr dm_name)          `thenM_`
 468     returnM (nlHsVar dm_name)
 469
 470 mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
 471   =     -- No default method
 472         -- Warn only if -fwarn-missing-methods
 473     doptM Opt_WarnMissingMethods                `thenM` \ warn ->
 474     warnTc (isInstDecl origin
 475            && warn
 476            && reportIfUnused (getOccName sel_id))
 477            (omittedMethodWarn sel_id)           `thenM_`
 478     returnM error_rhs
 479   where
 480     error_rhs  = noLoc $ HsLam (mkMatchGroup [mkSimpleMatch wild_pats simple_rhs])
 481     simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
 482                        (nlHsLit (HsStringPrim (mkFastString error_msg)))
 483     error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 484
 485         -- When the type is of form t1 -> t2 -> t3
 486         -- make a default method like (\ _ _ -> noMethBind "blah")
 487         -- rather than simply        (noMethBind "blah")
 488         -- Reason: if t1 or t2 are higher-ranked types we get n
 489         --         silly ambiguity messages.
 490         -- Example:     f :: (forall a. Eq a => a -> a) -> Int
 491         --              f = error "urk"
 492         -- Here, tcSub tries to force (error "urk") to have the right type,
 493         -- thus:        f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
 494         -- where 't' is fresh ty var.  This leads directly to "ambiguous t".
 495         --
 496         -- NB: technically this changes the meaning of the default-default
 497         --     method slightly, because `seq` can see the lambdas.  Oh well.
 498     (_,_,tau1)    = tcSplitSigmaTy (idType sel_id)
 499     (_,_,tau2)    = tcSplitSigmaTy tau1
 500         -- Need two splits because the  selector can have a type like
 501         --      forall a. Foo a => forall b. Eq b => ...
 502     (arg_tys, _) = tcSplitFunTys tau2
 503     wild_pats    = [nlWildPat | ty <- arg_tys]
 504
 505 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
 506   =     -- A generic default method
 507         -- If the method is defined generically, we can only do the job if the
 508         -- instance declaration is for a single-parameter type class with
 509         -- a type constructor applied to type arguments in the instance decl
 510         --      (checkTc, so False provokes the error)
 511     ASSERT( isInstDecl origin ) -- We never get here from a class decl
 512     do  { checkTc (isJust maybe_tycon)
 513                   (badGenericInstance sel_id (notSimple inst_tys))
 514         ; checkTc (tyConHasGenerics tycon)
 515                   (badGenericInstance sel_id (notGeneric tycon))
 516
 517         ; dflags <- getDOpts
 518         ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
 519                    (vcat [ppr clas <+> ppr inst_tys,
 520                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 521
 522                 -- Rename it before returning it
 523         ; (rn_rhs, _) <- rnLExpr rhs
 524         ; returnM rn_rhs }
 525   where
 526     rhs = mkGenericRhs sel_id clas_tyvar tycon
 527
 528           -- The tycon is only used in the generic case, and in that
 529           -- case we require that the instance decl is for a single-parameter
 530           -- type class with type variable arguments:
 531           --    instance (...) => C (T a b)
 532     clas_tyvar    = head (classTyVars clas)
 533     Just tycon    = maybe_tycon
 534     maybe_tycon   = case inst_tys of
 535                         [ty] -> case tcSplitTyConApp_maybe ty of
 536                                   Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
 537                                   other                                           -> Nothing
 538                         other -> Nothing
 539
 540 isInstDecl (SigOrigin InstSkol)    = True
 541 isInstDecl (SigOrigin (ClsSkol _)) = False
 542 \end{code}
 543
 544
 545 \begin{code}
 546 -- The renamer just puts the selector ID as the binder in the method binding
 547 -- but we must use the method name; so we substitute it here.  Crude but simple.
 548 find_bind sel_name meth_name binds
 549   = foldlBag seqMaybe Nothing (mapBag f binds)
 550   where
 551         f (L loc1 bind@(FunBind { fun_id = L loc2 op_name })) | op_name == sel_name
 552                  = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
 553         f _other = Nothing
 554 \end{code}
 555
 556
 557 %************************************************************************
 558 %*                                                                      *
 559 \subsection{Extracting generic instance declaration from class declarations}
 560 %*                                                                      *
 561 %************************************************************************
 562
 563 @getGenericInstances@ extracts the generic instance declarations from a class
 564 declaration.  For exmaple
 565
 566         class C a where
 567           op :: a -> a
 568
 569           op{ x+y } (Inl v)   = ...
 570           op{ x+y } (Inr v)   = ...
 571           op{ x*y } (v :*: w) = ...
 572           op{ 1   } Unit      = ...
 573
 574 gives rise to the instance declarations
 575
 576         instance C (x+y) where
 577           op (Inl v)   = ...
 578           op (Inr v)   = ...
 579
 580         instance C (x*y) where
 581           op (v :*: w) = ...
 582
 583         instance C 1 where
 584           op Unit      = ...
 585
 586
 587 \begin{code}
 588 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo]
 589 getGenericInstances class_decls
 590   = do  { gen_inst_infos <- mappM (addLocM get_generics) class_decls
 591         ; let { gen_inst_info = concat gen_inst_infos }
 592
 593         -- Return right away if there is no generic stuff
 594         ; if null gen_inst_info then returnM []
 595           else do
 596
 597         -- Otherwise print it out
 598         { dflags <- getDOpts
 599         ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
 600                    (vcat (map pprInstInfoDetails gen_inst_info)))
 601         ; returnM gen_inst_info }}
 602
 603 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
 604   | null generic_binds
 605   = returnM [] -- The comon case: no generic default methods
 606
 607   | otherwise   -- A source class decl with generic default methods
 608   = recoverM (returnM [])                               $
 609     tcAddDeclCtxt decl                                  $
 610     tcLookupLocatedClass class_name                     `thenM` \ clas ->
 611
 612         -- Group by type, and
 613         -- make an InstInfo out of each group
 614     let
 615         groups = groupWith listToBag generic_binds
 616     in
 617     mappM (mkGenericInstance clas) groups               `thenM` \ inst_infos ->
 618
 619         -- Check that there is only one InstInfo for each type constructor
 620         -- The main way this can fail is if you write
 621         --      f {| a+b |} ... = ...
 622         --      f {| x+y |} ... = ...
 623         -- Then at this point we'll have an InstInfo for each
 624         --
 625         -- The class should be unary, which is why simpleInstInfoTyCon should be ok
 626     let
 627         tc_inst_infos :: [(TyCon, InstInfo)]
 628         tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
 629
 630         bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
 631                               group `lengthExceeds` 1]
 632         get_uniq (tc,_) = getUnique tc
 633     in
 634     mappM (addErrTc . dupGenericInsts) bad_groups       `thenM_`
 635
 636         -- Check that there is an InstInfo for each generic type constructor
 637     let
 638         missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
 639     in
 640     checkTc (null missing) (missingGenericInstances missing)    `thenM_`
 641
 642     returnM inst_infos
 643   where
 644     generic_binds :: [(HsType Name, LHsBind Name)]
 645     generic_binds = getGenericBinds def_methods
 646
 647
 648 ---------------------------------
 649 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
 650   -- Takes a group of method bindings, finds the generic ones, and returns
 651   -- them in finite map indexed by the type parameter in the definition.
 652 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
 653
 654 getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
 655   = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
 656   where
 657     wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
 658 getGenericBind _
 659   = []
 660
 661 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
 662 groupWith op []          = []
 663 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
 664     where
 665       vs            = map snd this
 666       (this,rest)   = partition same_t prs
 667       same_t (t',v) = t `eqPatType` t'
 668
 669 eqPatLType :: LHsType Name -> LHsType Name -> Bool
 670 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
 671
 672 eqPatType :: HsType Name -> HsType Name -> Bool
 673 -- A very simple equality function, only for
 674 -- type patterns in generic function definitions.
 675 eqPatType (HsTyVar v1)       (HsTyVar v2)       = v1==v2
 676 eqPatType (HsAppTy s1 t1)    (HsAppTy s2 t2)    = s1 `eqPatLType` s2 && t2 `eqPatLType` t2
 677 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2 && unLoc op1 == unLoc op2
 678 eqPatType (HsNumTy n1)       (HsNumTy n2)       = n1 == n2
 679 eqPatType (HsParTy t1)       t2                 = unLoc t1 `eqPatType` t2
 680 eqPatType t1                 (HsParTy t2)       = t1 `eqPatType` unLoc t2
 681 eqPatType _ _ = False
 682
 683 ---------------------------------
 684 mkGenericInstance :: Class
 685                   -> (HsType Name, LHsBinds Name)
 686                   -> TcM InstInfo
 687
 688 mkGenericInstance clas (hs_ty, binds)
 689   -- Make a generic instance declaration
 690   -- For example:       instance (C a, C b) => C (a+b) where { binds }
 691
 692   =     -- Extract the universally quantified type variables
 693         -- and wrap them as forall'd tyvars, so that kind inference
 694         -- works in the standard way
 695     let
 696         sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty)))
 697         hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
 698     in
 699         -- Type-check the instance type, and check its form
 700     tcHsSigType GenPatCtxt hs_forall_ty         `thenM` \ forall_inst_ty ->
 701     let
 702         (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
 703     in
 704     checkTc (validGenericInstanceType inst_ty)
 705             (badGenericInstanceType binds)      `thenM_`
 706
 707         -- Make the dictionary function.
 708     getSrcSpanM                                         `thenM` \ span ->
 709     getOverlapFlag                                      `thenM` \ overlap_flag ->
 710     newDFunName clas [inst_ty] (srcSpanStart span)      `thenM` \ dfun_name ->
 711     let
 712         inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
 713         dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
 714         ispec      = mkLocalInstance dfun_id overlap_flag
 715     in
 716     returnM (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] })
 717 \end{code}
 718
 719
 720 %************************************************************************
 721 %*                                                                      *
 722                 Error messages
 723 %*                                                                      *
 724 %************************************************************************
 725
 726 \begin{code}
 727 tcAddDeclCtxt decl thing_inside
 728   = addErrCtxt ctxt thing_inside
 729   where
 730      thing | isClassDecl decl  = "class"
 731            | isTypeDecl decl   = "type synonym" ++ maybeInst
 732            | isDataDecl decl   = if tcdND decl == NewType
 733                                  then "newtype" ++ maybeInst
 734                                  else "data type" ++ maybeInst
 735            | isFamilyDecl decl = "family"
 736
 737      maybeInst | isFamInstDecl decl = " family"
 738                | otherwise          = ""
 739
 740      ctxt = hsep [ptext SLIT("In the"), text thing,
 741                   ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
 742
 743 defltMethCtxt clas
 744   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
 745
 746 methodCtxt sel_id
 747   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 748
 749 badMethodErr clas op
 750   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 751           ptext SLIT("does not have a method"), quotes (ppr op)]
 752
 753 badATErr clas at
 754   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 755           ptext SLIT("does not have an associated type"), quotes (ppr at)]
 756
 757 omittedMethodWarn sel_id
 758   = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
 759
 760 omittedATWarn at
 761   = ptext SLIT("No explicit AT declaration for") <+> quotes (ppr at)
 762
 763 badGenericInstance sel_id because
 764   = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
 765          because]
 766
 767 notSimple inst_tys
 768   = vcat [ptext SLIT("because the instance type(s)"),
 769           nest 2 (ppr inst_tys),
 770           ptext SLIT("is not a simple type of form (T a1 ... an)")]
 771
 772 notGeneric tycon
 773   = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
 774           ptext SLIT("was not compiled with -fgenerics")]
 775
 776 badGenericInstanceType binds
 777   = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
 778           nest 4 (ppr binds)]
 779
 780 missingGenericInstances missing
 781   = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
 782
 783 dupGenericInsts tc_inst_infos
 784   = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
 785           nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
 786           ptext SLIT("All the type patterns for a generic type constructor must be identical")
 787     ]
 788   where
 789     ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
 790
 791 mixedGenericErr op
 792   = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
 793 \end{code}