ConTag, fIRST_TAG,
mkDataCon,
dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon,
- dataConTyVars, dataConStupidTheta,
- dataConArgTys, dataConOrigArgTys, dataConResTy,
+ dataConTyVars, dataConResTys,
+ dataConStupidTheta,
+ dataConInstArgTys, dataConOrigArgTys, dataConInstResTy,
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType,
dataConStrictMarks, dataConExStricts,
#include "HsVersions.h"
-import Type ( Type, ThetaType, substTyWith, substTy, zipTopTvSubst,
+import Type ( Type, ThetaType, substTyWith, substTy, zipOpenTvSubst,
mkForAllTys, mkFunTys, mkTyConApp,
splitTyConApp_maybe,
mkPredTys, isStrictPred, pprType
)
-import TyCon ( TyCon, FieldLabel, tyConDataCons, tyConDataCons,
+import TyCon ( TyCon, FieldLabel, tyConDataCons,
isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
import Name ( Name, NamedThing(..), nameUnique )
-- Its type is of form
-- forall a1..an . t1 -> ... tm -> T a1..an
-- No existentials, no GADTs, nothing.
+ --
+ -- NB1: the order of the forall'd variables does matter;
+ -- for a vanilla constructor, we assume that if the result
+ -- type is (T t1 ... tn) then we can instantiate the constr
+ -- at types [t1, ..., tn]
+ --
+ -- NB2: a vanilla constructor can still be declared in GADT-style
+ -- syntax, provided its type looks like the above.
dcTyVars :: [TyVar], -- Universally-quantified type vars
-- for the data constructor.
- -- dcVanilla = True <=> The [TyVar] are identical to those of the parent tycon
- -- False <=> The [TyVar] are NOT NECESSARILY THE SAME AS THE TYVARS
- -- FOR THE PARENT TyCon. (With GADTs the data
- -- con might not even have the same number of
- -- type variables.)
+ -- See NB1 on dcVanilla for the conneciton between dcTyVars and dcResTys
+ --
+ -- In general, the dcTyVars are NOT NECESSARILY THE SAME AS THE TYVARS
+ -- FOR THE PARENT TyCon. With GADTs the data con might not even have
+ -- the same number of type variables.
+ -- [This is a change (Oct05): previously, vanilla datacons guaranteed to
+ -- have the same type variables as their parent TyCon, but that seems ugly.]
dcStupidTheta :: ThetaType, -- This is a "thinned" version of
-- the context of the data decl.
-- longer in the type of the wrapper Id, because
-- that makes it harder to use the wrap-id to rebuild
-- values after record selection or in generics.
+ --
+ -- Fact: the free tyvars of dcStupidTheta are a subset of
+ -- the free tyvars of dcResTys
+ -- Reason: dcStupidTeta is gotten by instantiating the
+ -- stupid theta from the tycon (see BuildTyCl.mkDataConStupidTheta)
dcTheta :: ThetaType, -- The existentially quantified stuff
dcOrigArgTys = arg_tys, dcTyCon = tycon, dcResTys = res_tys})
= (tyvars, theta, arg_tys, tycon, res_tys)
-dataConArgTys :: DataCon
- -> [Type] -- Instantiated at these types
- -- NB: these INCLUDE the existentially quantified arg types
- -> [Type] -- Needs arguments of these types
+dataConStupidTheta :: DataCon -> ThetaType
+dataConStupidTheta dc = dcStupidTheta dc
+
+dataConResTys :: DataCon -> [Type]
+dataConResTys dc = dcResTys dc
+
+dataConInstArgTys :: DataCon
+ -> [Type] -- Instantiated at these types
+ -- NB: these INCLUDE the existentially quantified arg types
+ -> [Type] -- Needs arguments of these types
-- NB: these INCLUDE the existentially quantified dict args
-- but EXCLUDE the data-decl context which is discarded
-- It's all post-flattening etc; this is a representation type
-dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars}) inst_tys
+dataConInstArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars}) inst_tys
= ASSERT( length tyvars == length inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
-dataConResTy :: DataCon -> [Type] -> Type
-dataConResTy (MkData {dcTyVars = tyvars, dcTyCon = tc, dcResTys = res_tys}) inst_tys
+dataConInstResTy :: DataCon -> [Type] -> Type
+dataConInstResTy (MkData {dcTyVars = tyvars, dcTyCon = tc, dcResTys = res_tys}) inst_tys
= ASSERT( length tyvars == length inst_tys )
- substTy (zipTopTvSubst tyvars inst_tys) (mkTyConApp tc res_tys)
- -- zipTopTvSubst because the res_tys can't contain any foralls
+ substTy (zipOpenTvSubst tyvars inst_tys) (mkTyConApp tc res_tys)
+ -- res_tys can't currently contain any foralls,
+ -- but might in future; hence zipOpenTvSubst
-- And the same deal for the original arg tys
--- This one only works for vanilla DataCons
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
-dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars, dcVanilla = is_vanilla}) inst_tys
- = ASSERT( is_vanilla )
- ASSERT( length tyvars == length inst_tys )
+dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars}) inst_tys
+ = ASSERT( length tyvars == length inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
-
-dataConStupidTheta :: DataCon -> ThetaType
-dataConStupidTheta dc = dcStupidTheta dc
\end{code}
These two functions get the real argument types of the constructor,
Just (tycon,ty_args)
| isProductTyCon tycon -- Includes check for non-existential,
-- and for constructors visible
- -> Just (tycon, ty_args, data_con, dataConArgTys data_con ty_args)
+ -> Just (tycon, ty_args, data_con, dataConInstArgTys data_con ty_args)
where
data_con = head (tyConDataCons tycon)
other -> Nothing
-- Predicates
isImplicitId, isDeadBinder, isDictId,
isExportedId, isLocalId, isGlobalId,
- isRecordSelector,
+ isRecordSelector, isNaughtyRecordSelector,
isClassOpId_maybe,
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
\begin{code}
recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
recordSelectorFieldLabel id = case globalIdDetails id of
- RecordSelId tycon lbl -> (tycon,lbl)
+ RecordSelId tycon lbl _ -> (tycon,lbl)
other -> panic "recordSelectorFieldLabel"
isRecordSelector id = case globalIdDetails id of
- RecordSelId _ _ -> True
+ RecordSelId {} -> True
other -> False
+isNaughtyRecordSelector id = case globalIdDetails id of
+ RecordSelId { sel_naughty = n } -> n
+ other -> False
+
isClassOpId_maybe id = case globalIdDetails id of
ClassOpId cls -> Just cls
_other -> Nothing
-- file, even if it's mentioned in some other interface unfolding.
isImplicitId id
= case globalIdDetails id of
- RecordSelId _ _ -> True
+ RecordSelId {} -> True
FCallId _ -> True
PrimOpId _ -> True
ClassOpId _ -> True
data GlobalIdDetails
= VanillaGlobal -- Imported from elsewhere, a default method Id.
- | RecordSelId TyCon FieldLabel -- The Id for a record selector
+ | RecordSelId -- The Id for a record selector
+ { sel_tycon :: TyCon
+ , sel_label :: FieldLabel
+ , sel_naughty :: Bool -- True <=> naughty
+ } -- See Note [Naughty record selectors]
+ -- with MkId.mkRecordSelectorId
| DataConWorkId DataCon -- The Id for a data constructor *worker*
| DataConWrapId DataCon -- The Id for a data constructor *wrapper*
ppr (ClassOpId _) = ptext SLIT("[ClassOp]")
ppr (PrimOpId _) = ptext SLIT("[PrimOp]")
ppr (FCallId _) = ptext SLIT("[ForeignCall]")
- ppr (RecordSelId _ _) = ptext SLIT("[RecSel]")
+ ppr (RecordSelId {}) = ptext SLIT("[RecSel]")
\end{code}
)
import TysWiredIn ( charTy, mkListTy )
import PrelRules ( primOpRules )
-import Type ( TyThing(..) )
+import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
- mkTyConApp, mkTyVarTys, mkClassPred, tcEqPred,
+ mkTyConApp, mkTyVarTys, mkClassPred,
mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
- tcSplitFunTys, tcSplitForAllTys
+ tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
)
import CoreUtils ( exprType )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
import Literal ( nullAddrLit, mkStringLit )
-import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
+import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
import Class ( Class, classTyCon, classSelIds )
import Var ( Id, TyVar, Var )
-import VarSet ( isEmptyVarSet )
+import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
import OccName ( mkOccFS, varName )
import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon, DataConIds(..), dataConTyVars,
- dataConFieldLabels, dataConRepArity,
- dataConRepArgTys, dataConRepType, dataConStupidTheta,
+ dataConFieldLabels, dataConRepArity, dataConResTys,
+ dataConRepArgTys, dataConRepType,
dataConSig, dataConStrictMarks, dataConExStricts,
- splitProductType, isVanillaDataCon
+ splitProductType, isVanillaDataCon, dataConFieldType,
+ dataConInstOrigArgTys
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
import Util ( dropList, isSingleton )
import Outputable
import FastString
-import ListSetOps ( assoc, assocMaybe )
-import List ( nubBy )
+import ListSetOps ( assoc )
\end{code}
%************************************************************************
unN :: forall b. N -> b -> b
unN = /\b -> \n:N -> (coerce (forall a. a->a) n)
+
+Note [Naughty record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A "naughty" field is one for which we can't define a record
+selector, because an existential type variable would escape. For example:
+ data T = forall a. MkT { x,y::a }
+We obviously can't define
+ x (MkT v _) = v
+Nevertheless we *do* put a RecordSelId into the type environment
+so that if the user tries to use 'x' as a selector we can bleat
+helpfully, rather than saying unhelpfully that 'x' is not in scope.
+Hence the sel_naughty flag, to identify record selcectors that don't really exist.
+
+In general, a field is naughty if its type mentions a type variable that
+isn't in the result type of the constructor.
+
+For GADTs, we require that all constructors with a common field 'f' have the same
+result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon]
+E.g.
+ data T where
+ T1 { f :: a } :: T [a]
+ T2 { f :: a, y :: b } :: T [a]
+and now the selector takes that type as its argument:
+ f :: forall a. T [a] -> a
+ f t = case t of
+ T1 { f = v } -> v
+ T2 { f = v } -> v
+Note the forall'd tyvars of the selector are just the free tyvars
+of the result type; there may be other tyvars in the constructor's
+type (e.g. 'b' in T2).
+
\begin{code}
-mkRecordSelId tycon field_label field_ty
+
+-- XXX - autrijus -
+-- Plan: 1. Determine naughtiness by comparing field type vs result type
+-- 2. Install naughty ones with selector_ty of type _|_ and fill in mzero for info
+-- 3. If it's not naughty, do the normal plan.
+
+mkRecordSelId :: TyCon -> FieldLabel -> Id
+mkRecordSelId tycon field_label
-- Assumes that all fields with the same field label have the same type
- = sel_id
+ | is_naughty = naughty_id
+ | otherwise = sel_id
where
- sel_id = mkGlobalId (RecordSelId tycon field_label) field_label selector_ty info
- data_cons = tyConDataCons tycon
- tyvars = tyConTyVars tycon -- These scope over the types in
- -- the FieldLabels of constructors of this type
- data_ty = mkTyConApp tycon tyvar_tys
- tyvar_tys = mkTyVarTys tyvars
-
- -- Very tiresomely, the selectors are (unnecessarily!) overloaded over
+ is_naughty = not (tyVarsOfType field_ty `subVarSet` tyvar_set)
+ sel_id_details = RecordSelId tycon field_label is_naughty
+
+ -- Escapist case here for naughty construcotrs
+ -- We give it no IdInfo, and a type of forall a.a (never looked at)
+ naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo
+ forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
+
+ -- Normal case starts here
+ sel_id = mkGlobalId sel_id_details field_label selector_ty info
+ data_cons = tyConDataCons tycon
+ data_cons_w_field = filter has_field data_cons -- Can't be empty!
+ has_field con = field_label `elem` dataConFieldLabels con
+
+ con1 = head data_cons_w_field
+ res_tys = dataConResTys con1
+ tyvar_set = tyVarsOfTypes res_tys
+ tyvars = varSetElems tyvar_set
+ data_ty = mkTyConApp tycon res_tys
+ field_ty = dataConFieldType con1 field_label
+
+ -- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over
-- just the dictionaries in the types of the constructors that contain
-- the relevant field. [The Report says that pattern matching on a
-- constructor gives the same constraints as applying it.] Urgh.
--
-- However, not all data cons have all constraints (because of
- -- TcTyDecls.thinContext). So we need to find all the data cons
+ -- BuildTyCl.mkDataConStupidTheta). So we need to find all the data cons
-- involved in the pattern match and take the union of their constraints.
- --
- -- NB: this code relies on the fact that DataCons are quantified over
- -- the identical type variables as their parent TyCon
- needed_preds = [pred | (DataAlt dc, _, _) <- the_alts, pred <- dataConStupidTheta dc]
- dict_tys = mkPredTys (nubBy tcEqPred needed_preds)
- n_dict_tys = length dict_tys
+ stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field)
+ n_stupid_dicts = length stupid_dict_tys
(field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
field_dict_tys = mkPredTys field_theta
selector_ty :: Type
selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $
- mkFunTys dict_tys $ mkFunTys field_dict_tys $
+ mkFunTys stupid_dict_tys $ mkFunTys field_dict_tys $
mkFunTy data_ty field_tau
- arity = 1 + n_dict_tys + n_field_dict_tys
+ arity = 1 + n_stupid_dicts + n_field_dict_tys
(strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
-- Use the demand analyser to work out strictness.
-- rather than n_dict_tys, because the latter gives an infinite loop:
-- n_dict tys depends on the_alts, which depens on arg_ids, which depends
-- on arity, which depends on n_dict tys. Sigh! Mega sigh!
- dict_ids = mkTemplateLocalsNum 1 dict_tys
- max_dict_tys = length (tyConStupidTheta tycon)
- field_dict_base = max_dict_tys + 1
- field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys
- dict_id_base = field_dict_base + n_field_dict_tys
- data_id = mkTemplateLocal dict_id_base data_ty
- arg_base = dict_id_base + 1
-
- alts = map mk_maybe_alt data_cons
- the_alts = catMaybes alts -- Already sorted by data-con
-
- no_default = all isJust alts -- No default needed
+ stupid_dict_ids = mkTemplateLocalsNum 1 stupid_dict_tys
+ max_stupid_dicts = length (tyConStupidTheta tycon)
+ field_dict_base = max_stupid_dicts + 1
+ field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys
+ dict_id_base = field_dict_base + n_field_dict_tys
+ data_id = mkTemplateLocal dict_id_base data_ty
+ arg_base = dict_id_base + 1
+
+ the_alts :: [CoreAlt]
+ the_alts = map mk_alt data_cons_w_field -- Already sorted by data-con
+ no_default = length data_cons == length data_cons_w_field -- No default needed
+
default_alt | no_default = []
| otherwise = [(DEFAULT, [], error_expr)]
| otherwise = MayHaveCafRefs
sel_rhs = mkLams tyvars $ mkLams field_tyvars $
- mkLams dict_ids $ mkLams field_dict_ids $
+ mkLams stupid_dict_ids $ mkLams field_dict_ids $
Lam data_id $ sel_body
sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id))
-- foo :: forall a. T -> a -> a
-- foo = /\a. \t:T. case t of { MkT f -> f a }
- mk_maybe_alt data_con
- = ASSERT( dc_tyvars == tyvars )
- -- The only non-vanilla case we allow is when we have an existential
- -- context that binds no type variables, thus
- -- data T a = (?v::Int) => MkT a
- -- In the non-vanilla case, the pattern must bind type variables and
+ mk_alt data_con
+ = -- In the non-vanilla case, the pattern must bind type variables and
-- the context stuff; hence the arg_prefix binding below
-
- case maybe_the_arg_id of
- Nothing -> Nothing
- Just the_arg_id -> Just (mkReboxingAlt uniqs data_con (arg_prefix ++ arg_src_ids) $
- mk_result (Var the_arg_id))
- where
- (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
- arg_src_ids = mkTemplateLocalsNum arg_base dc_arg_tys
- arg_base' = arg_base + length arg_src_ids
- arg_prefix | isVanillaDataCon data_con = []
- | otherwise = tyvars ++ mkTemplateLocalsNum arg_base' (mkPredTys dc_theta)
-
- unpack_base = arg_base' + length dc_theta
- uniqs = map mkBuiltinUnique [unpack_base..]
-
- maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_src_ids) field_label
- field_lbls = dataConFieldLabels data_con
+ mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids)
+ (mk_result (Var the_arg_id))
+ where
+ (arg_prefix, arg_ids)
+ | isVanillaDataCon data_con -- Instantiate from commmon base
+ = ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys))
+ | otherwise
+ = (dc_tyvars ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
+ mkTemplateLocalsNum arg_base' dc_arg_tys)
+
+ (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
+ arg_base' = arg_base + length dc_theta
+
+ unpack_base = arg_base' + length dc_theta
+ uniqs = map mkBuiltinUnique [unpack_base..]
+
+ the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
+ field_lbls = dataConFieldLabels data_con
error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
import Bag
import FastTypes
import Outputable
-import Util
#if __GLASGOW_HASKELL__ >= 404
import GLAEXTS ( Int# )
#endif
import Literal ( hashLiteral, literalType, litIsDupable,
litIsTrivial, isZeroLit, Literal( MachLabel ) )
-import DataCon ( DataCon, dataConRepArity, dataConArgTys,
+import DataCon ( DataCon, dataConRepArity, dataConInstArgTys,
isVanillaDataCon, dataConTyCon )
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
let
arity = tyConArity tc
val_args = drop arity args
- to_arg_tys = dataConArgTys dc tc_arg_tys
+ to_arg_tys = dataConInstArgTys dc tc_arg_tys
mk_coerce ty arg = mkCoerce ty arg
new_val_args = zipWith mk_coerce to_arg_tys val_args
in
import VarSet ( IdSet, mkVarSet, varSetElems,
intersectVarSet, minusVarSet, extendVarSetList,
unionVarSet, unionVarSets, elemVarSet )
-import SrcLoc ( Located(..), unLoc, noLoc, getLoc )
+import SrcLoc ( Located(..), unLoc, noLoc )
\end{code}
\begin{code}
mk_alt con
= newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
- -- This call to dataConArgTys won't work for existentials
+ -- This call to dataConInstOrigArgTys won't work for existentials
-- but existentials don't have record types anyway
let
val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat )
import PrelInfo ( pAT_ERROR_ID )
import TcType ( Type, tcTyConAppArgs )
-import Type ( splitFunTysN )
+import Type ( splitFunTysN, mkTyVarTys )
import TysWiredIn ( consDataCon, mkTupleTy, mkListTy,
tupleCon, parrFakeCon, mkPArrTy )
import BasicTypes ( Boxity(..) )
import ListSetOps ( runs )
-import SrcLoc ( noSrcSpan, noLoc, unLoc, Located(..) )
+import SrcLoc ( noLoc, unLoc, Located(..) )
import Util ( lengthExceeds, notNull )
import Name ( Name )
import Outputable
tidy1 v wrap (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty)
= returnDs (wrap, ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty)
where
- tidy_ps = PrefixCon (tidy_con con pat_ty ps)
+ tidy_ps = PrefixCon (tidy_con con ex_tvs pat_ty ps)
tidy1 v wrap (ListPat pats ty)
= returnDs (wrap, unLoc list_ConPat)
= returnDs (wrap, non_interesting_pat)
-tidy_con data_con pat_ty (PrefixCon ps) = ps
-tidy_con data_con pat_ty (InfixCon p1 p2) = [p1,p2]
-tidy_con data_con pat_ty (RecCon rpats)
+tidy_con data_con ex_tvs pat_ty (PrefixCon ps) = ps
+tidy_con data_con ex_tvs pat_ty (InfixCon p1 p2) = [p1,p2]
+tidy_con data_con ex_tvs pat_ty (RecCon rpats)
| null rpats
= -- Special case for C {}, which can be used for
-- a constructor that isn't declared to have
map (noLoc . WildPat) con_arg_tys'
| otherwise
- = ASSERT( isVanillaDataCon data_con )
- -- We're in a record case, so the data con must be vanilla
- -- and hence no existentials to worry about
- map mk_pat tagged_arg_tys
+ = map mk_pat tagged_arg_tys
where
-- Boring stuff to find the arg-tys of the constructor
- inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque
+ inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty -- Newtypes must be opaque
+ | otherwise = mkTyVarTys ex_tvs
+
con_arg_tys' = dataConInstOrigArgTys data_con inst_tys
tagged_arg_tys = con_arg_tys' `zip` dataConFieldLabels data_con
import HsSyn ( Pat(..), HsConDetails(..) )
import DsBinds ( dsLHsBinds )
-import DataCon ( isVanillaDataCon, dataConTyVars, dataConOrigArgTys )
+import DataCon ( isVanillaDataCon, dataConTyVars, dataConInstOrigArgTys )
import TcType ( tcTyConAppArgs )
import Type ( substTys, zipTopTvSubst, mkTyVarTys )
import CoreSyn
-- Get the arg types, which we use to type the new vars
-- to match on, from the "outside"; the types of pats1 may
-- be more refined, and hence won't do
- arg_tys = substTys (zipTopTvSubst (dataConTyVars con) inst_tys)
- (dataConOrigArgTys con)
+ arg_tys = dataConInstOrigArgTys con inst_tys
inst_tys | isVanillaDataCon con = tcTyConAppArgs pat_ty -- Newtypes opaque!
| otherwise = mkTyVarTys tvs1
\end{code}
DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
- ConDecl(..), LConDecl,
+ ConDecl(..), ResType(..), LConDecl,
DeprecDecl(..), LDeprecDecl,
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
tcdName, tyClDeclNames, tyClDeclTyVars,
import Class ( FunDep )
import Outputable
import Util ( count )
-import SrcLoc ( Located(..), unLoc )
+import SrcLoc ( Located(..), unLoc, noLoc )
import FastString
\end{code}
-- (only for the 'where' form)
tcdCons :: [LConDecl name], -- Data constructors
- -- For data T a = T1 | T2 a the LConDecls are all ConDecls
- -- For data T a where { T1 :: T a } the LConDecls are all GadtDecls
+ -- For data T a = T1 | T2 a the LConDecls all have ResTyH98
+ -- For data T a where { T1 :: T a } the LConDecls all have ResTyGADT
tcdDerivs :: Maybe [LHsType name]
-- Derivings; Nothing => not specified
-> SDoc
pp_decl_head context thing tyvars
= hsep [pprHsContext context, ppr thing, interppSP tyvars]
-
-pp_condecls cs@(L _ (GadtDecl _ _) : _) -- In GADT syntax
+pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
= hang (ptext SLIT("where")) 2 (vcat (map ppr cs))
pp_condecls cs -- In H98 syntax
= equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))
type LConDecl name = Located (ConDecl name)
data ConDecl name
- = ConDecl (Located name) -- Constructor name; this is used for the
- -- DataCon itself, and for the user-callable wrapper Id
-
- [LHsTyVarBndr name] -- Existentially quantified type variables
- (LHsContext name) -- ...and context
- -- If both are empty then there are no existentials
- (HsConDetails name (LBangType name))
-
- | GadtDecl (Located name) -- Constructor name; this is used for the
- -- DataCon itself, and for the user-callable wrapper Id
- (LHsType name) -- Constructor type; it may have HsBangs on the
- -- argument types
+ = ConDecl
+ { con_name :: Located name -- Constructor name; this is used for the
+ -- DataCon itself, and for the user-callable wrapper Id
+
+ , con_explicit :: HsExplicitForAll -- Is there an user-written forall? (cf. HStypes.HsForAllTy)
+
+ , con_qvars :: [LHsTyVarBndr name] -- ResTyH98: the constructor's existential type variables
+ -- ResTyGADT: all the constructor's quantified type variables
+
+ , con_cxt :: LHsContext name -- The context. This *does not* include the
+ -- "stupid theta" which lives only in the TyData decl
+
+ , con_details :: HsConDetails name (LBangType name) -- The main payload
+
+ , con_res :: ResType name -- Result type of the constructor
+ }
+
+data ResType name
+ = ResTyH98 -- Constructor was declared using Haskell 98 syntax
+ | ResTyGADT (LHsType name) -- Constructor was declared using GADT-style syntax,
+ -- and here is its result type
\end{code}
\begin{code}
conDeclsNames cons
= snd (foldl do_one ([], []) cons)
where
- do_one (flds_seen, acc) (ConDecl lname _ _ (RecCon flds))
+ do_one (flds_seen, acc) (ConDecl { con_name = lname, con_details = RecCon flds })
= (map unLoc new_flds ++ flds_seen, lname : [f | f <- new_flds] ++ acc)
where
new_flds = [ f | (f,_) <- flds, not (unLoc f `elem` flds_seen) ]
- do_one (flds_seen, acc) (ConDecl lname _ _ _)
- = (flds_seen, lname:acc)
-
--- gaw 2004
- do_one (flds_seen, acc) (GadtDecl lname _)
- = (flds_seen, lname:acc)
+ do_one (flds_seen, acc) c
+ = (flds_seen, (con_name c):acc)
conDetailsTys details = map getBangType (hsConArgs details)
\end{code}
\begin{code}
instance (OutputableBndr name) => Outputable (ConDecl name) where
- ppr (ConDecl con tvs cxt con_details)
- = sep [pprHsForAll Explicit tvs cxt, ppr_con_details con con_details]
- ppr (GadtDecl con ty)
- = ppr con <+> dcolon <+> ppr ty
-
-ppr_con_details con (InfixCon ty1 ty2)
- = hsep [ppr ty1, pprHsVar con, ppr ty2]
-
--- ConDecls generated by MkIface.ifaceTyThing always have a PrefixCon, even
--- if the constructor is an infix one. This is because in an interface file
--- we don't distinguish between the two. Hence when printing these for the
--- user, we need to parenthesise infix constructor names.
-ppr_con_details con (PrefixCon tys)
- = hsep (pprHsVar con : map ppr tys)
-
-ppr_con_details con (RecCon fields)
- = ppr con <+> braces (sep (punctuate comma (map ppr_field fields)))
+ ppr = pprConDecl
+
+pprConDecl (ConDecl con expl tvs cxt details ResTyH98)
+ = sep [pprHsForAll expl tvs cxt, ppr_details con details]
where
- ppr_field (n, ty) = ppr n <+> dcolon <+> ppr ty
+ ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsVar con, ppr t2]
+ ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
+ ppr_details con (RecCon fields) = ppr con <+> ppr_fields fields
+
+pprConDecl (ConDecl con expl tvs cxt details (ResTyGADT res_ty))
+ = sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_details details]
+ where
+ ppr_details (PrefixCon arg_tys) = dcolon <+> ppr (foldr mk_fun_ty res_ty arg_tys)
+ ppr_details (RecCon fields) = ppr fields <+> dcolon <+> ppr res_ty
+ ppr_details (PrefixCon _) = pprPanic "pprConDecl" (ppr con)
+
+ mk_fun_ty a b = noLoc (HsFunTy a b)
+ppr_fields fields = braces (sep (punctuate comma (map ppr_field fields)))
+ppr_field (n, ty) = ppr n <+> dcolon <+> ppr ty
\end{code}
%************************************************************************
-- identify the splice
mkHsString s = HsString (mkFastString s)
+
+-------------
+userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
+userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
\end{code}
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 )
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}
= 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 }
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
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}
vanillaIdInfo, newStrictnessInfo )
import Class ( Class )
import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon )
-import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon )
+import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConInstArgTys, isVanillaDataCon )
import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
import Var ( TyVar, mkTyVar, tyVarKind )
import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName,
arg_names <- newIfaceNames arg_occs
; let tyvars = [ mkTyVar name (tyVarKind tv)
| (name,tv) <- arg_names `zip` dataConTyVars con]
- arg_tys = dataConArgTys con (mkTyVarTys tyvars)
+ arg_tys = dataConInstArgTys con (mkTyVarTys tyvars)
id_names = dropList tyvars arg_names
arg_ids = ASSERT2( equalLength id_names arg_tys,
ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys )
tcVanillaAlt data_con inst_tys arg_occs rhs
= do { arg_names <- newIfaceNames arg_occs
- ; let arg_tys = dataConArgTys data_con inst_tys
+ ; let arg_tys = dataConInstArgTys data_con inst_tys
; let arg_ids = ASSERT2( equalLength arg_names arg_tys,
ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs )
zipWith mkLocalId arg_names arg_tys
-- Datatype declarations
newconstr :: { LConDecl RdrName }
- : conid atype { LL $ ConDecl $1 [] (noLoc []) (PrefixCon [$2]) }
+ : conid atype { LL $ ConDecl $1 Explicit [] (noLoc []) (PrefixCon [$2]) ResTyH98 }
| conid '{' var '::' ctype '}'
- { LL $ ConDecl $1 [] (noLoc []) (RecCon [($3, $5)]) }
+ { LL $ ConDecl $1 Explicit [] (noLoc []) (RecCon [($3, $5)]) ResTyH98 }
gadt_constrlist :: { Located [LConDecl RdrName] }
: '{' gadt_constrs '}' { LL (unLoc $2) }
| gadt_constrs ';' { $1 }
| gadt_constr { L1 [$1] }
+-- We allow the following forms:
+-- C :: Eq a => a -> T a
+-- C :: forall a. Eq a => !a -> T a
+-- D { x,y :: a } :: T a
+-- forall a. Eq a => D { x,y :: a } :: T a
+
gadt_constr :: { LConDecl RdrName }
: con '::' sigtype
- { LL (GadtDecl $1 $3) }
+ { LL (mkGadtDecl $1 $3) }
+ -- Syntax: Maybe merge the record stuff with the single-case above?
+ -- (to kill the mostly harmless reduce/reduce error)
+ -- XXX revisit autrijus
+ | constr_stuff_record '::' sigtype
+ { let (con,details) = unLoc $1 in
+ LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3)) }
+{-
+ | forall context '=>' constr_stuff_record '::' sigtype
+ { let (con,details) = unLoc $4 in
+ LL (ConDecl con Implicit (unLoc $1) $2 details (ResTyGADT $6)) }
+ | forall constr_stuff_record '::' sigtype
+ { let (con,details) = unLoc $2 in
+ LL (ConDecl con Implicit (unLoc $1) (noLoc []) details (ResTyGADT $4)) }
+-}
+
constrs :: { Located [LConDecl RdrName] }
: {- empty; a GHC extension -} { noLoc [] }
constr :: { LConDecl RdrName }
: forall context '=>' constr_stuff
{ let (con,details) = unLoc $4 in
- LL (ConDecl con (unLoc $1) $2 details) }
+ LL (ConDecl con Explicit (unLoc $1) $2 details ResTyH98) }
| forall constr_stuff
{ let (con,details) = unLoc $2 in
- LL (ConDecl con (unLoc $1) (noLoc []) details) }
+ LL (ConDecl con Explicit (unLoc $1) (noLoc []) details ResTyH98) }
forall :: { Located [LHsTyVarBndr RdrName] }
: 'forall' tv_bndrs '.' { LL $2 }
| oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL }
| btype conop btype { LL ($2, InfixCon $1 $3) }
+constr_stuff_record :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) }
+ : oqtycon '{' '}' {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) }
+ | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) }
+
fielddecls :: { [([Located RdrName], LBangType RdrName)] }
: fielddecl ',' fielddecls { unLoc $1 : $3 }
| fielddecl { [unLoc $1] }
: {- empty -} { (\ tc_occ -> []) }
| '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
con_info = PrefixCon [toHsType $2] }
- in [noLoc $ ConDecl (noLoc dc_name) []
- (noLoc []) con_info]) }
+ in [noLoc $ ConDecl (noLoc dc_name) Explicit []
+ (noLoc []) con_info ResTyH98]) }
cons1 :: { [LConDecl RdrName] }
: con { [$1] }
con :: { LConDecl RdrName }
: d_pat_occ attv_bndrs hs_atys
- { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3)}
+ { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit $2 (noLoc []) (PrefixCon $3) ResTyH98}
| d_pat_occ '::' ty
- { noLoc $ GadtDecl (noLoc (mkRdrUnqual $1)) (toHsType $3) }
+ -- XXX - autrijus - $3 needs to be split into argument and return types!
+ -- also not sure whether the [] below (quantified vars) appears.
+ -- also the "PrefixCon []" is wrong.
+ -- also we want to munge $3 somehow.
+ -- extractWhatEver to unpack ty into the parts to ConDecl
+ -- XXX - define it somewhere in RdrHsSyn
+ { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) Explicit [] (noLoc []) (PrefixCon []) (undefined $3) }
attv_bndrs :: { [LHsTyVarBndr RdrName] }
: {- empty -} { [] }
-- -> (FastString, RdrName, RdrNameHsType)
-- -> P RdrNameHsDecl
mkExtName, -- RdrName -> CLabelString
+ mkGadtDecl, -- Located RdrName -> LHsType RdrName -> ConDecl RdrName
-- Bunch of functions in the parser monad for
-- checking and constructing values
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPred, -- HsType -> P HsPred
- checkTyClHdr,
- checkSynHdr,
+ checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+ checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
checkInstType, -- HsType -> P HsType
checkPattern, -- HsExp -> P HsPat
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
checkValSig (L l other) ty
= parseError l "Type signature given for an expression"
+mkGadtDecl
+ :: Located RdrName
+ -> LHsType RdrName -- assuming HsType
+ -> ConDecl RdrName
+mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = ConDecl
+ { con_name = name
+ , con_explicit = Implicit
+ , con_qvars = qvars
+ , con_cxt = cxt
+ , con_details = PrefixCon args
+ , con_res = ResTyGADT res
+ }
+ where
+ (args, res) = splitHsFunType ty
+mkGadtDecl name ty = ConDecl
+ { con_name = name
+ , con_explicit = Implicit
+ , con_qvars = []
+ , con_cxt = noLoc []
+ , con_details = PrefixCon args
+ , con_res = ResTyGADT res
+ }
+ where
+ (args, res) = splitHsFunType ty
+
-- A variable binding is parsed as a FunBind.
isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
hsSigFVs other = emptyFVs
----------------
-conDeclFVs (L _ (ConDecl _ tyvars context details))
+-- XXX - autrijus - handle return type for GADT
+conDeclFVs (L _ (ConDecl _ _ tyvars context details _))
= delFVs (map hsLTyVarName tyvars) $
extractHsCtxtTyNames context `plusFV`
conDetailsFVs details
+
+{-
-- gaw 2004
conDeclFVs (L _ (GadtDecl _ ty))
= extractHsTyNames ty
+-}
conDetailsFVs (PrefixCon btys) = plusFVs (map bangTyFVs btys)
conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2
import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv )
-import RdrHsSyn ( extractGenericPatTyVars )
+import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
import DynFlags ( DynFlag(..) )
import Maybes ( seqMaybe )
import Maybe ( isNothing )
+import BasicTypes ( Boxity(..) )
\end{code}
@rnSourceDecl@ `renames' declarations.
deriv_fvs) }
| otherwise -- GADT
- = ASSERT( null (unLoc context) )
- do { tycon' <- lookupLocatedTopBndrRn tycon
- ; tyvars' <- bindTyVarsRn data_doc tyvars
+ = do { tycon' <- lookupLocatedTopBndrRn tycon
+ ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
+ ; tyvars' <- bindTyVarsRn data_doc tyvars
(\ tyvars' -> return tyvars')
-- For GADTs, the type variables in the declaration
-- do not scope over the constructor signatures
where
is_vanilla = case condecls of -- Yuk
[] -> True
- L _ (ConDecl {}) : _ -> True
+ L _ (ConDecl { con_res = ResTyH98 }) : _ -> True
other -> False
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
con_names = map con_names_helper condecls
- con_names_helper (L _ (ConDecl n _ _ _)) = n
- con_names_helper (L _ (GadtDecl n _)) = n
+ con_names_helper (L _ c) = con_name c
rn_derivs Nothing = returnM (Nothing, emptyFVs)
rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
meth_doc = text "In the default-methods for class" <+> ppr cname
cls_doc = text "In the declaration for class" <+> ppr cname
sig_doc = text "In the signatures for class" <+> ppr cname
+
+badGadtStupidTheta tycon
+ = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
+ ptext SLIT("(You can put a context on each contructor, though.)")]
\end{code}
%*********************************************************
= mappM (wrapLocM rnConDecl) condecls
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
-rnConDecl (ConDecl name tvs cxt details)
- = addLocM checkConName name `thenM_`
- lookupLocatedTopBndrRn name `thenM` \ new_name ->
-
- bindTyVarsRn doc tvs $ \ new_tyvars ->
- rnContext doc cxt `thenM` \ new_context ->
- rnConDetails doc details `thenM` \ new_details ->
- returnM (ConDecl new_name new_tyvars new_context new_details)
- where
- doc = text "In the definition of data constructor" <+> quotes (ppr name)
+rnConDecl (ConDecl name expl tvs cxt details res_ty)
+ = do { addLocM checkConName name
-rnConDecl (GadtDecl name ty)
- = addLocM checkConName name `thenM_`
- lookupLocatedTopBndrRn name `thenM` \ new_name ->
- rnHsSigType doc ty `thenM` \ new_ty ->
- returnM (GadtDecl new_name new_ty)
+ ; new_name <- lookupLocatedTopBndrRn name
+ ; name_env <- getLocalRdrEnv
+
+ -- For H98 syntax, the tvs are the existential ones
+ -- For GADT syntax, the tvs are all the quantified tyvars
+ -- Hence the 'filter' in the ResTyH98 case only
+ ; let not_in_scope = not . (`elemLocalRdrEnv` name_env) . unLoc
+ arg_tys = hsConArgs details
+ implicit_tvs = case res_ty of
+ ResTyH98 -> filter not_in_scope $
+ get_rdr_tvs arg_tys
+ ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
+ tvs' = case expl of
+ Explicit -> tvs
+ Implicit -> userHsTyVarBndrs implicit_tvs
+
+ ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
+ { new_context <- rnContext doc cxt
+ ; new_details <- rnConDetails doc details
+ ; new_res_ty <- rnConResult doc res_ty
+ ; let rv = ConDecl new_name expl new_tyvars new_context new_details new_res_ty
+ ; traceRn (text "****** - autrijus" <> ppr rv)
+ ; return rv } }
where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
+ get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
+
+rnConResult _ ResTyH98 = return ResTyH98
+rnConResult doc (ResTyGADT ty) = do
+ ty' <- rnHsSigType doc ty
+ return $ ResTyGADT ty'
rnConDetails doc (PrefixCon tys)
= mappM (rnLHsType doc) tys `thenM` \ new_tys ->
-- class signatures:
-- class C a where { op :: a -> a }
forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned
- tyvar_bndrs = [ L loc (UserTyVar v) | (L loc v) <- forall_tyvars ]
+ tyvar_bndrs = userHsTyVarBndrs forall_tyvars
in
rnForAll doc Implicit tyvar_bndrs ctxt ty
)
import Name ( mkSysTvName )
import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
-import DataCon ( dataConRepArity, dataConTyVars, dataConArgTys, isVanillaDataCon )
+import DataCon ( dataConRepArity, dataConTyVars, dataConInstArgTys, isVanillaDataCon )
import Var ( tyVarKind, mkTyVar )
import VarSet
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
mk_args missing_con inst_tys
= mk_tv_bndrs missing_con inst_tys `thenSmpl` \ (tv_bndrs, inst_tys') ->
getUniquesSmpl `thenSmpl` \ id_uniqs ->
- let arg_tys = dataConArgTys missing_con inst_tys'
+ let arg_tys = dataConInstArgTys missing_con inst_tys'
arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
in
returnSmpl (tv_bndrs ++ arg_ids)
import VarSet
import Name ( Name, NamedThing(..), nameOccName )
import NameEnv
-import Unify ( tcMatchTyX, MatchEnv(..) )
+import Unify ( ruleMatchTyX, MatchEnv(..) )
import BasicTypes ( Activation, CompilerPhase, isActive )
import Outputable
import FastString
\begin{code}
------------------------------------------
match_ty menv (tv_subst, id_subst) ty1 ty2
- = do { tv_subst' <- Unify.tcMatchTyX menv tv_subst ty1 ty2
+ = do { tv_subst' <- Unify.ruleMatchTyX menv tv_subst ty1 ty2
; return (tv_subst', id_subst) }
\end{code}
import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
import Id ( Id, idType, isLocalId )
import VarSet
-import DataCon ( DataCon, dataConArgTys, dataConRepType )
+import DataCon ( DataCon, dataConInstArgTys, dataConRepType )
import CoreSyn ( AltCon(..) )
import PrimOp ( primOpType )
import Literal ( literalType )
not (isNewTyCon tycon) ->
let
cons = tyConDataCons tycon
- arg_tys = dataConArgTys con tys_applied
+ arg_tys = dataConInstArgTys con tys_applied
-- This almost certainly does not work for existential constructors
in
checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( badFieldCon, refineTyVars )
import TcMType ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType )
-import TcType ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType,
- tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
+import TcType ( TcTyVar, TcType, TcSigmaType, TcRhoType,
+ tcSplitFunTys, mkTyVarTys,
isSigmaTy, mkFunTy, mkTyConApp, tyVarsOfTypes, isLinearPred,
tcSplitSigmaTy, tidyOpenType
)
import Kind ( openTypeKind, liftedTypeKind, argTypeKind )
-import Id ( idType, recordSelectorFieldLabel, isRecordSelector )
+import Id ( idType, recordSelectorFieldLabel, isRecordSelector, isNaughtyRecordSelector )
import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks,
- dataConWrapId )
+ dataConWrapId, isVanillaDataCon, dataConTyVars, dataConOrigArgTys )
import Name ( Name )
-import TyCon ( TyCon, FieldLabel, tyConTyVars, tyConStupidTheta,
- tyConDataCons, tyConFields )
-import Type ( zipTopTvSubst, substTheta, substTy )
+import TyCon ( TyCon, FieldLabel, tyConStupidTheta, tyConArity, tyConDataCons )
+import Type ( substTheta, substTy )
import Var ( tyVarKind )
import VarSet ( emptyVarSet, elemVarSet )
import TysWiredIn ( boolTy, parrTyCon, tupleTyCon )
enumFromToName, enumFromThenToName,
enumFromToPName, enumFromThenToPName, negateName
)
-import ListSetOps ( minusList )
import DynFlags
import StaticFlags ( opt_NoMethodSharing )
import HscTypes ( TyThing(..) )
import SrcLoc ( Located(..), unLoc, getLoc )
import Util
+import ListSetOps ( assocMaybe )
+import Maybes ( catMaybes )
import Outputable
import FastString
-
-#ifdef DEBUG
-import TyCon ( isAlgTyCon )
-#endif
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcExpr expr@(RecordCon con@(L loc con_name) _ rbinds) res_ty
- = addErrCtxt (recordConCtxt expr) $
- addLocM (tcId (OccurrenceOf con_name)) con `thenM` \ (con_expr, _, con_tau) ->
- let
- (_, record_ty) = tcSplitFunTys con_tau
- (tycon, ty_args) = tcSplitTyConApp record_ty
- in
- ASSERT( isAlgTyCon tycon )
- zapExpectedTo res_ty record_ty `thenM_`
+tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
+ = addErrCtxt (recordConCtxt expr) $
+ do { (con_expr, _, con_tau) <- setSrcSpan loc $
+ tcId (OccurrenceOf con_name) con_name
+ ; data_con <- tcLookupDataCon con_name
- -- Check that the record bindings match the constructor
- -- con_name is syntactically constrained to be a data constructor
- tcLookupDataCon con_name `thenM` \ data_con ->
- let
- bad_fields = badFields rbinds data_con
- in
- if notNull bad_fields then
- mappM (addErrTc . badFieldCon data_con) bad_fields `thenM_`
- failM -- Fail now, because tcRecordBinds will crash on a bad field
- else
+ ; let (arg_tys, record_ty) = tcSplitFunTys con_tau
+ flds_w_tys = zipEqual "tcExpr RecordCon" (dataConFieldLabels data_con) arg_tys
+
+ -- Make the result type line up
+ ; zapExpectedTo res_ty record_ty
-- Typecheck the record bindings
- tcRecordBinds tycon ty_args rbinds `thenM` \ rbinds' ->
+ ; rbinds' <- tcRecordBinds data_con flds_w_tys rbinds
-- Check for missing fields
- checkMissingFields data_con rbinds `thenM_`
+ ; checkMissingFields data_con rbinds
- returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds')
+ ; returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
-- The main complication with RecordUpd is that we need to explicitly
-- handle the *non-updated* fields. Consider:
sel_id : _ = sel_ids
(tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
data_cons = tyConDataCons tycon -- it's not a field label
- tycon_tyvars = tyConTyVars tycon -- The data cons use the same type vars
in
- tcInstTyVars tycon_tyvars `thenM` \ (_, result_inst_tys, inst_env) ->
+
+ -- Check that all data cons are vanilla. Doing record updates on GADTs
+ -- and/or existentials is more than my tiny brain can cope with today
+ -- [I think we might be able to manage if none of the selectors is naughty,
+ -- but that's for another day.]
+ checkTc (all isVanillaDataCon data_cons)
+ (nonVanillaUpd tycon) `thenM_`
-- STEP 2
-- Check that at least one constructor has all the named fields
checkTc (any (null . badFields rbinds) data_cons)
(badFieldsUpd rbinds) `thenM_`
- -- STEP 3
- -- Typecheck the update bindings.
- -- (Do this after checking for bad fields in case there's a field that
- -- doesn't match the constructor.)
- let
- result_record_ty = mkTyConApp tycon result_inst_tys
- in
- zapExpectedTo res_ty result_record_ty `thenM_`
- tcRecordBinds tycon result_inst_tys rbinds `thenM` \ rbinds' ->
-
-- STEP 4
-- Use the un-updated fields to find a vector of booleans saying
-- which type arguments must be the same in updatee and result.
-- have FieldLabels abstracted over the same tyvars.
let
upd_field_lbls = recBindFields rbinds
- con_field_lbls_s = map dataConFieldLabels data_cons
-- A constructor is only relevant to this process if
- -- it contains all the fields that are being updated
- relevant_field_lbls_s = filter is_relevant con_field_lbls_s
- is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
+ -- it contains *all* the fields that are being updated
+ relevant_cons = filter is_relevant data_cons
+ is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls
+ con1 = head relevant_cons -- A representative constructor
+ con1_tyvars = dataConTyVars con1
+ con1_fld_tys = dataConFieldLabels con1 `zip` dataConOrigArgTys con1
+ common_tyvars = tyVarsOfTypes [ty | (fld,ty) <- con1_fld_tys
+ , not (fld `elem` upd_field_lbls) ]
- non_upd_field_lbls = concat relevant_field_lbls_s `minusList` upd_field_lbls
- common_tyvars = tyVarsOfTypes [ty | (fld,ty,_) <- tyConFields tycon,
- fld `elem` non_upd_field_lbls]
is_common_tv tv = tv `elemVarSet` common_tyvars
mk_inst_ty tv result_inst_ty
| is_common_tv tv = returnM result_inst_ty -- Same as result type
| otherwise = newTyFlexiVarTy (tyVarKind tv) -- Fresh type, of correct kind
in
- zipWithM mk_inst_ty tycon_tyvars result_inst_tys `thenM` \ inst_tys ->
+ tcInstTyVars con1_tyvars `thenM` \ (_, result_inst_tys, inst_env) ->
+ zipWithM mk_inst_ty con1_tyvars result_inst_tys `thenM` \ inst_tys ->
+
+ -- STEP 3
+ -- Typecheck the update bindings.
+ -- (Do this after checking for bad fields in case there's a field that
+ -- doesn't match the constructor.)
+ let
+ result_record_ty = mkTyConApp tycon result_inst_tys
+ inst_fld_tys = [(fld, substTy inst_env ty) | (fld, ty) <- con1_fld_tys]
+ in
+ zapExpectedTo res_ty result_record_ty `thenM_`
+ tcRecordBinds con1 inst_fld_tys rbinds `thenM` \ rbinds' ->
-- STEP 5
-- Typecheck the expression to be updated
let
- record_ty = mkTyConApp tycon inst_tys
+ record_ty = ASSERT( length inst_tys == tyConArity tycon )
+ mkTyConApp tycon inst_tys
+ -- This is one place where the isVanilla check is important
+ -- So that inst_tys matches the tycon
in
tcCheckRho record_expr record_ty `thenM` \ record_expr' ->
-- do pattern matching over the data cons.
--
-- What dictionaries do we need?
- -- We just take the context of the type constructor
+ -- We just take the context of the first data constructor
+ -- This isn't right, but I just can't bear to union up all the relevant ones
let
theta' = substTheta inst_env (tyConStupidTheta tycon)
in
-- Remember to chuck in the constraints from the "silly context"
; return (expr, tvs, tau) }
+ ; AGlobal (AnId id) | isNaughtyRecordSelector id
+ -> failWithTc (naughtyRecordSel id)
; AGlobal (AnId id) -> instantiate id
-- A global cannot possibly be ill-staged
-- nor does it need the 'lifting' treatment
\begin{code}
tcRecordBinds
- :: TyCon -- Type constructor for the record
- -> [TcType] -- Args of this type constructor
+ :: DataCon
+ -> [(FieldLabel,TcType)] -- Expected type for each field
-> HsRecordBinds Name
-> TcM (HsRecordBinds TcId)
-tcRecordBinds tycon ty_args rbinds
- = mappM do_bind rbinds
+tcRecordBinds data_con flds_w_tys rbinds
+ = do { mb_binds <- mappM do_bind rbinds
+ ; return (catMaybes mb_binds) }
where
- tenv = zipTopTvSubst (tyConTyVars tycon) ty_args
-
do_bind (L loc field_lbl, rhs)
+ | Just field_ty <- assocMaybe flds_w_tys field_lbl
= addErrCtxt (fieldCtxt field_lbl) $
- let
- field_ty = tyConFieldType tycon field_lbl
- field_ty' = substTy tenv field_ty
- in
- tcCheckSigma rhs field_ty' `thenM` \ rhs' ->
- tcLookupId field_lbl `thenM` \ sel_id ->
- ASSERT( isRecordSelector sel_id )
- returnM (L loc sel_id, rhs')
-
-tyConFieldType :: TyCon -> FieldLabel -> Type
-tyConFieldType tycon field_lbl
- = case [ty | (f,ty,_) <- tyConFields tycon, f == field_lbl] of
- [] -> panic "tyConFieldType"
- (ty:other) -> ASSERT( null other) ty
- -- This lookup and assertion will surely succeed, because
- -- we check that the fields are indeed record selectors
- -- before calling tcRecordBinds
+ do { rhs' <- tcCheckSigma rhs field_ty
+ ; sel_id <- tcLookupId field_lbl
+ ; ASSERT( isRecordSelector sel_id )
+ return (Just (L loc sel_id, rhs')) }
+ | otherwise
+ = do { addErrTc (badFieldCon data_con field_lbl)
+ ; return Nothing }
badFields rbinds data_con
= filter (not . (`elem` field_names)) (recBindFields rbinds)
where
the_app = foldl mkHsApp fun args -- Used in error messages
+nonVanillaUpd tycon
+ = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon)
+ <+> ptext SLIT("is not (yet) supported"),
+ ptext SLIT("Use pattern-matching instead")]
badFieldsUpd rbinds
= hang (ptext SLIT("No constructor has all these fields:"))
4 (pprQuotedList (recBindFields rbinds))
recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
+naughtyRecordSel sel_id
+ = ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+>
+ ptext SLIT("as a function due to escaped type variables") $$
+ ptext SLIT("Probably fix: use pattern-matching syntax instead")
+
notSelector field
= hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
-- Typechecking kinded types
tcHsKindedContext, tcHsKindedType, tcHsBangType,
- tcTyVarBndrs, dsHsType, tcLHsConSig, tcDataKindSig,
+ tcTyVarBndrs, dsHsType, tcLHsConResTy,
+ tcDataKindSig,
tcHsPatSigType, tcAddLetBoundTyVars,
#include "HsVersions.h"
-import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, HsBang,
+import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr,
LHsContext, HsPred(..), LHsPred, LHsBinds, HsExplicitForAll(..),
- getBangStrictness, collectSigTysFromHsBinds )
+ collectSigTysFromHsBinds )
import RnHsSyn ( extractHsTyVars )
import TcRnMonad
import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnvTvs,
import NameEnv
import PrelNames ( genUnitTyConName )
import TysWiredIn ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon )
-import Bag ( bagToList )
import BasicTypes ( Boxity(..), RecFlag )
import SrcLoc ( Located(..), unLoc, noLoc, srcSpanStart )
import UniqSupply ( uniqsFromSupply )
GADT constructor signatures
\begin{code}
-tcLHsConSig :: LHsType Name
- -> TcM ([TcTyVar], TcThetaType,
- [HsBang], [TcType],
- TyCon, [TcType])
--- Take apart the type signature for a data constructor
--- The difference is that there can be bangs at the top of
--- the argument types, and kind-checking is the right place to check
-tcLHsConSig sig@(L span (HsForAllTy exp tv_names ctxt ty))
- = setSrcSpan span $
- addErrCtxt (gadtSigCtxt sig) $
- tcTyVarBndrs tv_names $ \ tyvars ->
- do { theta <- mappM dsHsLPred (unLoc ctxt)
- ; (bangs, arg_tys, tc, res_tys) <- tc_con_sig_tau ty
- ; return (tyvars, theta, bangs, arg_tys, tc, res_tys) }
-tcLHsConSig ty
- = do { (bangs, arg_tys, tc, res_tys) <- tc_con_sig_tau ty
- ; return ([], [], bangs, arg_tys, tc, res_tys) }
-
---------
-tc_con_sig_tau (L _ (HsFunTy arg ty))
- = do { (bangs, arg_tys, tc, res_tys) <- tc_con_sig_tau ty
- ; arg_ty <- tcHsBangType arg
- ; return (getBangStrictness arg : bangs,
- arg_ty : arg_tys, tc, res_tys) }
-
-tc_con_sig_tau ty
- = do { (tc, res_tys) <- tc_con_res ty []
- ; return ([], [], tc, res_tys) }
-
---------
+tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType])
+tcLHsConResTy ty@(L span _)
+ = setSrcSpan span $
+ addErrCtxt (gadtResCtxt ty) $
+ tc_con_res ty []
+
tc_con_res (L _ (HsAppTy fun res_ty)) res_tys
= do { res_ty' <- dsHsType res_ty
; tc_con_res fun (res_ty' : res_tys) }
tc_con_res ty _ = failWithTc (badGadtDecl ty)
-gadtSigCtxt ty
- = hang (ptext SLIT("In the signature of a data constructor:"))
+gadtResCtxt ty
+ = hang (ptext SLIT("In the result type of a data constructor:"))
2 (ppr ty)
badGadtDecl ty
- = hang (ptext SLIT("Malformed constructor signature:"))
+ = hang (ptext SLIT("Malformed constructor result type:"))
2 (ppr ty)
typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty)
#include "HsVersions.h"
import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..),
- ConDecl(..), Sig(..), , NewOrData(..),
+ ConDecl(..), Sig(..), , NewOrData(..), ResType(..),
tyClDeclTyVars, isSynDecl,
LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr
)
import TcClassDcl ( tcClassSigs, tcAddDeclCtxt )
import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType,
kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext,
- kcHsSigType, tcHsBangType, tcLHsConSig, tcDataKindSig )
+ kcHsSigType, tcHsBangType, tcLHsConResTy, tcDataKindSig )
import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness,
UserTypeCtxt(..), SourceTyCtxt(..) )
import TcType ( TcKind, TcType, tyVarsOfType, mkPhiTy,
- mkArrowKind, liftedTypeKind, mkTyVarTys, tcEqTypes,
- tcSplitSigmaTy, tcEqType )
+ mkArrowKind, liftedTypeKind, mkTyVarTys,
+ tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe )
import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType )
import Kind ( mkArrowKinds, splitKindFunTys )
import Generics ( validGenericMethodType, canDoGenerics )
tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
tyConStupidTheta, getSynTyConDefn, isSynTyCon, tyConName )
import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig,
- dataConFieldLabels, dataConOrigArgTys, dataConTyCon )
-import Type ( zipTopTvSubst, substTys )
+ dataConFieldLabels, dataConTyCon,
+ dataConTyVars, dataConFieldType, dataConResTys )
import Var ( TyVar, idType, idName )
-import VarSet ( elemVarSet )
+import VarSet ( elemVarSet, mkVarSet )
import Name ( Name )
import Outputable
+import Maybe ( isJust, fromJust )
+import Unify ( tcMatchTys, tcMatchTyX )
import Util ( zipLazy, isSingleton, notNull, sortLe )
import List ( partition )
import SrcLoc ( Located(..), unLoc, getLoc )
import ListSetOps ( equivClasses )
+import List ( delete )
import Digraph ( SCC(..) )
import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics,
Opt_UnboxStrictFields ) )
; cons' <- mappM (wrapLocM kc_con_decl) cons
; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) }
where
- kc_con_decl (ConDecl name ex_tvs ex_ctxt details)
- = kcHsTyVars ex_tvs $ \ ex_tvs' ->
- do { ex_ctxt' <- kcHsContext ex_ctxt
- ; details' <- kc_con_details details
- ; return (ConDecl name ex_tvs' ex_ctxt' details')}
- kc_con_decl (GadtDecl name ty)
- = do { ty' <- kcHsSigType ty
- ; traceTc (text "kc_con_decl" <+> ppr name <+> ppr ty')
- ; return (GadtDecl name ty') }
+ kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res) = do
+ kcHsTyVars ex_tvs $ \ex_tvs' -> do
+ ex_ctxt' <- kcHsContext ex_ctxt
+ details' <- kc_con_details details
+ res' <- case res of
+ ResTyH98 -> return ResTyH98
+ ResTyGADT ty -> return . ResTyGADT =<< kcHsSigType ty
+ return (ConDecl name expl ex_tvs' ex_ctxt' details' res')
kc_con_details (PrefixCon btys)
= do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') }
arg_vrcs = calc_vrcs tc_name
is_rec = calc_isrec tc_name
h98_syntax = case cons of -- All constructors have same shape
- L _ (GadtDecl {}) : _ -> False
+ L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
other -> True
tcTyClDecl1 calc_vrcs calc_isrec
-> ConDecl Name -> TcM DataCon
tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes
- (ConDecl name ex_tvs ex_ctxt details)
+ (ConDecl name _ ex_tvs ex_ctxt details ResTyH98)
= ASSERT( null ex_tvs && null (unLoc ex_ctxt) )
do { let tc_datacon field_lbls arg_ty
= do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype
PrefixCon [arg_ty] -> tc_datacon [] arg_ty
RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty }
-tcConDecl unbox_strict DataType tycon tc_tvs -- Ordinary data types
- (ConDecl name ex_tvs ex_ctxt details)
- = tcTyVarBndrs ex_tvs $ \ ex_tvs' -> do
- { ex_ctxt' <- tcHsKindedContext ex_ctxt
+tcConDecl unbox_strict DataType tycon tc_tvs -- Data types
+ (ConDecl name _ tvs ctxt details res_ty)
+ = tcTyVarBndrs tvs $ \ tvs' -> do
+ { ctxt' <- tcHsKindedContext ctxt
+ ; (data_tc, res_ty_args) <- tcResultType tycon tc_tvs res_ty
; let
- is_vanilla = null ex_tvs && null (unLoc ex_ctxt)
- -- Vanilla iff no ex_tvs and no context
- -- Must check the context too because of
- -- implicit params; e.g.
- -- data T = (?x::Int) => MkT Int
+ con_tvs = case res_ty of
+ ResTyH98 -> tc_tvs ++ tvs'
+ ResTyGADT _ -> tryVanilla tvs' res_ty_args
+
+ -- Vanilla iff result type matches the quantified vars exactly,
+ -- and there is no existential context
+ -- Must check the context too because of implicit params; e.g.
+ -- data T = (?x::Int) => MkT Int
+ is_vanilla = res_ty_args `tcEqTypes` mkTyVarTys con_tvs
+ && null (unLoc ctxt)
tc_datacon is_infix field_lbls btys
- = do { let { bangs = map getBangStrictness btys }
+ = do { let bangs = map getBangStrictness btys
; arg_tys <- mappM tcHsBangType btys
; buildDataCon (unLoc name) is_infix is_vanilla
(argStrictness unbox_strict tycon bangs arg_tys)
(map unLoc field_lbls)
- (tc_tvs ++ ex_tvs')
- ex_ctxt'
- arg_tys
- tycon (mkTyVarTys tc_tvs) }
+ con_tvs ctxt' arg_tys
+ data_tc res_ty_args }
+ -- NB: we put data_tc, the type constructor gotten from the constructor
+ -- type signature into the data constructor; that way
+ -- checkValidDataCon can complain if it's wrong.
+
; case details of
PrefixCon btys -> tc_datacon False [] btys
- InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
- RecCon fields -> do { checkTc (null ex_tvs) (exRecConErr name)
- -- It's ok to have an implicit-parameter context
- -- for the data constructor, provided it binds
- -- no type variables
- ; let { (field_names, btys) = unzip fields }
- ; tc_datacon False field_names btys } }
-
-tcConDecl unbox_strict DataType tycon tc_tvs -- GADTs
- decl@(GadtDecl name con_ty)
- = do { traceTc (text "tcConDecl" <+> ppr name)
- ; (tvs, theta, bangs, arg_tys, data_tc, res_tys) <- tcLHsConSig con_ty
-
- ; traceTc (text "tcConDecl1" <+> ppr name)
- ; let -- Now dis-assemble the type, and check its form
- is_vanilla = null theta && mkTyVarTys tvs `tcEqTypes` res_tys
-
- -- Vanilla datacons guarantee to use the same
- -- type variables as the parent tycon
- (tvs', arg_tys', res_tys')
- | is_vanilla = (tc_tvs, substTys subst arg_tys, substTys subst res_tys)
- | otherwise = (tvs, arg_tys, res_tys)
- subst = zipTopTvSubst tvs (mkTyVarTys tc_tvs)
-
- ; traceTc (text "tcConDecl3" <+> ppr name)
- ; buildDataCon (unLoc name) False {- Not infix -} is_vanilla
- (argStrictness unbox_strict tycon bangs arg_tys)
- [{- No field labels -}]
- tvs' theta arg_tys' data_tc res_tys' }
- -- NB: we put data_tc, the type constructor gotten from the constructor
- -- type signature into the data constructor; that way checkValidDataCon
- -- can complain if it's wrong.
+ InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
+ RecCon fields -> tc_datacon False field_names btys
+ where
+ (field_names, btys) = unzip fields
+
+ }
+
+tcResultType :: TyCon -> [TyVar] -> ResType Name -> TcM (TyCon, [TcType])
+tcResultType tycon tvs ResTyH98 = return (tycon, mkTyVarTys tvs)
+tcResultType _ _ (ResTyGADT res_ty) = tcLHsConResTy res_ty
+
+tryVanilla :: [TyVar] -> [TcType] -> [TyVar]
+-- (tryVanilla tvs tys) returns a permutation of tvs.
+-- It tries to re-order the tvs so that it exactly
+-- matches the [Type], if that is possible
+tryVanilla tvs (ty:tys) | Just tv <- tcGetTyVar_maybe ty -- The type is a tyvar
+ , tv `elem` tvs -- That tyvar is in the list
+ = tv : tryVanilla (delete tv tvs) tys
+tryVanilla tvs tys = tvs -- Fall through case
+
-------------------
argStrictness :: Bool -- True <=> -funbox-strict_fields
}
-------------------------
+-- For data types declared with record syntax, we require
+-- that each constructor that has a field 'f'
+-- (a) has the same result type
+-- (b) has the same type for 'f'
+-- module alpha conversion of the quantified type variables
+-- of the constructor.
+
checkValidTyCon :: TyCon -> TcM ()
checkValidTyCon tc
| isSynTyCon tc
groups = equivClasses cmp_fld (concatMap get_fields data_cons)
cmp_fld (f1,_) (f2,_) = f1 `compare` f2
- get_fields con = dataConFieldLabels con `zip` dataConOrigArgTys con
+ get_fields con = dataConFieldLabels con `zip` repeat con
-- dataConFieldLabels may return the empty list, which is fine
- check_fields fields@((first_field_label, field_ty) : other_fields)
+ -- XXX - autrijus - Make this far more complex to acommodate
+ -- for different return types. Add res_ty to the mix,
+ -- comparing them in two steps, all for good error messages.
+ -- Plan: Use Unify.tcMatchTys to compare the first candidate's
+ -- result type against other candidates' types (check bothways).
+ -- If they magically agrees, take the substitution and
+ -- apply them to the latter ones, and see if they match perfectly.
+ -- check_fields fields@((first_field_label, field_ty) : other_fields)
+ check_fields fields@((label, con1) : other_fields)
-- These fields all have the same name, but are from
-- different constructors in the data type
- = -- Check that all the fields in the group have the same type
+ = recoverM (return ()) $ mapM_ checkOne other_fields
+ -- Check that all the fields in the group have the same type
-- NB: this check assumes that all the constructors of a given
-- data type use the same type variables
- checkTc (all (tcEqType field_ty . snd) other_fields)
- (fieldTypeMisMatch first_field_label)
+ where
+ tvs1 = mkVarSet (dataConTyVars con1)
+ res1 = dataConResTys con1
+ fty1 = dataConFieldType con1 label
+
+ checkOne (_, con2) -- Do it bothways to ensure they are structurally identical
+ = do { checkFieldCompat label con1 con2 tvs1 res1 res2 fty1 fty2
+ ; checkFieldCompat label con2 con1 tvs2 res2 res1 fty2 fty1 }
+ where
+ tvs2 = mkVarSet (dataConTyVars con2)
+ res2 = dataConResTys con2
+ fty2 = dataConFieldType con2 label
+
+checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
+ = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
+ ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
+ where
+ mb_subst1 = tcMatchTys tvs1 res1 res2
+ mb_subst2 = tcMatchTyX tvs1 (fromJust mb_subst1) fty1 fty2
-------------------------------
checkValidDataCon :: TyCon -> DataCon -> TcM ()
---------------------------------------------------------------------
-fieldTypeMisMatch field_name
- = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)]
+resultTypeMisMatch field_name con1 con2
+ = vcat [sep [ptext SLIT("Constructors") <+> ppr con1 <+> ptext SLIT("and") <+> ppr con2,
+ ptext SLIT("have a common field") <+> quotes (ppr field_name) <> comma],
+ nest 2 $ ptext SLIT("but have different result types")]
+fieldTypeMisMatch field_name con1 con2
+ = sep [ptext SLIT("Constructors") <+> ppr con1 <+> ptext SLIT("and") <+> ppr con2,
+ ptext SLIT("give different types for field"), quotes (ppr field_name)]
dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"),
nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)]
where
le (L l1 _) (L l2 _) = l1 <= l2
-exRecConErr name
- = ptext SLIT("Can't combine named fields with locally-quantified type variables or context")
- $$
- (ptext SLIT("In the declaration of data constructor") <+> ppr name)
-
badDataConTyCon data_con
= hang (ptext SLIT("Data constructor") <+> quotes (ppr data_con) <+>
ptext SLIT("returns type") <+> quotes (ppr (dataConTyCon data_con)))
mkDictTy, tcSplitPredTy_maybe,
isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique,
mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName,
+ dataConsStupidTheta,
---------------------------------
-- Foreign import and export
mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst,
getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
extendTvSubst, extendTvSubstList, isInScope,
- substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
+ substTy, substTys, substTyWith, substTheta,
+ substTyVar, substTyVarBndr, substPred,
typeKind, repType,
pprKind, pprParendKind,
pprPred, pprTheta, pprThetaArrow, pprClassPred
)
import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, tyConUnique )
-import DataCon ( DataCon )
+import DataCon ( DataCon, dataConStupidTheta, dataConResTys )
import Class ( Class )
import Var ( TyVar, Id, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
import ForeignCall ( Safety, playSafe, DNType(..) )
+import Unify ( tcMatchTys )
import VarSet
-- others:
import Util ( snocView, equalLength )
import Maybes ( maybeToBool, expectJust, mapCatMaybes )
import ListSetOps ( hasNoDups )
+import List ( nubBy )
import Outputable
import DATA_IOREF
\end{code}
isLinearPred other = False
\end{code}
+--------------------- The stupid theta (sigh) ---------------------------------
+
+\begin{code}
+dataConsStupidTheta :: [DataCon] -> ThetaType
+-- Union the stupid thetas from all the specified constructors (non-empty)
+-- All the constructors should have the same result type, modulo alpha conversion
+-- The resulting ThetaType uses type variables from the *first* constructor in the list
+--
+-- It's here because it's used in MkId.mkRecordSelId, and in TcExpr
+dataConsStupidTheta (con1:cons)
+ = nubBy tcEqPred all_preds
+ where
+ all_preds = dataConStupidTheta con1 ++ other_stupids
+ res_tys1 = dataConResTys con1
+ tvs1 = tyVarsOfTypes res_tys1
+ other_stupids = [ substPred subst pred
+ | con <- cons
+ , let Just subst = tcMatchTys tvs1 res_tys1 (dataConResTys con)
+ , pred <- dataConStupidTheta con ]
+\end{code}
+
%************************************************************************
%* *
tyConTyVars,
tyConArgVrcs,
algTyConRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize,
- tyConFields, tyConSelIds,
+ tyConSelIds,
tyConStupidTheta,
tyConArity,
isClassTyCon, tyConClass_maybe,
tyConTyVars :: [TyVar], -- Scopes over (a) the [PredType] in AlgTyConRhs.DataTyCon
-- (b) the cached types in AlgTyConRhs.NewTyCon
- -- (c) the types in algTcFields
-- But not over the data constructors
argVrcs :: ArgVrcs,
- algTcFields :: [(FieldLabel, Type, Id)],
- -- Its fields (empty if none):
- -- * field name
- -- * its type (scoped over by tyConTyVars)
- -- * record selector (name = field name)
+ algTcSelIds :: [Id], -- Its record selectors (empty if none):
algTcStupidTheta :: [PredType], -- The "stupid theta" for the data type
-- (always empty for GADTs)
-- This is the making of a TyCon. Just the same as the old mkAlgTyCon,
-- but now you also have to pass in the generic information about the type
-- constructor - you can get hold of it easily (see Generics module)
-mkAlgTyCon name kind tyvars argvrcs stupid rhs flds is_rec gen_info
+mkAlgTyCon name kind tyvars argvrcs stupid rhs sel_ids is_rec gen_info
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
argVrcs = argvrcs,
algTcStupidTheta = stupid,
algTcRhs = rhs,
- algTcFields = flds,
+ algTcSelIds = sel_ids,
algTcClass = Nothing,
algTcRec = is_rec,
hasGenerics = gen_info
argVrcs = argvrcs,
algTcStupidTheta = [],
algTcRhs = rhs,
- algTcFields = [],
+ algTcSelIds = [],
algTcClass = Just clas,
algTcRec = is_rec,
hasGenerics = False
tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
#endif
-tyConFields :: TyCon -> [(FieldLabel,Type,Id)]
-tyConFields (AlgTyCon {algTcFields = fs}) = fs
-tyConFields other_tycon = []
-
tyConSelIds :: TyCon -> [Id]
-tyConSelIds tc = [id | (_,_,id) <- tyConFields tc]
+tyConSelIds (AlgTyCon {algTcSelIds = fs}) = fs
+tyConSelIds other_tycon = []
algTyConRhs :: TyCon -> AlgTyConRhs
algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs
extendTvSubst, extendTvSubstList, isInScope, composeTvSubst,
-- Performing substitution on types
- substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
- deShadowTy,
+ substTy, substTys, substTyWith, substTheta,
+ substPred, substTyVar, substTyVarBndr, deShadowTy,
-- Pretty-printing
pprType, pprParendType, pprTyThingCategory,
-- and so generated a rep type mentioning t not t2.
--
-- Simplest fix is to nuke the "optimisation"
+zip_ty_env tvs tys env = pprTrace "Var/Type length mismatch: " (ppr tvs $$ ppr tys) env
+-- zip_ty_env _ _ env = env
instance Outputable TvSubst where
ppr (TvSubst ins env)
\begin{code}
module Unify (
-- Matching and unification
- tcMatchTys, tcMatchTyX, tcMatchPreds, MatchEnv(..),
+ tcMatchTys, tcMatchTyX, ruleMatchTyX, tcMatchPreds, MatchEnv(..),
tcUnifyTys,
import Type ( typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, mkTyVarTys,
TvSubstEnv, emptyTvSubstEnv, TvSubst(..), substTy, tcEqTypeX )
import TypeRep ( Type(..), PredType(..), funTyCon )
-import DataCon ( DataCon, dataConResTy )
+import DataCon ( DataCon, dataConInstResTy )
import Util ( snocView )
import ErrUtils ( Message )
import Outputable
-- We're assuming that all the interesting
-- tyvars in tys1 are in tmpls
+-- This is similar, but extends a substitution
+tcMatchTyX :: TyVarSet -- Template tyvars
+ -> TvSubst -- Substitution to extend
+ -> Type -- Template
+ -> Type -- Target
+ -> Maybe TvSubst
+tcMatchTyX tmpls (TvSubst in_scope subst_env) ty1 ty2
+ = case match menv subst_env ty1 ty2 of
+ Just subst_env -> Just (TvSubst in_scope subst_env)
+ Nothing -> Nothing
+ where
+ menv = ME {me_tmpls = tmpls, me_env = mkRnEnv2 in_scope}
+
tcMatchPreds
:: [TyVar] -- Bind these
-> [PredType] -> [PredType]
in_scope_tyvars = mkInScopeSet (tyVarsOfTheta ps1 `unionVarSet` tyVarsOfTheta ps2)
-- This one is called from the expression matcher, which already has a MatchEnv in hand
-tcMatchTyX :: MatchEnv
+ruleMatchTyX :: MatchEnv
-> TvSubstEnv -- Substitution to extend
-> Type -- Template
-> Type -- Target
-> Maybe TvSubstEnv
-tcMatchTyX menv subst ty1 ty2 = match menv subst ty1 ty2 -- Rename for export
+ruleMatchTyX menv subst ty1 ty2 = match menv subst ty1 ty2 -- Rename for export
\end{code}
Now the internals of matching
; return (subst_env_fixpt, all_bound_here subst_env) }
where
- pat_res_ty = dataConResTy con (mkTyVarTys tvs)
+ pat_res_ty = dataConInstResTy con (mkTyVarTys tvs)
-- 'tvs' are the tyvars bound by the pattern
tv_set = mkVarSet tvs
projects / ghc-hetmet.git / commitdiff