\begin{code}
module MkId (
- mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId,
+ mkDictFunId, mkDictFunTy, mkDictSelId,
mkDataConIds,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
that they aren't discarded by the occurrence analyser.
\begin{code}
-mkDefaultMethodId :: Id -- Selector Id
- -> Name -- Default method name
- -> Id -- Default method Id
-mkDefaultMethodId sel_id dm_name = mkExportedLocalId dm_name (idType sel_id)
-
mkDictFunId :: Name -- Name to use for the dict fun;
-> [TyVar]
-> ThetaType
-- ** 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, mkGenR, mkGenRCo, mkGenC, mkGenS,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
mkInstTyCoOcc, mkEqPredCoOcc,
\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, mkGenR, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
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
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 :: OccName -> Int -> OccName
+mkGenC occ m = mk_deriv tcName ("C1_" ++ show m) (occNameString occ)
+
+mkGenS :: OccName -> Int -> Int -> OccName
+mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n)
+ (occNameString occ)
+
+mkGenR = mk_simple_deriv tcName "Rep_"
+mkGenRCo = mk_simple_deriv tcName "CoRep_"
+
-- data T = MkT ... deriving( Data ) needs defintions for
-- $tT :: Data.Generics.Basics.DataType
-- $cMkT :: Data.Generics.Basics.Constr
-- Finally the ones that are sure to succeed, or which are covered by the checking algorithm
might_fail_pat (LazyPat _) = False -- Always succeeds
-might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat, TypePat
+might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat
--------------
might_fail_lpat :: LPat Id -> Bool
go (SigPatIn pat _) = collectl pat bndrs
go (SigPatOut pat _) = collectl pat bndrs
- go (TypePat _) = bndrs
go (CoPat _ pat _) = collectl (noLoc pat) bndrs
go (ViewPat _ pat _) = collectl pat bndrs
go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p)
-- Singleton => Ok
-- Empty => Too hard, signature ignored
rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
+rep_sig (L _ (GenericSig nm _)) = failWithDs msg
+ where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm)
+ , ptext (sLit "Default signatures are not supported by Template Haskell") ]
+
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 []
k1 <- repKind k
repTSig t1 k1
repTy (HsSpliceTy splice _ _) = repSplice splice
-repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
repTy ty = notHandled "Exotic form of type" (ppr ty)
-- represent a kind
-- f :: Num a => a -> a
TypeSig (Located name) (LHsType name)
+ -- A type signature for a default method inside a class
+ -- default 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
okBindSig _ = True
okHsBootSig :: Sig a -> Bool
-okHsBootSig (TypeSig _ _) = True
-okHsBootSig (FixSig _) = True
-okHsBootSig _ = False
+okHsBootSig (TypeSig _ _) = True
+okHsBootSig (GenericSig _ _) = False
+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
sigName :: LSig name -> Maybe name
-- Used only in Haddock
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
hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
+hsSigDoc (GenericSig {}) = ptext (sLit "default type signature")
hsSigDoc (IdSig {}) = ptext (sLit "id signature")
hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma")
hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma")
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
ppr_sig :: OutputableBndr name => Sig name -> SDoc
ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty)
+ppr_sig (GenericSig var ty) = ptext (sLit "default") <+> 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)
\begin{code}
type LDerivDecl name = Located (DerivDecl name)
-data DerivDecl name = DerivDecl (LHsType name)
+data DerivDecl name = DerivDecl { deriv_type :: LHsType name }
deriving (Data, Typeable)
instance (OutputableBndr name) => Outputable (DerivDecl name) where
(SyntaxExpr id) -- (>=) function, of type t->t->Bool
(SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName)
- ------------ Generics ---------------
- | TypePat (LHsType id) -- Type pattern for generic definitions
- -- e.g f{| a+b |} = ...
- -- These show up only in class declarations,
- -- and should be a top-level pattern
-
------------ Pattern type signatures ---------------
| SigPatIn (LPat id) -- Pattern with a type signature
(LHsType id)
pprPat (NPat l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k]
pprPat (QuasiQuotePat qq) = ppr qq
-pprPat (TypePat ty) = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}")
pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co
pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
go1 (QuasiQuotePat {}) = urk pat -- Gotten rid of by renamer, before
-- isIrrefutablePat is called
- go1 (TypePat {}) = urk pat
urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
hsPatNeedsParens (NPat {}) = False
hsPatNeedsParens (NPlusKPat {}) = True
hsPatNeedsParens (QuasiQuotePat {}) = True
-hsPatNeedsParens (TypePat {}) = False
conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon args) = not (null args)
-- interface files smaller), so when printing a HsType we may need to
-- add parens.
- | HsNumTy Integer -- Generics only
-
| HsPredTy (HsPred name) -- Only used in the type of an instance
-- declaration, eg. Eq [a] -> Eq a
-- ^^^^
ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPredTy pred) = ppr pred
-ppr_mono_ty _ (HsNumTy n) = integer n -- generics only
ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
- -- Bindigns
+ -- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind,
-- Literals
go (SigPatIn pat _) = collect_lpat pat bndrs
go (SigPatOut pat _) = collect_lpat pat bndrs
go (QuasiQuotePat _) = bndrs
- go (TypePat _) = bndrs
go (CoPat _ pat _) = go pat
\end{code}
collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc)
-collect_sig_pat (TypePat ty) acc = ty:acc
collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc
collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc
put_ bh idinfo
put_ _ (IfaceForeign _ _) =
error "Binary.put_(IfaceDecl): IfaceForeign"
- put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
+ put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
putByte bh 2
put_ bh (occNameFS a1)
put_ bh a2
put_ bh a5
put_ bh a6
put_ bh a7
- put_ bh a8
put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
putByte bh 3
put_ bh (occNameFS a1)
a5 <- get bh
a6 <- get bh
a7 <- get bh
- a8 <- get bh
occ <- return $! mkOccNameFS tcName a1
- return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
+ return (IfaceData occ a2 a3 a4 a5 a6 a7)
3 -> do
a1 <- get bh
a2 <- get bh
buildDataCon,
TcMethInfo, buildClass,
mkAbstractTyConRhs,
- mkNewTyConRhs, mkDataTyConRhs
+ mkNewTyConRhs, mkDataTyConRhs,
+ newImplicitBinder
) where
#include "HsVersions.h"
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> RecFlag
- -> Bool -- ^ True <=> want generics functions
-> Bool -- ^ True <=> was declared in GADT syntax
-> TyConParent
-> Maybe (TyCon, [Type]) -- ^ family instance if applicable
-> TcRnIf m n TyCon
-buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
+buildAlgTyCon tc_name tvs stupid_theta rhs is_rec gadt_syn
parent mb_family
| Just fam_inst_info <- mb_family
= -- We need to tie a knot as the coercion of a data instance depends
fixM $ \ tycon_rec -> do
{ fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
- fam_parent is_rec want_generics gadt_syn) }
+ fam_parent is_rec gadt_syn) }
| otherwise
= return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
- parent is_rec want_generics gadt_syn)
+ parent is_rec gadt_syn)
where
kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
------------------------------------------------------
\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
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) }
ifRec :: RecFlag, -- Recursive or not?
ifGadtSyntax :: Bool, -- True <=> declared using
-- GADT syntax
- ifGeneric :: Bool, -- True <=> generic converter
- -- functions available
- -- We need this for imported
- -- data decls, since the
- -- imported modules may have
- -- been compiled with
- -- different flags to the
- -- current compilation unit
ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
-- Invariant:
= hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
4 (dcolon <+> ppr kind)
-pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
+pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context,
ifTyVars = tyvars, ifCons = condecls,
ifRec = isrec, ifFamInst = mbFamInst})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
- 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
+ 4 (vcat [pprRec isrec, pp_condecls tycon condecls,
pprFamily mbFamInst])
where
pp_nd = case condecls of
pprRec :: RecFlag -> SDoc
pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
-pprGen :: Bool -> SDoc
-pprGen True = ptext (sLit "Generics: yes")
-pprGen False = ptext (sLit "Generics: no")
-
pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc
pprFamily Nothing = ptext (sLit "FamilyInstance: none")
pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst
(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)
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
- ifGeneric = tyConHasGenerics tycon,
ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
| isForeignTyCon tycon
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec,
- ifGeneric = want_generic,
ifFamInst = mb_family })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; mb_fam_inst <- tcFamInst mb_family
; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
- want_generic gadt_syn parent mb_fam_inst
+ gadt_syn parent mb_fam_inst
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
| Opt_TemplateHaskell
| Opt_QuasiQuotes
| Opt_ImplicitParams
- | Opt_Generics -- "Derivable type classes"
| Opt_ImplicitPrelude
| Opt_ScopedTypeVariables
| Opt_UnboxedTuples
| Opt_DeriveFunctor
| Opt_DeriveTraversable
| Opt_DeriveFoldable
+ | Opt_DeriveGeneric -- Allow deriving Generic/1
+ | Opt_DefaultSignatures -- Allow extra signatures for defmeths
+ | Opt_Generics -- Old generic classes, now deprecated
| Opt_TypeSynonymInstances
| Opt_FlexibleContexts
( "ParallelArrays", Opt_ParallelArrays, nop ),
( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ),
( "QuasiQuotes", Opt_QuasiQuotes, nop ),
- ( "Generics", Opt_Generics, nop ),
+ ( "Generics", Opt_Generics,
+ \ _ -> deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support." ),
( "ImplicitPrelude", Opt_ImplicitPrelude, nop ),
( "RecordWildCards", Opt_RecordWildCards, nop ),
( "NamedFieldPuns", Opt_RecordPuns, nop ),
( "DeriveFunctor", Opt_DeriveFunctor, nop ),
( "DeriveTraversable", Opt_DeriveTraversable, nop ),
( "DeriveFoldable", Opt_DeriveFoldable, nop ),
+ ( "DeriveGeneric", Opt_DeriveGeneric, nop ),
+ ( "DefaultSignatures", Opt_DefaultSignatures, nop ),
( "TypeSynonymInstances", Opt_TypeSynonymInstances, nop ),
( "FlexibleContexts", Opt_FlexibleContexts, nop ),
( "FlexibleInstances", Opt_FlexibleInstances, nop ),
, Opt_DeriveFunctor
, Opt_DeriveFoldable
, Opt_DeriveTraversable
+ , Opt_DeriveGeneric
, Opt_FlexibleContexts
, Opt_FlexibleInstances
, Opt_ConstrainedClassMethods
("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),
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
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)
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)
addpr :: (Int,Int) -> Int
add2 :: (Int,Int) -> (Int,Int) -> (Int, Int)
- add4 :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int)
add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int)
add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int)
addpr (x,y) = x+y
add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
- add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)
add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6)
\end{code}
-- * TyThings and type environments
TyThing(..),
tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, tyThingCoAxiom,
- implicitTyThings, isImplicitTyThing,
+ implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing,
TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
-- The order of the list does not matter.
implicitTyThings :: TyThing -> [TyThing]
-
--- For data and newtype declarations:
-implicitTyThings (ATyCon tc)
- = -- fields (names of selectors)
- -- (possibly) implicit coercion and family coercion
- -- depending on whether it's a newtype or a family instance or both
- implicitCoTyCon tc ++
- -- for each data constructor in order,
- -- the contructor, worker, and (possibly) wrapper
- concatMap (extras_plus . ADataCon) (tyConDataCons tc)
-
-implicitTyThings (ACoAxiom _cc)
- = []
-
-implicitTyThings (AClass cl)
- = -- dictionary datatype:
+implicitTyThings (AnId _) = []
+implicitTyThings (ACoAxiom _cc) = []
+implicitTyThings (ATyCon tc) = implicitTyConThings tc
+implicitTyThings (AClass cl) = implicitClassThings cl
+implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc)
+ -- For data cons add the worker and (possibly) wrapper
+
+implicitClassThings :: Class -> [TyThing]
+implicitClassThings cl
+ = -- Does not include default methods, because those Ids may have
+ -- their own pragmas, unfoldings etc, not derived from the Class object
+ -- Dictionary datatype:
-- [extras_plus:]
-- type constructor
-- [recursive call:]
-- superclass and operation selectors
map AnId (classAllSelIds cl)
-implicitTyThings (ADataCon dc) =
- -- For data cons add the worker and (possibly) wrapper
- map AnId (dataConImplicitIds dc)
+implicitTyConThings :: TyCon -> [TyThing]
+implicitTyConThings tc
+ = -- fields (names of selectors)
+ -- (possibly) implicit coercion and family coercion
+ -- depending on whether it's a newtype or a family instance or both
+ implicitCoTyCon tc ++
+ -- for each data constructor in order,
+ -- the contructor, worker, and (possibly) wrapper
+ concatMap (extras_plus . ADataCon) (tyConDataCons tc)
-implicitTyThings (AnId _) = []
-- add a thing and recursive call
extras_plus :: TyThing -> [TyThing]
{ token ITcubxparen }
}
-<0> {
- "{|" / { ifExtension genericsEnabled } { token ITocurlybar }
- "|}" / { ifExtension genericsEnabled } { token ITccurlybar }
-}
-
<0,option_prags> {
\( { special IToparen }
\) { special ITcparen }
-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed
-- integer
-genericsBit :: Int
-genericsBit = 0 -- {| and |}
+-- The "genericsBit" is now unused, available for others
+-- genericsBit :: Int
+-- genericsBit = 0 -- {|, |} and "generic"
+
ffiBit :: Int
ffiBit = 1
parrBit :: Int
always :: Int -> Bool
always _ = True
-genericsEnabled :: Int -> Bool
-genericsEnabled flags = testBit flags genericsBit
parrEnabled :: Int -> Bool
parrEnabled flags = testBit flags parrBit
arrowsEnabled :: Int -> Bool
alr_justClosedExplicitLetBlock = False
}
where
- bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
- .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
+ bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
.|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
.|. arrowsBit `setBitIf` xopt Opt_Arrows flags
.|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
decl_cls : at_decl_cls { LL (unitOL (L1 (TyClD (unLoc $1)))) }
| decl { $1 }
+ -- A 'default' signature used with the generic-programming extension
+ | 'default' infixexp '::' sigtypedoc
+ {% do { (TypeSig l ty) <- checkValSig $2 $4
+ ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } }
+
decls_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
: decls_cls ';' decl_cls { LL (unLoc $1 `appOL` unLoc $3) }
| decls_cls ';' { LL (unLoc $1) }
| '$(' exp ')' { LL $ mkHsSpliceTy $2 }
| TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $
mkUnqual varName (getTH_ID_SPLICE $1) }
--- Generics
- | INTEGER { L1 (HsNumTy (getINTEGER $1)) }
-- An inst_type is what occurs in the head of an instance decl
-- e.g. (Foo a, Gaz b) => Wibble a b
: '|' 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
+ :
+ -- 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))))
-- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |}
-- above. Due to a lack of consensus on the syntax, this feature is not being used until we get user
--- demand. Note that the {| |} symbols are reused from -XGenerics and hence if you want to compile
--- a program that makes use of this temporary syntax you must supply that flag to GHC
+-- demand.
transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) }
-- Function is applied to a list of stmts *in order*
HsPredTy p -> extract_pred p acc
HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
HsParTy ty -> extract_lty ty acc
- HsNumTy {} -> acc
HsCoreTy {} -> acc -- The type is closed
HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables
HsSpliceTy {} -> acc -- Type splices mention no type variables
get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
get _ acc = acc
- get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
- get_m _ acc = acc
+ get_m _ acc = acc
\end{code}
-> do fs <- mapM checkPatField fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsQuasiQuoteE q -> return (QuasiQuotePat q)
--- Generics
- HsType ty -> return (TypePat ty)
_ -> patFail loc e0
placeHolderPunRhs :: LHsExpr RdrName
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 default_RDR `looks_like` lhs
+ then "Perhaps you meant to use -XDefaultSignatures?"
+ 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 _ _ = False
foreign_RDR = mkUnqual varName (fsLit "foreign")
+ default_RDR = mkUnqual varName (fsLit "default")
checkDoAndIfThenElse :: LHsExpr RdrName
-> Bool
%* *
%************************************************************************
-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.
-- dotnet interop
, objectTyConName, marshalObjectName, unmarshalObjectName
, marshalStringName, unmarshalStringName, checkDotnetResName
-
+
+ -- Generics
+ , genClassName, gen1ClassName
+ , datatypeClassName, constructorClassName, selectorClassName
+
-- Monad comprehensions
, guardMName
, liftMName
]
genericTyConNames :: [Name]
-genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]
+genericTyConNames = [
+ v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
+ k1TyConName, m1TyConName, sumTyConName, prodTyConName,
+ compTyConName, rTyConName, pTyConName, dTyConName,
+ cTyConName, sTyConName, rec0TyConName, par0TyConName,
+ d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
+ repTyConName, rep1TyConName
+ ]
-- Know names from the DPH package which vary depending on the selected DPH backend.
--
gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS,
gHC_MAGIC,
- gHC_CLASSES, gHC_BASE, gHC_ENUM,
+ gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception,
gHC_ORDERING = mkPrimModule (fsLit "GHC.Ordering")
gHC_GENERICS = mkPrimModule (fsLit "GHC.Generics")
gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic")
+gHC_CSTRING = mkPrimModule (fsLit "GHC.CString")
gHC_CLASSES = mkBaseModule (fsLit "GHC.Classes")
gHC_BASE = mkBaseModule (fsLit "GHC.Base")
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, from_RDR, from1_RDR,
+ to_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, conName_RDR,
+ conFixity_RDR, conIsRecord_RDR,
+ noArityDataCon_RDR, arityDataCon_RDR, selName_RDR,
+ prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,
+ rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName
+
+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")
+
+from_RDR = varQual_RDR gHC_GENERICS (fsLit "from")
+from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1")
+to_RDR = varQual_RDR gHC_GENERICS (fsLit "to")
+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")
+
+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")
leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey
rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey
--- Generics
-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,
+ repTyConName, 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
+
+repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey
+rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey
-- Base strings Strings
unpackCStringName, unpackCStringAppendName, unpackCStringFoldrName,
unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
-unpackCStringName = varQual gHC_BASE (fsLit "unpackCString#") unpackCStringIdKey
-unpackCStringAppendName = varQual gHC_BASE (fsLit "unpackAppendCString#") unpackCStringAppendIdKey
-unpackCStringFoldrName = varQual gHC_BASE (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey
-unpackCStringUtf8Name = varQual gHC_BASE (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey
+unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey
+unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey
+unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey
+unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey
eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey
stringTyConName = tcQual gHC_BASE (fsLit "String") stringTyConKey
readClassName :: Name
readClassName = clsQual gHC_READ (fsLit "Read") readClassKey
+-- Classes Generic and Generic1, Datatype, Constructor and Selector
+genClassName, gen1ClassName, datatypeClassName, constructorClassName,
+ selectorClassName :: Name
+genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey
+gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey
+
+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,
applicativeClassKey = mkPreludeClassUnique 34
foldableClassKey = mkPreludeClassUnique 35
traversableClassKey = mkPreludeClassUnique 36
+
+genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey,
+ selectorClassKey :: Unique
+genClassKey = mkPreludeClassUnique 37
+gen1ClassKey = mkPreludeClassUnique 38
+
+datatypeClassKey = mkPreludeClassUnique 39
+constructorClassKey = mkPreludeClassUnique 40
+selectorClassKey = mkPreludeClassUnique 41
\end{code}
%************************************************************************
funPtrTyConKey = mkPreludeTyConUnique 75
tVarPrimTyConKey = mkPreludeTyConUnique 76
--- Generic Type Constructors
-crossTyConKey, plusTyConKey, genUnitTyConKey :: Unique
-crossTyConKey = mkPreludeTyConUnique 79
-plusTyConKey = mkPreludeTyConUnique 80
-genUnitTyConKey = mkPreludeTyConUnique 81
-
-- Parallel array type constructor
parrTyConKey :: Unique
parrTyConKey = mkPreludeTyConUnique 82
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,
+ repTyConKey, 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
+
+repTyConKey = mkPreludeTyConUnique 155
+rep1TyConKey = mkPreludeTyConUnique 156
+
---------------- Template Haskell -------------------
-- USES TyConUniques 200-299
-----------------------------------------------------
(DataTyCon cons is_enum)
NoParentTyCon
is_rec
- True -- All the wired-in tycons have generics
False -- Not in GADT syntax
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
mk_tuple boxity arity = (tycon, tuple_con)
where
- tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info
+ tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity
modu = mkTupleModule boxity arity
tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq
(ATyCon tycon) BuiltInSyntax
(ADataCon tuple_con) BuiltInSyntax
tc_uniq = mkTupleTyConUnique boxity arity
dc_uniq = mkTupleDataConUnique boxity arity
- gen_info = True -- Tuples all have generics..
- -- hmm: that's a *lot* of code
unitTyCon :: TyCon
unitTyCon = tupleTyCon Boxed 0
import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
-import RdrHsSyn
import RnHsSyn
import TcRnMonad
import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch)
\begin{code}
rnMethodBinds :: Name -- Class name
-> (Name -> [Name]) -- Signature tyvar function
- -> [Name] -- Names for generic type variables
-> LHsBinds RdrName
-> RnM (LHsBinds Name, FreeVars)
-rnMethodBinds cls sig_fn gen_tyvars binds
- = foldlM do_one (emptyBag,emptyFVs) (bagToList binds)
+rnMethodBinds cls sig_fn 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
+ = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind
; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
rnMethodBind :: Name
-> (Name -> [Name])
- -> [Name]
-> LHsBindLR RdrName RdrName
-> RnM (Bag (LHsBindLR Name Name), FreeVars)
-rnMethodBind cls sig_fn gen_tyvars
+rnMethodBind cls sig_fn
(L loc bind@(FunBind { fun_id = name, fun_infix = is_infix
, fun_matches = MatchGroup matches _ }))
= setSrcSpan loc $ do
-- We use the selector name as the binder
(new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
- mapFvRn (rn_match (FunRhs plain_name is_infix)) matches
+ mapFvRn (rnMatch (FunRhs plain_name is_infix)) matches
let new_group = MatchGroup new_matches placeHolderType
when is_infix $ checkPrecMatch plain_name new_group
, bind_fvs = fvs })),
fvs `addOneFV` plain_name)
-- The 'fvs' field isn't used for method binds
- where
- -- Truly gruesome; bring into scope the correct members of the generic
- -- type variables. See comments in RnSource.rnSourceDecl(ClassDecl)
- rn_match info match@(L _ (Match (L _ (TypePat ty) : _) _ _))
- = extendTyVarEnvFVRn gen_tvs $
- rnMatch info match
- where
- tvs = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty)
- gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs]
-
- rn_match info match = rnMatch info match
-- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBind _ _ _ (L loc bind@(PatBind {})) = do
+rnMethodBind _ _ (L loc bind@(PatBind {})) = do
addErrAt loc (methodBindErr bind)
return (emptyBag, emptyFVs)
-rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b)
+rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b)
\end{code}
-- 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
+ -- default op :: Eq a => a -> a
+
; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs
; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs'
; new_ty <- rnHsSigType (quotes (ppr v)) ty
; return (TypeSig new_v new_ty) }
+renameSig mb_names sig@(GenericSig v ty)
+ = do { defaultSigs_on <- xoptM Opt_DefaultSignatures
+ ; unless defaultSigs_on (addErr (defaultSigErr sig))
+ ; new_v <- lookupSigOccRn mb_names sig v
+ ; new_ty <- rnHsSigType (quotes (ppr v)) ty
+ ; return (GenericSig new_v new_ty) }
+
renameSig _ (SpecInstSig ty)
= do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
; return (SpecInstSig new_ty) }
= addErrAt loc $
sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]
+defaultSigErr :: Sig RdrName -> SDoc
+defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:"))
+ 2 (ppr sig)
+ , ptext (sLit "Use -XDefaultSignatures to enable default signatures") ]
+
methodBindErr :: HsBindLR RdrName RdrName -> SDoc
methodBindErr mbind
= hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations"))
nonStdGuardErr guards
= hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)"))
4 (interpp'SP guards)
+
\end{code}
extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames,
-- Free variables
- hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs,
-
- maybeGenericMatch
+ hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs
) where
#include "HsVersions.h"
get (HsParTy ty) = getl ty
get (HsBangTy _ ty) = getl ty
get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds)
- get (HsNumTy _) = emptyNameSet
get (HsTyVar tv) = unitNameSet tv
get (HsSpliceTy _ fvs _) = fvs
get (HsQuasiQuoteTy {}) = emptyNameSet
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
bangTyFVs :: LHsType Name -> FreeVars
bangTyFVs bty = extractHsTyNames (getBangType bty)
\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{A few functions on generic defintions
-%* *
-%************************************************************************
-
-These functions on generics are defined over Matches Name, which is
-why they are here and not in HsMatches.
-
-\begin{code}
-maybeGenericMatch :: LMatch Name -> Maybe (HsType Name, LMatch Name)
- -- Tells whether a Match is for a generic definition
- -- and extract the type from a generic match and put it at the front
-
-maybeGenericMatch (L loc (Match (L _ (TypePat (L _ ty)) : pats) sig_ty grhss))
- = Just (ty, L loc (Match pats sig_ty grhss))
-
-maybeGenericMatch _ = Nothing
-\end{code}
; pats' <- rnLPatsAndThen mk pats
; return (TuplePat pats' boxed placeHolderType) }
-rnPatAndThen _ (TypePat ty)
- = do { ty' <- liftCpsFV $ rnHsTypeFVs (text "In a type pattern") ty
- ; return (TypePat ty') }
-
#ifndef GHCI
rnPatAndThen _ p@(QuasiQuotePat {})
= pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p)
import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
-import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
+import RdrHsSyn ( extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
makeMiniFixityEnv)
import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn,
lookupTopBndrRn, lookupLocatedTopBndrRn,
- lookupOccRn, newLocalBndrsRn, bindLocalNamesFV,
+ lookupOccRn, bindLocalNamesFV,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
bindLocalNames, checkDupRdrNames, mapFvRn
-- 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
rnMethodBinds cls (\_ -> []) -- No scoped tyvars
- [] mbinds
+ mbinds
) `thenM` \ (mbinds', meth_fvs) ->
-- Rename the associated types
-- The typechecker (not the renamer) checks that all
-- we want to name both "x" tyvars with the same unique, so that they are
-- easy to group together in the typechecker.
; (mbinds', meth_fvs)
- <- extendTyVarEnvForMethodBinds tyvars' $ do
- { name_env <- getLocalRdrEnv
- ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
- not (unLoc tv `elemLocalRdrEnv` name_env) ]
+ <- extendTyVarEnvForMethodBinds tyvars' $
-- No need to check for duplicate method signatures
-- since that is done by RnNames.extendGlobalRdrEnvRn
-- and the methods are already in scope
- ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
- ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
+ rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds
-- Haddock docs
; docs' <- mapM (wrapLocM rnDocDecl) docs
= do { flds' <- rnConDeclFields doc flds
; return (HsRecTy flds') }
-rnHsType _ (HsNumTy i)
- | i == 1 = return (HsNumTy i)
- | otherwise = addErr err_msg >> return (HsNumTy i)
- where
- err_msg = ptext (sLit "Only unit numeric type pattern is valid")
-
-
rnHsType doc (HsFunTy ty1 ty2) = do
ty1' <- rnLHsType doc ty1
-- Might find a for-all as the arg of a function type
import HscTypes
import FamInstEnv
+import LoadIface
import TcMType
import TcRnMonad
import TyCon
; (eps, hpt) <- getEpsAndHpt
; let { -- Fetch the iface of a given module. Must succeed as
- -- all imported modules must already have been loaded.
+ -- all directly imported modules must already have been loaded.
modIface mod =
case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
Nothing -> panic "FamInst.checkFamInstConsistency"
Just iface -> iface
; hmiModule = mi_module . hm_iface
- ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
- ; mkFamInstEnv = extendFamInstEnvList emptyFamInstEnv
- ; hptModInsts = [ (hmiModule hmi, hmiFamInstEnv hmi)
- | hmi <- eltsUFM hpt]
- ; modInstsEnv = eps_mod_fam_inst_env eps -- external modules
- `extendModuleEnvList` -- plus
- hptModInsts -- home package modules
+ ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv
+ . md_fam_insts . hm_details
+ ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)
+ | hmi <- eltsUFM hpt]
; groups = map (dep_finsts . mi_deps . modIface)
directlyImpMods
; okPairs = listToSet $ concatMap allPairs groups
-- the difference gives us the pairs we need to check now
}
- ; mapM_ (check modInstsEnv) toCheckPairs
+ ; mapM_ (check hpt_fam_insts) toCheckPairs
}
where
allPairs [] = []
allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
- -- The modules are guaranteed to be in the environment, as they are either
- -- already loaded in the EPS or they are in the HPT.
- --
- check modInstsEnv (ModulePair m1 m2)
- = let { instEnv1 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1
- ; instEnv2 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m2
- ; insts1 = famInstEnvElts instEnv1
- }
- in
- mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
+ check hpt_fam_insts (ModulePair m1 m2)
+ = do { env1 <- getFamInsts hpt_fam_insts m1
+ ; env2 <- getFamInsts hpt_fam_insts m2
+ ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))
+ (famInstEnvElts env1) }
+
+getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
+getFamInsts hpt_fam_insts mod
+ | Just env <- lookupModuleEnv hpt_fam_insts mod = return env
+ | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
+ ; eps <- getEps
+ ; return (expectJust "checkFamInstConsistency" $
+ lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
+ where
+ doc = ppr mod <+> ptext (sLit "is a family-instance module")
\end{code}
%************************************************************************
\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]
-
+ -> TcM ([TcMethInfo], -- Exactly one for each method
+ NameEnv Type) -- Types of the generic-default methods
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 { gen_dm_prs <- mapM (addLocM tc_gen_sig) gen_sigs
+ ; let gen_dm_env = mkNameEnv gen_dm_prs
-checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b)
+ ; op_info <- mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
+ ; 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)
-tcClassSig :: NameEnv DefMethSpec -- Info about default methods;
- -> LSig Name
- -> TcM TcMethInfo
+ ; sequence_ [ failWithTc (badGenericMethod clas n)
+ | (n,_) <- gen_dm_prs, 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, 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]
+
+ 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 `elemNameEnv` genop_env = GenericDM
+ | op_name `elem` dm_bind_names = VanillaDM
+ | otherwise = NoDM
+ ; return (op_name, dm, op_ty) }
+
+ 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}
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
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
-> 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
-- (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 }
+ 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
+ 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]
let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
-
+ ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id)))
; (ev_binds, (tc_bind, _))
<- checkConstraints skol_info tyvars dfun_ev_vars $
tcExtendIdEnv [local_meth_id] $
op Unit = ...
\begin{code}
-mkGenericDefMethBind :: Class -> [Type] -> Id -> TcM (LHsBind Name)
-mkGenericDefMethBind clas inst_tys sel_id
+mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
+mkGenericDefMethBind clas inst_tys sel_id dm_name
= -- A generic default method
- -- If the method is defined generically, we can only do the job if the
- -- instance declaration is for a single-parameter type class with
- -- a type constructor applied to type arguments in the instance decl
- -- (checkTc, so False provokes the error)
- do { checkTc (isJust maybe_tycon)
- (badGenericInstance sel_id (notSimple inst_tys))
- ; checkTc (tyConHasGenerics tycon)
- (badGenericInstance sel_id (notGeneric tycon))
-
- ; dflags <- getDOpts
+ -- If the method is defined generically, we only have to call the
+ -- dm_name.
+ do { dflags <- getDOpts
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
(vcat [ppr clas <+> ppr inst_tys,
nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
- -- Rename it before returning it
- ; (rn_rhs, _) <- rnLExpr rhs
; return (noLoc $ mkFunBind (noLoc (idName sel_id))
- [mkSimpleMatch [] rn_rhs]) }
+ [mkSimpleMatch [] rhs]) }
where
- rhs = mkGenericRhs sel_id clas_tyvar tycon
-
- -- The tycon is only used in the generic case, and in that
- -- case we require that the instance decl is for a single-parameter
- -- type class with type variable arguments:
- -- instance (...) => C (T a b)
- clas_tyvar = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
- Just tycon = maybe_tycon
- maybe_tycon = case inst_tys of
- [ty] -> case tcSplitTyConApp_maybe ty of
- Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
- _ -> Nothing
- _ -> Nothing
-
-
----------------------------
-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 })
+ rhs = nlHsVar dm_name
\end{code}
-
%************************************************************************
%* *
Error messages
= hsep [ptext (sLit "Class"), quotes (ppr clas),
ptext (sLit "does not have a method"), quotes (ppr op)]
+badGenericMethod :: Outputable a => a -> Name -> SDoc
+badGenericMethod clas op
+ = hsep [ptext (sLit "Class"), quotes (ppr clas),
+ ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
+
badATErr :: Class -> Name -> SDoc
badATErr clas at
= hsep [ptext (sLit "Class"), quotes (ppr clas),
omittedATWarn :: 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}
import NameSet
import TyCon
import TcType
+import BuildTyCl
+import BasicTypes
import Var
import VarSet
import PrelNames
import SrcLoc
+import UniqSupply
import Util
import ListSetOps
import Outputable
ds_cls = c, ds_tys = tys, ds_theta = rhs })
= parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
<+> equals <+> ppr rhs)
+
+instance Outputable DerivSpec where
+ ppr = pprDerivSpec
\end{code}
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
; traceTc "tcDeriving" (ppr is_boot)
- ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+ ; (early_specs, genericsExtras)
+ <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+ ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras
; overlap_flag <- getOverlapFlag
; let (infer_specs, given_specs) = splitEithers early_specs
; 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)
+ -- We no longer generate the old generic to/from functions
+ -- from each type declaration, so this is emptyBag
+ ; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls
+
+ ; (inst_info, rn_binds, rn_dus)
+ <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts)
+ ; 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
2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
$$ ppr extra_binds)
+
renameDeriv :: Bool -> LHsBinds RdrName
-> [(InstInfo RdrName, DerivAuxBinds)]
-> TcM ([InstInfo Name], HsValBinds Name, DefUses)
-- scope (yuk), and rename the method binds
ASSERT( null sigs )
bindLocalNames (map Var.varName tyvars) $
- do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
+ do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) binds
; let binds' = VanillaInst rn_binds [] standalone_deriv
; return (inst_info { iBinds = binds' }, fvs) }
where
(tyvars,_, clas,_) = instanceHead inst
clas_nm = className clas
-
------------------------------------------
-mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
-mkGenericBinds is_boot tycl_decls
- | is_boot
- = return emptyBag
- | otherwise
- = do { tcs <- mapM tcLookupTyCon [ tcdName d
- | L _ d <- tycl_decls, isDataDecl d ]
- ; return (unionManyBags [ mkTyConGenericBinds tc
- | tc <- tcs, tyConHasGenerics tc ]) }
- -- We are only interested in the data type declarations,
- -- and then only in the ones whose 'has-generics' flag is on
- -- The predicate tyConHasGenerics finds both of these
\end{code}
Note [Newtype deriving and unused constructors]
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
\begin{code}
+-- Make the "extras" for the generic representation
+mkGenDerivExtras :: TyCon
+ -> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])
+mkGenDerivExtras tc = do
+ { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc
+ ; metaInsts <- genDtMeta (tc, metaTyCons)
+ ; return (metaTyCons, rep0TyInst, metaInsts) }
+
makeDerivSpecs :: Bool
-> [LTyClDecl Name]
- -> [LInstDecl Name]
+ -> [LInstDecl Name]
-> [LDerivDecl Name]
- -> TcM [EarlyDerivSpec]
-
+ -> TcM ( [EarlyDerivSpec]
+ , [(MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])])
makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
- | is_boot -- No 'deriving' at all in hs-boot files
- = do { mapM_ add_deriv_err deriv_locs
- ; return [] }
+ | is_boot -- No 'deriving' at all in hs-boot files
+ = do { mapM_ add_deriv_err deriv_locs
+ ; return ([],[]) }
| otherwise
- = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
- ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
- ; return (eqns1 ++ eqns2) }
+ = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
+ ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
+
+ -- Generic representation stuff: we might need to add some "extras"
+ -- to the instances
+ ; xDerRep <- getDOpts >>= return . xopt Opt_DeriveGeneric
+ ; generic_extras_deriv <- if not xDerRep
+ -- No extras if the flag is off
+ then (return [])
+ else do {
+ let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ]
+ -- Select only those types that derive Generic
+ ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata
+ , getClassName c == Just genClassName ]
+ ; let sel_deriv_decls = catMaybes [ getTypeName t
+ | L _ (DerivDecl (L _ t)) <- deriv_decls
+ , getClassName t == Just genClassName ]
+ ; derTyDecls <- mapM tcLookupTyCon $
+ filter (needsExtras xDerRep
+ (sel_tydata ++ sel_deriv_decls)) allTyNames
+ -- We need to generate the extras to add to what has
+ -- already been derived
+ ; {- pprTrace "sel_tydata" (ppr sel_tydata) $
+ pprTrace "sel_deriv_decls" (ppr sel_deriv_decls) $
+ pprTrace "derTyDecls" (ppr derTyDecls) $
+ pprTrace "deriv_decls" (ppr deriv_decls) $ -}
+ mapM mkGenDerivExtras derTyDecls }
+
+ -- Merge and return
+ ; return ( eqns1 ++ eqns2, generic_extras_deriv) }
where
+ -- We need extras if the flag DeriveGeneric is on and this type is
+ -- deriving Generic
+ needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata
+
+ -- Extracts the name of the class in the deriving
+ getClassName :: HsType Name -> Maybe Name
+ getClassName (HsForAllTy _ _ _ (L _ n)) = getClassName n
+ getClassName (HsPredTy (HsClassP n _)) = Just n
+ getClassName _ = Nothing
+
+ -- Extracts the name of the type in the deriving
+ -- This function (and also getClassName above) is not really nice, and I
+ -- might not have covered all possible cases. I wonder if there is no easier
+ -- way to extract class and type name from a LDerivDecl...
+ getTypeName :: HsType Name -> Maybe Name
+ getTypeName (HsForAllTy _ _ _ (L _ n)) = getTypeName n
+ getTypeName (HsTyVar n) = Just n
+ getTypeName (HsOpTy _ (L _ n) _) = Just n
+ getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n
+ getTypeName (HsAppTy (L _ n) _) = getTypeName n
+ getTypeName (HsParTy (L _ n)) = getTypeName n
+ getTypeName (HsKindSig (L _ n) _) = getTypeName n
+ getTypeName _ = Nothing
+
extractTyDataPreds decls
= [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
all_tydata :: [(LHsType Name, LTyClDecl Name)]
- -- Derived predicate paired with its data type declaration
+ -- Derived predicate paired with its data type declaration
all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls)
deriv_locs = map (getLoc . snd) all_tydata
- ++ map getLoc deriv_decls
+ ++ map getLoc deriv_decls
add_deriv_err loc = setSrcSpan loc $
- addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
- 2 (ptext (sLit "Use an instance declaration instead")))
+ addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
+ 2 (ptext (sLit "Use an instance declaration instead")))
------------------------------------------------------------------
deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
-- generated method definitions should succeed. This set will be simplified
-- before being used in the instance declaration
inferConstraints _ cls inst_tys rep_tc rep_tc_args
+ -- Generic constraints are easy
+ | cls `hasKey` genClassKey
+ = []
+ -- The others are a bit more complicated
+ | otherwise
= ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
stupid_constraints ++ extra_constraints
++ sc_constraints ++ con_arg_constraints
cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
| cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
cond_functorOK False)
+ | cls_key == genClassKey = Just (cond_RepresentableOk `andCond`
+ checkFlag Opt_DeriveGeneric)
| otherwise = Nothing
where
cls_key = getUnique cls
Nothing -> Nothing -- c1 succeeds
Just x -> case c2 tc of -- c1 fails
Nothing -> Nothing
- Just y -> Just (x $$ ptext (sLit " and") $$ y)
+ Just y -> Just (x $$ ptext (sLit " or") $$ y)
-- Both fail
andCond :: Condition -> Condition -> Condition
check_con con
| isVanillaDataCon con
, all isTauTy (dataConOrigArgTys con) = Nothing
- | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type")))
+ | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type")))
no_cons_why :: TyCon -> SDoc
no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
- ptext (sLit "has no data constructors")
+ ptext (sLit "must have at least one data constructor")
+
+cond_RepresentableOk :: Condition
+cond_RepresentableOk (_,t) = canDoGenerics t
cond_enumOrProduct :: Condition
cond_enumOrProduct = cond_isEnumeration `orCond`
where
bad_cons = [ con | con <- tyConDataCons tc
, any isUnLiftedType (dataConOrigArgTys con) ]
- why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type"))
+ why = badCon (head bad_cons) (ptext (sLit "must have only arguments of lifted type"))
cond_isEnumeration :: Condition
cond_isEnumeration (_, rep_tc)
| otherwise = Just why
where
why = sep [ quotes (pprSourceTyCon rep_tc) <+>
- ptext (sLit "is not an enumeration type")
+ ptext (sLit "must be an enumeration type")
, ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ]
-- See Note [Enumeration types] in TyCon
| otherwise = Just why
where
why = quotes (pprSourceTyCon rep_tc) <+>
- ptext (sLit "does not have precisely one constructor")
+ ptext (sLit "must have precisely one constructor")
cond_typeableOK :: Condition
-- OK for Typeable class
| otherwise = Nothing
where
too_many = quotes (pprSourceTyCon tc) <+>
- ptext (sLit "has too many arguments")
+ ptext (sLit "must have 7 or fewer arguments")
bad_kind = quotes (pprSourceTyCon tc) <+>
- ptext (sLit "has arguments of kind other than `*'")
+ ptext (sLit "must only have arguments of kind `*'")
functorLikeClassKeys :: [Unique]
functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
cond_functorOK allowFunctions (_, rep_tc)
| null tc_tvs
= Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
- <+> ptext (sLit "has no parameters"))
+ <+> ptext (sLit "must have some type parameters"))
| not (null bad_stupid_theta)
= Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
- <+> ptext (sLit "has a class context") <+> pprTheta bad_stupid_theta)
+ <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta)
| otherwise
= msum (map check_con data_cons) -- msum picks the first 'Just', if any
, ft_bad_app = Just (badCon con wrong_arg)
, ft_forall = \_ x -> x }
- existential = ptext (sLit "has existential arguments")
- covariant = ptext (sLit "uses the type variable in a function argument")
- functions = ptext (sLit "contains function types")
- wrong_arg = ptext (sLit "uses the type variable in an argument other than the last")
+ existential = ptext (sLit "must not have existential arguments")
+ covariant = ptext (sLit "must not use the type variable in a function argument")
+ functions = ptext (sLit "must not contain function types")
+ wrong_arg = ptext (sLit "must not use the type variable in an argument other than the last")
checkFlag :: ExtensionFlag -> Condition
checkFlag flag (dflags, _)
non_iso_class :: Class -> Bool
--- *Never* derive Read,Show,Typeable,Data by isomorphism,
+-- *Never* derive Read, Show, Typeable, Data, Generic by isomorphism,
-- even with -XGeneralizedNewtypeDeriving
non_iso_class cls
- = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++
- typeableClassKeys)
+ = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
+ , genClassKey] ++ typeableClassKeys)
typeableClassKeys :: [Unique]
typeableClassKeys = map getUnique typeableClassNames
Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
where
gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
- gen_list = [(eqClassKey, gen_Eq_binds)
- ,(ordClassKey, gen_Ord_binds)
- ,(enumClassKey, gen_Enum_binds)
- ,(boundedClassKey, gen_Bounded_binds)
- ,(ixClassKey, gen_Ix_binds)
- ,(showClassKey, gen_Show_binds fix_env)
- ,(readClassKey, gen_Read_binds fix_env)
- ,(dataClassKey, gen_Data_binds)
- ,(functorClassKey, gen_Functor_binds)
- ,(foldableClassKey, gen_Foldable_binds)
- ,(traversableClassKey, gen_Traversable_binds)
+ gen_list = [(eqClassKey, gen_Eq_binds)
+ ,(ordClassKey, gen_Ord_binds)
+ ,(enumClassKey, gen_Enum_binds)
+ ,(boundedClassKey, gen_Bounded_binds)
+ ,(ixClassKey, gen_Ix_binds)
+ ,(showClassKey, gen_Show_binds fix_env)
+ ,(readClassKey, gen_Read_binds fix_env)
+ ,(dataClassKey, gen_Data_binds)
+ ,(functorClassKey, gen_Functor_binds)
+ ,(foldableClassKey, gen_Foldable_binds)
+ ,(traversableClassKey, gen_Traversable_binds)
+ ,(genClassKey, genGenericBinds)
]
\end{code}
+%************************************************************************
+%* *
+\subsection[TcDeriv-generic-binds]{Bindings for the new generic deriving mechanism}
+%* *
+%************************************************************************
+
+For the generic representation we need to generate:
+\begin{itemize}
+\item A Generic instance
+\item A Rep type instance
+\item Many auxiliary datatypes and instances for them (for the meta-information)
+\end{itemize}
+
+@genGenericBinds@ does (1)
+@genGenericRepExtras@ does (2) and (3)
+@genGenericAll@ does all of them
+
+\begin{code}
+genGenericBinds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+genGenericBinds _ tc = (mkBindsRep tc, [ {- No DerivAuxBinds -} ])
+
+genGenericRepExtras :: TyCon -> TcM (MetaTyCons, TyCon)
+genGenericRepExtras tc =
+ do uniqS <- newUniqueSupply
+ 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..] ]
+
+ mkTyCon name = ASSERT( isExternalName name )
+ buildAlgTyCon name [] [] mkAbstractTyConRhs
+ NonRecursive 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
+
+ rep0_tycon <- tc_mkRepTyCon tc metaDts
+
+ -- pprTrace "rep0" (ppr rep0_tycon) $
+ return (metaDts, rep0_tycon)
+{-
+genGenericAll :: TyCon
+ -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon)
+genGenericAll tc =
+ do (metaDts, rep0_tycon) <- genGenericRepExtras tc
+ clas <- tcLookupClass genClassName
+ dfun_name <- new_dfun_name clas tc
+ let
+ mkInstRep = (InstInfo { iSpec = inst, iBinds = binds }
+ , [ {- No DerivAuxBinds -} ])
+ inst = mkLocalInstance dfun NoOverlap
+ binds = VanillaInst (mkBindsRep tc) [] False
+
+ tvs = tyConTyVars tc
+ tc_ty = mkTyConApp tc (mkTyVarTys tvs)
+
+ dfun = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty]
+ return (mkInstRep, metaDts, rep0_tycon)
+-}
+genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)]
+genDtMeta (tc,metaDts) =
+ do dClas <- tcLookupClass datatypeClassName
+ d_dfun_name <- new_dfun_name dClas tc
+ cClas <- tcLookupClass constructorClassName
+ c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
+ sClas <- tcLookupClass selectorClassName
+ s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc
+ | _ <- x ]
+ | x <- metaS metaDts ])
+ fix_env <- getFixityEnv
+
+ let
+ (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
+
+ -- Datatype
+ d_metaTycon = metaD metaDts
+ d_inst = mkLocalInstance d_dfun NoOverlap
+ d_binds = VanillaInst dBinds [] False
+ d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas
+ [ mkTyConTy d_metaTycon ]
+ d_mkInst = (InstInfo { iSpec = d_inst, iBinds = d_binds }, [])
+
+ -- Constructor
+ c_metaTycons = metaC metaDts
+ c_insts = [ mkLocalInstance (c_dfun c ds) NoOverlap
+ | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
+ c_binds = [ VanillaInst c [] False | c <- cBinds ]
+ c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas
+ [ mkTyConTy c ]
+ c_mkInst = [ (InstInfo { iSpec = is, iBinds = bs }, [])
+ | (is,bs) <- myZip1 c_insts c_binds ]
+
+ -- Selector
+ s_metaTycons = metaS metaDts
+ s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) NoOverlap))
+ (myZip2 s_metaTycons s_dfun_names)
+ s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
+ s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas
+ [ mkTyConTy s ]
+ s_mkInst = map (map (\(is,bs) -> (InstInfo {iSpec=is, iBinds=bs}, [])))
+ (myZip2 s_insts s_binds)
+
+ myZip1 :: [a] -> [b] -> [(a,b)]
+ myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2
+
+ myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
+ myZip2 l1 l2 =
+ ASSERT (and (zipWith (>=) (map length l1) (map length l2)))
+ [ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
+
+ return (d_mkInst : c_mkInst ++ concat s_mkInst)
+\end{code}
+
%************************************************************************
%* *
}
tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
--- Find the instance of a data famliy
+-- Find the instance of a data family
-- Note [Looking up family instances for deriving]
tcLookupDataFamInst tycon tys
| not (isFamilyTyCon tycon)
\begin{code}
tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
-- Just pop the new rules into the EPS and envt resp
- -- All the rules come from an interface file, not soruce
+ -- All the rules come from an interface file, not source
-- Nevertheless, some may be for this module, if we read
-- its interface instead of its source code
tcExtendRules lcl_rules thing_inside
\end{code}
Make a name for the representation tycon of a family instance. It's an
-*external* name, like otber top-level names, and hence must be made with
+*external* name, like other top-level names, and hence must be made with
newGlobalBinder.
\begin{code}
import HscTypes
import PrelInfo
import MkCore ( eRROR_ID )
-import PrelNames
+import PrelNames hiding (error_RDR)
import PrimOp
import SrcLoc
import TyCon
import Class
import Name
import NameSet
-import PrelNames
import TysWiredIn
import BasicTypes
import SrcLoc
ty' <- kcLiftedType ty
return (HsPArrTy ty', liftedTypeKind)
-kc_hs_type (HsNumTy n)
- = return (HsNumTy n, liftedTypeKind)
-
kc_hs_type (HsKindSig ty k) = do
ty' <- kc_check_lhs_type ty (EK k EkKindSig)
return (HsKindSig ty' k, k)
tau_ty2 <- dsHsType ty2
setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2])
-ds_type (HsNumTy n)
- = ASSERT(n==1) do
- tc <- tcLookupTyCon genUnitTyConName
- return (mkTyConApp tc [])
-
ds_type ty@(HsAppTy _ _)
= ds_app ty []
Instead, we simply rely on the fact that casts are cheap:
$df :: forall a. C a => C [a]
- {-# INLINE df #} -- NB: INLINE this
+ {-# INLINE df #-} -- NB: INLINE this
$df = /\a. \d. MkC [a] ($cop_list a d)
= $cop_list |> forall a. C a -> (sym (Co:C [a]))
; let { (local_info,
at_tycons_s) = unzip local_info_tycons
; at_idx_tycons = concat at_tycons_s ++ idx_tycons
- ; clas_decls = filter (isClassDecl . unLoc) tycl_decls
- ; implicit_things = concatMap implicitTyThings at_idx_tycons
- ; aux_binds = mkRecSelBinds at_idx_tycons
- }
+ ; implicit_things = concatMap implicitTyConThings at_idx_tycons
+ ; aux_binds = mkRecSelBinds at_idx_tycons }
-- (2) Add the tycons of indexed types and their implicit
-- tythings to the global environment
- ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
+ ; tcExtendGlobalEnv (map ATyCon at_idx_tycons ++ implicit_things) $ do {
- -- (3) Instances from generic class declarations
- ; generic_inst_info <- getGenericInstances clas_decls
-- Next, construct the instance environment so far, consisting
-- of
-- (a) local instance decls
- -- (b) generic instances
- -- (c) local family instance decls
+ -- (b) local family instance decls
; addInsts local_info $
- addInsts generic_inst_info $
addFamInsts at_idx_tycons $ do {
- -- (4) Compute instances from "deriving" clauses;
+ -- (3) Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance
-- decl, so it needs to know about all the instances possible
-- NB: class instance declarations can contain derivings as
-- part of associated data type declarations
- failIfErrsM -- If the addInsts stuff gave any errors, don't
- -- try the deriving stuff, becuase that may give
- -- more errors still
- ; (deriv_inst_info, deriv_binds, deriv_dus)
+ failIfErrsM -- If the addInsts stuff gave any errors, don't
+ -- try the deriving stuff, because that may give
+ -- more errors still
+ ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts)
<- tcDeriving tycl_decls inst_decls deriv_decls
- ; gbl_env <- addInsts deriv_inst_info getGblEnv
+
+ -- Extend the global environment also with the generated datatypes for
+ -- the generic representation
+ ; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts)
+ ; gbl_env <- tcExtendGlobalEnv all_tycons $
+ tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
+ addFamInsts deriv_ty_insts $
+ addInsts deriv_inst_info getGblEnv
; return ( addTcgDUs gbl_env deriv_dus,
- generic_inst_info ++ deriv_inst_info ++ local_info,
+ deriv_inst_info ++ local_info,
aux_binds `plusHsValBinds` deriv_binds)
}}}
addInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
-addFamInsts :: [TyThing] -> TcM a -> TcM a
+addFamInsts :: [TyCon] -> TcM a -> TcM a
addFamInsts tycons thing_inside
- = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
- where
- mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
- mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
- (ppr tything)
+ = tcExtendLocalFamInstEnv (map mkLocalFamInst tycons) thing_inside
\end{code}
\begin{code}
tcLocalInstDecl1 :: LInstDecl Name
- -> TcM (InstInfo Name, [TyThing])
+ -> TcM (InstInfo Name, [TyCon])
-- A source-file instance declaration
-- Type-check all the stuff before the "where"
--
checkValidAndMissingATs :: Class
-> ([TyVar], [TcType]) -- instance types
-> [(LTyClDecl Name, -- source form of AT
- TyThing)] -- Core form of AT
+ TyCon)] -- Core form of AT
-> TcM ()
checkValidAndMissingATs clas inst_tys ats
= do { -- Issue a warning for each class AT that is not defined in this
; mapM_ (checkIndexes clas inst_tys) ats
}
- checkIndexes clas inst_tys (hsAT, ATyCon tycon)
+ checkIndexes clas inst_tys (hsAT, tycon)
-- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
= checkIndexes' clas inst_tys hsAT
(tyConTyVars tycon,
snd . fromJust . tyConFamInst_maybe $ tycon)
- checkIndexes _ _ _ = panic "checkIndexes"
checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
= let atName = tcdName . unLoc $ hsAT
GADTs).
\begin{code}
-tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
+tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyCon
tcFamInstDecl top_lvl (L loc decl)
= -- Prime error recovery, set source location
setSrcSpan loc $
; when (isTopLevel top_lvl && isAssocFamily tc)
(addErr $ assocInClassErr (tcdName decl))
- ; return (ATyCon tc) }
+ ; return tc }
isAssocFamily :: TyCon -> Bool -- Is an assocaited type
isAssocFamily tycon
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
- False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
+ h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
-- We always assume that indexed types are recursive. Why?
-- (1) Due to their open nature, we can never be sure that a
-- further instance might not introduce a new recursive
----------------------
tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
+
+ tc_default sel_id (GenDefMeth dm_name)
+ = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
+ ; tc_body sel_id False {- Not generated code? -} meth_bind }
+{-
tc_default sel_id GenDefMeth -- Derivable type classes stuff
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
; tc_body sel_id False {- Not generated code? -} meth_bind }
-
+-}
tc_default sel_id NoDefMeth -- No default method at all
= do { warnMissingMethod sel_id
; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) }
-tc_pat _ pat@(TypePat _) _ _
- = failWithTc (badTypePat pat)
-
------------------------
-- Lists, tuples, arrays
tc_pat penv (ListPat pats _) pat_ty thing_inside
= hang (ptext (sLit "Illegal polymorphic type signature in pattern:"))
2 (ppr sig_ty)
-badTypePat :: Pat Name -> SDoc
-badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat
-
lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM ()
lazyUnliftedPatErr pat
= failWithTc $
-- interfaces, so that their rules and instance decls will be
-- found.
; loadOrphanModules (imp_orphs imports) False
- ; loadOrphanModules (imp_finsts imports) True
-- Check type-familily consistency
; traceRn (text "rn1: checking family instance consistency")
-- any mutually recursive types are done right
-- Just discard the auxiliary bindings; they are generated
-- only for Haskell source code, and should already be in Core
- (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ;
+ (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
setGblEnv tcg_env $ do {
-- Make the new type env available to stuff slurped from interface files
-- Typecheck type/class decls
; traceTc "Tc2" empty
- ; (tcg_env, aux_binds, dm_ids)
+ ; (tcg_env, aux_binds)
<- tcTyAndClassDecls emptyModDetails tycl_decls
- ; setGblEnv tcg_env $
- tcExtendIdEnv dm_ids $ do {
+ ; setGblEnv tcg_env $ do {
-- Typecheck instance decls
-- Family instance declarations are rejected here
-- The latter come in via tycl_decls
traceTc "Tc2" empty ;
- (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ;
+ (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ;
-- If there are any errors, tcTyAndClassDecls fails here
- setGblEnv tcg_env $
- tcExtendIdEnv dm_ids $ do {
+ setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
-- and import the supporting declarations
setLclTypeEnv tcl_env $ do { -- Environment doesn't change now
-- Second pass over class and instance declarations,
+ -- now using the kind-checked decls
traceTc "Tc6" empty ;
inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
-- Load any orphan-module and family instance-module
-- interfaces, so their instances are visible.
; loadOrphanModules (dep_orphs (mi_deps iface)) False
- ; loadOrphanModules (dep_finsts (mi_deps iface)) True
-- Check that the family instances of all directly loaded
-- modules are consistent.
, ppr_fam_insts fam_insts
, vcat (map ppr rules)
, vcat (map ppr vects)
- , ppr_gen_tycons (typeEnvTyCons type_env)
, ptext (sLit "Dependent modules:") <+>
ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
, ptext (sLit "Dependent packages:") <+>
where
le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
ppr_tycon tycon = ppr (tyThingToIfaceDecl (ATyCon tycon))
- where
ppr_rules :: [CoreRule] -> SDoc
ppr_rules [] = empty
ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
nest 2 (pprRules rs),
ptext (sLit "#-}")]
-
-ppr_gen_tycons :: [TyCon] -> SDoc
-ppr_gen_tycons [] = empty
-ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"),
- nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
\end{code}
import TcType
import TysWiredIn ( unitTy )
import Type
-import Generics
import Class
import TyCon
import DataCon
import Id
-import MkId ( mkDefaultMethodId )
import MkCore ( rEC_SEL_ERROR_ID )
import IdInfo
import Var
import VarSet
import Name
+import NameEnv
import Outputable
import Maybes
import Unify
%************************************************************************
\begin{code}
+
tcTyAndClassDecls :: ModDetails
-> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order
-> TcM (TcGblEnv, -- Input env extended by types and classes
-- and their implicit Ids,DataCons
- HsValBinds Name, -- Renamed bindings for record selectors
- [Id]) -- Default method ids
+ HsValBinds Name) -- Renamed bindings for record selectors
-- Fails if there are any errors
tcTyAndClassDecls boot_details decls_s
-- And now build the TyCons/Classes
; let rec_flags = calcRecFlags boot_details rec_tyclss
- ; concatMapM (tcTyClDecl rec_flags) kc_decls }
+ ; concatMapM (tcTyClDecl rec_flags) kc_decls }
; tcExtendGlobalEnv tyclss $ do
{ -- Perform the validity check
-- second time here. This doesn't matter as the definitions are
-- the same.
; let { implicit_things = concatMap implicitTyThings tyclss
- ; rec_sel_binds = mkRecSelBinds tyclss
+ ; rec_sel_binds = mkRecSelBinds [tc | ATyCon tc <- tyclss]
; dm_ids = mkDefaultMethodIds tyclss }
- ; env <- tcExtendGlobalEnv implicit_things getGblEnv
- ; return (env, rec_sel_binds, dm_ids) } }
+ ; env <- tcExtendGlobalEnv implicit_things $
+ tcExtendGlobalValEnv dm_ids $
+ getGblEnv
+ ; return (env, rec_sel_binds) } }
zipRecTyClss :: [[LTyClDecl Name]]
-> [TyThing] -- Knot-tied
where
kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
; return (TypeSig nm op_ty') }
+ kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
+ ; return (GenericSig nm op_ty') }
kc_sig other_sig = return other_sig
kcTyClDecl decl@(ForeignType {})
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildAlgTyCon tc_name final_tvs []
- DataFamilyTyCon Recursive False True
+ DataFamilyTyCon Recursive True
parent Nothing
; return [ATyCon tycon]
}
{ extra_tvs <- tcDataKindSig mb_ksig
; let final_tvs = tvs' ++ extra_tvs
; stupid_theta <- tcHsKindedContext ctxt
- ; want_generic <- xoptM Opt_Generics
; unbox_strict <- doptM Opt_UnboxStrictFields
; kind_signatures <- xoptM Opt_KindSignatures
; existential_ok <- xoptM Opt_ExistentialQuantification
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs tc_name tycon (head data_cons)
; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
- (want_generic && canDoGenerics data_cons) (not h98_syntax)
- NoParentTyCon Nothing
+ (not h98_syntax) NoParentTyCon Nothing
})
; return [ATyCon tycon]
}
tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
; fds' <- mapM (addLocM tc_fundep) fundeps
- ; sig_stuff <- tcClassSigs class_name sigs meths
+ ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
; clas <- fixM $ \ clas -> do
{ let -- This little knot is just so we can get
-- hold of the name of the class TyCon, which we
; buildClass False {- Must include unfoldings for selectors -}
class_name tvs' ctxt' fds' (concat atss')
sig_stuff tc_isrec }
- ; return (AClass clas : map ATyCon (classATs clas))
+
+ ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
+ | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas
+ , let gen_dm_tau = expectJust "tcTyClDecl1" $
+ lookupNameEnv gen_dm_env (idName sel_id)
+ , let gen_dm_ty = mkSigmaTy tvs'
+ [mkClassPred clas (mkTyVarTys tvs')]
+ gen_dm_tau
+ ]
+ class_ats = map ATyCon (classATs clas)
+
+ ; return (AClass clas : gen_dm_ids ++ class_ats )
-- NB: Order is important due to the call to `mkGlobalThings' when
-- tying the the type and class declaration type checking knot.
}
ATyCon tc -> checkValidTyCon tc
AClass cl -> do { checkValidClass cl
; mapM_ (addLocM checkValidTyCl) (tcdATs decl) }
+ AnId _ -> return () -- Generic default methods are checked
+ -- with their parent class
_ -> panic "checkValidTyCl"
; traceTc "Done validity of" (ppr thing)
}
where
(tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
unary = isSingleton tyvars
- no_generics = null [() | (_, GenDefMeth) <- op_stuff]
+ no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
check_op constrained_class_methods (sel_id, dm)
= addErrCtxt (classOpCtxt sel_id tau) $ do
; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
(noClassTyVarErr cls sel_id)
- -- Check that for a generic method, the type of
- -- the method is sufficiently simple
- ; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
- (badGenericMethodType op_name op_ty)
+ ; case dm of
+ GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name
+ ; checkValidType (FunSigCtxt op_name) (idType dm_id) }
+ _ -> return ()
}
where
op_name = idName sel_id
mkDefaultMethodIds :: [TyThing] -> [Id]
-- See Note [Default method Ids and Template Haskell]
mkDefaultMethodIds things
- = [ mkDefaultMethodId sel_id dm_name
+ = [ mkExportedLocalId dm_name (idType sel_id)
| AClass cls <- things
, (sel_id, DefMeth dm_name) <- classOpItems cls ]
\end{code}
when typechecking the [d| .. |] quote, and typecheck them later.
\begin{code}
-mkRecSelBinds :: [TyThing] -> HsValBinds Name
+mkRecSelBinds :: [TyCon] -> HsValBinds Name
-- NB We produce *un-typechecked* bindings, rather like 'deriving'
-- This makes life easier, because the later type checking will add
-- all necessary type abstractions and applications
-mkRecSelBinds ty_things
+mkRecSelBinds tycons
= ValBindsOut [(NonRecursive, b) | b <- binds] sigs
where
(sigs, binds) = unzip rec_sels
rec_sels = map mkRecSelBind [ (tc,fld)
- | ATyCon tc <- ty_things
+ | tc <- tycons
, fld <- tyConFields tc ]
mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
= ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+>
ptext (sLit "cannot have generic methods")
-badGenericMethodType :: Name -> Kind -> SDoc
-badGenericMethodType op op_ty
- = hang (ptext (sLit "Generic method type is too complex"))
- 2 (vcat [ppr op <+> dcolon <+> ppr op_ty,
- ptext (sLit "You can only use type variables, arrows, lists, and tuples")])
-
recSynErr :: [LTyClDecl Name] -> TcRn ()
recSynErr syn_decls
= setSrcSpan (getLoc (head sorted_decls)) $
import Digraph
import BasicTypes
import SrcLoc
-import Outputable
+import Maybes( mapCatMaybes )
import Util ( isSingleton )
import Data.List
\end{code}
nt_loop_breakers `unionNameSets`
prod_loop_breakers
- all_tycons = [ tc | tycls <- tyclss,
+ all_tycons = [ tc | tc <- mapCatMaybes getTyCon tyclss
-- Recursion of newtypes/data types can happen via
-- the class TyCon, so tyclss includes the class tycons
- let tc = getTyCon tycls,
- not (tyConName tc `elemNameSet` boot_name_set) ]
+ , not (tyConName tc `elemNameSet` boot_name_set) ]
-- Remove the boot_name_set because they are going
-- to be loop breakers regardless.
new_tc_rhs :: TyCon -> Type
new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables
-getTyCon :: TyThing -> TyCon
-getTyCon (ATyCon tc) = tc
-getTyCon (AClass cl) = classTyCon cl
-getTyCon _ = panic "getTyCon"
+getTyCon :: TyThing -> Maybe TyCon
+getTyCon (ATyCon tc) = Just tc
+getTyCon (AClass cl) = Just (classTyCon cl)
+getTyCon _ = Nothing
findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
-- Finds a set of tycons that cut all loops
data DefMeth = NoDefMeth -- No default method
| DefMeth Name -- A polymorphic default method
- | GenDefMeth -- A generic default method
+ | GenDefMeth Name -- A generic default method
deriving Eq
-- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
= case meth of
NoDefMeth -> NoDM
DefMeth _ -> VanillaDM
- GenDefMeth -> GenericDM
+ GenDefMeth _ -> GenericDM
\end{code}
showsPrec p c = showsPrecSDoc p (ppr c)
instance Outputable DefMeth where
- ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n
- ppr GenDefMeth = ptext (sLit "Generic default method")
- ppr NoDefMeth = empty -- No default method
+ ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n
+ ppr (GenDefMeth n) = ptext (sLit "Generic default method") <+> ppr n
+ ppr NoDefMeth = empty -- No default method
pprFundeps :: Outputable a => [FunDep a] -> SDoc
pprFundeps [] = empty
pprFamInst :: FamInst -> SDoc
pprFamInst famInst
= hang (pprFamInstHdr famInst)
- 2 (ptext (sLit "--") <+> pprNameLoc (getName famInst))
+ 2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> pp_ax)
+ , ptext (sLit "--") <+> pprNameLoc (getName famInst)])
+ where
+ pp_ax = case tyConFamilyCoercion_maybe (fi_tycon famInst) of
+ Just ax -> ppr ax
+ Nothing -> ptext (sLit "<not there!>")
pprFamInstHdr :: FamInst -> SDoc
pprFamInstHdr (FamInst {fi_tycon = rep_tc})
%
-% (c) The University of Glasgow 2006
+% (c) The University of Glasgow 2011
%
\begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
-module Generics ( canDoGenerics, mkTyConGenericBinds,
- mkGenericRhs,
- validGenericInstanceType, validGenericMethodType
+
+module Generics ( canDoGenerics,
+ mkBindsRep, tc_mkRepTyCon, mkBindsMetaD,
+ MetaTyCons(..), metaTyCons2TyCons
) where
import DataCon
import TyCon
-import Name
+import Name hiding (varName)
+import Module (moduleName, moduleNameString)
import RdrName
import BasicTypes
-import Var
-import VarSet
-import Id
import TysWiredIn
import PrelNames
-
+
+-- For generation of representation types
+import TcEnv (tcLookupTyCon)
+import TcRnMonad
+import HscTypes
+import BuildTyCl
+
import SrcLoc
-import Util
import Bag
import Outputable
import FastString
#include "HsVersions.h"
\end{code}
-Roadmap of what's where in the Generics work.
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Parser
-No real checks.
-
-RnSource.rnHsType
- Checks that HsNumTy has a "1" in it.
-
-TcInstDcls.mkGenericInstance:
- Checks for invalid type patterns, such as f {| Int |}
-
-TcClassDcl.tcClassSig
- Checks for a method type that is too complicated;
- e.g. has for-alls or lists in it
- We could lift this restriction
-
-TcClassDecl.mkDefMethRhs
- Checks that the instance type is simple, in an instance decl
- where we let the compiler fill in a generic method.
- e.g. instance C (T Int)
- is not valid if C has generic methods.
-
-TcClassDecl.checkGenericClassIsUnary
- Checks that we don't have generic methods in a multi-parameter class
-
-TcClassDecl.checkDefaultBinds
- Checks that all the equations for a method in a class decl
- are generic, or all are non-generic
-
-
-
-Checking that the type constructors which are present in Generic
-patterns (not Unit, this is done differently) is done in mk_inst_info
-(TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
-HsOpTy is tied to Generic definitions which is not a very good design
-feature, indeed a bug. However, the check is easy to move from
-tcHsType back to mk_inst_info and everything will be fine. Also see
-bug #5. [I don't think that this is the case anymore after SPJ's latest
-changes in that regard. Delete this comment? -=chak/7Jun2]
-
-Generics.lhs
-
-Making generic information to put into a tycon. Constructs the
-representation type, which, I think, are not used later. Perhaps it is
-worth removing them from the GI datatype. Although it does get used in
-the construction of conversion functions (internally).
-
-TyCon.lhs
-
-Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
-
-TysWiredIn.lhs
-
-Defines generic and other type and data constructors.
-
-This is sadly incomplete, but will be added to.
-
-
-Bugs & shortcomings of existing implementation:
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-2. Another pretty big bug I dscovered at the last minute when I was
-testing the code is that at the moment the type variable of the class
-is scoped over the entire declaration, including the patterns. For
-instance, if I have the following code,
-
-class Er a where
- ...
- er {| Plus a b |} (Inl x) (Inl y) = er x y
- er {| Plus a b |} (Inr x) (Inr y) = er x y
- er {| Plus a b |} _ _ = False
-
-and I print out the types of the generic patterns, I get the
-following. Note that all the variable names for "a" are the same,
-while for "b" they are all different.
-
-check_ty
- [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
- std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
- std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
-
-This is a bug as if I change the code to
-
- er {| Plus c b |} (Inl x) (Inl y) = er x y
-
-all the names come out to be different.
-
-Thus, all the types (Plus a b) come out to be different, so I cannot
-compare them and test whether they are all the same and thus cannot
-return an error if the type variables are different.
-
-Temporary fix/hack. I am not checking for this, I just assume they are
-the same, see line "check_ty = True" in TcInstDecls. When we resolve
-the issue with variables, though - I assume that we will make them to
-be the same in all the type patterns, jus uncomment the check and
-everything should work smoothly.
-
-Hence, I have also left the rather silly construction of:
-* extracting all the type variables from all the types
-* putting them *all* into the environment
-* typechecking all the types
-* selecting one of them and using it as the instance_ty.
-
-(the alternative is to make sure that all the types are the same,
-taking one, extracting its variables, putting them into the environment,
-type checking it, using it as the instance_ty)
-
-6. What happens if we do not supply all of the generic patterns? At
-the moment, the compiler crashes with an error message "Non-exhaustive
-patterns in a generic declaration"
-
-
-What has not been addressed:
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Contexts. In the generated instance declarations for the 3 primitive
-type constructors, we need contexts. It is unclear what those should
-be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
-
-Type application. We have type application in expressions
-(essentially) on the lhs of an equation. Do we want to allow it on the
-RHS?
-
-Scoping of type variables in a generic definition. At the moment, (see
-TcInstDecls) we extract the type variables inside the type patterns
-and add them to the environment. See my bug #2 above. This seems pretty
-important.
-
-
-
-%************************************************************************
-%* *
-\subsection{Getting the representation type out}
-%* *
-%************************************************************************
-
-\begin{code}
-validGenericInstanceType :: Type -> Bool
- -- Checks for validity of the type pattern in a generic
- -- declaration. It's ok to have
- -- f {| a + b |} ...
- -- but it's not OK to have
- -- f {| a + Int |}
-
-validGenericInstanceType inst_ty
- = case tcSplitTyConApp_maybe inst_ty of
- Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
- Nothing -> False
-
-validGenericMethodType :: Type -> Bool
- -- At the moment we only allow method types built from
- -- * type variables
- -- * function arrow
- -- * boxed tuples
- -- * lists
- -- * an arbitrary type not involving the class type variables
- -- e.g. this is ok: forall b. Ord b => [b] -> a
- -- where a is the class variable
-validGenericMethodType ty
- = valid tau
- where
- (local_tvs, _, tau) = tcSplitSigmaTy ty
-
- valid ty
- | not (isTauTy ty) = False -- Note [Higher ramk methods]
- | isTyVarTy ty = True
- | no_tyvars_in_ty = True
- | otherwise = case tcSplitTyConApp_maybe ty of
- Just (tc,tys) -> valid_tycon tc && all valid tys
- Nothing -> False
- where
- no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
-
- valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc
- -- Compare bimapApp, below
-\end{code}
-
-
%************************************************************************
%* *
\subsection{Generating representation types}
%************************************************************************
\begin{code}
-canDoGenerics :: [DataCon] -> Bool
+canDoGenerics :: TyCon -> Maybe SDoc
-- Called on source-code data types, to see if we should generate
--- generic functions for them. (This info is recorded in the interface file for
--- imported data types.)
-
-canDoGenerics data_cons
- = not (any bad_con data_cons) -- See comment below
- && not (null data_cons) -- No values of the type
+-- generic functions for them.
+-- Nothing == yes
+-- Just s == no, because of `s`
+
+canDoGenerics tycon
+ = mergeErrors (
+ -- We do not support datatypes with context
+ (if (not (null (tyConStupidTheta tycon)))
+ then (Just (ppr tycon <+> text "must not have a datatype context"))
+ else Nothing)
+ -- We don't like type families
+ : (if (isFamilyTyCon tycon)
+ then (Just (ppr tycon <+> text "must not be a family instance"))
+ else Nothing)
+ -- See comment below
+ : (map bad_con (tyConDataCons tycon)))
where
- bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
- -- If any of the constructor has an unboxed type as argument,
- -- then we can't build the embedding-projection pair, because
- -- it relies on instantiating *polymorphic* sum and product types
- -- at the argument types of the constructors
+ -- If any of the constructor has an unboxed type as argument,
+ -- then we can't build the embedding-projection pair, because
+ -- it relies on instantiating *polymorphic* sum and product types
+ -- at the argument types of the constructors
+ bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
+ then (Just (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
+ else (if (not (isVanillaDataCon dc))
+ then (Just (ppr dc <+> text "must be a vanilla data constructor"))
+ else Nothing)
+
-- Nor can we do the job if it's an existential data constructor,
-- Nor if the args are polymorphic types (I don't think)
bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
+
+ mergeErrors :: [Maybe SDoc] -> Maybe SDoc
+ mergeErrors [] = Nothing
+ mergeErrors ((Just s):t) = case mergeErrors t of
+ Nothing -> Just s
+ Just s' -> Just (s <> text ", and" $$ s')
+ mergeErrors (Nothing :t) = mergeErrors t
\end{code}
%************************************************************************
\begin{code}
type US = Int -- Local unique supply, just a plain Int
-type FromAlt = (LPat RdrName, LHsExpr RdrName)
+type Alt = (LPat RdrName, LHsExpr RdrName)
-mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
-mkTyConGenericBinds tycon
- = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
- `unionBags`
+-- Bindings for the Generic instance
+mkBindsRep :: TyCon -> LHsBinds RdrName
+mkBindsRep tycon =
+ unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
+ `unionBags`
unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
+ where
+ from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
+ to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ]
+ loc = srcLocSpan (getSrcLoc tycon)
+ datacons = tyConDataCons tycon
+
+ -- Recurse over the sum first
+ from_alts, to_alts :: [Alt]
+ (from_alts, to_alts) = mkSum (1 :: US) tycon datacons
+
+--------------------------------------------------------------------------------
+-- The type instance synonym and synonym
+-- type instance Rep (D a b) = Rep_D a b
+-- type Rep_D a b = ...representation type for D ...
+--------------------------------------------------------------------------------
+
+tc_mkRepTyCon :: TyCon -- The type to generate representation for
+ -> MetaTyCons -- Metadata datatypes to refer to
+ -> TcM TyCon -- Generated representation0 type
+tc_mkRepTyCon tycon metaDts =
+-- Consider the example input tycon `D`, where data D a b = D_ a
+ do { -- `rep0` = GHC.Generics.Rep (type family)
+ rep0 <- tcLookupTyCon repTyConName
+
+ -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
+ ; rep0Ty <- tc_mkRepTy tycon metaDts
+
+ -- `rep_name` is a name we generate for the synonym
+ ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR
+ ; let -- `tyvars` = [a,b]
+ tyvars = tyConTyVars tycon
+
+ -- rep0Ty has kind * -> *
+ rep_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
+
+ -- `appT` = D a b
+ appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
+
+ ; buildSynTyCon rep_name tyvars (SynonymTyCon rep0Ty) rep_kind
+ NoParentTyCon (Just (rep0, appT)) }
+
+--------------------------------------------------------------------------------
+-- Type representation
+--------------------------------------------------------------------------------
+
+tc_mkRepTy :: -- The type to generate representation for
+ TyCon
+ -- Metadata datatypes to refer to
+ -> MetaTyCons
+ -- Generated representation0 type
+ -> TcM Type
+tc_mkRepTy tycon metaDts =
+ do
+ d1 <- tcLookupTyCon d1TyConName
+ c1 <- tcLookupTyCon c1TyConName
+ s1 <- tcLookupTyCon s1TyConName
+ nS1 <- tcLookupTyCon noSelTyConName
+ rec0 <- tcLookupTyCon rec0TyConName
+ par0 <- tcLookupTyCon par0TyConName
+ u1 <- tcLookupTyCon u1TyConName
+ v1 <- tcLookupTyCon v1TyConName
+ plus <- tcLookupTyCon sumTyConName
+ times <- tcLookupTyCon prodTyConName
+
+ let mkSum' a b = mkTyConApp plus [a,b]
+ mkProd a b = mkTyConApp times [a,b]
+ mkRec0 a = mkTyConApp rec0 [a]
+ mkPar0 a = mkTyConApp par0 [a]
+ mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)]
+ mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a)
+ (null (dataConFieldLabels a))]
+ -- This field has no label
+ mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a]
+ -- This field has a label
+ mkS False d a = mkTyConApp s1 [d, a]
+
+ sumP [] = mkTyConTy v1
+ sumP l = ASSERT (length metaCTyCons == length l)
+ foldBal mkSum' [ mkC i d a
+ | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
+ -- The Bool is True if this constructor has labelled fields
+ prod :: Int -> [Type] -> Bool -> Type
+ prod i [] _ = ASSERT (length metaSTyCons > i)
+ ASSERT (length (metaSTyCons !! i) == 0)
+ mkTyConTy u1
+ prod i l b = ASSERT (length metaSTyCons > i)
+ ASSERT (length l == length (metaSTyCons !! i))
+ foldBal mkProd [ arg d t b
+ | (d,t) <- zip (metaSTyCons !! i) l ]
+
+ arg :: Type -> Type -> Bool -> Type
+ arg d t b = mkS b d (recOrPar t (getTyVar_maybe t))
+ -- Argument is not a type variable, use Rec0
+ recOrPar t Nothing = mkRec0 t
+ -- Argument is a type variable, use Par0
+ recOrPar t (Just _) = mkPar0 t
+
+ metaDTyCon = mkTyConTy (metaD metaDts)
+ metaCTyCons = map mkTyConTy (metaC metaDts)
+ metaSTyCons = map (map mkTyConTy) (metaS metaDts)
+
+ return (mkD tycon)
+
+--------------------------------------------------------------------------------
+-- Meta-information
+--------------------------------------------------------------------------------
+
+data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
+ metaD :: TyCon
+ -- One meta datatype per constructor
+ , metaC :: [TyCon]
+ -- One meta datatype per selector per constructor
+ , metaS :: [[TyCon]] }
+
+instance Outputable MetaTyCons where
+ ppr (MetaTyCons d c s) = ppr d <+> ppr c <+> ppr s
+
+metaTyCons2TyCons :: MetaTyCons -> [TyCon]
+metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
+
+
+-- Bindings for Datatype, Constructor, and Selector instances
+mkBindsMetaD :: FixityEnv -> TyCon
+ -> ( LHsBinds RdrName -- Datatype instance
+ , [LHsBinds RdrName] -- Constructor instances
+ , [[LHsBinds RdrName]]) -- Selector instances
+mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
+ where
+ mkBag l = foldr1 unionBags
+ [ unitBag (L loc (mkFunBind (L loc name) matches))
+ | (name, matches) <- l ]
+ dtBinds = mkBag [ (datatypeName_RDR, dtName_matches)
+ , (moduleName_RDR, moduleName_matches)]
+
+ allConBinds = map conBinds datacons
+ conBinds c = mkBag ( [ (conName_RDR, conName_matches c)]
+ ++ ifElseEmpty (dataConIsInfix c)
+ [ (conFixity_RDR, conFixity_matches c) ]
+ ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
+ [ (conIsRecord_RDR, conIsRecord_matches c) ]
+ )
+
+ ifElseEmpty p x = if p then x else []
+ fixity c = case lookupFixity fix_env (dataConName c) of
+ Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
+ Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
+ Fixity n InfixN -> buildFix n notAssocDataCon_RDR
+ buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
+ , nlHsIntLit (toInteger n)]
+
+ allSelBinds = map (map selBinds) datasels
+ selBinds s = mkBag [(selName_RDR, selName_matches s)]
+
+ loc = srcLocSpan (getSrcLoc tycon)
+ mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
+ datacons = tyConDataCons tycon
+ datasels = map dataConFieldLabels datacons
+
+ dtName_matches = mkStringLHS . showPpr . nameOccName . tyConName
+ $ tycon
+ moduleName_matches = mkStringLHS . moduleNameString . moduleName
+ . nameModule . tyConName $ tycon
+
+ conName_matches c = mkStringLHS . showPpr . nameOccName
+ . dataConName $ c
+ conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)]
+ conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
+
+ selName_matches s = mkStringLHS (showPpr (nameOccName s))
+
+
+--------------------------------------------------------------------------------
+-- Dealing with sums
+--------------------------------------------------------------------------------
+
+mkSum :: US -- Base for generating unique names
+ -> TyCon -- The type constructor
+ -> [DataCon] -- The data constructors
+ -> ([Alt], -- Alternatives for the T->Trep "from" function
+ [Alt]) -- Alternatives for the Trep->T "to" function
+
+-- Datatype without any constructors
+mkSum _us tycon [] = ([from_alt], [to_alt])
+ where
+ from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
+ to_alt = (mkM1_P nlWildPat, makeError errMsgTo)
+ -- These M1s are meta-information for the datatype
+ makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
+ errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon
+ errMsgTo = "No values for empty datatype " ++ showPpr tycon
+
+-- Datatype with at least one constructor
+mkSum us _tycon datacons =
+ unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
+
+-- Build the sum for a particular constructor
+mk1Sum :: US -- Base for generating unique names
+ -> Int -- The index of this constructor
+ -> Int -- Total number of constructors
+ -> DataCon -- The data constructor
+ -> (Alt, -- Alternative for the T->Trep "from" function
+ Alt) -- Alternative for the Trep->T "to" function
+mk1Sum us i n datacon = (from_alt, to_alt)
where
- from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
- to_matches = [mkSimpleHsAlt to_pat to_body]
- loc = srcLocSpan (getSrcLoc tycon)
- datacons = tyConDataCons tycon
- (from_RDR, to_RDR) = mkGenericNames tycon
-
- -- Recurse over the sum first
- from_alts :: [FromAlt]
- (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
- init_us = 1::Int -- Unique supply
-
-----------------------------------------------------
--- Dealing with sums
-----------------------------------------------------
-
-mk_sum_stuff :: US -- Base for generating unique names
- -> [DataCon] -- The data constructors
- -> ([FromAlt], -- Alternatives for the T->Trep "from" function
- InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function
-
--- For example, given
--- data T = C | D Int Int Int
---
--- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
--- case cd of { Inl u -> C;
--- Inr abc -> case abc of { a :*: bc ->
--- case bc of { b :*: c ->
--- D a b c }} },
--- cd)
-
-mk_sum_stuff us [datacon]
- = ([from_alt], to_pat, to_body_fn app_exp)
- where
- n_args = dataConSourceArity datacon -- Existentials already excluded
-
- datacon_vars = map mkGenericLocal [us .. us+n_args-1]
- us' = us + n_args
-
- datacon_rdr = getRdrName datacon
- app_exp = nlHsVarApps datacon_rdr datacon_vars
- from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
-
- (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars
-
-mk_sum_stuff us datacons
- = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
- nlVarPat to_arg,
- noLoc (HsCase (nlHsVar to_arg)
- (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
- mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
+ n_args = dataConSourceArity datacon -- Existentials already excluded
+
+ datacon_vars = map mkGenericLocal [us .. us+n_args-1]
+ us' = us + n_args
+
+ datacon_rdr = getRdrName datacon
+ app_exp = nlHsVarApps datacon_rdr datacon_vars
+
+ from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
+ from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars))
+
+ to_alt = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs)
+ -- These M1s are meta-information for the datatype
+ to_alt_rhs = app_exp
+
+-- Generates the L1/R1 sum pattern
+genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
+genLR_P i n p
+ | n == 0 = error "impossible"
+ | n == 1 = p
+ | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p]
+ | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p]
+ where m = div n 2
+
+-- Generates the L1/R1 sum expression
+genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
+genLR_E i n e
+ | n == 0 = error "impossible"
+ | n == 1 = e
+ | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i (div n 2) e
+ | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m) e
+ where m = div n 2
+
+--------------------------------------------------------------------------------
+-- Dealing with products
+--------------------------------------------------------------------------------
+
+-- Build a product expression
+mkProd_E :: US -- Base for unique names
+ -> [RdrName] -- List of variables matched on the lhs
+ -> LHsExpr RdrName -- Resulting product expression
+mkProd_E _ [] = mkM1_E (nlHsVar u1DataCon_RDR)
+mkProd_E _ vars = mkM1_E (foldBal prod appVars)
+ -- These M1s are meta-information for the constructor
where
- (l_datacons, r_datacons) = splitInHalf datacons
- (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons
- (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons
-
- to_arg = mkGenericLocal us
- us' = us+1
-
- wrap :: RdrName -> [FromAlt] -> [FromAlt]
- -- Wrap an application of the Inl or Inr constructor round each alternative
- wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]
-
-
-----------------------------------------------------
--- Dealing with products
-----------------------------------------------------
-mk_prod_stuff :: US -- Base for unique names
- -> [RdrName] -- arg-ids; args of the original user-defined constructor
- -- They are bound enclosing from_rhs
- -- Please bind these in the to_body_fn
- -> (US, -- Depleted unique-name supply
- LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids
- InPat RdrName, -- to_pat:
- LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation
-
--- For example:
--- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
--- abc,
--- \<body-code> -> case abc of { a :*: bc ->
--- case bc of { b :*: c ->
--- <body-code> )
-
--- We need to use different uniques in the branches
--- because the returned to_body_fns are nested.
--- Hence the returned unqique-name supply
-
-mk_prod_stuff us [] -- Unit case
- = (us+1,
- nlHsVar genUnitDataCon_RDR,
- noLoc (SigPatIn (nlVarPat (mkGenericLocal us))
- (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
- -- Give a signature to the pattern so we get
- -- data S a = Nil | S a
- -- toS = \x -> case x of { Inl (g :: Unit) -> Nil
- -- Inr x -> S x }
- -- The (:: Unit) signature ensures that we'll infer the right
- -- type for toS. If we leave it out, the type is too polymorphic
-
- \x -> x)
-
-mk_prod_stuff us [arg_var] -- Singleton case
- = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
-
-mk_prod_stuff us arg_vars -- Two or more
- = (us'',
- nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
- nlVarPat to_arg,
--- gaw 2004 FIX?
- \x -> noLoc (HsCase (nlHsVar to_arg)
- (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
+ appVars = map wrapArg_E vars
+ prod a b = prodDataCon_RDR `nlHsApps` [a,b]
+
+wrapArg_E :: RdrName -> LHsExpr RdrName
+wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v])
+ -- This M1 is meta-information for the selector
+
+-- Build a product pattern
+mkProd_P :: US -- Base for unique names
+ -> [RdrName] -- List of variables to match
+ -> LPat RdrName -- Resulting product pattern
+mkProd_P _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
+mkProd_P _ vars = mkM1_P (foldBal prod appVars)
+ -- These M1s are meta-information for the constructor
where
- to_arg = mkGenericLocal us
- (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
- (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars
- (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
- pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]
-
-splitInHalf :: [a] -> ([a],[a])
-splitInHalf list = (left, right)
- where
- half = length list `div` 2
- left = take half list
- right = drop half list
+ appVars = map wrapArg_P vars
+ prod a b = prodDataCon_RDR `nlConPat` [a,b]
+
+wrapArg_P :: RdrName -> LPat RdrName
+wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
+ -- This M1 is meta-information for the selector
mkGenericLocal :: US -> RdrName
mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
-mkGenericNames :: TyCon -> (RdrName, RdrName)
-mkGenericNames tycon
- = (from_RDR, to_RDR)
- where
- tc_name = tyConName tycon
- tc_occ = nameOccName tc_name
- tc_mod = ASSERT( isExternalName tc_name ) nameModule tc_name
- from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
- to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Generating the RHS of a generic default method}
-%* *
-%************************************************************************
-
-Generating the Generic default method. Uses the bimaps to generate the
-actual method. All of this is rather incomplete, but it would be nice
-to make even this work. Example
-
- class Foo a where
- op :: Op a
-
- instance Foo T
-
-Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
-
- instance Foo T where
- op = <mkGenericRhs op a T>
-
-To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
-
- toOp :: Op Trep -> Op T
- fromOp :: Op T -> Op Trep
-
-(the bimap) and then fill in the RHS with
-
- instance Foo T where
- op = toOp op
-
-Remember, we're generating a RenamedHsExpr, so the result of all this
-will be fed to the type checker. So the 'op' on the RHS will be
-at the representation type for T, Trep.
+mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
+mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
+mkM1_P :: LPat RdrName -> LPat RdrName
+mkM1_P p = m1DataCon_RDR `nlConPat` [p]
-Note [Polymorphic methods]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose the class op is polymorphic:
+-- | Variant of foldr1 for producing balanced lists
+foldBal :: (a -> a -> a) -> [a] -> a
+foldBal op = foldBal' op (error "foldBal: empty list")
- class Baz a where
- op :: forall b. Ord b => a -> b -> b
+foldBal' :: (a -> a -> a) -> a -> [a] -> a
+foldBal' _ x [] = x
+foldBal' _ _ [y] = y
+foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
+ in foldBal' op x a `op` foldBal' op x b
-Then we can still generate a bimap with
-
- toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
-
-and fill in the instance decl thus
-
- instance Foo T where
- op = toOp op
-
-By the time the type checker has done its stuff we'll get
-
- instance Foo T where
- op = \b. \dict::Ord b. toOp b (op Trep b dict)
-
-Note [Higher rank methods]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Higher-rank method types don't work, because we'd generate a bimap that
-needs impredicative polymorphism. In principle that should be possible
-(with boxy types and all) but it would take a bit of working out. Here's
-an example:
- class ChurchEncode k where
- match :: k -> z
- -> (forall a b z. a -> b -> z) {- product -}
- -> (forall a z. a -> z) {- left -}
- -> (forall a z. a -> z) {- right -}
- -> z
-
- match {| Unit |} Unit unit prod left right = unit
- match {| a :*: b |} (x :*: y) unit prod left right = prod x y
- match {| a :+: b |} (Inl l) unit prod left right = left l
- match {| a :+: b |} (Inr r) unit prod left right = right r
-
-\begin{code}
-mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
-mkGenericRhs sel_id tyvar tycon
- = ASSERT( isSingleton ctxt ) -- Checks shape of selector-id context
--- pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
- mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
- where
- -- Initialising the "Environment" with the from/to functions
- -- on the datatype (actually tycon) in question
- (from_RDR, to_RDR) = mkGenericNames tycon
-
- -- Instantiate the selector type, and strip off its class context
- (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
-
- -- Do it again! This deals with the case where the method type
- -- is polymorphic -- see Note [Polymorphic methods] above
- (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
-
- -- Now we probably have a tycon in front
- -- of us, quite probably a FunTyCon.
- ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
- bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
-
-type EPEnv = (TyVar, -- The class type variable
- EP (LHsExpr RdrName), -- The EP it maps to
- [TyVar] -- Other in-scope tyvars; they have an identity EP
- )
-
--------------------
-generate_bimap :: EPEnv
- -> Type
- -> EP (LHsExpr RdrName)
--- Top level case - splitting the TyCon.
-generate_bimap env@(tv,ep,local_tvs) ty
- | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
- = idEP -- A constant type
-
- | Just tv1 <- getTyVar_maybe ty
- = ASSERT( tv == tv1 ) ep -- The class tyvar
-
- | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
- = bimapTyCon tycon (map (generate_bimap env) ty_args)
-
- | otherwise
- = pprPanic "generate_bimap" (ppr ty)
-
--------------------
-bimapTyCon :: TyCon -> [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapTyCon tycon arg_eps
- | tycon == funTyCon = bimapArrow arg_eps
- | tycon == listTyCon = bimapList arg_eps
- | isBoxedTupleTyCon tycon = bimapTuple arg_eps
- | otherwise = pprPanic "bimapTyCon" (ppr tycon)
-
--------------------
--- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
-bimapArrow :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapArrow [ep1, ep2]
- = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body,
- toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
- where
- from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR))
- to_body = toEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
-
--------------------
--- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
-bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapTuple eps
- = EP { fromEP = mkHsLam [noLoc tuple_pat] from_body,
- toEP = mkHsLam [noLoc tuple_pat] to_body }
- where
- names = takeList eps gs_RDR
- tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType
- eps_w_names = eps `zip` names
- to_body = mkLHsTupleExpr [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
- from_body = mkLHsTupleExpr [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
-
--------------------
--- bimapList :: EP a b -> EP [a] [b]
-bimapList :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapList [ep]
- = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
- toEP = nlHsApp (nlHsVar map_RDR) (toEP ep) }
-
--------------------
-a_RDR, b_RDR :: RdrName
-a_RDR = mkVarUnqual (fsLit "a")
-b_RDR = mkVarUnqual (fsLit "b")
-
-gs_RDR :: [RdrName]
-gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
-
-idEP :: EP (LHsExpr RdrName)
-idEP = EP idexpr idexpr
- where
- idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)
\end{code}
isTyConAssoc,
isRecursiveTyCon,
isHiBootTyCon,
- isImplicitTyCon, tyConHasGenerics,
+ isImplicitTyCon,
-- ** Extracting information out of TyCons
tyConName,
tyConExtName, -- External name for foreign types
algTyConRhs,
newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe,
- tupleTyConBoxity,
+ tupleTyConBoxity, tupleTyConArity,
-- ** Manipulating TyCons
tcExpandTyCon_maybe, coreExpandTyCon_maybe,
algTcRec :: RecFlag, -- ^ Tells us whether the data type is part
-- of a mutually-recursive group or not
-
- hasGenerics :: Bool, -- ^ Whether generic (in the -XGenerics sense)
- -- to\/from functions are available in the exports
- -- of the data type's source module.
-
+
algTcParent :: TyConParent -- ^ Gives the class or family declaration 'TyCon'
-- for derived 'TyCon's representing class
-- or family instances, respectively.
tyConArity :: Arity,
tyConBoxed :: Boxity,
tyConTyVars :: [TyVar],
- dataCon :: DataCon, -- ^ Corresponding tuple data constructor
- hasGenerics :: Bool
+ dataCon :: DataCon -- ^ Corresponding tuple data constructor
}
-- | Represents type synonyms
-> AlgTyConRhs -- ^ Information about dat aconstructors
-> TyConParent
-> RecFlag -- ^ Is the 'TyCon' recursive?
- -> Bool -- ^ Does it have generic functions? See 'hasGenerics'
-> Bool -- ^ Was the 'TyCon' declared with GADT syntax?
-> TyCon
-mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn
+mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
algTcRhs = rhs,
algTcParent = ASSERT( okParent name parent ) parent,
algTcRec = is_rec,
- algTcGadtSyntax = gadt_syn,
- hasGenerics = gen_info
+ algTcGadtSyntax = gadt_syn
}
-- | Simpler specialization of 'mkAlgTyCon' for classes
mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon
mkClassTyCon name kind tyvars rhs clas is_rec =
- mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False False
+ mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False
mkTupleTyCon :: Name
-> Kind -- ^ Kind of the resulting 'TyCon'
-> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'
-> DataCon
-> Boxity -- ^ Whether the tuple is boxed or unboxed
- -> Bool -- ^ Does it have generic functions? See 'hasGenerics'
-> TyCon
-mkTupleTyCon name kind arity tyvars con boxed gen_info
+mkTupleTyCon name kind arity tyvars con boxed
= TupleTyCon {
tyConUnique = nameUnique name,
tyConName = name,
tyConArity = arity,
tyConBoxed = boxed,
tyConTyVars = tyvars,
- dataCon = con,
- hasGenerics = gen_info
+ dataCon = con
}
-- ^ Foreign-imported (.NET) type constructors are represented
tupleTyConBoxity :: TyCon -> Boxity
tupleTyConBoxity tc = tyConBoxed tc
+-- | Extract the arity of the given 'TyCon', if it is a 'TupleTyCon'.
+-- Panics otherwise
+tupleTyConArity :: TyCon -> Arity
+tupleTyConArity tc = tyConArity tc
+
-- | Is this a recursive 'TyCon'?
isRecursiveTyCon :: TyCon -> Bool
isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True
\end{code}
\begin{code}
--- | Does this 'TyCon' have any generic to\/from functions available? See also 'hasGenerics'
-tyConHasGenerics :: TyCon -> Bool
-tyConHasGenerics (AlgTyCon {hasGenerics = hg}) = hg
-tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg
-tyConHasGenerics _ = False -- Synonyms
tyConKind :: TyCon -> Kind
tyConKind (FunTyCon { tc_kind = k }) = k
isClosedAlgType :: Type -> Bool
isClosedAlgType ty
= case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
- isAlgTyCon tc && not (isFamilyTyCon tc)
- _other -> False
+ Just (tc, ty_args) | isAlgTyCon tc && not (isFamilyTyCon tc)
+ -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True
+ _other -> False
\end{code}
\begin{code}
[] -- no stupid theta
rhs
rec_flag -- FIXME: is this ok?
- False -- FIXME: no generics
False -- not GADT syntax
NoParentTyCon
(Just $ mk_fam_inst pdata vect_tc)
[] -- no stupid theta.
rhs' -- new constructor defs.
rec_flag -- FIXME: is this ok?
- False -- FIXME: no generics
False -- not GADT syntax
NoParentTyCon
Nothing -- not a family instance
</row>
<row>
<entry><option>-XGenerics</option></entry>
- <entry>Enable <link linkend="generic-classes">generic classes</link></entry>
+ <entry>Deprecated, does nothing. No longer enables <link linkend="generic-classes">generic classes</link>.
+ See also GHC's support for
+ <link linkend="generic-programming">generic programming</link>.</entry>
<entry>dynamic</entry>
<entry><option>-XNoGenerics</option></entry>
</row>
<entry><option>-XNoDeriveDataTypeable</option></entry>
</row>
<row>
+ <entry><option>-XDeriveGeneric</option></entry>
+ <entry>Enable <link linkend="deriving-typeable">deriving for the Generic class</link>.</entry>
+ <entry>dynamic</entry>
+ <entry><option>-XNoDeriveGeneric</option></entry>
+ </row>
+ <row>
<entry><option>-XGeneralizedNewtypeDeriving</option></entry>
<entry>Enable <link linkend="newtype-deriving">newtype deriving</link>.</entry>
<entry>dynamic</entry>
<entry><option>-XNoConstrainedClassMethods</option></entry>
</row>
<row>
+ <entry><option>-XDefaultSignatures</option></entry>
+ <entry>Enable <link linkend="class-default-signatures">default signatures</link>.</entry>
+ <entry>dynamic</entry>
+ <entry><option>-XNoDefaultSignatures</option></entry>
+ </row>
+ <row>
<entry><option>-XMultiParamTypeClasses</option></entry>
<entry>Enable <link linkend="multi-param-type-classes">multi parameter type classes</link>.</entry>
<entry>dynamic</entry>
</para>
</listitem>
+<listitem><para> With <option>-XDeriveGeneric</option>, you can derive
+instances of the class <literal>Generic</literal>, defined in
+<literal>GHC.Generics</literal>. You can use these to define generic functions,
+as described in <xref linkend="generic-programming"/>.
+</para></listitem>
+
<listitem><para> With <option>-XDeriveFunctor</option>, you can derive instances of
the class <literal>Functor</literal>,
defined in <literal>GHC.Base</literal>.
</sect3>
+
+
+<sect3 id="class-default-signatures">
+<title>Default signatures</title>
+
+<para>
+Haskell 98 allows you to define a default implementation when declaring a class:
+<programlisting>
+ class Enum a where
+ enum :: [a]
+ enum = []
+</programlisting>
+The type of the <literal>enum</literal> method is <literal>[a]</literal>, and
+this is also the type of the default method. You can lift this restriction
+and give another type to the default method using the flag
+<option>-XDefaultSignatures</option>. For instance, if you have written a
+generic implementation of enumeration in a class <literal>GEnum</literal>
+with method <literal>genum</literal> in terms of <literal>GHC.Generics</literal>,
+you can specify a default method that uses that generic implementation:
+<programlisting>
+ class Enum a where
+ enum :: [a]
+ default enum :: (Generic a, GEnum (Rep a)) => [a]
+ enum = map to genum
+</programlisting>
+We reuse the keyword <literal>default</literal> to signal that a signature
+applies to the default method only; when defining instances of the
+<literal>Enum</literal> class, the original type <literal>[a]</literal> of
+<literal>enum</literal> still applies. When giving an empty instance, however,
+the default implementation <literal>map to0 genum</literal> is filled-in,
+and type-checked with the type
+<literal>(Generic a, GEnum (Rep a)) => [a]</literal>.
+</para>
+
+<para>
+We use default signatures to simplify generic programming in GHC
+(<xref linkend="generic-programming"/>).
+</para>
+
+
+</sect3>
</sect2>
<sect2 id="functional-dependencies">
<title>Generic classes</title>
<para>
-The ideas behind this extension are described in detail in "Derivable type classes",
-Ralf Hinze and Simon Peyton Jones, Haskell Workshop, Montreal Sept 2000, pp94-105.
-An example will give the idea:
+GHC used to have an implementation of generic classes as defined in the paper
+"Derivable type classes", Ralf Hinze and Simon Peyton Jones, Haskell Workshop,
+Montreal Sept 2000, pp94-105. These have been removed and replaced by the more
+general <link linkend="generic-programming">support for generic programming</link>.
</para>
-<programlisting>
- import Data.Generics
-
- class Bin a where
- toBin :: a -> [Int]
- fromBin :: [Int] -> (a, [Int])
-
- toBin {| Unit |} Unit = []
- toBin {| a :+: b |} (Inl x) = 0 : toBin x
- toBin {| a :+: b |} (Inr y) = 1 : toBin y
- toBin {| a :*: b |} (x :*: y) = toBin x ++ toBin y
-
- fromBin {| Unit |} bs = (Unit, bs)
- fromBin {| a :+: b |} (0:bs) = (Inl x, bs') where (x,bs') = fromBin bs
- fromBin {| a :+: b |} (1:bs) = (Inr y, bs') where (y,bs') = fromBin bs
- fromBin {| a :*: b |} bs = (x :*: y, bs'') where (x,bs' ) = fromBin bs
- (y,bs'') = fromBin bs'
-</programlisting>
-<para>
-This class declaration explains how <literal>toBin</literal> and <literal>fromBin</literal>
-work for arbitrary data types. They do so by giving cases for unit, product, and sum,
-which are defined thus in the library module <literal>Data.Generics</literal>:
-</para>
-<programlisting>
- data Unit = Unit
- data a :+: b = Inl a | Inr b
- data a :*: b = a :*: b
-</programlisting>
-<para>
-Now you can make a data type into an instance of Bin like this:
-<programlisting>
- instance (Bin a, Bin b) => Bin (a,b)
- instance Bin a => Bin [a]
-</programlisting>
-That is, just leave off the "where" clause. Of course, you can put in the
-where clause and over-ride whichever methods you please.
-</para>
+</sect1>
- <sect2>
- <title> Using generics </title>
- <para>To use generics you need to</para>
- <itemizedlist>
- <listitem>
- <para>
- Use the flags <option>-XGenerics</option> (to enable the
- extra syntax and generate extra per-data-type code),
- and <option>-package syb</option> (to make the
- <literal>Data.Generics</literal> module available.
- </para>
- </listitem>
- <listitem>
- <para>Import the module <literal>Data.Generics</literal> from the
- <literal>syb</literal> package. This import brings into
- scope the data types <literal>Unit</literal>,
- <literal>:*:</literal>, and <literal>:+:</literal>. (You
- don't need this import if you don't mention these types
- explicitly; for example, if you are simply giving instance
- declarations.)</para>
- </listitem>
- </itemizedlist>
- </sect2>
-<sect2> <title> Changes wrt the paper </title>
-<para>
-Note that the type constructors <literal>:+:</literal> and <literal>:*:</literal>
-can be written infix (indeed, you can now use
-any operator starting in a colon as an infix type constructor). Also note that
-the type constructors are not exactly as in the paper (Unit instead of 1, etc).
-Finally, note that the syntax of the type patterns in the class declaration
-uses "<literal>{|</literal>" and "<literal>|}</literal>" brackets; curly braces
-alone would ambiguous when they appear on right hand sides (an extension we
-anticipate wanting).
-</para>
-</sect2>
+<sect1 id="generic-programming">
+<title>Generic programming</title>
-<sect2> <title>Terminology and restrictions</title>
<para>
-Terminology. A "generic default method" in a class declaration
-is one that is defined using type patterns as above.
-A "polymorphic default method" is a default method defined as in Haskell 98.
-A "generic class declaration" is a class declaration with at least one
-generic default method.
+Using a combination of <option>-XDeriveGeneric</option>
+(<xref linkend="deriving-typeable"/>) and
+<option>-XDefaultSignatures</option> (<xref linkend="class-default-signatures"/>),
+you can easily do datatype-generic
+programming using the <literal>GHC.Generics</literal> framework. This section
+gives a very brief overview of how to do it. For more detail please refer to the
+<ulink url="http://www.haskell.org/haskellwiki/Generics">HaskellWiki page</ulink>
+or the original paper:
</para>
-<para>
-Restrictions:
<itemizedlist>
<listitem>
<para>
-Alas, we do not yet implement the stuff about constructor names and
-field labels.
+José Pedro Magalhães, Atze Dijkstra, Johan Jeuring, and Andres Löh.
+<ulink url="http://dreixel.net/research/pdf/gdmh.pdf">
+ A generic deriving mechanism for Haskell</ulink>.
+<citetitle>Proceedings of the third ACM Haskell symposium on Haskell</citetitle>
+(Haskell'2010), pp. 37-48, ACM, 2010.
</para>
</listitem>
+</itemizedlist>
-<listitem>
-<para>
-A generic class can have only one parameter; you can't have a generic
-multi-parameter class.
-</para>
-</listitem>
+<emphasis>Note</emphasis>: the current support for generic programming in GHC
+is preliminary. In particular, we only allow deriving instances for the
+<literal>Generic</literal> class. Support for deriving
+<literal>Generic1</literal> (and thus enabling generic functions of kind
+<literal>* -> *</literal> such as <literal>fmap</literal>) will come at a
+later stage.
-<listitem>
-<para>
-A default method must be defined entirely using type patterns, or entirely
-without. So this is illegal:
-<programlisting>
- class Foo a where
- op :: a -> (a, Bool)
- op {| Unit |} Unit = (Unit, True)
- op x = (x, False)
-</programlisting>
-However it is perfectly OK for some methods of a generic class to have
-generic default methods and others to have polymorphic default methods.
-</para>
-</listitem>
-<listitem>
-<para>
-The type variable(s) in the type pattern for a generic method declaration
-scope over the right hand side. So this is legal (note the use of the type variable ``p'' in a type signature on the right hand side:
-<programlisting>
- class Foo a where
- op :: a -> Bool
- op {| p :*: q |} (x :*: y) = op (x :: p)
- ...
-</programlisting>
-</para>
-</listitem>
+<sect2>
+<title>Deriving representations</title>
-<listitem>
<para>
-The type patterns in a generic default method must take one of the forms:
-<programlisting>
- a :+: b
- a :*: b
- Unit
-</programlisting>
-where "a" and "b" are type variables. Furthermore, all the type patterns for
-a single type constructor (<literal>:*:</literal>, say) must be identical; they
-must use the same type variables. So this is illegal:
+The first thing we need is generic representations. The
+<literal>GHC.Generics</literal> module defines a couple of primitive types
+that can be used to represent most Haskell datatypes:
+
<programlisting>
- class Foo a where
- op :: a -> Bool
- op {| a :+: b |} (Inl x) = True
- op {| p :+: q |} (Inr y) = False
+-- | Unit: used for constructors without arguments
+data U1 p = U1
+
+-- | Constants, additional parameters and recursion of kind *
+newtype K1 i c p = K1 { unK1 :: c }
+
+-- | Meta-information (constructor names, etc.)
+newtype M1 i c f p = M1 { unM1 :: f p }
+
+-- | Sums: encode choice between constructors
+infixr 5 :+:
+data (:+:) f g p = L1 (f p) | R1 (g p)
+
+-- | Products: encode multiple arguments to constructors
+infixr 6 :*:
+data (:*:) f g p = f p :*: g p
+</programlisting>
+
+For example, a user-defined datatype of trees <literal>data UserTree a = Node a
+(UserTree a) (UserTree a) | Leaf</literal> gets the following representation:
+
+<programlisting>
+instance Generic (UserTree a) where
+ -- Representation type
+ type Rep (UserTree a) =
+ M1 D D1UserTree (
+ M1 C C1_0UserTree (
+ M1 S NoSelector (K1 P a)
+ :*: M1 S NoSelector (K1 R (UserTree a))
+ :*: M1 S NoSelector (K1 R (UserTree a)))
+ :+: M1 C C1_1UserTree U1)
+
+ -- Conversion functions
+ from (Node x l r) = M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r))))
+ from Leaf = M1 (R1 (M1 U1))
+ to (M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r))))) = Node x l r
+ to (M1 (R1 (M1 U1))) = Leaf
+
+-- Meta-information
+data D1UserTree
+data C1_0UserTree
+data C1_1UserTree
+
+instance Datatype D1UserTree where
+ datatypeName _ = "UserTree"
+ moduleName _ = "Main"
+
+instance Constructor C1_0UserTree where
+ conName _ = "Node"
+
+instance Constructor C1_1UserTree where
+ conName _ = "Leaf"
</programlisting>
-The type patterns must be identical, even in equations for different methods of the class.
-So this too is illegal:
-<programlisting>
- class Foo a where
- op1 :: a -> Bool
- op1 {| a :*: b |} (x :*: y) = True
- op2 :: a -> Bool
- op2 {| p :*: q |} (x :*: y) = False
-</programlisting>
-(The reason for this restriction is that we gather all the equations for a particular type constructor
-into a single generic instance declaration.)
+This representation is generated automatically if a
+<literal>deriving Generic</literal> clause is attached to the datatype.
+<link linkend="stand-alone-deriving">Standalone deriving</link> can also be
+used.
</para>
-</listitem>
+</sect2>
-<listitem>
-<para>
-A generic method declaration must give a case for each of the three type constructors.
-</para>
-</listitem>
+<sect2>
+<title>Writing generic functions</title>
-<listitem>
<para>
-The type for a generic method can be built only from:
- <itemizedlist>
- <listitem> <para> Function arrows </para> </listitem>
- <listitem> <para> Type variables </para> </listitem>
- <listitem> <para> Tuples </para> </listitem>
- <listitem> <para> Arbitrary types not involving type variables </para> </listitem>
- </itemizedlist>
-Here are some example type signatures for generic methods:
+A generic function is defined by creating a class and giving instances for
+each of the representation types of <literal>GHC.Generics</literal>. As an
+example we show generic serialization:
<programlisting>
- op1 :: a -> Bool
- op2 :: Bool -> (a,Bool)
- op3 :: [Int] -> a -> a
- op4 :: [a] -> Bool
-</programlisting>
-Here, op1, op2, op3 are OK, but op4 is rejected, because it has a type variable
-inside a list.
-</para>
-<para>
-This restriction is an implementation restriction: we just haven't got around to
-implementing the necessary bidirectional maps over arbitrary type constructors.
-It would be relatively easy to add specific type constructors, such as Maybe and list,
-to the ones that are allowed.</para>
-</listitem>
+data Bin = O | I
-<listitem>
-<para>
-In an instance declaration for a generic class, the idea is that the compiler
-will fill in the methods for you, based on the generic templates. However it can only
-do so if
- <itemizedlist>
- <listitem>
- <para>
- The instance type is simple (a type constructor applied to type variables, as in Haskell 98).
- </para>
- </listitem>
- <listitem>
- <para>
- No constructor of the instance type has unboxed fields.
- </para>
- </listitem>
- </itemizedlist>
-(Of course, these things can only arise if you are already using GHC extensions.)
-However, you can still give an instance declarations for types which break these rules,
-provided you give explicit code to override any generic default methods.
-</para>
-</listitem>
+class GSerialize f where
+ gput :: f a -> [Bin]
-</itemizedlist>
-</para>
+instance GSerialize U1 where
+ gput U1 = []
-<para>
-The option <option>-ddump-deriv</option> dumps incomprehensible stuff giving details of
-what the compiler does with generic declarations.
-</para>
+instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where
+ gput (a :*: b) = gput a ++ gput b
+
+instance (GSerialize a, GSerialize b) => GSerialize (a :+: b) where
+ gput (L1 x) = O : gput x
+ gput (R1 x) = I : gput x
+instance (GSerialize a) => GSerialize (M1 i c a) where
+ gput (M1 x) = gput x
+
+instance (Serialize a) => GSerialize (K1 i c a) where
+ gput (K1 x) = put x
+</programlisting>
+
+Typically this class will not be exported, as it only makes sense to have
+instances for the representation types.
+</para>
</sect2>
-<sect2> <title> Another example </title>
+<sect2>
+<title>Generic defaults</title>
+
<para>
-Just to finish with, here's another example I rather like:
+The only thing left to do now is to define a "front-end" class, which is
+exposed to the user:
<programlisting>
- class Tag a where
- nCons :: a -> Int
- nCons {| Unit |} _ = 1
- nCons {| a :*: b |} _ = 1
- nCons {| a :+: b |} _ = nCons (bot::a) + nCons (bot::b)
+class Serialize a where
+ put :: a -> [Bin]
- tag :: a -> Int
- tag {| Unit |} _ = 1
- tag {| a :*: b |} _ = 1
- tag {| a :+: b |} (Inl x) = tag x
- tag {| a :+: b |} (Inr y) = nCons (bot::a) + tag y
+ default put :: (Generic a, GSerialize (Rep a)) => a -> [Bit]
+ put = gput . from
+</programlisting>
+Here we use a <link linkend="class-default-signatures">default signature</link>
+to specify that the user does not have to provide an implementation for
+<literal>put</literal>, as long as there is a <literal>Generic</literal>
+instance for the type to instantiate. For the <literal>UserTree</literal> type,
+for instance, the user can just write:
+
+<programlisting>
+instance (Serialize a) => Serialize (UserTree a)
</programlisting>
+
+The default method for <literal>put</literal> is then used, corresponding to the
+generic implementation of serialization.
</para>
</sect2>
+
</sect1>
+
<sect1 id="monomorphism">
<title>Control over monomorphism</title>
GhcStage1HcOpts = -O -fasm
GhcStage2HcOpts = -O2 -fasm
GhcHcOpts = -Rghc-timing
-GhcLibHcOpts = -O2 -XGenerics
+GhcLibHcOpts = -O2
GhcLibWays += p
ifeq "$(PlatformSupportsSharedLibs)" "YES"
#
# -O(2) is pretty desirable, otherwise no inlining of prelude
# things (incl "+") happens when compiling with this compiler
-#
-# -XGenerics switches on generation of support code for
-# derivable type classes. This is now off by default,
-# but we switch it on for the libraries so that we generate
-# the code in case someone importing wants it
-GhcLibHcOpts=-O2 -XGenerics
+GhcLibHcOpts=-O2
# Strip local symbols from libraries? This can make the libraries smaller,
# but makes debugging somewhat more difficult. Doesn't work with all ld's.
GhcStage2HcOpts += -fhpc -hpcdir $(TOP)/testsuite/hpc_output/
endif
ifeq "$(ValidateSlow)" "YES"
-GhcStage2HcOpts += -XGenerics -DDEBUG
-GhcLibHcOpts += -XGenerics
+GhcStage2HcOpts += -DDEBUG
endif
######################################################################
LitPat _ -> tl
NPat _ _ _ -> tl -- form of literal pattern?
NPlusKPat id _ _ _ -> thing id : tl
- TypePat _ -> tl -- XXX need help here
SigPatIn p _ -> patThings p tl
SigPatOut p _ -> patThings p tl
_ -> error "boundThings"
projects / ghc-hetmet.git / commitdiff