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
......@@ -667,6 +671,7 @@ okBindSig _ = True
okHsBootSig :: Sig a -> Bool
okHsBootSig (TypeSig _ _) = True
okHsBootSig (GenericSig _ _) = True -- JPM: Is this true?
okHsBootSig (FixSig _) = True
okHsBootSig _ = False
......@@ -676,6 +681,7 @@ okClsDclSig _ = True -- All others OK
okInstDclSig :: Sig a -> Bool
okInstDclSig (TypeSig _ _) = False
okInstDclSig (GenericSig _ _) = False
okInstDclSig (FixSig _) = False
okInstDclSig _ = True
......@@ -707,6 +713,7 @@ isVanillaLSig _ = False
isTypeLSig :: LSig name -> Bool -- Type signatures
isTypeLSig (L _(TypeSig {})) = True
isTypeLSig (L _(GenericSig {})) = True
isTypeLSig (L _(IdSig {})) = True
isTypeLSig _ = False
......@@ -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) }
......
......@@ -1336,7 +1336,7 @@ tyThingToIfaceDecl (AClass clas)
op_ty = funResultTy rho_ty
toDmSpec NoDefMeth = NoDM
toDmSpec GenDefMeth = GenericDM
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)) }
: '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 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
......
......@@ -94,7 +94,7 @@ isUnboundName name = name `hasKey` unboundKey
%* *
%************************************************************************
This section tells what the compiler knows about the assocation of
This section tells what the compiler knows about the association of
names with uniques. These ones are the *non* wired-in ones. The
wired in ones are defined in TysWiredIn etc.
......@@ -221,10 +221,25 @@ basicKnownKeyNames
-- dotnet interop
, objectTyConName, marshalObjectName, unmarshalObjectName
, marshalStringName, unmarshalStringName, checkDotnetResName
-- Generics
, rep0ClassName, rep1ClassName
, datatypeClassName, constructorClassName, selectorClassName
]
genericTyConNames :: [Name]
genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]
genericTyConNames = [
-- Old stuff
crossTyConName, plusTyConName, genUnitTyConName,
-- New stuff
v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
k1TyConName, m1TyConName, sumTyConName, prodTyConName,
compTyConName, rTyConName, pTyConName, dTyConName,
cTyConName, sTyConName, rec0TyConName, par0TyConName,
d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
rep0TyConName, rep1TyConName
]
-- Know names from the DPH package which vary depending on the selected DPH backend.
--
......@@ -525,12 +540,61 @@ mkTyConRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyCon")
undefined_RDR :: RdrName
undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
error_RDR :: RdrName
error_RDR = varQual_RDR gHC_ERR (fsLit "error")
-- Old Generics (constructors and functions)
crossDataCon_RDR, inlDataCon_RDR, inrDataCon_RDR, genUnitDataCon_RDR :: RdrName
crossDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:")
inlDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inl")
inrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inr")
genUnitDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Unit")
-- Generics (constructors and functions)
u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,
k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR,
prodDataCon_RDR, comp1DataCon_RDR, from0_RDR, from1_RDR,
to0_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, conName_RDR,
conFixity_RDR, conIsRecord_RDR, conIsTuple_RDR,
noArityDataCon_RDR, arityDataCon_RDR,
prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,
rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName
--v1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "V1")
u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1")
par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1")
rec1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Rec1")
k1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "K1")
m1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "M1")
l1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "L1")
r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1")
prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:")
comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1")
from0_RDR = varQual_RDR gHC_GENERICS (fsLit "from0")
from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1")
to0_RDR = varQual_RDR gHC_GENERICS (fsLit "to0")
to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1")
datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName")
moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName")
selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName")
conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName")
conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity")
conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord")
conIsTuple_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsTuple")
noArityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NoArity")
arityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Arity")
prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix")
infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix")
leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")
rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative")
notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, traverse_RDR :: RdrName
fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap")
pure_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure")
......@@ -576,12 +640,47 @@ eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey
leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey
rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey
-- Generics
-- Old Generics (types)
crossTyConName, plusTyConName, genUnitTyConName :: Name
crossTyConName = tcQual gHC_GENERICS (fsLit ":*:") crossTyConKey
plusTyConName = tcQual gHC_GENERICS (fsLit ":+:") plusTyConKey
genUnitTyConName = tcQual gHC_GENERICS (fsLit "Unit") genUnitTyConKey
-- Generics (types)
v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
k1TyConName, m1TyConName, sumTyConName, prodTyConName,
compTyConName, rTyConName, pTyConName, dTyConName,
cTyConName, sTyConName, rec0TyConName, par0TyConName,
d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
rep0TyConName, rep1TyConName :: Name
v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey
u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey
par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey
rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey
k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey
m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey
sumTyConName = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey
prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey
compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey
rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey
pTyConName = tcQual gHC_GENERICS (fsLit "P") pTyConKey
dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey
cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey
sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey
rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey
par0TyConName = tcQual gHC_GENERICS (fsLit "Par0") par0TyConKey
d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey
c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey
s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey
noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey
rep0TyConName = tcQual gHC_GENERICS (fsLit "Rep0") rep0TyConKey
rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey
-- Base strings Strings
unpackCStringName, unpackCStringAppendName, unpackCStringFoldrName,
unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
......@@ -755,6 +854,16 @@ showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey
readClassName :: Name
readClassName = clsQual gHC_READ (fsLit "Read") readClassKey
-- Classes Representable0 and Representable1, Datatype, Constructor and Selector
rep0ClassName, rep1ClassName, datatypeClassName, constructorClassName,
selectorClassName :: Name
rep0ClassName = clsQual gHC_GENERICS (fsLit "Representable0") rep0ClassKey
rep1ClassName = clsQual gHC_GENERICS (fsLit "Representable1") rep1ClassKey
datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey
constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey
selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey
-- parallel array types and functions
enumFromToPName, enumFromThenToPName, nullPName, lengthPName,
singletonPName, replicatePName, mapPName, filterPName,
......@@ -944,6 +1053,15 @@ applicativeClassKey, foldableClassKey, traversableClassKey :: Unique
applicativeClassKey = mkPreludeClassUnique 34
foldableClassKey = mkPreludeClassUnique 35
traversableClassKey = mkPreludeClassUnique 36
rep0ClassKey, rep1ClassKey, datatypeClassKey, constructorClassKey,
selectorClassKey :: Unique
rep0ClassKey = mkPreludeClassUnique 37
rep1ClassKey = mkPreludeClassUnique 38
datatypeClassKey = mkPreludeClassUnique 39
constructorClassKey = mkPreludeClassUnique 40
selectorClassKey = mkPreludeClassUnique 41
\end{code}
%************************************************************************
......@@ -1029,7 +1147,7 @@ ptrTyConKey = mkPreludeTyConUnique 74
funPtrTyConKey = mkPreludeTyConUnique 75
tVarPrimTyConKey = mkPreludeTyConUnique 76
-- Generic Type Constructors
-- Old Generic Type Constructors
crossTyConKey, plusTyConKey, genUnitTyConKey :: Unique
crossTyConKey = mkPreludeTyConUnique 79
plusTyConKey = mkPreludeTyConUnique 80
......@@ -1086,6 +1204,41 @@ opaqueTyConKey = mkPreludeTyConUnique 133
stringTyConKey :: Unique
stringTyConKey = mkPreludeTyConUnique 134
-- Generics (Unique keys)
v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,
compTyConKey, rTyConKey, pTyConKey, dTyConKey,
cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey,
d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,
rep0TyConKey, rep1TyConKey :: Unique
v1TyConKey = mkPreludeTyConUnique 135
u1TyConKey = mkPreludeTyConUnique 136
par1TyConKey = mkPreludeTyConUnique 137
rec1TyConKey = mkPreludeTyConUnique 138
k1TyConKey = mkPreludeTyConUnique 139
m1TyConKey = mkPreludeTyConUnique 140
sumTyConKey = mkPreludeTyConUnique 141
prodTyConKey = mkPreludeTyConUnique 142
compTyConKey = mkPreludeTyConUnique 143
rTyConKey = mkPreludeTyConUnique 144
pTyConKey = mkPreludeTyConUnique 145
dTyConKey = mkPreludeTyConUnique 146
cTyConKey = mkPreludeTyConUnique 147
sTyConKey = mkPreludeTyConUnique 148
rec0TyConKey = mkPreludeTyConUnique 149
par0TyConKey = mkPreludeTyConUnique 150
d1TyConKey = mkPreludeTyConUnique 151
c1TyConKey = mkPreludeTyConUnique 152
s1TyConKey = mkPreludeTyConUnique 153
noSelTyConKey = mkPreludeTyConUnique 154
rep0TyConKey = mkPreludeTyConUnique 155
rep1TyConKey = mkPreludeTyConUnique 156
---------------- Template Haskell -------------------
-- USES TyConUniques 200-299
-----------------------------------------------------
......
......@@ -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,6 +675,11 @@ 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
......@@ -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) }
......
......@@ -121,6 +121,7 @@ hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs)
hsSigFVs :: Sig Name -> FreeVars
hsSigFVs (TypeSig _ ty) = extractHsTyNames ty
hsSigFVs (GenericSig _ ty) = extractHsTyNames ty
hsSigFVs (SpecInstSig ty) = extractHsTyNames ty
hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty
hsSigFVs _ = emptyFVs
......
......@@ -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
= 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
; 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]
tcClassSig :: NameEnv DefMethSpec -- Info about default methods;
-> LSig Name
-> TcM TcMethInfo
genop_names :: [Name] -- These ones have a generic signature
genop_names = [n | L _ (GenericSig (L _ n) _) <- sigs]
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
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) }
tcClassSig _ s = pprPanic "tcClassSig" (ppr s)
tc_sig sig = pprPanic "tc_cls_sig" (ppr sig)
\end{code}
......@@ -174,62 +162,76 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,