import IfaceEnv ( newImplicitBinder )
import TcRnMonad
-import Subst ( substTyWith )
-import Util ( zipLazy )
-import FieldLabel ( allFieldLabelTags, mkFieldLabel, fieldLabelName )
-import VarSet
-import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, mkDataCon, dataConFieldLabels )
+import DataCon ( DataCon, isNullarySrcDataCon, dataConTyVars,
+ mkDataCon, dataConFieldLabels, dataConOrigArgTys )
import Var ( tyVarKind, TyVar, Id )
+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 ( mkSynTyCon, mkAlgTyCon, visibleDataCons,
+import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta,
tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ),
- ArgVrcs, AlgTyConRhs(..), newTyConRhs, visibleDataCons )
-import Type ( mkArrowKinds, liftedTypeKind, tyVarsOfTypes, typeKind,
- tyVarsOfPred, splitTyConApp_maybe, mkPredTys, 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}
------------------------------------------------------
-buildAlgTyCon :: Name -> [TyVar] -> ThetaType
+buildAlgTyCon :: Name -> [TyVar]
+ -> ThetaType -- Stupid theta
-> AlgTyConRhs
-> ArgVrcs -> RecFlag
-> Bool -- True <=> want generics functions
-> TcRnIf m n TyCon
-buildAlgTyCon tc_name tvs ctxt rhs arg_vrcs is_rec want_generics
- = do { let { tycon = mkAlgTyCon tc_name kind tvs ctxt arg_vrcs
- rhs sel_ids is_rec want_generics
+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
- ; sel_ids = mkRecordSelectors tycon rhs
+ ; fields = mkTyConSelIds tycon rhs
}
; return tycon }
mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
mkDataTyConRhs cons
- = DataTyCon cons (all is_nullary cons)
+ = DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons }
+
+mkNewTyConRhs :: TyCon -> DataCon -> AlgTyConRhs
+mkNewTyConRhs tycon con
+ = NewTyCon { data_con = con,
+ nt_rhs = rhs_ty,
+ nt_etad_rhs = eta_reduce tvs rhs_ty,
+ nt_rep = mkNewTyConRep tycon rhs_ty }
where
- is_nullary con = null (dataConOrigArgTys con)
- -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
- -- but that looks at the *representation* arity, and isEnumerationType
- -- refers to the *source* code definition
-
-mkNewTyConRhs :: DataCon -> AlgTyConRhs
-mkNewTyConRhs con
- = NewTyCon con -- The constructor
- (head (dataConOrigArgTys con)) -- The RHS type
- (mkNewTyConRep (dataConTyCon con)) -- The ultimate rep type
+ 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
+-- 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
+-- type, looking through other newtypes.
+--
+-- The non-recursive newtypes are easy, because they look transparent
+-- to splitTyConApp_maybe, but recursive ones really are represented as
+-- TyConApps (see TypeRep).
+--
+-- The trick is to to deal correctly with recursive newtypes
+-- such as newtype T = MkT T
+
+mkNewTyConRep tc rhs_ty
+ | null (tyConDataCons tc) = unitTy
+ -- External Core programs can have newtypes with no data constructors
+ | otherwise = go [tc] rhs_ty
+ where
+ -- 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
+buildDataCon :: Name -> Bool -> Bool
-> [StrictnessMark]
-> [Name] -- Field labels
- -> [TyVar] -> ThetaType
- -> [TyVar] -> ThetaType
- -> [Type] -> TyCon
+ -> [TyVar]
+ -> ThetaType -- Does not include the "stupid theta"
+ -> [Type] -> TyCon -> [Type]
-> TcRnIf m n DataCon
-- A wrapper for DataCon.mkDataCon that
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
-buildDataCon src_name arg_stricts field_lbl_names
- tyvars ctxt ex_tyvars ex_ctxt
- arg_tys tycon
- = newImplicitBinder src_name mkDataConWrapperOcc `thenM` \ wrap_name ->
- newImplicitBinder src_name mkDataConWorkerOcc `thenM` \ work_name ->
+buildDataCon src_name declared_infix vanilla arg_stricts field_lbls
+ tyvars ctxt arg_tys tycon res_tys
+ = 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"
- let
- -- Make the FieldLabels
- -- The zipLazy avoids forcing the arg_tys too early
- final_lbls = [ mkFieldLabel name tycon ty tag
- | ((name, tag), ty) <- (field_lbl_names `zip` allFieldLabelTags)
- `zipLazy` arg_tys
- ]
-
- ctxt' = thinContext arg_tys ctxt
- data_con = mkDataCon src_name arg_stricts final_lbls
- tyvars ctxt'
- ex_tyvars ex_ctxt
- arg_tys tycon dc_ids
- dc_ids = mkDataConIds wrap_name work_name data_con
- in
- returnM data_con
-
--- The context for a data constructor should be limited to
+ -- 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
+ data_con = mkDataCon src_name declared_infix vanilla
+ arg_stricts field_lbls
+ tyvars stupid_ctxt ctxt
+ arg_tys tycon res_tys dc_ids
+ dc_ids = mkDataConIds wrap_name work_name data_con
+
+ ; returnM data_con }
+
+
+-- The stupid context for a data constructor should be limited to
-- the type variables mentioned in the arg_tys
-thinContext arg_tys ctxt
- = filter in_arg_tys ctxt
+mkDataConStupidTheta tycon arg_tys res_tys
+ | null stupid_theta = [] -- The common case
+ | otherwise = filter in_arg_tys stupid_theta
where
- arg_tyvars = tyVarsOfTypes arg_tys
- in_arg_tys pred = not $ isEmptyVarSet $
+ 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
------------------------------------------------------
-mkRecordSelectors :: TyCon -> AlgTyConRhs -> [Id]
-mkRecordSelectors tycon data_cons
- = -- 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.
- [ mkRecordSelId tycon field
- | field <- nubBy eq_name fields ]
- where
- fields = [ field | con <- visibleDataCons data_cons,
- field <- dataConFieldLabels con ]
- eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2
\end{code}
| (op_name, dm_info, _) <- sig_stuff ] }
-- Build the selector id and default method id
- ; dict_con <- buildDataCon datacon_name
+ ; dict_con <- buildDataCon datacon_name
+ False -- Not declared infix
+ True -- Is vanilla; tyvars same as tycon
(map (const NotMarkedStrict) dict_component_tys)
[{- No labelled fields -}]
- tvs [{-No context-}]
- [{-No existential tyvars-}] [{-Or context-}]
- dict_component_tys
- (classTyCon clas)
+ tvs [{-No context-}] dict_component_tys
+ (classTyCon clas) (mkTyVarTys tvs)
; let { clas = mkClass class_name tvs fds
sc_theta sc_sel_ids op_items
; clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
; rhs = case dict_component_tys of
- [rep_ty] -> mkNewTyConRhs dict_con
+ [rep_ty] -> mkNewTyConRhs tycon dict_con
other -> mkDataTyConRhs [dict_con]
}
; return clas
\end{code}
-------------------------------------------------------
-\begin{code}
-mkNewTyConRep :: TyCon -- The original type constructor
- -> Type -- Chosen representation type
- -- (guaranteed not to be another newtype)
-
--- Find the representation type for this newtype TyCon
--- Remember that the representation type is the *ultimate* representation
--- type, looking through other newtypes.
---
--- The non-recursive newtypes are easy, because they look transparent
--- to splitTyConApp_maybe, but recursive ones really are represented as
--- TyConApps (see TypeRep).
---
--- The trick is to to deal correctly with recursive newtypes
--- such as newtype T = MkT T
-
-mkNewTyConRep tc
- | null (tyConDataCons tc) = unitTy
- -- External Core programs can have newtypes with no data constructors
- | otherwise = go [] tc
- where
- -- Invariant: tc is a NewTyCon
- -- tcs have been seen before
- go tcs tc
- | tc `elem` tcs = unitTy
- | otherwise
- = case splitTyConApp_maybe rep_ty of
- Nothing -> rep_ty
- Just (tc', tys) | not (isNewTyCon tc') -> rep_ty
- | otherwise -> go1 (tc:tcs) tc' tys
- where
- (_,rep_ty) = newTyConRhs tc
-
- go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
-\end{code}
projects / ghc-hetmet.git / blobdiff