Commit 6ad311b7 authored by dreixel's avatar dreixel
Browse files

Merge branch 'ghc-generics' of http://darcs.haskell.org/ghc into ghc-generics

parents 2d4d636a d7fb8d37
......@@ -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
......
......@@ -10,7 +10,8 @@ module BuildTyCl (
buildDataCon,
TcMethInfo, buildClass,
mkAbstractTyConRhs,
mkNewTyConRhs, mkDataTyConRhs
mkNewTyConRhs, mkDataTyConRhs,
newImplicitBinder
) where
#include "HsVersions.h"
......
......@@ -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]
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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})
......
......@@ -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
......@@ -111,6 +113,41 @@ mkBindsRep tycon =
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 `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
--------------------------------------------------------------------------------
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment