import HsSyn
import RnHsSyn
-import RnExpr
import Inst
import InstEnv
-import TcPat( addInlinePrags )
import TcEnv
+import TcPat( addInlinePrags )
import TcBinds
import TcUnify
import TcHsType
import Id
import Name
import Var
-import NameEnv
import NameSet
import Outputable
import PrelNames
tcClassSigs :: Name -- Name of the class
-> [LSig Name]
-> LHsBinds Name
- -> TcM [TcMethInfo]
+ -> TcM [TcMethInfo] -- One for each method
tcClassSigs clas sigs def_methods
- = do { dm_env <- mapM (addLocM (checkDefaultBind clas op_names))
- (bagToList def_methods)
- ; mapM (tcClassSig (mkNameEnv dm_env)) op_sigs }
- where
- op_sigs = [sig | sig@(L _ (TypeSig _ _)) <- sigs]
- op_names = [n | (L _ (TypeSig (L _ n) _)) <- op_sigs]
-
-checkDefaultBind :: Name -> [Name] -> HsBindLR Name Name -> TcM (Name, DefMethSpec)
- -- Check default bindings
- -- a) must be for a class op for this class
- -- b) must be all generic or all non-generic
-checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
- = do { -- Check that the op is from this class
- checkTc (op `elem` ops) (badMethodErr clas op)
-
- -- Check that all the defns ar generic, or none are
- ; case (none_generic, all_generic) of
- (True, _) -> return (op, VanillaDM)
- (_, True) -> return (op, GenericDM)
- _ -> failWith (mixedGenericErr op)
- }
- where
- n_generic = count (isJust . maybeGenericMatch) matches
- none_generic = n_generic == 0
- all_generic = matches `lengthIs` n_generic
+ = do { -- Check that all def_methods are in the class
+ ; op_info <- mapM (addLocM tc_sig) [sig | sig@(L _ (TypeSig _ _)) <- sigs]
+ ; let op_names = [ n | (n,_,_) <- op_info ]
-checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b)
+ ; sequence_ [ failWithTc (badMethodErr clas n)
+ | n <- dm_bind_names, not (n `elem` op_names) ]
+ -- Value binding for non class-method (ie no TypeSig)
+ ; sequence_ [ failWithTc (badGenericMethod clas n)
+ | n <- genop_names, not (n `elem` dm_bind_names) ]
+ -- Generic signature without value binding
-tcClassSig :: NameEnv DefMethSpec -- Info about default methods;
- -> LSig Name
- -> TcM TcMethInfo
-
-tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
- = setSrcSpan loc $ do
- { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
- ; let dm = lookupNameEnv dm_env op_name `orElse` NoDM
- ; return (op_name, dm, op_ty) }
-tcClassSig _ s = pprPanic "tcClassSig" (ppr s)
+ ; return op_info }
+ where
+ dm_bind_names :: [Name] -- These ones have a value binding in the class decl
+ dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
+
+ genop_names :: [Name] -- These ones have a generic signature
+ genop_names = [n | L _ (GenericSig (L _ n) _) <- sigs]
+
+ tc_sig (TypeSig (L _ op_name) op_hs_ty)
+ = do { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
+ ; let dm | op_name `elem` genop_names = GenericDM
+ | op_name `elem` dm_bind_names = VanillaDM
+ | otherwise = NoDM
+ ; return (op_name, dm, op_ty) }
+ tc_sig sig = pprPanic "tc_cls_sig" (ppr sig)
\end{code}
-- default methods. Better to make separate AbsBinds for each
; let
(tyvars, _, _, op_items) = classBigSig clas
- rigid_info = ClsSkol clas
- prag_fn = mkPragFun sigs default_binds
+ prag_fn = mkPragFun sigs default_binds
sig_fn = mkSigFun sigs
- clas_tyvars = tcSkolSigTyVars rigid_info tyvars
+ clas_tyvars = tcSuperSkolTyVars tyvars
pred = mkClassPred clas (mkTyVarTys clas_tyvars)
; this_dict <- newEvVar pred
+ ; traceTc "TIM2" (ppr sigs)
; let tc_dm = tcDefMeth clas clas_tyvars
- this_dict default_binds
+ this_dict default_binds sigs
sig_fn prag_fn
; dm_binds <- tcExtendTyVarEnv clas_tyvars $
mapM tc_dm op_items
- ; return (listToBag (catMaybes dm_binds)) }
+ ; return (unionManyBags dm_binds) }
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
-tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
+tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name]
-> SigFun -> PragFun -> ClassOpItem
- -> TcM (Maybe (LHsBind Id))
+ -> TcM (LHsBinds TcId)
-- Generate code for polymorphic default methods only (hence DefMeth)
-- (Generic default methods have turned into instance decls by now.)
-- 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.
-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
-tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
+tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
= case dm_info of
- NoDefMeth -> return Nothing
- GenDefMeth -> return Nothing
- DefMeth dm_name -> do
- { let sel_name = idName sel_id
- ; local_dm_name <- newLocalName sel_name
- -- Base the local_dm_name on the selector name, because
- -- type errors from tcInstanceMethodBody come from here
-
- -- See Note [Silly default-method bind]
- -- (possibly out of date)
-
- ; let meth_bind = findMethodBind sel_name binds_in
- `orElse` pprPanic "tcDefMeth" (ppr sel_id)
- -- dm_info = DefMeth dm_name only if there is a binding in binds_in
-
- dm_sig_fn _ = sig_fn sel_name
- dm_id = mkDefaultMethodId sel_id dm_name
- local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars)
- local_dm_id = mkLocalId local_dm_name local_dm_type
- prags = prag_fn sel_name
-
- ; dm_id_w_inline <- addInlinePrags dm_id prags
- ; spec_prags <- tcSpecPrags dm_id prags
-
- ; warnTc (not (null spec_prags))
- (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
- <+> quotes (ppr sel_name))
-
- ; liftM Just $
- tcInstanceMethodBody (ClsSkol clas)
- tyvars
- [this_dict]
- dm_id_w_inline local_dm_id
- dm_sig_fn IsDefaultMethod meth_bind }
+ NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
+ ; return emptyBag }
+ DefMeth dm_name -> tc_dm dm_name (instantiateMethod clas sel_id (mkTyVarTys tyvars))
+ GenDefMeth dm_name -> do { tau <- tc_genop_ty (findGenericSig sigs sel_name)
+ ; tc_dm dm_name tau }
+ -- In the case of a generic default, we have to get the type from the signature
+ -- Otherwise we can get it by instantiating the method selector
+ where
+ sel_name = idName sel_id
+ prags = prag_fn sel_name
+ dm_sig_fn _ = sig_fn sel_name
+ dm_bind = findMethodBind sel_name binds_in
+ `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+
+ -- 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
+
+ tc_dm dm_name local_dm_ty
+ = do { local_dm_name <- newLocalName sel_name
+ -- Base the local_dm_name on the selector name, because
+ -- type errors from tcInstanceMethodBody come from here
+
+ ; let dm_ty = mkSigmaTy tyvars [mkClassPred clas (mkTyVarTys tyvars)] local_dm_ty
+ dm_id = mkExportedLocalId dm_name dm_ty
+ local_dm_id = mkLocalId local_dm_name local_dm_ty
+
+ ; dm_id_w_inline <- addInlinePrags dm_id prags
+ ; spec_prags <- tcSpecPrags dm_id prags
+
+ ; warnTc (not (null spec_prags))
+ (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
+ <+> quotes (ppr sel_name))
+
+ ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
+ dm_id_w_inline local_dm_id dm_sig_fn
+ IsDefaultMethod dm_bind
+
+ ; return (unitBag tc_bind) }
+
+ tc_genop_ty :: LHsType Name -> TcM Type
+ tc_genop_ty hs_ty
+ = setSrcSpan (getLoc hs_ty) $
+ do { tau <- tcHsKindedType hs_ty
+ ; checkValidType (FunSigCtxt sel_name) tau
+ ; return tau }
+
+findGenericSig :: [LSig Name] -> Name -> LHsType Name
+-- Find the 'generic op :: ty' signature among the sigs
+-- If dm_info is GenDefMeth, the corresponding signature
+-- should jolly well exist! Hence the panic
+findGenericSig sigs sel_name
+ = case [lty | L _ (GenericSig (L _ n) lty) <- sigs
+ , n == sel_name ] of
+ [lty] -> lty
+ _ -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs)
---------------
tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
-
+ ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id)))
; (ev_binds, (tc_bind, _))
<- checkConstraints skol_info tyvars dfun_ev_vars $
tcExtendIdEnv [local_meth_id] $
op Unit = ...
\begin{code}
-mkGenericDefMethBind :: Class -> [Type] -> Id -> TcM (LHsBind Name)
-mkGenericDefMethBind clas inst_tys sel_id
+mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
+mkGenericDefMethBind clas inst_tys sel_id dm_name
= -- 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)
- do { checkTc (isJust maybe_tycon)
- (badGenericInstance sel_id (notSimple inst_tys))
- ; checkTc (tyConHasGenerics tycon)
- (badGenericInstance sel_id (notGeneric tycon))
-
- ; dflags <- getDOpts
+ -- If the method is defined generically, we only have to call the
+ -- dm_name.
+ do { dflags <- getDOpts
; liftIO (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
; return (noLoc $ mkFunBind (noLoc (idName sel_id))
- [mkSimpleMatch [] rn_rhs]) }
+ [mkSimpleMatch [] 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 = ASSERT (not (null (classTyVars clas))) 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
- _ -> Nothing
- _ -> Nothing
-
+ rhs = nlHsVar dm_name
---------------------------
getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name]
else do
-- Otherwise print it out
- { dflags <- getDOpts
- ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
- (vcat (map pprInstInfoDetails gen_inst_info)))
+ { dumpDerivingInfo $ hang (ptext (sLit "Generic instances"))
+ 2 (vcat (map pprInstInfoDetails gen_inst_info))
; return gen_inst_info }}
get_generics :: TyClDecl Name -> TcM [InstInfo Name]
= hsep [ptext (sLit "Class"), quotes (ppr clas),
ptext (sLit "does not have a method"), quotes (ppr op)]
+badGenericMethod :: Outputable a => a -> Name -> SDoc
+badGenericMethod clas op
+ = hsep [ptext (sLit "Class"), quotes (ppr clas),
+ ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
+
badATErr :: Class -> Name -> SDoc
badATErr clas at
= hsep [ptext (sLit "Class"), quotes (ppr clas),
omittedATWarn at
= ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
-badGenericInstance :: Var -> SDoc -> SDoc
-badGenericInstance sel_id because
- = sep [ptext (sLit "Can't derive generic code for") <+> quotes (ppr sel_id),
- because]
-
-notSimple :: [Type] -> SDoc
-notSimple inst_tys
- = vcat [ptext (sLit "because the instance type(s)"),
- nest 2 (ppr inst_tys),
- ptext (sLit "is not a simple type of form (T a1 ... an)")]
-
-notGeneric :: TyCon -> SDoc
-notGeneric tycon
- = vcat [ptext (sLit "because the instance type constructor") <+> quotes (ppr tycon) <+>
- ptext (sLit "was not compiled with -XGenerics")]
-
badGenericInstanceType :: LHsBinds Name -> SDoc
badGenericInstanceType binds
= vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
where
ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
-mixedGenericErr :: Name -> SDoc
-mixedGenericErr op
- = ptext (sLit "Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
+badDmPrag :: Id -> Sig Name -> TcM ()
+badDmPrag sel_id prag
+ = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method")
+ <+> quotes (ppr sel_id)
+ <+> ptext (sLit "lacks an accompanying binding"))
\end{code}
projects / ghc-hetmet.git / blobdiff