From: Jose Pedro Magalhaes Date: Fri, 20 May 2011 17:17:13 +0000 (+0200) Subject: Merge branch 'ghc-generics' of http://darcs.haskell.org/ghc into ghc-generics X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=6ad311b7965a7af86f3b931b134215dff76f5fbb;hp=2d4d636af091b8da27466b5cf90011395a9c2f66 Merge branch 'ghc-generics' of darcs.haskell.org/ghc into ghc-generics --- diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 8940692..446d11a 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -53,7 +53,7 @@ module OccName ( mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, - mkGenD, mkGenR0, mkGenR0Co, mkGenC, mkGenS, + mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, @@ -543,7 +543,7 @@ isDerivedOccName occ = mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, - mkGenD, mkGenR0, mkGenR0Co, + mkGenD, mkGenR, mkGenRCo, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, @@ -588,8 +588,8 @@ mkGenS :: OccName -> Int -> Int -> OccName mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n) (occNameString occ) -mkGenR0 = mk_simple_deriv tcName "Rep0_" -mkGenR0Co = mk_simple_deriv tcName "CoRep0_" +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 diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 92d0f42..a3f441e 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" diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 4d096d2..493466b 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,21 +1027,15 @@ 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) +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 = -- dictionary datatype: -- [extras_plus:] -- type constructor @@ -1058,11 +1052,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/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 9ac0a6f..c2e9bc8 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -372,13 +372,12 @@ 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 - ; 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 { -- Next, construct the instance environment so far, consisting @@ -401,9 +400,11 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- Extend the global environment also with the generated datatypes for -- the generic representation - ; gbl_env <- addFamInsts (map ATyCon deriv_ty_insts) $ - tcExtendGlobalEnv (map ATyCon (deriv_tys ++ deriv_ty_insts)) $ - addInsts deriv_inst_info getGblEnv + ; 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, 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 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 011b024..2542ad3 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1644,7 +1644,6 @@ 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 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 43a0da7..d4e859b 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -106,7 +106,7 @@ 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 @@ -1031,16 +1031,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) diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 894da34..5b4374a 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 "") pprFamInstHdr :: FamInst -> SDoc pprFamInstHdr (FamInst {fi_tycon = rep_tc}) diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs index d1e1f32..f4afda5 100644 --- a/compiler/types/Generics.lhs +++ b/compiler/types/Generics.lhs @@ -22,10 +22,12 @@ import RdrName import BasicTypes import TysWiredIn import PrelNames + -- For generation of representation types import TcEnv (tcLookupTyCon) -import TcRnMonad (TcM, newUnique) +import TcRnMonad import HscTypes +import BuildTyCl import SrcLoc import Bag @@ -112,6 +114,41 @@ mkBindsRep tycon = (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 `kind of D` -> * + -- rep_kind = tyConKind tycon `mkArrowKind` liftedTypeKind + -- SLPJ The above type looks quite wrong to me! + -- The kind sig in the comment for rep0Ty looks right + -- + 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 -------------------------------------------------------------------------------- @@ -173,43 +210,6 @@ tc_mkRepTy tycon metaDts = return (mkD tycon) -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 - uniq1 <- newUnique - uniq2 <- newUnique - -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * - rep0Ty <- tc_mkRepTy tycon metaDts - -- `rep0` = GHC.Generics.Rep (type family) - rep0 <- tcLookupTyCon repTyConName - - let modl = nameModule (tyConName tycon) - loc = nameSrcSpan (tyConName tycon) - -- `repName` is a name we generate for the synonym - repName = mkExternalName uniq1 modl (mkGenR0 (nameOccName (tyConName tycon))) loc - -- `coName` is a name for the coercion - coName = mkExternalName uniq2 modl (mkGenR0 (nameOccName (tyConName tycon))) loc - -- `tyvars` = [a,b] - tyvars = tyConTyVars tycon - -- `appT` = D a b - appT = [mkTyConApp tycon (mkTyVarTys tyvars)] - -- Result - res = mkSynTyCon repName - -- rep0Ty has kind `kind of D` -> * - (tyConKind tycon `mkArrowKind` liftedTypeKind) - tyvars (SynonymTyCon rep0Ty) - (FamInstTyCon rep0 appT -{- - (mkCoercionTyCon coName (tyConArity tycon) - (CoAxiom tyvars (mkTyConApp rep0 appT) rep0Ty))) --} - -- co : forall a b. Rep (D a b) ~ `rep0Ty` a b - (CoAxiom uniq2 coName tyvars (mkTyConApp rep0 appT) rep0Ty)) - return res - -------------------------------------------------------------------------------- -- Meta-information --------------------------------------------------------------------------------