import IfaceEnv ( newImplicitBinder )
import TcRnMonad
-import Util ( zipLazy )
import DataCon ( DataCon, isNullarySrcDataCon,
mkDataCon, dataConFieldLabels, dataConOrigArgTys )
import Var ( tyVarKind, TyVar, Id )
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 )
+ ArgVrcs, AlgTyConRhs(..), newTyConRhs )
import Type ( mkArrowKinds, liftedTypeKind, typeKind, tyVarsOfTypes, tyVarsOfPred,
splitTyConApp_maybe, mkPredTys, mkTyVarTys, ThetaType, Type,
substTyWith, zipTopTvSubst, substTheta )
import Outputable
-import List ( nubBy )
+import List ( nub )
\end{code}
------------------------------------------------------
buildAlgTyCon :: Name -> [TyVar]
+ -> ThetaType -- Stupid theta
-> AlgTyConRhs
-> ArgVrcs -> RecFlag
-> Bool -- True <=> want generics functions
-> TcRnIf m n TyCon
-buildAlgTyCon tc_name tvs rhs arg_vrcs is_rec want_generics
- = do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs
+buildAlgTyCon tc_name tvs stupid_theta rhs arg_vrcs is_rec want_generics
+ = 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 }
mkAbstractTyConRhs :: AlgTyConRhs
mkAbstractTyConRhs = AbstractTyCon
-mkDataTyConRhs :: Maybe ThetaType -> [DataCon] -> AlgTyConRhs
-mkDataTyConRhs mb_theta cons
- = DataTyCon mb_theta cons (all isNullarySrcDataCon cons)
+mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
+mkDataTyConRhs cons
+ = DataTyCon cons (all isNullarySrcDataCon cons)
mkNewTyConRhs :: TyCon -> DataCon -> AlgTyConRhs
mkNewTyConRhs tycon con
mkNewTyConRep :: TyCon -- The original type constructor
-> Type -- Chosen representation type
-- (guaranteed not to be another newtype)
+ -- Free vars of rep = tyConTyVars tc
-- Find the representation type for this newtype TyCon
-- Remember that the representation type is the *ultimate* representation
| tc `elem` tcs = unitTy
| otherwise
= case splitTyConApp_maybe rhs_ty of
- Just (tc', tys) | isNewTyCon tc'
- -> substTyWith tc_tvs tys (go (tc:tcs) tc')
+ 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
+ (_tc_tvs, rhs_ty) = newTyConRhs tc
------------------------------------------------------
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}
; rhs = case dict_component_tys of
[rep_ty] -> mkNewTyConRhs tycon dict_con
- other -> mkDataTyConRhs Nothing [dict_con]
+ other -> mkDataTyConRhs [dict_con]
}
; return clas
})}
projects / ghc-hetmet.git / blobdiff