+%************************************************************************
+%* *
+\subsection{Typechecking a method}
+%* *
+%************************************************************************
+
+@tcMethodBind@ is used to type-check both default-method and
+instance-decl method declarations. We must type-check methods one at a
+time, because their signatures may have different contexts and
+tyvar sets.
+
+\begin{code}
+type MethodSpec = (Id, -- Global selector Id
+ Id, -- Local Id (class tyvars instantiated)
+ LHsBind Name) -- Binding for the method
+
+tcMethodBind
+ :: [TcTyVar] -- Skolemised type variables for the
+ -- enclosing class/instance decl.
+ -- They'll be signature tyvars, and we
+ -- want to check that they don't get bound
+ -- Also they are scoped, so we bring them into scope
+ -- Always equal the range of the type envt
+ -> TcThetaType -- Available theta; it's just used for the error message
+ -> [Inst] -- Available from context, used to simplify constraints
+ -- from the method body
+ -> TcPragFun -- Pragmas (e.g. inline pragmas)
+ -> MethodSpec -- Details of this method
+ -> TcM (LHsBinds Id)
+
+tcMethodBind inst_tyvars inst_theta avail_insts prag_fn
+ (sel_id, meth_id, meth_bind)
+ = recoverM (returnM emptyLHsBinds) $
+ -- If anything fails, recover returning no bindings.
+ -- This is particularly useful when checking the default-method binding of
+ -- a class decl. If we don't recover, we don't add the default method to
+ -- the type enviroment, and we get a tcLookup failure on $dmeth later.
+
+ -- Check the bindings; first adding inst_tyvars to the envt
+ -- so that we don't quantify over them in nested places
+
+
+ let -- Fake up a TcSigInfo to pass to tcMonoBinds
+ rigid_info = SigSkol (idName meth_id)
+ in
+ tcSkolType rigid_info (idType meth_id) `thenM` \ (tyvars', theta', tau') ->
+ getInstLoc (SigOrigin rigid_info) `thenM` \ loc ->
+ let meth_sig = TcSigInfo { sig_id = meth_id, sig_tvs = tyvars', sig_scoped = [],
+ sig_theta = theta', sig_tau = tau', sig_loc = loc }
+ lookup_sig name = ASSERT( name == idName meth_id )
+ Just meth_sig
+ in
+ tcExtendTyVarEnv inst_tyvars (
+ addErrCtxt (methodCtxt sel_id) $
+ getLIE $
+ tcMonoBinds [meth_bind] lookup_sig Recursive
+ ) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
+
+ -- Now do context reduction. We simplify wrt both the local tyvars
+ -- and the ones of the class/instance decl, so that there is
+ -- no problem with
+ -- class C a where
+ -- op :: Eq a => a -> b -> a
+ --
+ -- We do this for each method independently to localise error messages
+
+ addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
+ newDictsAtLoc (sig_loc meth_sig) (sig_theta meth_sig) `thenM` \ meth_dicts ->
+ let
+ meth_tvs = sig_tvs meth_sig
+ all_tyvars = meth_tvs ++ inst_tyvars
+ all_insts = avail_insts ++ meth_dicts
+ sel_name = idName sel_id
+ in
+ tcSimplifyCheck
+ (ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
+ all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
+
+ checkSigTyVars all_tyvars `thenM_`
+
+ tcPrags meth_id (prag_fn sel_name) `thenM` \ prags ->
+ let
+ [(_,_,local_meth_id)] = mono_bind_infos
+ poly_meth_bind = noLoc $ AbsBinds meth_tvs
+ (map instToId meth_dicts)
+ [(meth_tvs, meth_id, local_meth_id, prags)]
+ (lie_binds `unionBags` meth_bind)
+ in
+ returnM (unitBag poly_meth_bind)
+
+
+mkMethodBind :: InstOrigin
+ -> Class -> [TcType] -- Class and instance types
+ -> LHsBinds Name -- Method binding (pick the right one from in here)
+ -> ClassOpItem
+ -> TcM (Maybe Inst, -- Method inst
+ MethodSpec)
+-- Find the binding for the specified method, or make
+-- up a suitable default method if it isn't there
+
+mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
+ = mkMethId origin clas sel_id inst_tys `thenM` \ (mb_inst, meth_id) ->
+ let
+ meth_name = idName meth_id
+ in
+ -- Figure out what method binding to use
+ -- If the user suppplied one, use it, else construct a default one
+ getSrcSpanM `thenM` \ loc ->
+ (case find_bind (idName sel_id) meth_name meth_binds of
+ Just user_bind -> returnM user_bind
+ Nothing ->
+ mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
+ -- Not infix decl
+ returnM (noLoc $ FunBind (noLoc meth_name) False
+ (mkMatchGroup [mkSimpleMatch [] rhs])
+ placeHolderNames)
+ ) `thenM` \ meth_bind ->
+
+ returnM (mb_inst, (sel_id, meth_id, meth_bind))
+
+mkMethId :: InstOrigin -> Class
+ -> Id -> [TcType] -- Selector, and instance types
+ -> TcM (Maybe Inst, Id)
+
+-- mkMethId instantiates the selector Id at the specified types
+mkMethId origin clas sel_id inst_tys
+ = let
+ (tyvars,rho) = tcSplitForAllTys (idType sel_id)
+ rho_ty = ASSERT( length tyvars == length inst_tys )
+ substTyWith tyvars inst_tys rho
+ (preds,tau) = tcSplitPhiTy rho_ty
+ first_pred = head preds
+ in
+ -- The first predicate should be of form (C a b)
+ -- where C is the class in question
+ ASSERT( not (null preds) &&
+ case getClassPredTys_maybe first_pred of
+ { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
+ )
+ if isSingleton preds then
+ -- If it's the only one, make a 'method'
+ getInstLoc origin `thenM` \ inst_loc ->
+ newMethod inst_loc sel_id inst_tys preds tau `thenM` \ meth_inst ->
+ returnM (Just meth_inst, instToId meth_inst)
+ else
+ -- If it's not the only one we need to be careful
+ -- For example, given 'op' defined thus:
+ -- class Foo a where
+ -- op :: (?x :: String) => a -> a
+ -- (mkMethId op T) should return an Inst with type
+ -- (?x :: String) => T -> T
+ -- That is, the class-op's context is still there.
+ -- BUT: it can't be a Method any more, because it breaks
+ -- INVARIANT 2 of methods. (See the data decl for Inst.)
+ newUnique `thenM` \ uniq ->
+ getSrcSpanM `thenM` \ loc ->
+ let
+ real_tau = mkPhiTy (tail preds) tau
+ meth_id = mkUserLocal (getOccName sel_id) uniq real_tau
+ (srcSpanStart loc) --TODO
+ in
+ returnM (Nothing, meth_id)
+
+ -- The user didn't supply a method binding,
+ -- so we have to make up a default binding
+ -- The RHS of a default method depends on the default-method info
+mkDefMethRhs origin clas inst_tys sel_id loc DefMeth
+ = -- An polymorphic default method
+ lookupImportedName (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
+ -- Might not be imported, but will be an OrigName
+ traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_`
+ returnM (nlHsVar dm_name)
+
+mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
+ = -- No default method
+ -- Warn only if -fwarn-missing-methods
+ doptM Opt_WarnMissingMethods `thenM` \ warn ->
+ warnTc (isInstDecl origin
+ && warn
+ && reportIfUnused (getOccName sel_id))
+ (omittedMethodWarn sel_id) `thenM_`
+ returnM error_rhs
+ where
+ error_rhs = noLoc $ HsLam (mkMatchGroup [mkSimpleMatch wild_pats simple_rhs])
+ simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
+ (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
+ error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+
+ -- When the type is of form t1 -> t2 -> t3
+ -- make a default method like (\ _ _ -> noMethBind "blah")
+ -- rather than simply (noMethBind "blah")
+ -- Reason: if t1 or t2 are higher-ranked types we get n
+ -- silly ambiguity messages.
+ -- Example: f :: (forall a. Eq a => a -> a) -> Int
+ -- f = error "urk"
+ -- Here, tcSub tries to force (error "urk") to have the right type,
+ -- thus: f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
+ -- where 't' is fresh ty var. This leads directly to "ambiguous t".
+ --
+ -- NB: technically this changes the meaning of the default-default
+ -- method slightly, because `seq` can see the lambdas. Oh well.
+ (_,_,tau1) = tcSplitSigmaTy (idType sel_id)
+ (_,_,tau2) = tcSplitSigmaTy tau1
+ -- Need two splits because the selector can have a type like
+ -- forall a. Foo a => forall b. Eq b => ...
+ (arg_tys, _) = tcSplitFunTys tau2
+ wild_pats = [nlWildPat | ty <- arg_tys]
+
+mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
+ = -- A generic default method
+ -- If the method is defined generically, we can only do the job if the
+ -- instance declaration is for a single-parameter type class with
+ -- a type constructor applied to type arguments in the instance decl
+ -- (checkTc, so False provokes the error)
+ ASSERT( isInstDecl origin ) -- We never get here from a class decl
+ do { checkTc (isJust maybe_tycon)
+ (badGenericInstance sel_id (notSimple inst_tys))
+ ; checkTc (tyConHasGenerics tycon)
+ (badGenericInstance sel_id (notGeneric tycon))
+
+ ; dflags <- getDOpts
+ ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
+ (vcat [ppr clas <+> ppr inst_tys,
+ nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
+
+ -- Rename it before returning it
+ ; (rn_rhs, _) <- rnLExpr rhs
+ ; returnM rn_rhs }
+ where
+ rhs = mkGenericRhs sel_id clas_tyvar tycon
+
+ -- The tycon is only used in the generic case, and in that
+ -- case we require that the instance decl is for a single-parameter
+ -- type class with type variable arguments:
+ -- instance (...) => C (T a b)
+ clas_tyvar = head (classTyVars clas)
+ Just tycon = maybe_tycon
+ maybe_tycon = case inst_tys of
+ [ty] -> case tcSplitTyConApp_maybe ty of
+ Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
+ other -> Nothing
+ other -> Nothing
+
+isInstDecl (SigOrigin (InstSkol _)) = True
+isInstDecl (SigOrigin (ClsSkol _)) = False
+\end{code}
+
+
+\begin{code}
+-- The renamer just puts the selector ID as the binder in the method binding
+-- but we must use the method name; so we substitute it here. Crude but simple.
+find_bind sel_name meth_name binds
+ = foldlBag seqMaybe Nothing (mapBag f binds)
+ where
+ f (L loc1 (FunBind (L loc2 op_name) fix matches fvs)) | op_name == sel_name
+ = Just (L loc1 (FunBind (L loc2 meth_name) fix matches fvs))
+ f _other = Nothing
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Extracting generic instance declaration from class declarations}
+%* *
+%************************************************************************
+
+@getGenericInstances@ extracts the generic instance declarations from a class
+declaration. For exmaple
+
+ class C a where
+ op :: a -> a
+
+ op{ x+y } (Inl v) = ...
+ op{ x+y } (Inr v) = ...
+ op{ x*y } (v :*: w) = ...
+ op{ 1 } Unit = ...
+
+gives rise to the instance declarations
+
+ instance C (x+y) where
+ op (Inl v) = ...
+ op (Inr v) = ...
+
+ instance C (x*y) where
+ op (v :*: w) = ...
+
+ instance C 1 where
+ op Unit = ...
+
+
+\begin{code}
+getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo]
+getGenericInstances class_decls
+ = do { gen_inst_infos <- mappM (addLocM get_generics) class_decls
+ ; let { gen_inst_info = concat gen_inst_infos }
+
+ -- Return right away if there is no generic stuff
+ ; if null gen_inst_info then returnM []
+ else do
+
+ -- Otherwise print it out
+ { dflags <- getDOpts
+ ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
+ (vcat (map pprInstInfoDetails gen_inst_info)))
+ ; returnM gen_inst_info }}
+
+get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
+ | null generic_binds
+ = returnM [] -- The comon case: no generic default methods
+
+ | otherwise -- A source class decl with generic default methods
+ = recoverM (returnM []) $
+ tcAddDeclCtxt decl $
+ tcLookupLocatedClass class_name `thenM` \ clas ->
+
+ -- Group by type, and
+ -- make an InstInfo out of each group