module BuildTyCl (
buildSynTyCon, buildAlgTyCon, buildDataCon,
buildClass,
- newTyConRhs -- Just a useful little function with no obvious home
+ mkAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs
) where
#include "HsVersions.h"
import IfaceEnv ( newImplicitBinder )
import TcRnMonad
-import Subst ( substTyWith )
-import Util ( zipLazy )
-import FieldLabel ( allFieldLabelTags, mkFieldLabel, fieldLabelName )
-import VarSet
-import DataCon ( DataCon, dataConOrigArgTys, mkDataCon, dataConFieldLabels )
-import Var ( tyVarKind, TyVar )
+import DataCon ( DataCon, isNullarySrcDataCon,
+ mkDataCon, dataConFieldLabels, dataConOrigArgTys )
+import Var ( tyVarKind, TyVar, Id )
+import VarSet ( isEmptyVarSet, intersectVarSet )
import TysWiredIn ( unitTy )
-import BasicTypes ( RecFlag, NewOrData( ..), StrictnessMark(..) )
+import BasicTypes ( RecFlag, StrictnessMark(..) )
import Name ( Name )
import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc,
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, DataConDetails( ..), AlgTyConFlavour(..) )
-import Type ( mkArrowKinds, liftedTypeKind, tyVarsOfTypes, typeKind,
- tyVarsOfPred, splitTyConApp_maybe, mkPredTys, ThetaType, Type )
+ 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 :: NewOrData -> Name -> [TyVar] -> ThetaType
- -> DataConDetails DataCon
+buildAlgTyCon :: Name -> [TyVar]
+ -> ThetaType -- Stupid theta
+ -> AlgTyConRhs
-> ArgVrcs -> RecFlag
-> Bool -- True <=> want generics functions
-> TcRnIf m n TyCon
-buildAlgTyCon new_or_data tc_name tvs ctxt cons arg_vrcs is_rec want_generics
- = do { let { tycon = mkAlgTyCon tc_name kind tvs ctxt arg_vrcs
- cons sel_ids flavour 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 cons
- ; flavour = case new_or_data of
- NewType -> NewTyCon (mkNewTyConRep tycon)
- DataType -> DataTyCon (all_nullary cons)
+ ; fields = mkTyConSelIds tycon rhs
}
; return tycon }
- where
- all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
- all_nullary Unknown = False -- Safe choice for unknown data types
- -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
- -- but that looks at the *representation* arity, and isEnumerationType
- -- refers to the *source* code definition
------------------------------------------------------
-buildDataCon :: Name
- -> [StrictnessMark]
- -> [Name] -- Field labels
- -> [TyVar] -> ThetaType
- -> [TyVar] -> ThetaType
- -> [Type] -> TyCon
- -> 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 ->
- -- 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
--- the type variables mentioned in the arg_tys
-thinContext arg_tys ctxt
- = filter in_arg_tys ctxt
- where
- arg_tyvars = tyVarsOfTypes arg_tys
- in_arg_tys pred = not $ isEmptyVarSet $
- tyVarsOfPred pred `intersectVarSet` arg_tyvars
-
-------------------------------------------------------
-mkRecordSelectors tycon data_cons
- = -- 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
+mkAbstractTyConRhs :: AlgTyConRhs
+mkAbstractTyConRhs = AbstractTyCon
+mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
+mkDataTyConRhs cons
+ = DataTyCon cons (all isNullarySrcDataCon cons)
-------------------------------------------------------
-newTyConRhs :: TyCon -> Type -- The defn of a newtype, as written by the programmer
-newTyConRhs tc = head (dataConOrigArgTys (head (tyConDataCons tc)))
-
+mkNewTyConRhs :: TyCon -> DataCon -> AlgTyConRhs
+mkNewTyConRhs tycon con
+ = NewTyCon con rhs_ty (mkNewTyConRep tycon)
+ where
+ rhs_ty = head (dataConOrigArgTys con)
+ -- Newtypes are guaranteed vanilla, so OrigArgTys will do
+
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
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
+ = 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
- rep_ty = newTyConRhs tc
-
- go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc)
+ (_tc_tvs, rhs_ty) = newTyConRhs tc
+
+
+------------------------------------------------------
+buildDataCon :: Name -> Bool -> Bool
+ -> [StrictnessMark]
+ -> [Name] -- Field labels
+ -> [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 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 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
+mkDataConStupidTheta tycon arg_tys res_tys
+ | null stupid_theta = [] -- The common case
+ | otherwise = filter in_arg_tys stupid_theta
+ 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
+
+------------------------------------------------------
+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.
\end{code}
+------------------------------------------------------
\begin{code}
buildClass :: Name -> [TyVar] -> ThetaType
-> [FunDep TyVar] -- Functional dependencies
| (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
tycon
; tycon = mkClassTyCon tycon_name clas_kind tvs
- tc_vrcs dict_con
- clas flavour tc_isrec
+ tc_vrcs rhs clas tc_isrec
-- A class can be recursive, and in the case of newtypes
-- this matters. For example
-- class C a where { op :: C b => a -> b -> Int }
; clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
- ; flavour = case dict_component_tys of
- [rep_ty] -> NewTyCon (mkNewTyConRep tycon)
- other -> DataTyCon False -- Not an enumeration
+ ; rhs = case dict_component_tys of
+ [rep_ty] -> mkNewTyConRhs tycon dict_con
+ other -> mkDataTyConRhs [dict_con]
}
; return clas
})}
projects / ghc-hetmet.git / blobdiff