import IfaceEnv ( newImplicitBinder )
import TcRnMonad
-import Util ( zipLazy )
-import DataCon ( DataCon, isNullarySrcDataCon,
+import DataCon ( DataCon, isNullarySrcDataCon, dataConTyVars,
mkDataCon, dataConFieldLabels, dataConOrigArgTys )
import Var ( tyVarKind, TyVar, Id )
-import VarSet ( isEmptyVarSet, intersectVarSet )
+import VarSet ( isEmptyVarSet, intersectVarSet, elemVarSet )
import TysWiredIn ( unitTy )
import BasicTypes ( RecFlag, StrictnessMark(..) )
import Name ( Name )
mkClassDataConOcc, mkSuperDictSelOcc )
import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId )
import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) )
-import TyCon ( FieldLabel, mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta,
+import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta,
tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ),
- ArgVrcs, AlgTyConRhs(..), newTyConRhs, visibleDataCons )
-import Type ( mkArrowKinds, liftedTypeKind, typeKind, tyVarsOfTypes, tyVarsOfPred,
- splitTyConApp_maybe, mkPredTys, mkTyVarTys, ThetaType, Type,
+ isRecursiveTyCon,
+ ArgVrcs, AlgTyConRhs(..), newTyConRhs )
+import Type ( mkArrowKinds, liftedTypeKind, typeKind,
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
+ splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe,
+ mkPredTys, mkTyVarTys, ThetaType, Type,
substTyWith, zipTopTvSubst, substTheta )
import Outputable
-import List ( nubBy )
+import List ( nub )
\end{code}
= do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs stupid_theta
rhs fields is_rec want_generics
; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
- ; fields = mkTyConFields tycon rhs
+ ; fields = mkTyConSelIds tycon rhs
}
; return tycon }
mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
mkDataTyConRhs cons
- = DataTyCon cons (all isNullarySrcDataCon cons)
+ = DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons }
mkNewTyConRhs :: TyCon -> DataCon -> AlgTyConRhs
mkNewTyConRhs tycon con
- = NewTyCon con rhs_ty (mkNewTyConRep tycon)
+ = NewTyCon { data_con = con,
+ nt_rhs = rhs_ty,
+ nt_etad_rhs = eta_reduce tvs rhs_ty,
+ nt_rep = mkNewTyConRep tycon rhs_ty }
where
+ tvs = dataConTyVars con
rhs_ty = head (dataConOrigArgTys con)
-- Newtypes are guaranteed vanilla, so OrigArgTys will do
+
+ eta_reduce [] ty = ([], ty)
+ eta_reduce (a:as) ty | null as',
+ Just (fun, arg) <- splitAppTy_maybe ty',
+ Just tv <- getTyVar_maybe arg,
+ tv == a,
+ not (a `elemVarSet` tyVarsOfType fun)
+ = ([], fun) -- Successful eta reduction
+ | otherwise
+ = (a:as', ty')
+ where
+ (as', ty') = eta_reduce as ty
mkNewTyConRep :: TyCon -- The original type constructor
+ -> Type -- The arg type of its constructor
-> Type -- Chosen representation type
- -- (guaranteed not to be another newtype)
- -- Free vars of rep = tyConTyVars tc
+-- The "representation type" is guaranteed not to be another newtype
+-- at the outermost level; but it might have newtypes in type arguments
-- Find the representation type for this newtype TyCon
-- Remember that the representation type is the *ultimate* representation
-- The trick is to to deal correctly with recursive newtypes
-- such as newtype T = MkT T
-mkNewTyConRep tc
+mkNewTyConRep tc rhs_ty
| null (tyConDataCons tc) = unitTy
-- External Core programs can have newtypes with no data constructors
- | otherwise = go [] tc
+ | otherwise = go [tc] rhs_ty
where
- -- Invariant: tc is a NewTyCon
- -- tcs have been seen before
- go tcs tc
- | tc `elem` tcs = unitTy
- | otherwise
- = case splitTyConApp_maybe rhs_ty of
- Just (tc1, tys) | isNewTyCon tc1
- -> ASSERT( length (tyConTyVars tc1) == length tys )
- substTyWith (tyConTyVars tc1) tys (go (tc:tcs) tc1)
- other -> rhs_ty
- where
- (_tc_tvs, rhs_ty) = newTyConRhs tc
-
+ -- Invariant: tcs have been seen before
+ go tcs rep_ty
+ = case splitTyConApp_maybe rep_ty of
+ Just (tc, tys)
+ | tc `elem` tcs -> unitTy -- Recursive loop
+ | isNewTyCon tc -> ASSERT( isRecursiveTyCon tc )
+ -- Non-recursive ones have been
+ -- dealt with by splitTyConApp_maybe
+ go (tc:tcs) (substTyWith tvs tys rhs_ty)
+ where
+ (tvs, rhs_ty) = newTyConRhs tc
+
+ other -> rep_ty
------------------------------------------------------
buildDataCon :: Name -> Bool -> Bool
-> [StrictnessMark]
-> [Name] -- Field labels
- -> [TyVar] -> ThetaType
+ -> [TyVar]
+ -> ThetaType -- Does not include the "stupid theta"
-> [Type] -> TyCon -> [Type]
-> TcRnIf m n DataCon
-- A wrapper for DataCon.mkDataCon that
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
-- This last one takes the name of the data constructor in the source
- -- code, which (for Haskell source anyway) will be in the SrcDataName name
- -- space, and makes it into a "real data constructor name"
+ -- code, which (for Haskell source anyway) will be in the DataName name
+ -- space, and puts it into the VarName name space
; let
stupid_ctxt = mkDataConStupidTheta tycon arg_tys res_tys
where
tc_subst = zipTopTvSubst (tyConTyVars tycon) res_tys
stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
+ -- Start by instantiating the master copy of the
+ -- stupid theta, taken from the TyCon
+
arg_tyvars = tyVarsOfTypes arg_tys
in_arg_tys pred = not $ isEmptyVarSet $
tyVarsOfPred pred `intersectVarSet` arg_tyvars
------------------------------------------------------
-mkTyConFields :: TyCon -> AlgTyConRhs -> [(FieldLabel,Type,Id)]
-mkTyConFields tycon rhs
- = -- We'll check later that fields with the same name
+mkTyConSelIds :: TyCon -> AlgTyConRhs -> [Id]
+mkTyConSelIds tycon rhs
+ = [ mkRecordSelId tycon fld
+ | fld <- nub (concatMap dataConFieldLabels (visibleDataCons rhs)) ]
+ -- We'll check later that fields with the same name
-- from different constructors have the same type.
- [ (fld, ty, mkRecordSelId tycon fld ty)
- | (fld, ty) <- nubBy eq_fld all_fld_tys ]
- where
- all_fld_tys = concatMap fld_tys_of (visibleDataCons rhs)
- fld_tys_of con = dataConFieldLabels con `zipLazy`
- dataConOrigArgTys con
- -- The laziness means that the type isn't sucked in prematurely
- -- Only vanilla datacons have fields at all, and they
- -- share the tycon's type variables => datConOrigArgTys will do
-
- eq_fld (f1,_) (f2,_) = f1 == f2
\end{code}
projects / ghc-hetmet.git / blobdiff