Commit 2a26efb6 authored by simonpj's avatar simonpj

Initial commit for Pedro's new generic default methods

(See his Haskell Symposium 2010 paper
    "A generic deriving mechaism for Haskell")
parent 5cfe9e92
......@@ -48,11 +48,12 @@ module OccName (
-- ** Derived 'OccName's
isDerivedOccName,
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc,
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkGenD, mkGenC, mkGenS, mkGenR0, mkGenR0Co,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
mkInstTyCoOcc, mkEqPredCoOcc,
......@@ -540,9 +541,10 @@ isDerivedOccName occ =
\end{code}
\begin{code}
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc,
mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkGenD, mkGenR0, mkGenR0Co,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
......@@ -554,6 +556,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
mkDataConWrapperOcc = mk_simple_deriv varName "$W"
mkWorkerOcc = mk_simple_deriv varName "$w"
mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
mkGenDefMethodOcc = mk_simple_deriv varName "$gdm"
mkClassOpAuxOcc = mk_simple_deriv varName "$c"
mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies
mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon
......@@ -572,10 +575,19 @@ mkCon2TagOcc = mk_simple_deriv varName "$con2tag_"
mkTag2ConOcc = mk_simple_deriv varName "$tag2con_"
mkMaxTagOcc = mk_simple_deriv varName "$maxtag_"
-- Generic derivable classes
-- Generic derivable classes (old)
mkGenOcc1 = mk_simple_deriv varName "$gfrom"
mkGenOcc2 = mk_simple_deriv varName "$gto"
-- Generic deriving mechanism (new)
mkGenD = mk_simple_deriv tcName "D1"
mkGenC occ m = mk_deriv tcName ("C1_" ++ show m) (occNameString occ)
mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n)
(occNameString occ)
mkGenR0 = mk_simple_deriv tcName "Rep0_"
mkGenR0Co = mk_simple_deriv tcName "CoRep0_"
-- data T = MkT ... deriving( Data ) needs defintions for
-- $tT :: Data.Generics.Basics.DataType
-- $cMkT :: Data.Generics.Basics.Constr
......
......@@ -420,6 +420,7 @@ rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
-- Singleton => Ok
-- Empty => Too hard, signature ignored
rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
rep_sig (L loc (GenericSig nm ty)) = rep_proto nm ty loc -- JPM: ?
rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
rep_sig _ = return []
......
......@@ -597,6 +597,10 @@ data Sig name -- Signatures and pragmas
-- f :: Num a => a -> a
TypeSig (Located name) (LHsType name)
-- A type signature for a generic function inside a class
-- generic eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
| GenericSig (Located name) (LHsType name)
-- A type signature in generated code, notably the code
-- generated for record selectors. We simply record
-- the desired Id itself, replete with its name, type
......@@ -666,18 +670,20 @@ okBindSig :: Sig a -> Bool
okBindSig _ = True
okHsBootSig :: Sig a -> Bool
okHsBootSig (TypeSig _ _) = True
okHsBootSig (FixSig _) = True
okHsBootSig _ = False
okHsBootSig (TypeSig _ _) = True
okHsBootSig (GenericSig _ _) = True -- JPM: Is this true?
okHsBootSig (FixSig _) = True
okHsBootSig _ = False
okClsDclSig :: Sig a -> Bool
okClsDclSig (SpecInstSig _) = False
okClsDclSig _ = True -- All others OK
okInstDclSig :: Sig a -> Bool
okInstDclSig (TypeSig _ _) = False
okInstDclSig (FixSig _) = False
okInstDclSig _ = True
okInstDclSig (TypeSig _ _) = False
okInstDclSig (GenericSig _ _) = False
okInstDclSig (FixSig _) = False
okInstDclSig _ = True
sigForThisGroup :: NameSet -> LSig Name -> Bool
sigForThisGroup ns sig
......@@ -706,9 +712,10 @@ isVanillaLSig (L _(TypeSig {})) = True
isVanillaLSig _ = False
isTypeLSig :: LSig name -> Bool -- Type signatures
isTypeLSig (L _(TypeSig {})) = True
isTypeLSig (L _(IdSig {})) = True
isTypeLSig _ = False
isTypeLSig (L _(TypeSig {})) = True
isTypeLSig (L _(GenericSig {})) = True
isTypeLSig (L _(IdSig {})) = True
isTypeLSig _ = False
isSpecLSig :: LSig name -> Bool
isSpecLSig (L _(SpecSig {})) = True
......@@ -731,6 +738,7 @@ isInlineLSig _ = False
hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
hsSigDoc (GenericSig {}) = ptext (sLit "generic default type signature")
hsSigDoc (IdSig {}) = ptext (sLit "id signature")
hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma")
hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma")
......@@ -745,6 +753,7 @@ eqHsSig :: Eq a => LSig a -> LSig a -> Bool
eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2
eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
eqHsSig (L _ (GenericSig n1 _)) (L _ (GenericSig n2 _)) = unLoc n1 == unLoc n2
eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2
-- For specialisations, we don't have equality over
-- HsType, so it's not convenient to spot duplicate
......@@ -758,6 +767,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where
ppr_sig :: OutputableBndr name => Sig name -> SDoc
ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty)
ppr_sig (GenericSig var ty) = ptext (sLit "generic") <+> pprVarSig (unLoc var) (ppr ty)
ppr_sig (IdSig id) = pprVarSig id (ppr (varType id))
ppr_sig (FixSig fix_sig) = ppr fix_sig
ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl)
......
......@@ -27,7 +27,7 @@ module HsUtils(
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
-- Bindigns
-- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind,
-- Literals
......
......@@ -229,8 +229,9 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
------------------------------------------------------
\begin{code}
type TcMethInfo = (Name, DefMethSpec, Type) -- A temporary intermediate, to communicate
-- between tcClassSigs and buildClass
type TcMethInfo = (Name, DefMethSpec, Type)
-- A temporary intermediate, to communicate between tcClassSigs and
-- buildClass.
buildClass :: Bool -- True <=> do not include unfoldings
-- on dict selectors
......@@ -332,7 +333,8 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
mk_op_item rec_clas (op_name, dm_spec, _)
= do { dm_info <- case dm_spec of
NoDM -> return NoDefMeth
GenericDM -> return GenDefMeth
GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
; return (GenDefMeth dm_name) }
VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
; return (DefMeth dm_name) }
; return (mkDictSelId no_unf op_name rec_clas, dm_info) }
......
......@@ -1335,9 +1335,9 @@ tyThingToIfaceDecl (AClass clas)
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty
toDmSpec NoDefMeth = NoDM
toDmSpec GenDefMeth = GenericDM
toDmSpec (DefMeth _) = VanillaDM
toDmSpec NoDefMeth = NoDM
toDmSpec (GenDefMeth _) = GenericDM
toDmSpec (DefMeth _) = VanillaDM
toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
......
......@@ -55,6 +55,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
("InstType ", inst_type_ds),
("InstData ", inst_data_ds),
("TypeSigs ", bind_tys),
("GenericSigs ", generic_sigs),
("ValBinds ", val_bind_ds),
("FunBinds ", fn_bind_ds),
("InlineMeths ", method_inlines),
......@@ -74,7 +75,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls)
(fixity_sigs, bind_tys, bind_specs, bind_inlines)
(fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs)
= count_sigs [d | SigD d <- decls]
-- NB: this omits fixity decls on local bindings and
-- in class decls. ToDo
......@@ -112,13 +113,14 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
count_bind (FunBind {}) = (0,1)
count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)
count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs)
sig_info (FixSig _) = (1,0,0,0)
sig_info (TypeSig _ _) = (0,1,0,0)
sig_info (SpecSig _ _ _) = (0,0,1,0)
sig_info (InlineSig _ _) = (0,0,0,1)
sig_info _ = (0,0,0,0)
sig_info (FixSig _) = (1,0,0,0,0)
sig_info (TypeSig _ _) = (0,1,0,0,0)
sig_info (SpecSig _ _ _) = (0,0,1,0,0)
sig_info (InlineSig _ _) = (0,0,0,1,0)
sig_info (GenericSig _ _) = (0,0,0,0,1)
sig_info _ = (0,0,0,0,0)
import_info (L _ (ImportDecl _ _ _ qual as spec))
= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
......@@ -137,13 +139,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
class_info decl@(ClassDecl {})
= case count_sigs (map unLoc (tcdSigs decl)) of
(_,classops,_,_) ->
(_,classops,_,_,_) ->
(classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
class_info _ = (0,0)
inst_info (InstDecl _ inst_meths inst_sigs ats)
= case count_sigs (map unLoc inst_sigs) of
(_,_,ss,is) ->
(_,_,ss,is,_) ->
case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
(tyDecl, dtDecl) ->
(addpr (foldr add2 (0,0)
......
......@@ -431,6 +431,7 @@ data Token
| ITderiving
| ITdo
| ITelse
| ITgeneric
| IThiding
| ITif
| ITimport
......@@ -635,6 +636,7 @@ reservedWordsFM = listToUFM $
( "deriving", ITderiving, 0 ),
( "do", ITdo, 0 ),
( "else", ITelse, 0 ),
( "generic", ITgeneric, bit genericsBit ),
( "hiding", IThiding, 0 ),
( "if", ITif, 0 ),
( "import", ITimport, 0 ),
......@@ -1752,7 +1754,7 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
-- integer
genericsBit :: Int
genericsBit = 0 -- {| and |}
genericsBit = 0 -- {|, |} and "generic"
ffiBit :: Int
ffiBit = 1
parrBit :: Int
......
......@@ -216,6 +216,7 @@ incorrect.
'deriving' { L _ ITderiving }
'do' { L _ ITdo }
'else' { L _ ITelse }
'generic' { L _ ITgeneric }
'hiding' { L _ IThiding }
'if' { L _ ITif }
'import' { L _ ITimport }
......@@ -1232,9 +1233,13 @@ gdrh :: { LGRHS RdrName }
: '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
: infixexp '::' sigtypedoc {% do s <- checkValSig $1 $3
; return (LL $ unitOL (LL $ SigD s)) }
-- See Note [Declaration/signature overlap] for why we need infixexp here
: 'generic' infixexp '::' sigtypedoc
{% do (TypeSig l ty) <- checkValSig $2 $4
; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) }
-- See Note [Declaration/signature overlap] for why we need infixexp here
| infixexp '::' sigtypedoc
{% do s <- checkValSig $1 $3
; return (LL $ unitOL (LL $ SigD s)) }
| var ',' sig_vars '::' sigtypedoc
{ LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
| infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
......
......@@ -812,17 +812,20 @@ checkValSig lhs@(L l _) ty
ppr lhs <+> text "::" <+> ppr ty)
$$ text hint)
where
hint = if looks_like_foreign lhs
hint = if foreign_RDR `looks_like` lhs
then "Perhaps you meant to use -XForeignFunctionInterface?"
else "Should be of form <variable> :: <type>"
else if generic_RDR `looks_like` lhs
then "Perhaps you meant to use -XGenerics?"
else "Should be of form <variable> :: <type>"
-- A common error is to forget the ForeignFunctionInterface flag
-- so check for that, and suggest. cf Trac #3805
-- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR
looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
looks_like_foreign _ = False
looks_like s (L _ (HsVar v)) = v == s
looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
looks_like s _ = False
foreign_RDR = mkUnqual varName (fsLit "foreign")
generic_RDR = mkUnqual varName (fsLit "generic")
checkDoAndIfThenElse :: LHsExpr RdrName
-> Bool
......
This diff is collapsed.
......@@ -586,8 +586,20 @@ rnMethodBinds :: Name -- Class name
-> RnM (LHsBinds Name, FreeVars)
rnMethodBinds cls sig_fn gen_tyvars binds
= foldlM do_one (emptyBag,emptyFVs) (bagToList binds)
= do { checkDupRdrNames meth_names
-- Check that the same method is not given twice in the
-- same instance decl instance C T where
-- f x = ...
-- g y = ...
-- f x = ...
-- We must use checkDupRdrNames because the Name of the
-- method is the Name of the class selector, whose SrcSpan
-- points to the class declaration; and we use rnMethodBinds
-- for instance decls too
; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
where
meth_names = collectMethodBinders binds
do_one (binds,fvs) bind
= do { (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind
; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
......@@ -663,7 +675,12 @@ renameSigs mb_names ok_sig sigs
-- Check for duplicates on RdrName version,
-- because renamed version has unboundName for
-- not-in-scope binders, which gives bogus dup-sig errors
-- NB: in a class decl, a 'generic' sig is not considered
-- equal to an ordinary sig, so we allow, say
-- class C a where
-- op :: a -> a
-- generic op :: Eq a => a -> a
; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs
; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs'
......@@ -690,6 +707,11 @@ renameSig mb_names sig@(TypeSig v ty)
; new_ty <- rnHsSigType (quotes (ppr v)) ty
; return (TypeSig new_v new_ty) }
renameSig mb_names sig@(GenericSig v ty)
= do { new_v <- lookupSigOccRn mb_names sig v
; new_ty <- rnHsSigType (quotes (ppr v)) ty
; return (GenericSig new_v new_ty) } -- JPM: ?
renameSig _ (SpecInstSig ty)
= do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
; return (SpecInstSig new_ty) }
......
......@@ -120,10 +120,11 @@ hsSigsFVs :: [LSig Name] -> FreeVars
hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs)
hsSigFVs :: Sig Name -> FreeVars
hsSigFVs (TypeSig _ ty) = extractHsTyNames ty
hsSigFVs (SpecInstSig ty) = extractHsTyNames ty
hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty
hsSigFVs _ = emptyFVs
hsSigFVs (TypeSig _ ty) = extractHsTyNames ty
hsSigFVs (GenericSig _ ty) = extractHsTyNames ty
hsSigFVs (SpecInstSig ty) = extractHsTyNames ty
hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty
hsSigFVs _ = emptyFVs
----------------
conDeclFVs :: LConDecl Name -> FreeVars
......
......@@ -443,19 +443,8 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
-- The typechecker (not the renamer) checks that all
-- the bindings are for the right class
let
meth_names = collectMethodBinders mbinds
(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
in
checkDupRdrNames meth_names `thenM_`
-- Check that the same method is not given twice in the
-- same instance decl instance C T where
-- f x = ...
-- g y = ...
-- f x = ...
-- We must use checkDupRdrNames because the Name of the
-- method is the Name of the class selector, whose SrcSpan
-- points to the class declaration
extendTyVarEnvForMethodBinds inst_tyvars (
-- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too
......
......@@ -97,48 +97,36 @@ Death to "ExpandingDicts".
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
checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b)
= 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 ]
; sequence [ failWithTc (badMethodErr clas n)
| n <- dm_bind_names, not (n `elem` op_names) ]
-- Value binding for non class-method (ie no TypeSig)
tcClassSig :: NameEnv DefMethSpec -- Info about default methods;
-> LSig Name
-> TcM TcMethInfo
; sequence [ failWithTc (badGenericMethod clas n)
| n <- genop_names, not (n `elem` dm_bind_names) ]
-- Generic signature without value binding
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}
......@@ -174,62 +162,76 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
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)
= 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 }
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 }
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
---------------
tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
......@@ -246,7 +248,7 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars
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] $
......@@ -562,6 +564,11 @@ badMethodErr clas op
= 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),
......
......@@ -40,10 +40,14 @@ import Name
import NameSet
import TyCon
import TcType
import BuildTyCl
import BasicTypes
import Var
import VarSet
import PrelNames
import SrcLoc
import Unique
import UniqSupply
import Util
import ListSetOps
import Outputable
......@@ -292,12 +296,14 @@ both of them. So we gather defs/uses from deriving just like anything else.
tcDeriving :: [LTyClDecl Name] -- All type constructors
-> [LInstDecl Name] -- All instance declarations
-> [LDerivDecl Name] -- All stand-alone deriving declarations
-> TcM ([InstInfo Name], -- The generated "instance decls"
HsValBinds Name, -- Extra generated top-level bindings
DefUses)
-> TcM ([InstInfo Name] -- The generated "instance decls"
,HsValBinds Name -- Extra generated top-level bindings
,DefUses
,[TyCon] -- Extra generated top-level types
,[TyCon]) -- Extra generated type family instances
tcDeriving tycl_decls inst_decls deriv_decls
= recoverM (return ([], emptyValBindsOut, emptyDUs)) $
= recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $
do { -- Fish the "deriving"-related information out of the TcEnv
-- And make the necessary "equations".
is_boot <- tcIsHsBoot
......@@ -313,14 +319,27 @@ tcDeriving tycl_decls inst_decls deriv_decls
; insts2 <- mapM (genInst False overlap_flag) final_specs
-- Generate the generic to/from functions from each type declaration
; gen_binds <- mkGenericBinds is_boot tycl_decls
; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
-- Generate the (old) generic to/from functions from each type declaration
; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls
-- Generate the generic Representable0/1 instances from each type declaration
; repInstsMeta <- genGenericRepBinds is_boot tycl_decls
; let repInsts = concat (map (\(a,b,c) -> a) repInstsMeta)
repMetaTys = map (\(a,b,c) -> b) repInstsMeta
repTyCons = map (\(a,b,c) -> c) repInstsMeta
-- Should we extendLocalInstEnv with repInsts?
; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ repInsts)
; dflags <- getDOpts
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
(ddump_deriving inst_info rn_binds))
; when (not (null inst_info)) $
dumpDerivingInfo (ddump_deriving inst_info rn_binds)
; return (inst_info, rn_binds, rn_dus) }
; return ( inst_info, rn_binds, rn_dus
, concat (map metaTyCons2TyCons repMetaTys), repTyCons) }
where
ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
ddump_deriving inst_infos extra_binds
......@@ -1463,6 +1482,133 @@ genDerivBinds loc fix_env clas tycon
,(foldableClassKey, gen_Foldable_binds)
,(traversableClassKey, gen_Traversable_binds)
]
-- Generate the binds for the generic representation
genGenericRepBinds :: Bool -> [LTyClDecl Name]
-> TcM [([(InstInfo RdrName, DerivAuxBinds)]
, MetaTyCons, TyCon)]
genGenericRepBinds isBoot tyclDecls
| isBoot = return []
| otherwise = do
allTyDecls <- mapM tcLookupTyCon [ tcdName d | L _ d <- tyclDecls
, isDataDecl d ]
let tyDecls = filter tyConHasGenerics allTyDecls
inst1 <- mapM genGenericRepBind tyDecls
let (repInsts, metaTyCons, repTys) = unzip3 inst1
metaInsts <- ASSERT (length tyDecls == length metaTyCons)
mapM genDtMeta (zip tyDecls metaTyCons)
return (ASSERT (length inst1 == length metaInsts)
[ (ri : mi, ms, rt)
| ((ri, ms, rt), mi) <- zip inst1 metaInsts ])
genGenericRepBind :: TyCon -> TcM ((InstInfo RdrName, DerivAuxBinds)
, MetaTyCons, TyCon)
genGenericRepBind tc =
do clas <- tcLookupClass rep0ClassName
uniqS <- newUniqueSupply
dfun_name <- new_dfun_name clas tc
let
-- Uniques for everyone
(uniqD:uniqs) = uniqsFromSupply uniqS
(uniqsC,us) = splitAt (length tc_cons) uniqs
uniqsS :: [[Unique]] -- Unique supply for the S datatypes
uniqsS = mkUniqsS tc_arits us
mkUniqsS [] _ = []
mkUniqsS (n:t) us = case splitAt n us of
(us1,us2) -> us1 : mkUniqsS t us2
tc_name = tyConName tc
tc_cons = tyConDataCons tc
tc_arits = map dataConSourceArity tc_cons
tc_occ = nameOccName tc_name
d_occ = mkGenD tc_occ
c_occ m = mkGenC tc_occ m
s_occ m n = mkGenS tc_occ m n
mod_name = nameModule (tyConName tc)
d_name = mkExternalName uniqD mod_name d_occ wiredInSrcSpan
c_names = [ mkExternalName u mod_name (c_occ m) wiredInSrcSpan
| (u,m) <- zip uniqsC [0..] ]
s_names = [ [ mkExternalName u mod_name (s_occ m n) wiredInSrcSpan
| (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
tvs = tyConTyVars tc
tc_ty = mkTyConApp tc (mkTyVarTys tvs)
mkTyCon name = ASSERT( isExternalName name )
buildAlgTyCon name [] [] mkAbstractTyConRhs
NonRecursive False False NoParentTyCon Nothing
metaDTyCon <- mkTyCon d_name
metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ]
metaSTyCons <- mapM sequence
[ [ mkTyCon s_name
| s_name <- s_namesC ] | s_namesC <- s_names ]
let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons