diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2011-05-26 17:22:02 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2011-05-26 17:22:02 +0100 |
| commit | 1091ebc9aaf430a0ed69f4ebd6190e31c3154e90 (patch) | |
| tree | cb7278b92f898972b3bb2708724222912d871ecb | |
| parent | 3664c198bbf23acce9820104c06878aa78a32a39 (diff) | |
| parent | 97ce7b595418d629a57654b5af07133e6418b45e (diff) | |
| download | haskell-1091ebc9aaf430a0ed69f4ebd6190e31c3154e90.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org/ghc
52 files changed, 1386 insertions, 1469 deletions
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 4d0e7f81a9..c691f62676 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -13,7 +13,7 @@ have a standard form, namely: \begin{code} module MkId ( - mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId, + mkDictFunId, mkDictFunTy, mkDictSelId, mkDataConIds, mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId, @@ -816,11 +816,6 @@ BUT make sure they are *exported* LocalIds (mkExportedLocalId) so 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 diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 5489ea7e26..446d11a994 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -48,11 +48,12 @@ module OccName ( -- ** Derived 'OccName's isDerivedOccName, - mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, + mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, @@ -539,9 +540,10 @@ isDerivedOccName occ = \end{code} \begin{code} -mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, - mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, - mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, +mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, + mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, + mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkGenD, mkGenR, mkGenRCo, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, @@ -553,6 +555,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkDataConWrapperOcc = mk_simple_deriv varName "$W" mkWorkerOcc = mk_simple_deriv varName "$w" mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkGenDefMethodOcc = mk_simple_deriv varName "$gdm" mkClassOpAuxOcc = mk_simple_deriv varName "$c" mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon @@ -571,10 +574,23 @@ mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" --- Generic derivable classes +-- Generic derivable classes (old) mkGenOcc1 = mk_simple_deriv varName "$gfrom" mkGenOcc2 = mk_simple_deriv varName "$gto" +-- Generic deriving mechanism (new) +mkGenD = mk_simple_deriv tcName "D1" + +mkGenC :: 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 diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index d9aefbea22..59c102f884 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -644,7 +644,7 @@ might_fail_pat (ConPatOut { pat_args = ps }) = any might_fail_lpat (hsConPatArgs -- 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 diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index a5bf2b69d6..7f798f81f7 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -1062,7 +1062,6 @@ collectl (L _ pat) bndrs 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) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index d4e92e148a..a4b47ee504 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -420,6 +420,10 @@ rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc +rep_sig (L _ (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 [] @@ -631,7 +635,6 @@ repTy (HsKindSig t k) = do 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 diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 67bbf86af8..5871914ad8 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -597,6 +597,10 @@ data Sig name -- Signatures and pragmas -- f :: Num a => a -> a TypeSig (Located name) (LHsType name) + -- A type signature for a 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 @@ -666,18 +670,20 @@ okBindSig :: Sig a -> Bool okBindSig _ = True okHsBootSig :: Sig a -> Bool -okHsBootSig (TypeSig _ _) = True -okHsBootSig (FixSig _) = True -okHsBootSig _ = False +okHsBootSig (TypeSig _ _) = True +okHsBootSig (GenericSig _ _) = 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 @@ -702,9 +708,10 @@ isVanillaLSig (L _(TypeSig {})) = True isVanillaLSig _ = False isTypeLSig :: LSig name -> Bool -- Type signatures -isTypeLSig (L _(TypeSig {})) = True -isTypeLSig (L _(IdSig {})) = True -isTypeLSig _ = False +isTypeLSig (L _(TypeSig {})) = True +isTypeLSig (L _(GenericSig {})) = True +isTypeLSig (L _(IdSig {})) = True +isTypeLSig _ = False isSpecLSig :: LSig name -> Bool isSpecLSig (L _(SpecSig {})) = True @@ -727,6 +734,7 @@ isInlineLSig _ = False 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") @@ -741,6 +749,7 @@ eqHsSig :: Eq a => LSig a -> LSig a -> Bool eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2 eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2 eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2 +eqHsSig (L _ (GenericSig n1 _)) (L _ (GenericSig n2 _)) = unLoc n1 == unLoc n2 eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2 -- For specialisations, we don't have equality over -- HsType, so it's not convenient to spot duplicate @@ -754,6 +763,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where ppr_sig :: OutputableBndr name => Sig name -> SDoc ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty) +ppr_sig (GenericSig var ty) = ptext (sLit "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) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 53d2949aab..c05f26a5fc 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -834,7 +834,7 @@ instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats \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 diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 1098ff03b2..7fb5f72533 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -134,12 +134,6 @@ data Pat id (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) @@ -283,7 +277,6 @@ pprPat (NPat l Nothing _) = ppr l 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 @@ -441,7 +434,6 @@ isIrrefutableHsPat pat go1 (QuasiQuotePat {}) = urk pat -- Gotten rid of by renamer, before -- isIrrefutablePat is called - go1 (TypePat {}) = urk pat urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat) @@ -465,7 +457,6 @@ hsPatNeedsParens (LitPat {}) = False hsPatNeedsParens (NPat {}) = False hsPatNeedsParens (NPlusKPat {}) = True hsPatNeedsParens (QuasiQuotePat {}) = True -hsPatNeedsParens (TypePat {}) = False conPatNeedsParens :: HsConDetails a b -> Bool conPatNeedsParens (PrefixCon args) = not (null args) diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 38608a48a2..7dbb16df64 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -168,8 +168,6 @@ data HsType name -- 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 -- ^^^^ @@ -440,7 +438,6 @@ ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcol 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 diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 723e0f96f0..cc57e05441 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -27,7 +27,7 @@ module HsUtils( nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, - -- Bindigns + -- Bindings mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, -- Literals @@ -547,7 +547,6 @@ collect_lpat (L _ pat) bndrs 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} @@ -727,7 +726,6 @@ collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc 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 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 134dcfac2c..c80628be72 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1310,7 +1310,7 @@ instance Binary IfaceDecl where 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 @@ -1319,7 +1319,6 @@ instance Binary IfaceDecl where 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) @@ -1354,9 +1353,8 @@ instance Binary IfaceDecl where 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 diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index d30352cfa1..eabe8c45aa 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -10,7 +10,8 @@ module BuildTyCl ( buildDataCon, TcMethInfo, buildClass, mkAbstractTyConRhs, - mkNewTyConRhs, mkDataTyConRhs + mkNewTyConRhs, mkDataTyConRhs, + newImplicitBinder ) where #include "HsVersions.h" @@ -59,13 +60,12 @@ buildAlgTyCon :: Name -> [TyVar] -> 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 @@ -74,11 +74,11 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn 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 @@ -221,8 +221,9 @@ mkDataConStupidTheta tycon arg_tys univ_tvs ------------------------------------------------------ \begin{code} -type TcMethInfo = (Name, DefMethSpec, Type) -- A temporary intermediate, to communicate - -- between tcClassSigs and buildClass +type TcMethInfo = (Name, DefMethSpec, Type) + -- A temporary intermediate, to communicate between + -- tcClassSigs and buildClass. buildClass :: Bool -- True <=> do not include unfoldings -- on dict selectors @@ -324,7 +325,8 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec mk_op_item rec_clas (op_name, dm_spec, _) = do { dm_info <- case dm_spec of NoDM -> return NoDefMeth - GenericDM -> return GenDefMeth + GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc + ; return (GenDefMeth dm_name) } VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc ; return (DefMeth dm_name) } ; return (mkDictSelId no_unf op_name rec_clas, dm_info) } diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index ef0ef5c5f0..49fded9a59 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -67,14 +67,6 @@ data IfaceDecl 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: @@ -473,11 +465,11 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, = 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 @@ -497,10 +489,6 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, 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 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 88dbfa3664..5c58a801f5 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1335,9 +1335,9 @@ tyThingToIfaceDecl (AClass clas) (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) op_ty = funResultTy rho_ty - toDmSpec NoDefMeth = NoDM - toDmSpec GenDefMeth = GenericDM - toDmSpec (DefMeth _) = VanillaDM + toDmSpec NoDefMeth = NoDM + toDmSpec (GenDefMeth _) = GenericDM + toDmSpec (DefMeth _) = VanillaDM toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2) @@ -1357,7 +1357,6 @@ tyThingToIfaceDecl (ATyCon tycon) ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifGeneric = tyConHasGenerics tycon, ifFamInst = famInstToIface (tyConFamInst_maybe tycon)} | isForeignTyCon tycon diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 9e663a8e7d..7ac95b1fa7 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -433,7 +433,6 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, 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 @@ -442,7 +441,7 @@ tc_iface_decl parent _ (IfaceData {ifName = 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) } diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 6804c03a16..d9f3246c34 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -336,7 +336,6 @@ data ExtensionFlag | Opt_TemplateHaskell | Opt_QuasiQuotes | Opt_ImplicitParams - | Opt_Generics -- "Derivable type classes" | Opt_ImplicitPrelude | Opt_ScopedTypeVariables | Opt_UnboxedTuples @@ -358,6 +357,9 @@ data ExtensionFlag | 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 @@ -1666,7 +1668,8 @@ xFlags = [ ( "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 ), @@ -1708,6 +1711,8 @@ xFlags = [ ( "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 ), @@ -1888,6 +1893,7 @@ glasgowExtsFlags = [ , Opt_DeriveFunctor , Opt_DeriveFoldable , Opt_DeriveTraversable + , Opt_DeriveGeneric , Opt_FlexibleContexts , Opt_FlexibleInstances , Opt_ConstrainedClassMethods diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index b96eb56b8c..d90262633c 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -55,6 +55,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ("InstType ", inst_type_ds), ("InstData ", inst_data_ds), ("TypeSigs ", bind_tys), + ("GenericSigs ", generic_sigs), ("ValBinds ", val_bind_ds), ("FunBinds ", fn_bind_ds), ("InlineMeths ", method_inlines), @@ -74,7 +75,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) - (fixity_sigs, bind_tys, bind_specs, bind_inlines) + (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) = count_sigs [d | SigD d <- decls] -- NB: this omits fixity decls on local bindings and -- in class decls. ToDo @@ -112,13 +113,14 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) count_bind (FunBind {}) = (0,1) count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) - count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) + count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs) - sig_info (FixSig _) = (1,0,0,0) - sig_info (TypeSig _ _) = (0,1,0,0) - sig_info (SpecSig _ _ _) = (0,0,1,0) - sig_info (InlineSig _ _) = (0,0,0,1) - sig_info _ = (0,0,0,0) + sig_info (FixSig _) = (1,0,0,0,0) + sig_info (TypeSig _ _) = (0,1,0,0,0) + sig_info (SpecSig _ _ _) = (0,0,1,0,0) + sig_info (InlineSig _ _) = (0,0,0,1,0) + sig_info (GenericSig _ _) = (0,0,0,0,1) + sig_info _ = (0,0,0,0,0) import_info (L _ (ImportDecl _ _ _ qual as spec)) = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec) @@ -137,13 +139,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) class_info decl@(ClassDecl {}) = case count_sigs (map unLoc (tcdSigs decl)) of - (_,classops,_,_) -> + (_,classops,_,_,_) -> (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) class_info _ = (0,0) inst_info (InstDecl _ inst_meths inst_sigs ats) = case count_sigs (map unLoc inst_sigs) of - (_,_,ss,is) -> + (_,_,ss,is,_) -> case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of (tyDecl, dtDecl) -> (addpr (foldr add2 (0,0) @@ -157,13 +159,11 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) 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} diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 4d096d213a..22aa3f4f04 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -55,7 +55,7 @@ module HscTypes ( -- * 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, @@ -1027,22 +1027,18 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) -- 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:] @@ -1058,11 +1054,16 @@ implicitTyThings (AClass cl) -- 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] diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index b20d2c011c..a55a6310c9 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -335,11 +335,6 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } { token ITcubxparen } } -<0> { - "{|" / { ifExtension genericsEnabled } { token ITocurlybar } - "|}" / { ifExtension genericsEnabled } { token ITccurlybar } -} - <0,option_prags> { \( { special IToparen } \) { special ITcparen } @@ -1754,8 +1749,10 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () -- -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 @@ -1806,8 +1803,6 @@ nondecreasingIndentationBit = 25 always :: Int -> Bool always _ = True -genericsEnabled :: Int -> Bool -genericsEnabled flags = testBit flags genericsBit parrEnabled :: Int -> Bool parrEnabled flags = testBit flags parrBit arrowsEnabled :: Int -> Bool @@ -1876,8 +1871,7 @@ mkPState flags buf loc = 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 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index aa20ea6799..102f989332 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -721,6 +721,11 @@ decl_cls :: { Located (OrdList (LHsDecl RdrName)) } 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) } @@ -1022,8 +1027,6 @@ atype :: { LHsType RdrName } | '$(' 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 @@ -1232,9 +1235,11 @@ gdrh :: { LGRHS RdrName } : '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 } sigdecl :: { Located (OrdList (LHsDecl RdrName)) } - : infixexp '::' sigtypedoc {% do s <- checkValSig $1 $3 - ; return (LL $ unitOL (LL $ SigD s)) } - -- See Note [Declaration/signature overlap] for why we need infixexp here + : + -- 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)))) @@ -1499,8 +1504,7 @@ squals :: { Located [LStmt RdrName] } -- In reverse order, because the last -- 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* diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 3b14990ec0..a9433441e8 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -127,7 +127,6 @@ extract_lty (L loc ty) acc 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 @@ -152,8 +151,7 @@ extractGenericPatTyVars binds 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} @@ -704,8 +702,6 @@ checkAPat dynflags loc e0 = case e0 of -> 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 @@ -784,17 +780,20 @@ checkValSig lhs@(L l _) ty ppr lhs <+> text "::" <+> ppr ty) $$ text hint) where - hint = if looks_like_foreign lhs + hint = if foreign_RDR `looks_like` lhs then "Perhaps you meant to use -XForeignFunctionInterface?" - else "Should be of form <variable> :: <type>" + else if 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 diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 99221e3f17..101780deb2 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -94,7 +94,7 @@ isUnboundName name = name `hasKey` unboundKey %* * %************************************************************************ -This section tells what the compiler knows about the assocation of +This section tells what the compiler knows about the association of names with uniques. These ones are the *non* wired-in ones. The wired in ones are defined in TysWiredIn etc. @@ -222,7 +222,11 @@ basicKnownKeyNames -- dotnet interop , objectTyConName, marshalObjectName, unmarshalObjectName , marshalStringName, unmarshalStringName, checkDotnetResName - + + -- Generics + , genClassName, gen1ClassName + , datatypeClassName, constructorClassName, selectorClassName + -- Monad comprehensions , guardMName , liftMName @@ -231,7 +235,14 @@ basicKnownKeyNames ] 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. -- @@ -263,7 +274,7 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME 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, @@ -279,6 +290,7 @@ gHC_UNIT = mkPrimModule (fsLit "GHC.Unit") 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") @@ -535,12 +547,59 @@ mkTyConRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyCon") undefined_RDR :: RdrName undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") +error_RDR :: RdrName +error_RDR = varQual_RDR gHC_ERR (fsLit "error") + +-- Old Generics (constructors and functions) crossDataCon_RDR, inlDataCon_RDR, inrDataCon_RDR, genUnitDataCon_RDR :: RdrName crossDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") inlDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inl") inrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inr") genUnitDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Unit") +-- Generics (constructors and functions) +u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, + k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, + prodDataCon_RDR, comp1DataCon_RDR, 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") @@ -586,19 +645,48 @@ eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey 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 @@ -766,6 +854,16 @@ showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey 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, @@ -963,6 +1061,15 @@ applicativeClassKey, foldableClassKey, traversableClassKey :: Unique 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} %************************************************************************ @@ -1049,12 +1156,6 @@ ptrTyConKey = mkPreludeTyConUnique 74 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 @@ -1105,6 +1206,41 @@ opaqueTyConKey = mkPreludeTyConUnique 133 stringTyConKey :: Unique stringTyConKey = mkPreludeTyConUnique 134 +-- Generics (Unique keys) +v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, + k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, + compTyConKey, rTyConKey, pTyConKey, dTyConKey, + cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey, + d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, + 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 ----------------------------------------------------- diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 9f5f369a99..5a80067160 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -196,7 +196,6 @@ pcTyCon is_enum is_rec name tyvars cons (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 @@ -261,7 +260,7 @@ unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mA 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 @@ -278,8 +277,6 @@ mk_tuple boxity arity = (tycon, tuple_con) (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 diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 63db219a11..80a47a4ff6 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -26,7 +26,6 @@ module RnBinds ( import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn -import RdrHsSyn import RnHsSyn import TcRnMonad import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch) @@ -586,23 +585,33 @@ a binder. \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 @@ -611,7 +620,7 @@ rnMethodBind cls sig_fn gen_tyvars -- 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 @@ -620,24 +629,13 @@ rnMethodBind cls sig_fn gen_tyvars , 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} @@ -668,7 +666,12 @@ renameSigs mb_names ok_sig sigs -- Check for duplicates on RdrName version, -- because renamed version has unboundName for -- not-in-scope binders, which gives bogus dup-sig errors - + -- NB: in a class decl, a 'generic' sig is not considered + -- equal to an ordinary sig, so we allow, say + -- class C a where + -- op :: a -> a + -- default op :: Eq a => a -> a + ; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs ; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs' @@ -695,6 +698,13 @@ renameSig mb_names sig@(TypeSig v ty) ; new_ty <- rnHsSigType (quotes (ppr v)) ty ; return (TypeSig new_v new_ty) } +renameSig mb_names sig@(GenericSig v ty) + = do { 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) } @@ -816,6 +826,11 @@ misplacedSigErr (L loc sig) = 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")) @@ -830,4 +845,5 @@ nonStdGuardErr :: [LStmtLR Name Name] -> SDoc nonStdGuardErr guards = hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)")) 4 (interpp'SP guards) + \end{code} diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index 9226cb4668..478ba32655 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -11,9 +11,7 @@ module RnHsSyn( extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames, -- Free variables - hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs, - - maybeGenericMatch + hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs ) where #include "HsVersions.h" @@ -66,7 +64,6 @@ extractHsTyNames ty 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 @@ -120,10 +117,11 @@ hsSigsFVs :: [LSig Name] -> FreeVars hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs) hsSigFVs :: Sig Name -> FreeVars -hsSigFVs (TypeSig _ ty) = extractHsTyNames ty -hsSigFVs (SpecInstSig ty) = extractHsTyNames ty -hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty -hsSigFVs _ = emptyFVs +hsSigFVs (TypeSig _ ty) = extractHsTyNames ty +hsSigFVs (GenericSig _ ty) = extractHsTyNames ty +hsSigFVs (SpecInstSig ty) = extractHsTyNames ty +hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty +hsSigFVs _ = emptyFVs ---------------- conDeclFVs :: LConDecl Name -> FreeVars @@ -144,24 +142,3 @@ conDetailsFVs details = plusFVs (map bangTyFVs (hsConDeclArgTys details)) 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} diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 76be4519d3..844a1f90c2 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -367,10 +367,6 @@ rnPatAndThen mk (TuplePat pats boxed _) ; 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) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 18c2dfd7ae..54dc378dd5 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -17,14 +17,14 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) 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 @@ -443,24 +443,13 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- The typechecker (not the renamer) checks that all -- the bindings are for the right class let - meth_names = collectMethodBinders mbinds (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty') in - checkDupRdrNames meth_names `thenM_` - -- Check that the same method is not given twice in the - -- same instance decl instance C T where - -- f x = ... - -- g y = ... - -- f x = ... - -- We must use checkDupRdrNames because the Name of the - -- method is the Name of the class selector, whose SrcSpan - -- points to the class declaration - extendTyVarEnvForMethodBinds inst_tyvars ( -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too rnMethodBinds cls (\_ -> []) -- No scoped tyvars - [] mbinds + mbinds ) `thenM` \ (mbinds', meth_fvs) -> -- Rename the associated types -- The typechecker (not the renamer) checks that all @@ -826,15 +815,11 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- 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 diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index e711417f85..be90d7d0a9 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -139,13 +139,6 @@ rnHsType doc (HsRecTy flds) = 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 diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index c41806a5ec..ccdbf579dc 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -7,6 +7,7 @@ module FamInst ( import HscTypes import FamInstEnv +import LoadIface import TcMType import TcRnMonad import TyCon @@ -82,20 +83,17 @@ checkFamInstConsistency famInstMods directlyImpMods ; (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 @@ -106,22 +104,27 @@ checkFamInstConsistency famInstMods directlyImpMods -- 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} %************************************************************************ diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 8db89b9c07..8fc8a24e7a 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -8,19 +8,15 @@ Typechecking class declarations \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 @@ -28,21 +24,15 @@ import TcMType 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 @@ -50,7 +40,6 @@ import Bag import FastString import Control.Monad -import Data.List \end{code} @@ -94,51 +83,43 @@ Death to "ExpandingDicts". %************************************************************************ \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} @@ -174,20 +155,21 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, pred = mkClassPred clas (mkTyVarTys clas_tyvars) ; this_dict <- newEvVar pred + ; traceTc "TIM2" (ppr sigs) ; let tc_dm = tcDefMeth clas clas_tyvars - this_dict default_binds + this_dict default_binds 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 @@ -196,40 +178,45 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -- (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] @@ -246,7 +233,7 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind - + ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id))) ; (ev_binds, (tc_bind, _)) <- checkConstraints skol_info tyvars dfun_ev_vars $ tcExtendIdEnv [local_meth_id] $ @@ -359,179 +346,22 @@ gives rise to the instance declarations 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 @@ -562,6 +392,11 @@ badMethodErr clas op = hsep [ptext (sLit "Class"), quotes (ppr clas), ptext (sLit "does not have a method"), quotes (ppr op)] +badGenericMethod :: Outputable a => a -> Name -> SDoc +badGenericMethod clas op + = hsep [ptext (sLit "Class"), quotes (ppr clas), + ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)] + badATErr :: Class -> Name -> SDoc badATErr clas at = hsep [ptext (sLit "Class"), quotes (ppr clas), @@ -570,23 +405,7 @@ badATErr clas at 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"), @@ -604,8 +423,10 @@ dupGenericInsts tc_inst_infos ] 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} diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 72b99c5f70..b278ab4f62 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -40,10 +40,13 @@ import Name 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 @@ -125,6 +128,9 @@ pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, 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} @@ -292,17 +298,21 @@ both of them. So we gather defs/uses from deriving just like anything else. tcDeriving :: [LTyClDecl Name] -- All type constructors -> [LInstDecl Name] -- All instance declarations -> [LDerivDecl Name] -- All stand-alone deriving declarations - -> TcM ([InstInfo Name], -- The generated "instance decls" - HsValBinds Name, -- Extra generated top-level bindings - DefUses) + -> TcM ([InstInfo Name] -- The generated "instance decls" + ,HsValBinds Name -- Extra generated top-level bindings + ,DefUses + ,[TyCon] -- Extra generated top-level types + ,[TyCon]) -- Extra generated type family instances tcDeriving tycl_decls inst_decls deriv_decls - = recoverM (return ([], emptyValBindsOut, emptyDUs)) $ + = recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $ do { -- Fish the "deriving"-related information out of the TcEnv -- And make the necessary "equations". is_boot <- tcIsHsBoot ; 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 @@ -313,14 +323,22 @@ tcDeriving tycl_decls inst_decls deriv_decls ; insts2 <- mapM (genInst False overlap_flag) final_specs - -- Generate the generic to/from functions from each type declaration - ; gen_binds <- mkGenericBinds is_boot tycl_decls - ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2) + -- 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 @@ -328,6 +346,7 @@ tcDeriving tycl_decls inst_decls deriv_decls 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) @@ -379,26 +398,12 @@ renameDeriv is_boot gen_binds insts -- 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] @@ -430,34 +435,93 @@ stored in NewTypeDerived. @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 @@ -727,6 +791,11 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaTy -- 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 @@ -830,6 +899,8 @@ sideConditions mtheta cls 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 @@ -848,7 +919,7 @@ orCond c1 c2 tc 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 @@ -874,11 +945,14 @@ cond_stdOK Nothing (_, rep_tc) 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` @@ -893,7 +967,7 @@ cond_noUnliftedArgs (_, tc) 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) @@ -901,7 +975,7 @@ 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 @@ -911,7 +985,7 @@ cond_isProduct (_, rep_tc) | 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 @@ -924,9 +998,9 @@ cond_typeableOK (_, tc) | 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] @@ -941,11 +1015,11 @@ cond_functorOK :: Bool -> Condition 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 @@ -972,10 +1046,10 @@ cond_functorOK allowFunctions (_, rep_tc) , 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, _) @@ -999,11 +1073,11 @@ std_class_via_iso clas 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 @@ -1451,20 +1525,159 @@ genDerivBinds loc fix_env clas tycon 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} + %************************************************************************ %* * diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index a087059926..96dc2614e3 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -211,7 +211,7 @@ tcLookupFamInst tycon tys } 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) @@ -461,7 +461,7 @@ tcExtendGlobalTyVars gtv_var extra_global_tvs \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 @@ -681,7 +681,7 @@ newDFunName clas tys loc \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} diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 310f3fd2c4..ad640efec8 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -42,7 +42,7 @@ import Name import HscTypes import PrelInfo import MkCore ( eRROR_ID ) -import PrelNames +import PrelNames hiding (error_RDR) import PrimOp import SrcLoc import TyCon diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index a58761b1af..65f16c56d2 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -44,7 +44,6 @@ import TyCon import Class import Name import NameSet -import PrelNames import TysWiredIn import BasicTypes import SrcLoc @@ -365,9 +364,6 @@ kc_hs_type (HsPArrTy ty) = do 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) @@ -606,11 +602,6 @@ ds_type (HsOpTy ty1 (L span op) ty2) = do 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 [] diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 954471f8c3..bb0089f8e2 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -208,7 +208,7 @@ Just <blah>. 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])) @@ -372,40 +372,41 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ; 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) }}} @@ -413,18 +414,14 @@ addInsts :: [InstInfo Name] -> TcM a -> TcM a 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" -- @@ -468,7 +465,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) 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 @@ -486,12 +483,11 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; 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 @@ -581,7 +577,7 @@ lot of kinding and type checking code with ordinary algebraic data types (and 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 $ @@ -602,7 +598,7 @@ tcFamInstDecl top_lvl (L loc decl) ; when (isTopLevel top_lvl && isAssocFamily tc) (addErr $ assocInClassErr (tcdName decl)) - ; return (ATyCon tc) } + ; return tc } isAssocFamily :: TyCon -> Bool -- Is an assocaited type isAssocFamily tycon @@ -696,7 +692,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, 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 @@ -1098,10 +1094,15 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ---------------------- 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 diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 7d725d7020..8304a22ddb 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -458,9 +458,6 @@ tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside ; 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 @@ -1049,9 +1046,6 @@ polyPatSig sig_ty = 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 $ diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index b6525b874c..5aa6959141 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -245,7 +245,6 @@ tcRnImports hsc_env this_mod import_decls -- 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") @@ -299,7 +298,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- 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 @@ -500,10 +499,9 @@ tcRnHsBootDecls decls -- 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 @@ -837,11 +835,10 @@ tcTopSrcDecls boot_details -- 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 @@ -875,6 +872,7 @@ tcTopSrcDecls boot_details 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 ; @@ -1386,7 +1384,6 @@ tcGetModuleExports mod directlyImpMods -- 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. @@ -1573,7 +1570,6 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , 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:") <+> @@ -1644,16 +1640,10 @@ ppr_tydecls tycons 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} diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 56bf75838f..8d62b78580 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -26,17 +26,16 @@ import TcMType 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 @@ -62,12 +61,12 @@ import Data.List %************************************************************************ \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 @@ -90,7 +89,7 @@ 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 @@ -106,11 +105,13 @@ tcTyAndClassDecls boot_details decls_s -- 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 @@ -307,6 +308,8 @@ kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) 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 {}) @@ -453,7 +456,7 @@ tcTyClDecl1 parent _calc_isrec ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildAlgTyCon tc_name final_tvs [] - DataFamilyTyCon Recursive False True + DataFamilyTyCon Recursive True parent Nothing ; return [ATyCon tycon] } @@ -479,7 +482,6 @@ tcTyClDecl1 _parent calc_isrec { 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 @@ -504,8 +506,7 @@ tcTyClDecl1 _parent calc_isrec 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] } @@ -521,7 +522,7 @@ tcTyClDecl1 _parent calc_isrec 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 @@ -534,7 +535,18 @@ tcTyClDecl1 _parent calc_isrec ; 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. } @@ -799,6 +811,8 @@ checkValidTyCl decl 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) } @@ -959,7 +973,7 @@ checkValidClass cls 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 @@ -980,10 +994,10 @@ checkValidClass cls ; 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 @@ -1011,7 +1025,7 @@ checkValidClass cls 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} @@ -1033,16 +1047,16 @@ must bring the default method Ids into scope first (so they can be seen 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) @@ -1249,12 +1263,6 @@ genericMultiParamErr clas = 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)) $ diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index cb61726a5c..15c817a657 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -30,7 +30,7 @@ import NameSet import Digraph import BasicTypes import SrcLoc -import Outputable +import Maybes( mapCatMaybes ) import Util ( isSingleton ) import Data.List \end{code} @@ -253,11 +253,10 @@ calcRecFlags boot_details tyclss 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. @@ -321,10 +320,10 @@ calcRecFlags boot_details tyclss 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 diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index 1e16bc4763..d9e44e591c 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -81,7 +81,7 @@ type ClassOpItem = (Id, DefMeth) 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 @@ -91,7 +91,7 @@ defMethSpecOfDefMeth meth = case meth of NoDefMeth -> NoDM DefMeth _ -> VanillaDM - GenDefMeth -> GenericDM + GenDefMeth _ -> GenericDM \end{code} @@ -208,9 +208,9 @@ instance Show Class where 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 diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 894da340c7..5b4374afa2 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -84,7 +84,12 @@ instance Outputable FamInst where 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}) diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs index 604db8d2d9..57b26556c8 100644 --- a/compiler/types/Generics.lhs +++ b/compiler/types/Generics.lhs @@ -1,18 +1,12 @@ % -% (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 @@ -22,17 +16,20 @@ import TcType 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 @@ -40,185 +37,6 @@ 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} @@ -226,25 +44,47 @@ validGenericMethodType ty %************************************************************************ \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} %************************************************************************ @@ -255,320 +95,302 @@ canDoGenerics data_cons \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} diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 1d8d48a773..915207621f 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -49,7 +49,7 @@ module TyCon( isTyConAssoc, isRecursiveTyCon, isHiBootTyCon, - isImplicitTyCon, tyConHasGenerics, + isImplicitTyCon, -- ** Extracting information out of TyCons tyConName, @@ -67,7 +67,7 @@ module TyCon( tyConExtName, -- External name for foreign types algTyConRhs, newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, - tupleTyConBoxity, + tupleTyConBoxity, tupleTyConArity, -- ** Manipulating TyCons tcExpandTyCon_maybe, coreExpandTyCon_maybe, @@ -333,11 +333,7 @@ data TyCon 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. @@ -353,8 +349,7 @@ data TyCon tyConArity :: Arity, tyConBoxed :: Boxity, tyConTyVars :: [TyVar], - dataCon :: DataCon, -- ^ Corresponding tuple data constructor - hasGenerics :: Bool + dataCon :: DataCon -- ^ Corresponding tuple data constructor } -- | Represents type synonyms @@ -788,10 +783,9 @@ mkAlgTyCon :: Name -> 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, @@ -802,14 +796,13 @@ mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn 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' @@ -817,9 +810,8 @@ mkTupleTyCon :: Name -> [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, @@ -827,8 +819,7 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info tyConArity = arity, tyConBoxed = boxed, tyConTyVars = tyvars, - dataCon = con, - hasGenerics = gen_info + dataCon = con } -- ^ Foreign-imported (.NET) type constructors are represented @@ -1087,6 +1078,11 @@ isBoxedTupleTyCon _ = False 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 @@ -1178,11 +1174,6 @@ expand tvs rhs tys \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 diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 3a8675edca..995d7a9c1d 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -979,9 +979,9 @@ isAlgType ty 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} diff --git a/compiler/vectorise/Vectorise/Type/PData.hs b/compiler/vectorise/Vectorise/Type/PData.hs index 332344bdc2..b7bd95e940 100644 --- a/compiler/vectorise/Vectorise/Type/PData.hs +++ b/compiler/vectorise/Vectorise/Type/PData.hs @@ -31,7 +31,6 @@ buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc -> [] -- 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) diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index 0fa8482d6b..cbfea455b6 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -82,7 +82,6 @@ vectTyConDecl tycon [] -- 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 diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 5b55fc6fc7..bfc28d82cb 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -676,7 +676,9 @@ </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> @@ -971,6 +973,12 @@ <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> @@ -1002,6 +1010,12 @@ <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> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index a556953460..0f37953d5d 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -3212,6 +3212,12 @@ then writing the data type instance by hand. </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>. @@ -3533,6 +3539,47 @@ GHC lifts this restriction (flag <option>-XConstrainedClassMethods</option>). </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"> @@ -9139,257 +9186,185 @@ allows you to fool the type checker. <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> diff --git a/mk/build.mk.sample b/mk/build.mk.sample index 216ca66c1b..a31b57618b 100644 --- a/mk/build.mk.sample +++ b/mk/build.mk.sample @@ -39,7 +39,7 @@ SRC_HC_OPTS = -O -H64m GhcStage1HcOpts = -O -fasm GhcStage2HcOpts = -O2 -fasm GhcHcOpts = -Rghc-timing -GhcLibHcOpts = -O2 -XGenerics +GhcLibHcOpts = -O2 GhcLibWays += p ifeq "$(PlatformSupportsSharedLibs)" "YES" diff --git a/mk/config.mk.in b/mk/config.mk.in index 3749bce6b6..d4a7cbeaf0 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -282,13 +282,8 @@ GhcThreaded = $(if $(findstring thr,$(GhcRTSWays)),YES,NO) # # -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. diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index c000f852a5..b7f788b6b9 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -36,8 +36,7 @@ ifeq "$(ValidateHpc)" "YES" GhcStage2HcOpts += -fhpc -hpcdir $(TOP)/testsuite/hpc_output/ endif ifeq "$(ValidateSlow)" "YES" -GhcStage2HcOpts += -XGenerics -DDEBUG -GhcLibHcOpts += -XGenerics +GhcStage2HcOpts += -DDEBUG endif ###################################################################### diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index b3ed58f327..c86a92a226 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -293,7 +293,6 @@ boundThings modname lbinding = 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" |