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 loc
 456         in
 457         returnM (Nothing, meth_id)
 458
 459      -- The user didn't supply a method binding,
 460      -- so we have to make up a default binding
 461      -- The RHS of a default method depends on the default-method info
 462 mkDefMethRhs origin clas inst_tys sel_id loc DefMeth
 463   =  -- An polymorphic default method
 464     lookupImportedName (mkDefMethRdrName sel_id)        `thenM` \ dm_name ->
 465         -- Might not be imported, but will be an OrigName
 466     traceRn (text "mkDefMeth" <+> ppr dm_name)          `thenM_`
 467     returnM (nlHsVar dm_name)
 468
 469 mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
 470   =     -- No default method
 471         -- Warn only if -fwarn-missing-methods
 472     doptM Opt_WarnMissingMethods                `thenM` \ warn ->
 473     warnTc (isInstDecl origin
 474            && warn
 475            && reportIfUnused (getOccName sel_id))
 476            (omittedMethodWarn sel_id)           `thenM_`
 477     returnM error_rhs
 478   where
 479     error_rhs  = noLoc $ HsLam (mkMatchGroup [mkSimpleMatch wild_pats simple_rhs])
 480     simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
 481                        (nlHsLit (HsStringPrim (mkFastString error_msg)))
 482     error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 483
 484         -- When the type is of form t1 -> t2 -> t3
 485         -- make a default method like (\ _ _ -> noMethBind "blah")
 486         -- rather than simply        (noMethBind "blah")
 487         -- Reason: if t1 or t2 are higher-ranked types we get n
 488         --         silly ambiguity messages.
 489         -- Example:     f :: (forall a. Eq a => a -> a) -> Int
 490         --              f = error "urk"
 491         -- Here, tcSub tries to force (error "urk") to have the right type,
 492         -- thus:        f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
 493         -- where 't' is fresh ty var.  This leads directly to "ambiguous t".
 494         --
 495         -- NB: technically this changes the meaning of the default-default
 496         --     method slightly, because `seq` can see the lambdas.  Oh well.
 497     (_,_,tau1)    = tcSplitSigmaTy (idType sel_id)
 498     (_,_,tau2)    = tcSplitSigmaTy tau1
 499         -- Need two splits because the  selector can have a type like
 500         --      forall a. Foo a => forall b. Eq b => ...
 501     (arg_tys, _) = tcSplitFunTys tau2
 502     wild_pats    = [nlWildPat | ty <- arg_tys]
 503
 504 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
 505   =     -- A generic default method
 506         -- If the method is defined generically, we can only do the job if the
 507         -- instance declaration is for a single-parameter type class with
 508         -- a type constructor applied to type arguments in the instance decl
 509         --      (checkTc, so False provokes the error)
 510     ASSERT( isInstDecl origin ) -- We never get here from a class decl
 511     do  { checkTc (isJust maybe_tycon)
 512                   (badGenericInstance sel_id (notSimple inst_tys))
 513         ; checkTc (tyConHasGenerics tycon)
 514                   (badGenericInstance sel_id (notGeneric tycon))
 515
 516         ; dflags <- getDOpts
 517         ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
 518                    (vcat [ppr clas <+> ppr inst_tys,
 519                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 520
 521                 -- Rename it before returning it
 522         ; (rn_rhs, _) <- rnLExpr rhs
 523         ; returnM rn_rhs }
 524   where
 525     rhs = mkGenericRhs sel_id clas_tyvar tycon
 526
 527           -- The tycon is only used in the generic case, and in that
 528           -- case we require that the instance decl is for a single-parameter
 529           -- type class with type variable arguments:
 530           --    instance (...) => C (T a b)
 531     clas_tyvar    = head (classTyVars clas)
 532     Just tycon    = maybe_tycon
 533     maybe_tycon   = case inst_tys of
 534                         [ty] -> case tcSplitTyConApp_maybe ty of
 535                                   Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
 536                                   other                                           -> Nothing
 537                         other -> Nothing
 538
 539 isInstDecl (SigOrigin InstSkol)    = True
 540 isInstDecl (SigOrigin (ClsSkol _)) = False
 541 \end{code}
 542
 543
 544 \begin{code}
 545 -- The renamer just puts the selector ID as the binder in the method binding
 546 -- but we must use the method name; so we substitute it here.  Crude but simple.
 547 find_bind sel_name meth_name binds
 548   = foldlBag seqMaybe Nothing (mapBag f binds)
 549   where
 550         f (L loc1 bind@(FunBind { fun_id = L loc2 op_name })) | op_name == sel_name
 551                  = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
 552         f _other = Nothing
 553 \end{code}
 554
 555
 556 %************************************************************************
 557 %*                                                                      *
 558 \subsection{Extracting generic instance declaration from class declarations}
 559 %*                                                                      *
 560 %************************************************************************
 561
 562 @getGenericInstances@ extracts the generic instance declarations from a class
 563 declaration.  For exmaple
 564
 565         class C a where
 566           op :: a -> a
 567
 568           op{ x+y } (Inl v)   = ...
 569           op{ x+y } (Inr v)   = ...
 570           op{ x*y } (v :*: w) = ...
 571           op{ 1   } Unit      = ...
 572
 573 gives rise to the instance declarations
 574
 575         instance C (x+y) where
 576           op (Inl v)   = ...
 577           op (Inr v)   = ...
 578
 579         instance C (x*y) where
 580           op (v :*: w) = ...
 581
 582         instance C 1 where
 583           op Unit      = ...
 584
 585
 586 \begin{code}
 587 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo]
 588 getGenericInstances class_decls
 589   = do  { gen_inst_infos <- mappM (addLocM get_generics) class_decls
 590         ; let { gen_inst_info = concat gen_inst_infos }
 591
 592         -- Return right away if there is no generic stuff
 593         ; if null gen_inst_info then returnM []
 594           else do
 595
 596         -- Otherwise print it out
 597         { dflags <- getDOpts
 598         ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
 599                    (vcat (map pprInstInfoDetails gen_inst_info)))
 600         ; returnM gen_inst_info }}
 601
 602 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
 603   | null generic_binds
 604   = returnM [] -- The comon case: no generic default methods
 605
 606   | otherwise   -- A source class decl with generic default methods
 607   = recoverM (returnM [])                               $
 608     tcAddDeclCtxt decl                                  $
 609     tcLookupLocatedClass class_name                     `thenM` \ clas ->
 610
 611         -- Group by type, and
 612         -- make an InstInfo out of each group
 613     let
 614         groups = groupWith listToBag generic_binds
 615     in
 616     mappM (mkGenericInstance clas) groups               `thenM` \ inst_infos ->
 617
 618         -- Check that there is only one InstInfo for each type constructor
 619         -- The main way this can fail is if you write
 620         --      f {| a+b |} ... = ...
 621         --      f {| x+y |} ... = ...
 622         -- Then at this point we'll have an InstInfo for each
 623         --
 624         -- The class should be unary, which is why simpleInstInfoTyCon should be ok
 625     let
 626         tc_inst_infos :: [(TyCon, InstInfo)]
 627         tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
 628
 629         bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
 630                               group `lengthExceeds` 1]
 631         get_uniq (tc,_) = getUnique tc
 632     in
 633     mappM (addErrTc . dupGenericInsts) bad_groups       `thenM_`
 634
 635         -- Check that there is an InstInfo for each generic type constructor
 636     let
 637         missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
 638     in
 639     checkTc (null missing) (missingGenericInstances missing)    `thenM_`
 640
 641     returnM inst_infos
 642   where
 643     generic_binds :: [(HsType Name, LHsBind Name)]
 644     generic_binds = getGenericBinds def_methods
 645
 646
 647 ---------------------------------
 648 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
 649   -- Takes a group of method bindings, finds the generic ones, and returns
 650   -- them in finite map indexed by the type parameter in the definition.
 651 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
 652
 653 getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
 654   = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
 655   where
 656     wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
 657 getGenericBind _
 658   = []
 659
 660 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
 661 groupWith op []          = []
 662 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
 663     where
 664       vs            = map snd this
 665       (this,rest)   = partition same_t prs
 666       same_t (t',v) = t `eqPatType` t'
 667
 668 eqPatLType :: LHsType Name -> LHsType Name -> Bool
 669 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
 670
 671 eqPatType :: HsType Name -> HsType Name -> Bool
 672 -- A very simple equality function, only for
 673 -- type patterns in generic function definitions.
 674 eqPatType (HsTyVar v1)       (HsTyVar v2)       = v1==v2
 675 eqPatType (HsAppTy s1 t1)    (HsAppTy s2 t2)    = s1 `eqPatLType` s2 && t2 `eqPatLType` t2
 676 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2 && unLoc op1 == unLoc op2
 677 eqPatType (HsNumTy n1)       (HsNumTy n2)       = n1 == n2
 678 eqPatType (HsParTy t1)       t2                 = unLoc t1 `eqPatType` t2
 679 eqPatType t1                 (HsParTy t2)       = t1 `eqPatType` unLoc t2
 680 eqPatType _ _ = False
 681
 682 ---------------------------------
 683 mkGenericInstance :: Class
 684                   -> (HsType Name, LHsBinds Name)
 685                   -> TcM InstInfo
 686
 687 mkGenericInstance clas (hs_ty, binds)
 688   -- Make a generic instance declaration
 689   -- For example:       instance (C a, C b) => C (a+b) where { binds }
 690
 691   =     -- Extract the universally quantified type variables
 692         -- and wrap them as forall'd tyvars, so that kind inference
 693         -- works in the standard way
 694     let
 695         sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty)))
 696         hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
 697     in
 698         -- Type-check the instance type, and check its form
 699     tcHsSigType GenPatCtxt hs_forall_ty         `thenM` \ forall_inst_ty ->
 700     let
 701         (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
 702     in
 703     checkTc (validGenericInstanceType inst_ty)
 704             (badGenericInstanceType binds)      `thenM_`
 705
 706         -- Make the dictionary function.
 707     getSrcSpanM                                         `thenM` \ span ->
 708     getOverlapFlag                                      `thenM` \ overlap_flag ->
 709     newDFunName clas [inst_ty] span                     `thenM` \ dfun_name ->
 710     let
 711         inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
 712         dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
 713         ispec      = mkLocalInstance dfun_id overlap_flag
 714     in
 715     returnM (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] })
 716 \end{code}
 717
 718
 719 %************************************************************************
 720 %*                                                                      *
 721                 Error messages
 722 %*                                                                      *
 723 %************************************************************************
 724
 725 \begin{code}
 726 tcAddDeclCtxt decl thing_inside
 727   = addErrCtxt ctxt thing_inside
 728   where
 729      thing | isClassDecl decl  = "class"
 730            | isTypeDecl decl   = "type synonym" ++ maybeInst
 731            | isDataDecl decl   = if tcdND decl == NewType
 732                                  then "newtype" ++ maybeInst
 733                                  else "data type" ++ maybeInst
 734            | isFamilyDecl decl = "family"
 735
 736      maybeInst | isFamInstDecl decl = " family"
 737                | otherwise          = ""
 738
 739      ctxt = hsep [ptext SLIT("In the"), text thing,
 740                   ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
 741
 742 defltMethCtxt clas
 743   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
 744
 745 methodCtxt sel_id
 746   = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
 747
 748 badMethodErr clas op
 749   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 750           ptext SLIT("does not have a method"), quotes (ppr op)]
 751
 752 badATErr clas at
 753   = hsep [ptext SLIT("Class"), quotes (ppr clas),
 754           ptext SLIT("does not have an associated type"), quotes (ppr at)]
 755
 756 omittedMethodWarn sel_id
 757   = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
 758
 759 omittedATWarn at
 760   = ptext SLIT("No explicit AT declaration for") <+> quotes (ppr at)
 761
 762 badGenericInstance sel_id because
 763   = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
 764          because]
 765
 766 notSimple inst_tys
 767   = vcat [ptext SLIT("because the instance type(s)"),
 768           nest 2 (ppr inst_tys),
 769           ptext SLIT("is not a simple type of form (T a1 ... an)")]
 770
 771 notGeneric tycon
 772   = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
 773           ptext SLIT("was not compiled with -fgenerics")]
 774
 775 badGenericInstanceType binds
 776   = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
 777           nest 4 (ppr binds)]
 778
 779 missingGenericInstances missing
 780   = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
 781
 782 dupGenericInsts tc_inst_infos
 783   = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
 784           nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
 785           ptext SLIT("All the type patterns for a generic type constructor must be identical")
 786     ]
 787   where
 788     ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
 789
 790 mixedGenericErr op
 791   = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
 792 \end{code}