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}
......
This diff is collapsed.
......@@ -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
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}
%************************************************************************
......
......@@ -141,6 +141,10 @@ unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
-- 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}
......
......@@ -14,7 +14,6 @@ module BuildTyCl (
import IfaceEnv ( newImplicitBinder )
import TcRnMonad
import Util ( zipLazy )
import DataCon ( DataCon, isNullarySrcDataCon,
mkDataCon, dataConFieldLabels, dataConOrigArgTys )
import Var ( tyVarKind, TyVar, Id )
......@@ -26,14 +25,14 @@ import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc,
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}
......@@ -58,7 +57,7 @@ buildAlgTyCon tc_name tvs stupid_theta rhs arg_vrcs is_rec want_generics
= do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs stupid_theta
rhs fields is_rec want_generics
; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
; fields = mkTyConFields tycon rhs
; fields = mkTyConSelIds tycon rhs
}
; return tycon }
......@@ -116,7 +115,8 @@ mkNewTyConRep tc
buildDataCon :: Name -> Bool -> Bool
-> [StrictnessMark]
-> [Name] -- Field labels
-> [TyVar] -> ThetaType
-> [TyVar]
-> ThetaType -- Does not include the "stupid theta"
-> [Type] -> TyCon -> [Type]
-> TcRnIf m n DataCon
-- A wrapper for DataCon.mkDataCon that
......@@ -150,26 +150,20 @@ mkDataConStupidTheta tycon arg_tys res_tys
where
tc_subst = zipTopTvSubst (tyConTyVars tycon) res_tys
stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
-- Start by instantiating the master copy of the
-- stupid theta, taken from the TyCon
arg_tyvars = tyVarsOfTypes arg_tys
in_arg_tys pred = not $ isEmptyVarSet $
tyVarsOfPred pred `intersectVarSet` arg_tyvars
------------------------------------------------------
mkTyConFields :: TyCon -> AlgTyConRhs -> [(FieldLabel,Type,Id)]
mkTyConFields tycon rhs
= -- We'll check later that fields with the same name
mkTyConSelIds :: TyCon -> AlgTyConRhs -> [Id]
mkTyConSelIds tycon rhs
= [ mkRecordSelId tycon fld
| fld <- nub (concatMap dataConFieldLabels (visibleDataCons rhs)) ]
-- We'll check later that fields with the same name
-- from different constructors have the same type.
[ (fld, ty, mkRecordSelId tycon fld ty)
| (fld, ty) <- nubBy eq_fld all_fld_tys ]
where
all_fld_tys = concatMap fld_tys_of (visibleDataCons rhs)
fld_tys_of con = dataConFieldLabels con `zipLazy`
dataConOrigArgTys con
-- The laziness means that the type isn't sucked in prematurely
-- Only vanilla datacons have fields at all, and they
-- share the tycon's type variables => datConOrigArgTys will do
eq_fld (f1,_) (f2,_) = f1 == f2
\end{code}
......
......@@ -46,7 +46,7 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
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,
......@@ -682,7 +682,7 @@ tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs)
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 )
......@@ -700,7 +700,7 @@ tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
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
......
......@@ -855,9 +855,9 @@ akind :: { Kind }
-- 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) }
......@@ -868,9 +868,30 @@ gadt_constrs :: { Located [LConDecl RdrName] }
| 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 [] }
......@@ -883,10 +904,10 @@ constrs1 :: { Located [LConDecl RdrName] }
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 }
......@@ -905,6 +926,10 @@ constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrN
| 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] }
......
......@@ -94,8 +94,8 @@ trep :: { OccName -> [LConDecl RdrName] }
: {- 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] }
......@@ -103,9 +103,15 @@ cons1 :: { [LConDecl RdrName] }
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 -} { [] }
......
......@@ -28,14 +28,15 @@ module RdrHsSyn (
-- -> (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]
......@@ -604,6 +605,31 @@ checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
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]
......
......@@ -117,13 +117,17 @@ hsSigFVs (SpecSig v ty) = extractHsTyNames ty
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
......
......@@ -16,7 +16,7 @@ import {-# SOURCE #-} RnExpr( rnLExpr )
import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv )
import RdrHsSyn ( extractGenericPatTyVars )
import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn