Commit 36436bc6 authored by simonpj's avatar simonpj

[project @ 2005-10-14 11:22:41 by simonpj]

Add record syntax for GADTs
	~~~~~~~~~~~~~~~~~~~~~~~~~~~

Atrijus Tang wanted to add record syntax for GADTs and existential
types, so he and I worked on it a bit at ICFP.  This commit is the
result.  Now you can say

 data T a where
  T1 { x :: a }           	 :: T [a]
  T2 { x :: a, y :: Int } 	 :: T [a]
  forall b. Show b =>
 	T3 { naughty :: b, ok :: Int } :: T Int
  T4 :: Eq a => a -> b -> T (a,b)

Here the constructors are declared using record syntax.

Still to come after this commit:
  - User manual documentation
  - More regression tests
  - Some missing cases in the parser (e.g. T3 won't parse)
Autrijus is going to do these.


Here's a quick summary of the rules.  (Atrijus is going to write
proper documentation shortly.)

Defnition: a 'vanilla' constructor has a type of the form
	forall a1..an. t1 -> ... -> tm -> T a1 ... an
No existentials, no context, nothing.  A constructor declared with
Haskell-98 syntax is vanilla by construction.  A constructor declared
with GADT-style syntax is vanilla iff its type looks like the above.
(In the latter case, the order of the type variables does not matter.)

* You can mix record syntax and non-record syntax in a single decl

* All constructors that share a common field 'x' must have the
  same result type (T [a] in the example).

* You can use field names without restriction in record construction
  and record pattern matching.

* Record *update* only works for data types that only have 'vanilla'
  constructors.

* Consider the field 'naughty', which uses a type variable that does
  not appear in the result type ('b' in the example).  You can use the
  field 'naughty' in pattern matching and construction, but NO
  SELECTOR function is generated for 'naughty'.  [An attempt to use
  'naughty' as a selector function will elicit a helpful error
  message.]

* Data types declared in GADT syntax cannot have a context. So this
is illegal:
	data (Monad m) => T a where
		  ....

* Constructors in GADT syntax can have a context (t.g. T3, T4 above)
  and that context is stored in the constructor and made available
  when the constructor is pattern-matched on.  WARNING: not competely
  implemented yet, but that's the plan.



Implementation notes
~~~~~~~~~~~~~~~~~~~~
- Data constructors (even vanilla ones) no longer share the type
  variables of their parent type constructor.

- HsDecls.ConDecl has changed quite a bit

- TyCons don't record the field labels and type any more (doesn't
  make sense for existential fields)

- GlobalIdDetails records which selectors are 'naughty', and hence
  don't have real code.
parent 8761b735
......@@ -9,8 +9,9 @@ module DataCon (
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,
......@@ -26,12 +27,12 @@ module DataCon (
#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 )
......@@ -199,14 +200,24 @@ data DataCon
-- 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.
......@@ -220,6 +231,11 @@ data DataCon
-- 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
......@@ -494,33 +510,35 @@ dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
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,
......@@ -587,7 +605,7 @@ splitProductType_maybe ty
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
......
......@@ -26,7 +26,7 @@ module Id (
-- Predicates
isImplicitId, isDeadBinder, isDictId,
isExportedId, isLocalId, isGlobalId,
isRecordSelector,
isRecordSelector, isNaughtyRecordSelector,
isClassOpId_maybe,
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
......@@ -230,13 +230,17 @@ idPrimRep id = typePrimRep (idType id)
\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
......@@ -297,7 +301,7 @@ isImplicitId :: Id -> Bool
-- 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
......
......@@ -231,7 +231,12 @@ an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported
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*
......@@ -257,7 +262,7 @@ instance Outputable GlobalIdDetails where
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}
......
......@@ -43,30 +43,31 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
)
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,
......@@ -88,8 +89,7 @@ import PrelNames
import Util ( dropList, isSingleton )
import Outputable
import FastString
import ListSetOps ( assoc, assocMaybe )
import List ( nubBy )
import ListSetOps ( assoc )
\end{code}
%************************************************************************
......@@ -378,32 +378,81 @@ Similarly for (recursive) newtypes
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
......@@ -425,10 +474,10 @@ mkRecordSelId tycon field_label field_ty
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.
......@@ -445,18 +494,18 @@ mkRecordSelId tycon field_label field_ty
-- 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)]
......@@ -465,7 +514,7 @@ mkRecordSelId tycon field_label field_ty
| 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))
......@@ -479,30 +528,27 @@ mkRecordSelId tycon field_label field_ty
-- 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])
......
......@@ -51,7 +51,6 @@ import PrelNames ( hasKey, buildIdKey, augmentIdKey )
import Bag
import FastTypes
import Outputable
import Util
#if __GLASGOW_HASKELL__ >= 404
import GLAEXTS ( Int# )
......
......@@ -52,7 +52,7 @@ import Packages ( isDllName )
#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,
......@@ -651,7 +651,7 @@ exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
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
......
......@@ -48,7 +48,7 @@ import HsUtils ( collectPatBinders, collectPatsBinders )
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}
......
......@@ -484,7 +484,7 @@ dsExpr expr@(RecordUpd record_expr rbinds record_in_ty record_out_ty)
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
......
......@@ -24,12 +24,12 @@ import MatchCon ( matchConFamily )
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
......@@ -434,7 +434,7 @@ tidy1 v wrap (LazyPat pat)
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)
......@@ -482,9 +482,9 @@ tidy1 v wrap non_interesting_pat
= 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
......@@ -492,14 +492,13 @@ tidy_con data_con pat_ty (RecCon rpats)
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
......
......@@ -12,7 +12,7 @@ import {-# SOURCE #-} Match ( match )
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
......@@ -134,8 +134,7 @@ match_con vars ty eqns
-- 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}
......
......@@ -14,7 +14,7 @@ module HsDecls (
DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
ConDecl(..), LConDecl,
ConDecl(..), ResType(..), LConDecl,
DeprecDecl(..), LDeprecDecl,
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
tcdName, tyClDeclNames, tyClDeclTyVars,
......@@ -48,7 +48,7 @@ import FunDeps ( pprFundeps )
import Class ( FunDep )
import Outputable
import Util ( count )
import SrcLoc ( Located(..), unLoc )
import SrcLoc ( Located(..), unLoc, noLoc )
import FastString
\end{code}
......@@ -343,8 +343,8 @@ data TyClDecl name
-- (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
......@@ -472,8 +472,7 @@ pp_decl_head :: OutputableBndr name
-> 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))
......@@ -502,18 +501,27 @@ instance Outputable NewOrData where
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}
......@@ -524,17 +532,13 @@ conDeclsNames :: Eq name => [ConDecl name] -> [Located name]
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}
......@@ -542,26 +546,26 @@ conDetailsTys details = map getBangType (hsConArgs details)
\begin{code}
instance (OutputableBndr name) => Outputable (ConDecl name) where