\begin{code}
module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod, tcInstanceMethodBody,
- mkGenericDefMethBind, getGenericInstances,
+ mkGenericDefMethBind,
tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
) where
#include "HsVersions.h"
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 TcType
import TcRnMonad
import BuildTyCl( TcMethInfo )
-import Generics
import Class
-import TyCon
-import MkId
import Id
import Name
-import Var
import NameEnv
import NameSet
+import Var
import Outputable
-import PrelNames
import DynFlags
import ErrUtils
-import Util
-import ListSetOps
import SrcLoc
import Maybes
import BasicTypes
import FastString
import Control.Monad
-import Data.List
\end{code}
%************************************************************************
\begin{code}
-tcClassSigs :: Name -- Name of the class
+tcClassSigs :: Name -- Name of the class
-> [LSig Name]
-> LHsBinds Name
- -> TcM [TcMethInfo] -- One for each method
-
+ -> TcM ([TcMethInfo], -- Exactly one for each method
+ NameEnv Type) -- Types of the generic-default methods
tcClassSigs clas sigs def_methods
- = 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 ]
+ = do { gen_dm_prs <- mapM (addLocM tc_gen_sig) gen_sigs
+ ; let gen_dm_env = mkNameEnv gen_dm_prs
+
+ ; op_info <- mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
- ; sequence [ failWithTc (badMethodErr clas n)
- | n <- dm_bind_names, not (n `elem` op_names) ]
- -- Value binding for non class-method (ie no TypeSig)
+ ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
+ ; sequence_ [ failWithTc (badMethodErr clas n)
+ | n <- dm_bind_names, not (n `elemNameSet` 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
+ ; sequence_ [ failWithTc (badGenericMethod clas n)
+ | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
+ -- Generic signature without value binding
- ; return op_info }
+ ; return (op_info, gen_dm_env) }
where
+ vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs]
+ gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs]
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)
+ tc_sig genop_env (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
+ ; let dm | op_name `elemNameEnv` genop_env = 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)
+
+ tc_gen_sig (L _ op_name, gen_hs_ty)
+ = do { gen_op_ty <- tcHsKindedType gen_hs_ty
+ ; return (op_name, gen_op_ty) }
\end{code}
; traceTc "TIM2" (ppr sigs)
; let tc_dm = tcDefMeth clas clas_tyvars
- this_dict default_binds sigs
+ this_dict default_binds
sig_fn prag_fn
; dm_binds <- tcExtendTyVarEnv clas_tyvars $
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
-tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name]
+tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
-> SigFun -> PragFun -> ClassOpItem
-> TcM (LHsBinds TcId)
-- Generate code for polymorphic default methods only (hence DefMeth)
-- 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 sigs sig_fn prag_fn (sel_id, dm_info)
- | NoDefMeth <- dm_info = return emptyBag
- | otherwise
- = do { (dm_id, tvs, sig_loc) <- tc_dm_id dm_info
- ; let L loc meth_bind = findMethodBind sel_name binds_in
- `orElse` pprPanic "tcDefMeth" (ppr sel_id)
- dm_bind = L loc (meth_bind { fun_id = L loc (idName dm_id) })
- -- Substitute the meth_name for the binder
- -- NB: the binding is always a FunBind
-
- dm_sig_fn _ = Just (clas_tv_names ++ tvs, sig_loc)
- dm_prag_fn _ = prag_fn sel_name
-
- ; (binds,_) <- tcExtendIdEnv [dm_id] $
- tcPolyBinds TopLevel dm_sig_fn dm_prag_fn
- NonRecursive NonRecursive
- [dm_bind]
- ; return binds }
+tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
+ = case dm_info of
+ NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
+ ; return emptyBag }
+ DefMeth dm_name -> tc_dm dm_name
+ GenDefMeth dm_name -> tc_dm dm_name
where
sel_name = idName sel_id
- clas_tv_names = map getName tyvars
-
- -- Find the 'generic op :: ty' signature among the sigs
- -- If dm_info is GenDefMeth, the corresponding signature
- -- should jolly well exist! Hence the panic
- genop_lhs_ty = case [lty | L _ (GenericSig (L _ n) lty) <- sigs
- , n == sel_name ] of
- [lty] -> lty
- _ -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs)
-
- tc_dm_id :: DefMeth -> TcM (Id, [Name], SrcSpan)
- -- Make a default-method Id of the appropriate type
- -- That may entail getting the generic-default signature
- -- from the type signatures.
- -- Also return the in-scope tyvars for the default method, and their binding site
- tc_dm_id NoDefMeth = panic "tc_dm_id"
- tc_dm_id (DefMeth dm_name)
- | Just (tvs, loc) <- sig_fn sel_name
- = return (mkDefaultMethodId sel_id dm_name, tvs, loc)
- | otherwise
- = pprPanic "No sig for" (ppr sel_name)
- tc_dm_id (GenDefMeth dm_name)
- = setSrcSpan loc $
- do { tau <- tcHsKindedType genop_lhs_ty
- ; checkValidType (FunSigCtxt sel_name) tau
- ; return ( mkExportedLocalId dm_name (mkForAllTys tyvars tau)
- , hsExplicitTvs genop_lhs_ty, loc ) }
- where
- loc = getLoc genop_lhs_ty
+ 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
+ = do { dm_id <- tcLookupId dm_name
+ ; local_dm_name <- newLocalName sel_name
+ -- Base the local_dm_name on the selector name, because
+ -- type errors from tcInstanceMethodBody come from here
+
+ ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
+ 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) }
---------------
tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
[mkSimpleMatch [] rhs]) }
where
rhs = nlHsVar dm_name
-
----------------------------
-getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name]
-getGenericInstances class_decls
- = do { gen_inst_infos <- mapM (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 return []
- else do
-
- -- Otherwise print it out
- { dumpDerivingInfo $ hang (ptext (sLit "Generic instances"))
- 2 (vcat (map pprInstInfoDetails gen_inst_info))
- ; return gen_inst_info }}
-
-get_generics :: TyClDecl Name -> TcM [InstInfo Name]
-get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
- | null generic_binds
- = return [] -- The comon case: no generic default methods
-
- | otherwise -- A source class decl with generic default methods
- = recoverM (return []) $
- tcAddDeclCtxt decl $ do
- clas <- tcLookupLocatedClass class_name
-
- -- Group by type, and
- -- make an InstInfo out of each group
- let
- groups = groupWith listToBag generic_binds
-
- inst_infos <- mapM (mkGenericInstance clas) groups
-
- -- Check that there is only one InstInfo for each type constructor
- -- The main way this can fail is if you write
- -- f {| a+b |} ... = ...
- -- f {| x+y |} ... = ...
- -- Then at this point we'll have an InstInfo for each
- --
- -- The class should be unary, which is why simpleInstInfoTyCon should be ok
- let
- tc_inst_infos :: [(TyCon, InstInfo Name)]
- tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
-
- bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
- group `lengthExceeds` 1]
- get_uniq (tc,_) = getUnique tc
-
- mapM_ (addErrTc . dupGenericInsts) bad_groups
-
- -- Check that there is an InstInfo for each generic type constructor
- let
- missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
-
- checkTc (null missing) (missingGenericInstances missing)
-
- return inst_infos
- where
- generic_binds :: [(HsType Name, LHsBind Name)]
- generic_binds = getGenericBinds def_methods
-get_generics decl = pprPanic "get_generics" (ppr decl)
-
-
----------------------------------
-getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
- -- Takes a group of method bindings, finds the generic ones, and returns
- -- them in finite map indexed by the type parameter in the definition.
-getGenericBinds binds = concat (map getGenericBind (bagToList binds))
-
-getGenericBind :: LHsBindLR Name Name -> [(HsType Name, LHsBindLR Name Name)]
-getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
- = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
- where
- wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
-getGenericBind _
- = []
-
-groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
-groupWith _ [] = []
-groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
- where
- vs = map snd this
- (this,rest) = partition same_t prs
- same_t (t', _v) = t `eqPatType` t'
-
-eqPatLType :: LHsType Name -> LHsType Name -> Bool
-eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
-
-eqPatType :: HsType Name -> HsType Name -> Bool
--- A very simple equality function, only for
--- type patterns in generic function definitions.
-eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2
-eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2
-eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 && unLoc op1 == unLoc op2
-eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2
-eqPatType (HsParTy t1) t2 = unLoc t1 `eqPatType` t2
-eqPatType t1 (HsParTy t2) = t1 `eqPatType` unLoc t2
-eqPatType _ _ = False
-
----------------------------------
-mkGenericInstance :: Class
- -> (HsType Name, LHsBinds Name)
- -> TcM (InstInfo Name)
-
-mkGenericInstance clas (hs_ty, binds) = do
- -- Make a generic instance declaration
- -- For example: instance (C a, C b) => C (a+b) where { binds }
-
- -- Extract the universally quantified type variables
- -- and wrap them as forall'd tyvars, so that kind inference
- -- works in the standard way
- let
- sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $
- extractHsTyVars (noLoc hs_ty)
- hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
-
- -- Type-check the instance type, and check its form
- forall_inst_ty <- tcHsSigType GenPatCtxt hs_forall_ty
- let
- (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
-
- checkTc (validGenericInstanceType inst_ty)
- (badGenericInstanceType binds)
-
- -- Make the dictionary function.
- span <- getSrcSpanM
- overlap_flag <- getOverlapFlag
- dfun_name <- newDFunName clas [inst_ty] span
- let
- inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
- dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
- ispec = mkLocalInstance dfun_id overlap_flag
-
- return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False })
\end{code}
-
%************************************************************************
%* *
Error messages
omittedATWarn :: Name -> SDoc
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