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 ( ...@@ -48,11 +48,12 @@ module OccName (
-- ** Derived 'OccName's -- ** Derived 'OccName's
isDerivedOccName, isDerivedOccName,
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkGenD, mkGenC, mkGenS, mkGenR0, mkGenR0Co,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkInstTyCoOcc, mkEqPredCoOcc,
...@@ -540,9 +541,10 @@ isDerivedOccName occ = ...@@ -540,9 +541,10 @@ isDerivedOccName occ =
\end{code} \end{code}
\begin{code} \begin{code}
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkGenD, mkGenR0, mkGenR0Co,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
...@@ -554,6 +556,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, ...@@ -554,6 +556,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
mkDataConWrapperOcc = mk_simple_deriv varName "$W" mkDataConWrapperOcc = mk_simple_deriv varName "$W"
mkWorkerOcc = mk_simple_deriv varName "$w" mkWorkerOcc = mk_simple_deriv varName "$w"
mkDefaultMethodOcc = mk_simple_deriv varName "$dm" mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
mkGenDefMethodOcc = mk_simple_deriv varName "$gdm"
mkClassOpAuxOcc = mk_simple_deriv varName "$c" mkClassOpAuxOcc = mk_simple_deriv varName "$c"
mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies
mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon
...@@ -572,10 +575,19 @@ mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" ...@@ -572,10 +575,19 @@ mkCon2TagOcc = mk_simple_deriv varName "$con2tag_"
mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" mkTag2ConOcc = mk_simple_deriv varName "$tag2con_"
mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" mkMaxTagOcc = mk_simple_deriv varName "$maxtag_"
-- Generic derivable classes -- Generic derivable classes (old)
mkGenOcc1 = mk_simple_deriv varName "$gfrom" mkGenOcc1 = mk_simple_deriv varName "$gfrom"
mkGenOcc2 = mk_simple_deriv varName "$gto" 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 -- data T = MkT ... deriving( Data ) needs defintions for
-- $tT :: Data.Generics.Basics.DataType -- $tT :: Data.Generics.Basics.DataType
-- $cMkT :: Data.Generics.Basics.Constr -- $cMkT :: Data.Generics.Basics.Constr
......
...@@ -420,6 +420,7 @@ rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] ...@@ -420,6 +420,7 @@ rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
-- Singleton => Ok -- Singleton => Ok
-- Empty => Too hard, signature ignored -- Empty => Too hard, signature ignored
rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc 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 (InlineSig nm ispec)) = rep_inline nm ispec loc
rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
rep_sig _ = return [] rep_sig _ = return []
......
...@@ -597,6 +597,10 @@ data Sig name -- Signatures and pragmas ...@@ -597,6 +597,10 @@ data Sig name -- Signatures and pragmas
-- f :: Num a => a -> a -- f :: Num a => a -> a
TypeSig (Located name) (LHsType name) 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 -- A type signature in generated code, notably the code
-- generated for record selectors. We simply record -- generated for record selectors. We simply record
-- the desired Id itself, replete with its name, type -- the desired Id itself, replete with its name, type
...@@ -666,18 +670,20 @@ okBindSig :: Sig a -> Bool ...@@ -666,18 +670,20 @@ okBindSig :: Sig a -> Bool
okBindSig _ = True okBindSig _ = True
okHsBootSig :: Sig a -> Bool okHsBootSig :: Sig a -> Bool
okHsBootSig (TypeSig _ _) = True okHsBootSig (TypeSig _ _) = True
okHsBootSig (FixSig _) = True okHsBootSig (GenericSig _ _) = True -- JPM: Is this true?
okHsBootSig _ = False okHsBootSig (FixSig _) = True
okHsBootSig _ = False
okClsDclSig :: Sig a -> Bool okClsDclSig :: Sig a -> Bool
okClsDclSig (SpecInstSig _) = False okClsDclSig (SpecInstSig _) = False
okClsDclSig _ = True -- All others OK okClsDclSig _ = True -- All others OK
okInstDclSig :: Sig a -> Bool okInstDclSig :: Sig a -> Bool
okInstDclSig (TypeSig _ _) = False okInstDclSig (TypeSig _ _) = False
okInstDclSig (FixSig _) = False okInstDclSig (GenericSig _ _) = False
okInstDclSig _ = True okInstDclSig (FixSig _) = False
okInstDclSig _ = True
sigForThisGroup :: NameSet -> LSig Name -> Bool sigForThisGroup :: NameSet -> LSig Name -> Bool
sigForThisGroup ns sig sigForThisGroup ns sig
...@@ -706,9 +712,10 @@ isVanillaLSig (L _(TypeSig {})) = True ...@@ -706,9 +712,10 @@ isVanillaLSig (L _(TypeSig {})) = True
isVanillaLSig _ = False isVanillaLSig _ = False
isTypeLSig :: LSig name -> Bool -- Type signatures isTypeLSig :: LSig name -> Bool -- Type signatures
isTypeLSig (L _(TypeSig {})) = True isTypeLSig (L _(TypeSig {})) = True
isTypeLSig (L _(IdSig {})) = True isTypeLSig (L _(GenericSig {})) = True
isTypeLSig _ = False isTypeLSig (L _(IdSig {})) = True
isTypeLSig _ = False
isSpecLSig :: LSig name -> Bool isSpecLSig :: LSig name -> Bool
isSpecLSig (L _(SpecSig {})) = True isSpecLSig (L _(SpecSig {})) = True
...@@ -731,6 +738,7 @@ isInlineLSig _ = False ...@@ -731,6 +738,7 @@ isInlineLSig _ = False
hsSigDoc :: Sig name -> SDoc hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = ptext (sLit "type signature") hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
hsSigDoc (GenericSig {}) = ptext (sLit "generic default type signature")
hsSigDoc (IdSig {}) = ptext (sLit "id signature") hsSigDoc (IdSig {}) = ptext (sLit "id signature")
hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma") hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma")
hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma") hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma")
...@@ -745,6 +753,7 @@ eqHsSig :: Eq a => LSig a -> LSig a -> Bool ...@@ -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 _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2 eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2
eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc 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 eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2
-- For specialisations, we don't have equality over -- For specialisations, we don't have equality over
-- HsType, so it's not convenient to spot duplicate -- HsType, so it's not convenient to spot duplicate
...@@ -758,6 +767,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where ...@@ -758,6 +767,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where
ppr_sig :: OutputableBndr name => Sig name -> SDoc ppr_sig :: OutputableBndr name => Sig name -> SDoc
ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty) 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 (IdSig id) = pprVarSig id (ppr (varType id))
ppr_sig (FixSig fix_sig) = ppr fix_sig ppr_sig (FixSig fix_sig) = ppr fix_sig
ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl) ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl)
......
...@@ -27,7 +27,7 @@ module HsUtils( ...@@ -27,7 +27,7 @@ module HsUtils(
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
-- Bindigns -- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind,
-- Literals -- Literals
......
...@@ -229,8 +229,9 @@ mkDataConStupidTheta tycon arg_tys univ_tvs ...@@ -229,8 +229,9 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
------------------------------------------------------ ------------------------------------------------------
\begin{code} \begin{code}
type TcMethInfo = (Name, DefMethSpec, Type) -- A temporary intermediate, to communicate type TcMethInfo = (Name, DefMethSpec, Type)
-- between tcClassSigs and buildClass -- A temporary intermediate, to communicate between tcClassSigs and
-- buildClass.
buildClass :: Bool -- True <=> do not include unfoldings buildClass :: Bool -- True <=> do not include unfoldings
-- on dict selectors -- on dict selectors
...@@ -332,7 +333,8 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec ...@@ -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, _) mk_op_item rec_clas (op_name, dm_spec, _)
= do { dm_info <- case dm_spec of = do { dm_info <- case dm_spec of
NoDM -> return NoDefMeth 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 VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
; return (DefMeth dm_name) } ; return (DefMeth dm_name) }
; return (mkDictSelId no_unf op_name rec_clas, dm_info) } ; return (mkDictSelId no_unf op_name rec_clas, dm_info) }
......
...@@ -1335,9 +1335,9 @@ tyThingToIfaceDecl (AClass clas) ...@@ -1335,9 +1335,9 @@ tyThingToIfaceDecl (AClass clas)
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty op_ty = funResultTy rho_ty
toDmSpec NoDefMeth = NoDM toDmSpec NoDefMeth = NoDM
toDmSpec GenDefMeth = GenericDM toDmSpec (GenDefMeth _) = GenericDM
toDmSpec (DefMeth _) = VanillaDM toDmSpec (DefMeth _) = VanillaDM
toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2) toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
......
...@@ -55,6 +55,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ...@@ -55,6 +55,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
("InstType ", inst_type_ds), ("InstType ", inst_type_ds),
("InstData ", inst_data_ds), ("InstData ", inst_data_ds),
("TypeSigs ", bind_tys), ("TypeSigs ", bind_tys),
("GenericSigs ", generic_sigs),
("ValBinds ", val_bind_ds), ("ValBinds ", val_bind_ds),
("FunBinds ", fn_bind_ds), ("FunBinds ", fn_bind_ds),
("InlineMeths ", method_inlines), ("InlineMeths ", method_inlines),
...@@ -74,7 +75,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ...@@ -74,7 +75,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) 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] = count_sigs [d | SigD d <- decls]
-- NB: this omits fixity decls on local bindings and -- NB: this omits fixity decls on local bindings and
-- in class decls. ToDo -- in class decls. ToDo
...@@ -112,13 +113,14 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ...@@ -112,13 +113,14 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
count_bind (FunBind {}) = (0,1) count_bind (FunBind {}) = (0,1)
count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) 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 (FixSig _) = (1,0,0,0,0)
sig_info (TypeSig _ _) = (0,1,0,0) sig_info (TypeSig _ _) = (0,1,0,0,0)
sig_info (SpecSig _ _ _) = (0,0,1,0) sig_info (SpecSig _ _ _) = (0,0,1,0,0)
sig_info (InlineSig _ _) = (0,0,0,1) sig_info (InlineSig _ _) = (0,0,0,1,0)
sig_info _ = (0,0,0,0) sig_info (GenericSig _ _) = (0,0,0,0,1)
sig_info _ = (0,0,0,0,0)
import_info (L _ (ImportDecl _ _ _ qual as spec)) import_info (L _ (ImportDecl _ _ _ qual as spec))
= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info 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 _ _)) ...@@ -137,13 +139,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
class_info decl@(ClassDecl {}) class_info decl@(ClassDecl {})
= case count_sigs (map unLoc (tcdSigs decl)) of = case count_sigs (map unLoc (tcdSigs decl)) of
(_,classops,_,_) -> (_,classops,_,_,_) ->
(classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
class_info _ = (0,0) class_info _ = (0,0)
inst_info (InstDecl _ inst_meths inst_sigs ats) inst_info (InstDecl _ inst_meths inst_sigs ats)
= case count_sigs (map unLoc inst_sigs) of = case count_sigs (map unLoc inst_sigs) of
(_,_,ss,is) -> (_,_,ss,is,_) ->
case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
(tyDecl, dtDecl) -> (tyDecl, dtDecl) ->
(addpr (foldr add2 (0,0) (addpr (foldr add2 (0,0)
......
...@@ -431,6 +431,7 @@ data Token ...@@ -431,6 +431,7 @@ data Token
| ITderiving | ITderiving
| ITdo | ITdo
| ITelse | ITelse
| ITgeneric
| IThiding | IThiding
| ITif | ITif
| ITimport | ITimport
...@@ -635,6 +636,7 @@ reservedWordsFM = listToUFM $ ...@@ -635,6 +636,7 @@ reservedWordsFM = listToUFM $
( "deriving", ITderiving, 0 ), ( "deriving", ITderiving, 0 ),
( "do", ITdo, 0 ), ( "do", ITdo, 0 ),
( "else", ITelse, 0 ), ( "else", ITelse, 0 ),
( "generic", ITgeneric, bit genericsBit ),
( "hiding", IThiding, 0 ), ( "hiding", IThiding, 0 ),
( "if", ITif, 0 ), ( "if", ITif, 0 ),
( "import", ITimport, 0 ), ( "import", ITimport, 0 ),
...@@ -1752,7 +1754,7 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () ...@@ -1752,7 +1754,7 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) ()
-- integer -- integer
genericsBit :: Int genericsBit :: Int
genericsBit = 0 -- {| and |} genericsBit = 0 -- {|, |} and "generic"
ffiBit :: Int ffiBit :: Int
ffiBit = 1 ffiBit = 1
parrBit :: Int parrBit :: Int
......
...@@ -216,6 +216,7 @@ incorrect. ...@@ -216,6 +216,7 @@ incorrect.
'deriving' { L _ ITderiving } 'deriving' { L _ ITderiving }
'do' { L _ ITdo } 'do' { L _ ITdo }
'else' { L _ ITelse } 'else' { L _ ITelse }
'generic' { L _ ITgeneric }
'hiding' { L _ IThiding } 'hiding' { L _ IThiding }
'if' { L _ ITif } 'if' { L _ ITif }
'import' { L _ ITimport } 'import' { L _ ITimport }
...@@ -1232,9 +1233,13 @@ gdrh :: { LGRHS RdrName } ...@@ -1232,9 +1233,13 @@ gdrh :: { LGRHS RdrName }
: '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 } : '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
sigdecl :: { Located (OrdList (LHsDecl RdrName)) } sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
: infixexp '::' sigtypedoc {% do s <- checkValSig $1 $3 : 'generic' infixexp '::' sigtypedoc
; return (LL $ unitOL (LL $ SigD s)) } {% do (TypeSig l ty) <- checkValSig $2 $4
-- See Note [Declaration/signature overlap] for why we need infixexp here ; 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 | var ',' sig_vars '::' sigtypedoc
{ LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] } { 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)))) | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
......
...@@ -812,17 +812,20 @@ checkValSig lhs@(L l _) ty ...@@ -812,17 +812,20 @@ checkValSig lhs@(L l _) ty
ppr lhs <+> text "::" <+> ppr ty) ppr lhs <+> text "::" <+> ppr ty)
$$ text hint) $$ text hint)
where where
hint = if looks_like_foreign lhs hint = if foreign_RDR `looks_like` lhs
then "Perhaps you meant to use -XForeignFunctionInterface?" 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 -- A common error is to forget the ForeignFunctionInterface flag
-- so check for that, and suggest. cf Trac #3805 -- so check for that, and suggest. cf Trac #3805
-- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR looks_like s (L _ (HsVar v)) = v == s
looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
looks_like_foreign _ = False looks_like s _ = False
foreign_RDR = mkUnqual varName (fsLit "foreign") foreign_RDR = mkUnqual varName (fsLit "foreign")
generic_RDR = mkUnqual varName (fsLit "generic")
checkDoAndIfThenElse :: LHsExpr RdrName checkDoAndIfThenElse :: LHsExpr RdrName
-> Bool -> Bool
......
...@@ -94,7 +94,7 @@ isUnboundName name = name `hasKey` unboundKey ...@@ -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 names with uniques. These ones are the *non* wired-in ones. The
wired in ones are defined in TysWiredIn etc. wired in ones are defined in TysWiredIn etc.
...@@ -221,10 +221,25 @@ basicKnownKeyNames ...@@ -221,10 +221,25 @@ basicKnownKeyNames
-- dotnet interop -- dotnet interop
, objectTyConName, marshalObjectName, unmarshalObjectName , objectTyConName, marshalObjectName, unmarshalObjectName
, marshalStringName, unmarshalStringName, checkDotnetResName , marshalStringName, unmarshalStringName, checkDotnetResName
-- Generics
, rep0ClassName, rep1ClassName
, datatypeClassName, constructorClassName, selectorClassName
] ]
genericTyConNames :: [Name] 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. -- 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") ...@@ -525,12 +540,61 @@ mkTyConRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyCon")
undefined_RDR :: RdrName undefined_RDR :: RdrName
undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") 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, inlDataCon_RDR, inrDataCon_RDR, genUnitDataCon_RDR :: RdrName
crossDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") crossDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:")
inlDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inl") inlDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inl")
inrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inr") inrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inr")
genUnitDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Unit") 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, pure_RDR, ap_RDR, foldable_foldr_RDR, traverse_RDR :: RdrName
fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap") fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap")
pure_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure") pure_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure")
...@@ -576,12 +640,47 @@ eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey ...@@ -576,12 +640,47 @@ eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey
leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey
rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey
-- Generics -- Old Generics (types)
crossTyConName, plusTyConName, genUnitTyConName :: Name crossTyConName, plusTyConName, genUnitTyConName :: Name
crossTyConName = tcQual gHC_GENERICS (fsLit ":*:") crossTyConKey crossTyConName = tcQual gHC_GENERICS (fsLit ":*:") crossTyConKey
plusTyConName = tcQual gHC_GENERICS (fsLit ":+:") plusTyConKey plusTyConName = tcQual gHC_GENERICS (fsLit ":+:") plusTyConKey
genUnitTyConName = tcQual gHC_GENERICS (fsLit "Unit") genUnitTyConKey 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 -- Base strings Strings
unpackCStringName, unpackCStringAppendName, unpackCStringFoldrName, unpackCStringName, unpackCStringAppendName, unpackCStringFoldrName,
unpackCStringUtf8Name, eqStringName, stringTyConName :: Name unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
...@@ -755,6 +854,16 @@ showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey ...@@ -755,6 +854,16 @@ showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey
readClassName :: Name readClassName :: Name
readClassName = clsQual gHC_READ (fsLit "Read") readClassKey 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 -- parallel array types and functions
enumFromToPName, enumFromThenToPName, nullPName, lengthPName, enumFromToPName, enumFromThenToPName, nullPName, lengthPName,
singletonPName, replicatePName, mapPName, filterPName, singletonPName, replicatePName, mapPName, filterPName,
...@@ -944,6 +1053,15 @@ applicativeClassKey, foldableClassKey, traversableClassKey :: Unique ...@@ -944,6 +1053,15 @@ applicativeClassKey, foldableClassKey, traversableClassKey :: Unique
applicativeClassKey = mkPreludeClassUnique 34 applicativeClassKey = mkPreludeClassUnique 34
foldableClassKey = mkPreludeClassUnique 35 foldableClassKey = mkPreludeClassUnique 35
traversableClassKey = mkPreludeClassUnique 36 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}